{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Keter.Rewrite
  ( ReverseProxyConfig (..)
  , RewriteRule (..)
  , RPEntry (..)
  , simpleReverseProxy
  )
  where

import Blaze.ByteString.Builder (fromByteString)
import Control.Applicative
import Control.Exception (bracket)
import Control.Monad (unless)
import Data.Aeson
import Data.Array ((!))
import Data.Attoparsec.Text (Parser, endOfInput, parseOnly, string, takeWhile1)
import Data.ByteString qualified as S
import Data.CaseInsensitive qualified as CI
import Data.Char (isDigit)
import Data.Function (fix)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Keter.Common
import Network.HTTP.Client qualified as NHC
import Network.HTTP.Client.Conduit
import Network.HTTP.Types
import Network.Wai qualified as Wai
import Network.Wai.Internal qualified as I
import Text.Regex.TDFA (MatchText, makeRegex, matchOnceText)
import Text.Regex.TDFA.String (Regex)

data RPEntry = RPEntry
    { RPEntry -> ReverseProxyConfig
config :: ReverseProxyConfig
    , RPEntry -> Manager
httpManager :: Manager
    }

instance Show RPEntry where
  show :: RPEntry -> String
show RPEntry
x = String
"RPEntry { config = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ReverseProxyConfig -> String
forall a. Show a => a -> String
show (RPEntry -> ReverseProxyConfig
config RPEntry
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"

getGroup :: MatchText String -> Int -> String
getGroup :: MatchText String -> Int -> String
getGroup MatchText String
matches Int
i = (String, (Int, Int)) -> String
forall a b. (a, b) -> a
fst ((String, (Int, Int)) -> String) -> (String, (Int, Int)) -> String
forall a b. (a -> b) -> a -> b
$ MatchText String
matches MatchText String -> Int -> (String, (Int, Int))
forall i e. Ix i => Array i e -> i -> e
! Int
i

rewrite :: (String, MatchText String, String) -> String -> String -> Text
rewrite :: (String, MatchText String, String) -> String -> String -> Text
rewrite (String
before, MatchText String
match, String
after) String
input String
replacement =
  case Parser Text Text -> Text -> Either String Text
forall a. Parser a -> Text -> Either String a
parseOnly Parser Text Text
parseSubstitute (String -> Text
T.pack String
replacement) of
    Left String
_ -> String -> Text
T.pack String
input
    Right Text
result -> String -> Text
T.pack String
before Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
result Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
after
  where
    parseSubstitute :: Parser Text
    parseSubstitute :: Parser Text Text
parseSubstitute =
          (Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput Parser Text () -> Parser Text Text -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text Text
"")
      Parser Text Text -> Parser Text Text -> Parser Text Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
          { Text
_ <- Text -> Parser Text Text
string Text
"\\\\"
          ; Text
rest <- Parser Text Text
parseSubstitute
          ; Text -> Parser Text Text
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text Text) -> Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ Text
"\\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest
          }
      Parser Text Text -> Parser Text Text -> Parser Text Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
          { Text
_ <- Text -> Parser Text Text
string Text
"\\"
          ; Int
n <- (String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (Text -> String) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Int) -> Parser Text Text -> Parser Text Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
takeWhile1 Char -> Bool
isDigit) :: Parser Int
          ; Text
rest <- Parser Text Text
parseSubstitute
          ; Text -> Parser Text Text
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text Text) -> Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (MatchText String -> Int -> String
getGroup MatchText String
match Int
n) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest
          }
      Parser Text Text -> Parser Text Text -> Parser Text Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
          { Text
text <- (Char -> Bool) -> Parser Text Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\')
          ; Text
rest <- Parser Text Text
parseSubstitute
          ; Text -> Parser Text Text
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text Text) -> Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest
          }

rewriteHeader :: Map HeaderName RewriteRule -> Header -> Header
rewriteHeader :: Map HeaderName RewriteRule -> Header -> Header
rewriteHeader Map HeaderName RewriteRule
rules header :: Header
header@(HeaderName
name, ByteString
value) =
  case HeaderName -> Map HeaderName RewriteRule -> Maybe RewriteRule
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderName
name Map HeaderName RewriteRule
rules of
    Maybe RewriteRule
Nothing -> Header
header
    Just  RewriteRule
r -> (HeaderName
name, RewriteRule -> ByteString -> ByteString
regexRewrite RewriteRule
r ByteString
value)

rewriteHeaders :: Map HeaderName RewriteRule -> [Header] -> [Header]
rewriteHeaders :: Map HeaderName RewriteRule -> [Header] -> [Header]
rewriteHeaders Map HeaderName RewriteRule
ruleMap = (Header -> Header) -> [Header] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map (Map HeaderName RewriteRule -> Header -> Header
rewriteHeader Map HeaderName RewriteRule
ruleMap)

regexRewrite :: RewriteRule -> S.ByteString -> S.ByteString
regexRewrite :: RewriteRule -> ByteString -> ByteString
regexRewrite (RewriteRule Text
_ Text
regex' Text
replacement) ByteString
input =
  case Regex -> String -> Maybe (String, MatchText String, String)
forall regex source.
RegexLike regex source =>
regex -> source -> Maybe (source, MatchText source, source)
matchOnceText Regex
regex String
strInput of
    Just  (String, MatchText String, String)
match -> Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ (String, MatchText String, String) -> String -> String -> Text
rewrite (String, MatchText String, String)
match String
strInput String
strReplacement
    Maybe (String, MatchText String, String)
Nothing     -> ByteString
input
  where
    strRegex :: String
strRegex = Text -> String
T.unpack Text
regex'
    regex :: Regex
    regex :: Regex
regex = String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
makeRegex String
strRegex
    strInput :: String
strInput = Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
input
    strReplacement :: String
strReplacement = Text -> String
T.unpack Text
replacement

filterHeaders :: [Header] -> [Header]
filterHeaders :: [Header] -> [Header]
filterHeaders = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter Header -> Bool
forall {a} {b}. (Eq a, IsString a) => (a, b) -> Bool
useHeader
  where
    useHeader :: (a, b) -> Bool
useHeader (a
"Transfer-Encoding", b
_) = Bool
False
    useHeader (a
"Content-Length", b
_)    = Bool
False
    useHeader (a
"Host", b
_)              = Bool
False
    useHeader (a, b)
_                        = Bool
True

mkRuleMap :: Set RewriteRule -> Map HeaderName RewriteRule
mkRuleMap :: Set RewriteRule -> Map HeaderName RewriteRule
mkRuleMap = [(HeaderName, RewriteRule)] -> Map HeaderName RewriteRule
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(HeaderName, RewriteRule)] -> Map HeaderName RewriteRule)
-> (Set RewriteRule -> [(HeaderName, RewriteRule)])
-> Set RewriteRule
-> Map HeaderName RewriteRule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RewriteRule -> (HeaderName, RewriteRule))
-> [RewriteRule] -> [(HeaderName, RewriteRule)]
forall a b. (a -> b) -> [a] -> [b]
map (\RewriteRule
k -> (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName)
-> (Text -> ByteString) -> Text -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> HeaderName) -> Text -> HeaderName
forall a b. (a -> b) -> a -> b
$ RewriteRule -> Text
ruleHeader RewriteRule
k, RewriteRule
k)) ([RewriteRule] -> [(HeaderName, RewriteRule)])
-> (Set RewriteRule -> [RewriteRule])
-> Set RewriteRule
-> [(HeaderName, RewriteRule)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set RewriteRule -> [RewriteRule]
forall a. Set a -> [a]
Set.toList

mkRequest :: ReverseProxyConfig -> Wai.Request -> Request
mkRequest :: ReverseProxyConfig -> Request -> Request
mkRequest ReverseProxyConfig
rpConfig Request
request =
   Request
NHC.defaultRequest
      { NHC.checkResponse = \Request
_ Response BodyReader
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      , NHC.responseTimeout = maybe NHC.responseTimeoutNone NHC.responseTimeoutMicro $ reverseTimeout rpConfig
      , method = Wai.requestMethod request
      , secure = reversedUseSSL rpConfig
      , host   = encodeUtf8 $ reversedHost rpConfig
      , port   = reversedPort rpConfig
      , path   = Wai.rawPathInfo request
      , queryString = Wai.rawQueryString request
      , requestHeaders = filterHeaders $ rewriteHeaders reqRuleMap (Wai.requestHeaders request)
      , requestBody =
          case Wai.requestBodyLength request of
            RequestBodyLength
Wai.ChunkedBody   -> GivesPopper () -> RequestBody
RequestBodyStreamChunked ((BodyReader -> IO ()) -> BodyReader -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> BodyReader
I.getRequestBodyChunk Request
request)
            Wai.KnownLength Word64
n -> Int64 -> GivesPopper () -> RequestBody
RequestBodyStream (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) ((BodyReader -> IO ()) -> BodyReader -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> BodyReader
I.getRequestBodyChunk Request
request)
      , decompress = const False
      , redirectCount = 0
      , cookieJar = Nothing
      , requestVersion = Wai.httpVersion request
      }
  where
    reqRuleMap :: Map HeaderName RewriteRule
reqRuleMap = Set RewriteRule -> Map HeaderName RewriteRule
mkRuleMap (Set RewriteRule -> Map HeaderName RewriteRule)
-> Set RewriteRule -> Map HeaderName RewriteRule
forall a b. (a -> b) -> a -> b
$ ReverseProxyConfig -> Set RewriteRule
rewriteRequestRules ReverseProxyConfig
rpConfig

simpleReverseProxy :: Manager -> ReverseProxyConfig -> Wai.Application
simpleReverseProxy :: Manager -> ReverseProxyConfig -> Application
simpleReverseProxy Manager
mgr ReverseProxyConfig
rpConfig Request
request Response -> IO ResponseReceived
sendResponse = IO (Response BodyReader)
-> (Response BodyReader -> IO ())
-> (Response BodyReader -> IO ResponseReceived)
-> IO ResponseReceived
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (Request -> Manager -> IO (Response BodyReader)
NHC.responseOpen Request
proxiedRequest Manager
mgr)
    Response BodyReader -> IO ()
forall (m :: * -> *) body. MonadIO m => Response body -> m ()
responseClose
    ((Response BodyReader -> IO ResponseReceived)
 -> IO ResponseReceived)
-> (Response BodyReader -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response BodyReader
res -> Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [Header] -> StreamingBody -> Response
Wai.responseStream
        (Response BodyReader -> Status
forall body. Response body -> Status
responseStatus Response BodyReader
res)
        (Map HeaderName RewriteRule -> [Header] -> [Header]
rewriteHeaders Map HeaderName RewriteRule
respRuleMap ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> [Header]
forall body. Response body -> [Header]
responseHeaders Response BodyReader
res)
        (BodyReader -> StreamingBody
forall {m :: * -> *} {p}.
Monad m =>
m ByteString -> (Builder -> m ()) -> p -> m ()
sendBody (BodyReader -> StreamingBody) -> BodyReader -> StreamingBody
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
res)
  where
    proxiedRequest :: Request
proxiedRequest = ReverseProxyConfig -> Request -> Request
mkRequest ReverseProxyConfig
rpConfig Request
request
    respRuleMap :: Map HeaderName RewriteRule
respRuleMap = Set RewriteRule -> Map HeaderName RewriteRule
mkRuleMap (Set RewriteRule -> Map HeaderName RewriteRule)
-> Set RewriteRule -> Map HeaderName RewriteRule
forall a b. (a -> b) -> a -> b
$ ReverseProxyConfig -> Set RewriteRule
rewriteResponseRules ReverseProxyConfig
rpConfig
    sendBody :: m ByteString -> (Builder -> m ()) -> p -> m ()
sendBody m ByteString
body Builder -> m ()
send p
_flush = (m () -> m ()) -> m ()
forall a. (a -> a) -> a
fix ((m () -> m ()) -> m ()) -> (m () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \m ()
loop -> do
        ByteString
bs <- m ByteString
body
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            () <- Builder -> m ()
send (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
fromByteString ByteString
bs
            m ()
loop

data ReverseProxyConfig = ReverseProxyConfig
    { ReverseProxyConfig -> Text
reversedHost :: Text
    , ReverseProxyConfig -> Int
reversedPort :: Int
    , ReverseProxyConfig -> Bool
reversedUseSSL :: Bool
    , ReverseProxyConfig -> Text
reversingHost :: Text
    , ReverseProxyConfig -> SSLConfig
reversingUseSSL :: !SSLConfig
    , ReverseProxyConfig -> Maybe Int
reverseTimeout :: Maybe Int
    , ReverseProxyConfig -> Set RewriteRule
rewriteResponseRules :: Set RewriteRule
    , ReverseProxyConfig -> Set RewriteRule
rewriteRequestRules :: Set RewriteRule
    } deriving (ReverseProxyConfig -> ReverseProxyConfig -> Bool
(ReverseProxyConfig -> ReverseProxyConfig -> Bool)
-> (ReverseProxyConfig -> ReverseProxyConfig -> Bool)
-> Eq ReverseProxyConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
== :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
$c/= :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
/= :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
Eq, Eq ReverseProxyConfig
Eq ReverseProxyConfig =>
(ReverseProxyConfig -> ReverseProxyConfig -> Ordering)
-> (ReverseProxyConfig -> ReverseProxyConfig -> Bool)
-> (ReverseProxyConfig -> ReverseProxyConfig -> Bool)
-> (ReverseProxyConfig -> ReverseProxyConfig -> Bool)
-> (ReverseProxyConfig -> ReverseProxyConfig -> Bool)
-> (ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig)
-> (ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig)
-> Ord ReverseProxyConfig
ReverseProxyConfig -> ReverseProxyConfig -> Bool
ReverseProxyConfig -> ReverseProxyConfig -> Ordering
ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ReverseProxyConfig -> ReverseProxyConfig -> Ordering
compare :: ReverseProxyConfig -> ReverseProxyConfig -> Ordering
$c< :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
< :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
$c<= :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
<= :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
$c> :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
> :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
$c>= :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
>= :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
$cmax :: ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig
max :: ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig
$cmin :: ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig
min :: ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig
Ord, Int -> ReverseProxyConfig -> ShowS
[ReverseProxyConfig] -> ShowS
ReverseProxyConfig -> String
(Int -> ReverseProxyConfig -> ShowS)
-> (ReverseProxyConfig -> String)
-> ([ReverseProxyConfig] -> ShowS)
-> Show ReverseProxyConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReverseProxyConfig -> ShowS
showsPrec :: Int -> ReverseProxyConfig -> ShowS
$cshow :: ReverseProxyConfig -> String
show :: ReverseProxyConfig -> String
$cshowList :: [ReverseProxyConfig] -> ShowS
showList :: [ReverseProxyConfig] -> ShowS
Show)

instance FromJSON ReverseProxyConfig where
    parseJSON :: Value -> Parser ReverseProxyConfig
parseJSON (Object Object
o) = Text
-> Int
-> Bool
-> Text
-> SSLConfig
-> Maybe Int
-> Set RewriteRule
-> Set RewriteRule
-> ReverseProxyConfig
ReverseProxyConfig
        (Text
 -> Int
 -> Bool
 -> Text
 -> SSLConfig
 -> Maybe Int
 -> Set RewriteRule
 -> Set RewriteRule
 -> ReverseProxyConfig)
-> Parser Text
-> Parser
     (Int
      -> Bool
      -> Text
      -> SSLConfig
      -> Maybe Int
      -> Set RewriteRule
      -> Set RewriteRule
      -> ReverseProxyConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reversed-host"
        Parser
  (Int
   -> Bool
   -> Text
   -> SSLConfig
   -> Maybe Int
   -> Set RewriteRule
   -> Set RewriteRule
   -> ReverseProxyConfig)
-> Parser Int
-> Parser
     (Bool
      -> Text
      -> SSLConfig
      -> Maybe Int
      -> Set RewriteRule
      -> Set RewriteRule
      -> ReverseProxyConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reversed-port"
        Parser
  (Bool
   -> Text
   -> SSLConfig
   -> Maybe Int
   -> Set RewriteRule
   -> Set RewriteRule
   -> ReverseProxyConfig)
-> Parser Bool
-> Parser
     (Text
      -> SSLConfig
      -> Maybe Int
      -> Set RewriteRule
      -> Set RewriteRule
      -> ReverseProxyConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reversed-ssl" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
        Parser
  (Text
   -> SSLConfig
   -> Maybe Int
   -> Set RewriteRule
   -> Set RewriteRule
   -> ReverseProxyConfig)
-> Parser Text
-> Parser
     (SSLConfig
      -> Maybe Int
      -> Set RewriteRule
      -> Set RewriteRule
      -> ReverseProxyConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reversing-host"
        Parser
  (SSLConfig
   -> Maybe Int
   -> Set RewriteRule
   -> Set RewriteRule
   -> ReverseProxyConfig)
-> Parser SSLConfig
-> Parser
     (Maybe Int
      -> Set RewriteRule -> Set RewriteRule -> ReverseProxyConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe SSLConfig)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ssl" Parser (Maybe SSLConfig) -> SSLConfig -> Parser SSLConfig
forall a. Parser (Maybe a) -> a -> Parser a
.!= SSLConfig
SSLFalse
        Parser
  (Maybe Int
   -> Set RewriteRule -> Set RewriteRule -> ReverseProxyConfig)
-> Parser (Maybe Int)
-> Parser
     (Set RewriteRule -> Set RewriteRule -> ReverseProxyConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe (Maybe Int))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"timeout" Parser (Maybe (Maybe Int)) -> Maybe Int -> Parser (Maybe Int)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Maybe Int
forall a. Maybe a
Nothing
        Parser (Set RewriteRule -> Set RewriteRule -> ReverseProxyConfig)
-> Parser (Set RewriteRule)
-> Parser (Set RewriteRule -> ReverseProxyConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe (Set RewriteRule))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"rewrite-response" Parser (Maybe (Set RewriteRule))
-> Set RewriteRule -> Parser (Set RewriteRule)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set RewriteRule
forall a. Set a
Set.empty
        Parser (Set RewriteRule -> ReverseProxyConfig)
-> Parser (Set RewriteRule) -> Parser ReverseProxyConfig
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe (Set RewriteRule))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"rewrite-request" Parser (Maybe (Set RewriteRule))
-> Set RewriteRule -> Parser (Set RewriteRule)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set RewriteRule
forall a. Set a
Set.empty
    parseJSON Value
_ = String -> Parser ReverseProxyConfig
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wanted an object"

instance ToJSON ReverseProxyConfig where
    toJSON :: ReverseProxyConfig -> Value
toJSON ReverseProxyConfig {Bool
Int
Maybe Int
Text
Set RewriteRule
SSLConfig
reverseTimeout :: ReverseProxyConfig -> Maybe Int
reversedUseSSL :: ReverseProxyConfig -> Bool
reversedHost :: ReverseProxyConfig -> Text
reversedPort :: ReverseProxyConfig -> Int
rewriteRequestRules :: ReverseProxyConfig -> Set RewriteRule
rewriteResponseRules :: ReverseProxyConfig -> Set RewriteRule
reversingHost :: ReverseProxyConfig -> Text
reversingUseSSL :: ReverseProxyConfig -> SSLConfig
reversedHost :: Text
reversedPort :: Int
reversedUseSSL :: Bool
reversingHost :: Text
reversingUseSSL :: SSLConfig
reverseTimeout :: Maybe Int
rewriteResponseRules :: Set RewriteRule
rewriteRequestRules :: Set RewriteRule
..} = [Pair] -> Value
object
        [ Key
"reversed-host" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
reversedHost
        , Key
"reversed-port" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
reversedPort
        , Key
"reversed-ssl" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
reversedUseSSL
        , Key
"reversing-host" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
reversingHost
        , Key
"ssl" Key -> SSLConfig -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SSLConfig
reversingUseSSL
        , Key
"timeout" Key -> Maybe Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
reverseTimeout
        , Key
"rewrite-response" Key -> Set RewriteRule -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Set RewriteRule
rewriteResponseRules
        , Key
"rewrite-request" Key -> Set RewriteRule -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Set RewriteRule
rewriteRequestRules
        ]

data RewriteRule = RewriteRule
    { RewriteRule -> Text
ruleHeader :: Text
    , RewriteRule -> Text
ruleRegex :: Text
    , RewriteRule -> Text
ruleReplacement :: Text
    } deriving (RewriteRule -> RewriteRule -> Bool
(RewriteRule -> RewriteRule -> Bool)
-> (RewriteRule -> RewriteRule -> Bool) -> Eq RewriteRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RewriteRule -> RewriteRule -> Bool
== :: RewriteRule -> RewriteRule -> Bool
$c/= :: RewriteRule -> RewriteRule -> Bool
/= :: RewriteRule -> RewriteRule -> Bool
Eq, Eq RewriteRule
Eq RewriteRule =>
(RewriteRule -> RewriteRule -> Ordering)
-> (RewriteRule -> RewriteRule -> Bool)
-> (RewriteRule -> RewriteRule -> Bool)
-> (RewriteRule -> RewriteRule -> Bool)
-> (RewriteRule -> RewriteRule -> Bool)
-> (RewriteRule -> RewriteRule -> RewriteRule)
-> (RewriteRule -> RewriteRule -> RewriteRule)
-> Ord RewriteRule
RewriteRule -> RewriteRule -> Bool
RewriteRule -> RewriteRule -> Ordering
RewriteRule -> RewriteRule -> RewriteRule
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RewriteRule -> RewriteRule -> Ordering
compare :: RewriteRule -> RewriteRule -> Ordering
$c< :: RewriteRule -> RewriteRule -> Bool
< :: RewriteRule -> RewriteRule -> Bool
$c<= :: RewriteRule -> RewriteRule -> Bool
<= :: RewriteRule -> RewriteRule -> Bool
$c> :: RewriteRule -> RewriteRule -> Bool
> :: RewriteRule -> RewriteRule -> Bool
$c>= :: RewriteRule -> RewriteRule -> Bool
>= :: RewriteRule -> RewriteRule -> Bool
$cmax :: RewriteRule -> RewriteRule -> RewriteRule
max :: RewriteRule -> RewriteRule -> RewriteRule
$cmin :: RewriteRule -> RewriteRule -> RewriteRule
min :: RewriteRule -> RewriteRule -> RewriteRule
Ord, Int -> RewriteRule -> ShowS
[RewriteRule] -> ShowS
RewriteRule -> String
(Int -> RewriteRule -> ShowS)
-> (RewriteRule -> String)
-> ([RewriteRule] -> ShowS)
-> Show RewriteRule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RewriteRule -> ShowS
showsPrec :: Int -> RewriteRule -> ShowS
$cshow :: RewriteRule -> String
show :: RewriteRule -> String
$cshowList :: [RewriteRule] -> ShowS
showList :: [RewriteRule] -> ShowS
Show)

instance FromJSON RewriteRule where
    parseJSON :: Value -> Parser RewriteRule
parseJSON (Object Object
o) = Text -> Text -> Text -> RewriteRule
RewriteRule
        (Text -> Text -> Text -> RewriteRule)
-> Parser Text -> Parser (Text -> Text -> RewriteRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"header"
        Parser (Text -> Text -> RewriteRule)
-> Parser Text -> Parser (Text -> RewriteRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"from"
        Parser (Text -> RewriteRule) -> Parser Text -> Parser RewriteRule
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"to"
    parseJSON Value
_ = String -> Parser RewriteRule
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wanted an object"

instance ToJSON RewriteRule where
    toJSON :: RewriteRule -> Value
toJSON RewriteRule {Text
ruleHeader :: RewriteRule -> Text
ruleRegex :: RewriteRule -> Text
ruleReplacement :: RewriteRule -> Text
ruleHeader :: Text
ruleRegex :: Text
ruleReplacement :: Text
..} = [Pair] -> Value
object
        [ Key
"header" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
ruleHeader
        , Key
"from" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
ruleRegex
        , Key
"to" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
ruleReplacement
        ]