{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE CPP               #-}
module Network.HTTP.ReverseProxy.Rewrite
  ( ReverseProxyConfig (..)
  , RewriteRule (..)
  , RPEntry (..)
  , simpleReverseProxy
  )
  where

import Control.Applicative
import Control.Exception (bracket)
import Data.Function (fix)
import Data.Monoid ((<>))

import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Map as Map
import Data.Map ( Map )
import Data.Array ((!))
import Data.Aeson
import Control.Monad (unless)

import qualified Data.ByteString as S
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import qualified Data.CaseInsensitive as CI

import Blaze.ByteString.Builder (fromByteString)

import Keter.Types.Common
-- Configuration files
import Data.Default

-- Regular expression parsing, replacement, matching
import Data.Attoparsec.Text (string, takeWhile1, endOfInput, parseOnly, Parser)
import Text.Regex.TDFA (makeRegex, matchOnceText, MatchText)
import Text.Regex.TDFA.String (Regex)
import Data.Char (isDigit)

-- Reverse proxy apparatus
import qualified Network.Wai as Wai
import qualified Network.Wai.Internal as I
import Network.HTTP.Client.Conduit
import qualified Network.HTTP.Client as NHC
import Network.HTTP.Types

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 (ReverseProxyConfig -> String) -> ReverseProxyConfig -> String
forall a b. (a -> b) -> a -> b
$ 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 -> Either String Text
forall a. Parser a -> Text -> Either String a
parseOnly Parser 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
parseSubstitute =
          (Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput Parser Text () -> Parser Text -> Parser Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
"")
      Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
          { Text
_ <- Text -> Parser Text
string Text
"\\\\"
          ; Text
rest <- Parser Text
parseSubstitute
          ; Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
"\\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest
          }
      Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
          { Text
_ <- Text -> Parser Text
string Text
"\\"
          ; Int
n <- ((Text -> Int) -> Parser Text -> Parser Text Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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) (Parser Text -> Parser Text Int) -> Parser Text -> Parser Text Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit) :: Parser Int
          ; Text
rest <- Parser Text
parseSubstitute
          ; Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser 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 -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
          { Text
text <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\')
          ; Text
rest <- Parser Text
parseSubstitute
          ; Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser 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 =
#if MIN_VERSION_http_client(0, 5, 0)
   Request
NHC.defaultRequest
      { checkResponse :: Request -> Response BodyReader -> IO ()
NHC.checkResponse = \Request
_ Response BodyReader
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      , responseTimeout :: ResponseTimeout
NHC.responseTimeout = ResponseTimeout
-> (Int -> ResponseTimeout) -> Maybe Int -> ResponseTimeout
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseTimeout
NHC.responseTimeoutNone Int -> ResponseTimeout
NHC.responseTimeoutMicro (Maybe Int -> ResponseTimeout) -> Maybe Int -> ResponseTimeout
forall a b. (a -> b) -> a -> b
$ ReverseProxyConfig -> Maybe Int
reverseTimeout ReverseProxyConfig
rpConfig
#else
   def
      { NHC.checkStatus = \_ _ _ -> Nothing
      , NHC.responseTimeout = reverseTimeout rpConfig
#endif
      , method :: ByteString
method = Request -> ByteString
Wai.requestMethod Request
request
      , secure :: Bool
secure = ReverseProxyConfig -> Bool
reversedUseSSL ReverseProxyConfig
rpConfig
      , host :: ByteString
host   = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ ReverseProxyConfig -> Text
reversedHost ReverseProxyConfig
rpConfig
      , port :: Int
port   = ReverseProxyConfig -> Int
reversedPort ReverseProxyConfig
rpConfig
      , path :: ByteString
path   = Request -> ByteString
Wai.rawPathInfo Request
request
      , queryString :: ByteString
queryString = Request -> ByteString
Wai.rawQueryString Request
request
      , requestHeaders :: [Header]
requestHeaders = [Header] -> [Header]
filterHeaders ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$ Map HeaderName RewriteRule -> [Header] -> [Header]
rewriteHeaders Map HeaderName RewriteRule
reqRuleMap (Request -> [Header]
Wai.requestHeaders Request
request)
      , requestBody :: RequestBody
requestBody =
          case Request -> RequestBodyLength
Wai.requestBodyLength Request
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 :: ByteString -> Bool
decompress = Bool -> ByteString -> Bool
forall a b. a -> b -> a
const Bool
False
      , redirectCount :: Int
redirectCount = Int
0
      , cookieJar :: Maybe CookieJar
cookieJar = Maybe CookieJar
forall a. Maybe a
Nothing
      , requestVersion :: HttpVersion
requestVersion = Request -> HttpVersion
Wai.httpVersion Request
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 (f :: * -> *) p.
Monad f =>
f ByteString -> (Builder -> f ()) -> p -> f ()
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 :: f ByteString -> (Builder -> f ()) -> p -> f ()
sendBody f ByteString
body Builder -> f ()
send p
_flush = (f () -> f ()) -> f ()
forall a. (a -> a) -> a
fix ((f () -> f ()) -> f ()) -> (f () -> f ()) -> f ()
forall a b. (a -> b) -> a -> b
$ \f ()
loop -> do
        ByteString
bs <- f ByteString
body
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ do
            () <- Builder -> f ()
send (Builder -> f ()) -> Builder -> f ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
fromByteString ByteString
bs
            f ()
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
/= :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
$c/= :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
== :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
$c== :: 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
min :: ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig
$cmin :: ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig
max :: ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig
$cmax :: ReverseProxyConfig -> ReverseProxyConfig -> ReverseProxyConfig
>= :: ReverseProxyConfig -> ReverseProxyConfig -> Bool
$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
compare :: ReverseProxyConfig -> ReverseProxyConfig -> Ordering
$ccompare :: ReverseProxyConfig -> ReverseProxyConfig -> Ordering
$cp1Ord :: Eq 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
showList :: [ReverseProxyConfig] -> ShowS
$cshowList :: [ReverseProxyConfig] -> ShowS
show :: ReverseProxyConfig -> String
$cshow :: ReverseProxyConfig -> String
showsPrec :: Int -> ReverseProxyConfig -> ShowS
$cshowsPrec :: Int -> 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 (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 (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 (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 (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 (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 (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 (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 (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
rewriteRequestRules :: Set RewriteRule
rewriteResponseRules :: Set RewriteRule
reverseTimeout :: Maybe Int
reversingUseSSL :: SSLConfig
reversingHost :: Text
reversedUseSSL :: Bool
reversedPort :: Int
reversedHost :: Text
reversingUseSSL :: ReverseProxyConfig -> SSLConfig
reversingHost :: ReverseProxyConfig -> Text
rewriteResponseRules :: ReverseProxyConfig -> Set RewriteRule
rewriteRequestRules :: ReverseProxyConfig -> Set RewriteRule
reversedPort :: ReverseProxyConfig -> Int
reversedHost :: ReverseProxyConfig -> Text
reversedUseSSL :: ReverseProxyConfig -> Bool
reverseTimeout :: ReverseProxyConfig -> Maybe Int
..} = [Pair] -> Value
object
        [ Key
"reversed-host" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
reversedHost
        , Key
"reversed-port" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
reversedPort
        , Key
"reversed-ssl" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
reversedUseSSL
        , Key
"reversing-host" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
reversingHost
        , Key
"ssl" Key -> SSLConfig -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SSLConfig
reversingUseSSL
        , Key
"timeout" Key -> Maybe Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
reverseTimeout
        , Key
"rewrite-response" Key -> Set RewriteRule -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Set RewriteRule
rewriteResponseRules
        , Key
"rewrite-request" Key -> Set RewriteRule -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Set RewriteRule
rewriteRequestRules
        ]

instance Default ReverseProxyConfig where
    def :: ReverseProxyConfig
def = ReverseProxyConfig :: Text
-> Int
-> Bool
-> Text
-> SSLConfig
-> Maybe Int
-> Set RewriteRule
-> Set RewriteRule
-> ReverseProxyConfig
ReverseProxyConfig
        { reversedHost :: Text
reversedHost = Text
""
        , reversedPort :: Int
reversedPort = Int
80
        , reversedUseSSL :: Bool
reversedUseSSL = Bool
False
        , reversingHost :: Text
reversingHost = Text
""
        , reversingUseSSL :: SSLConfig
reversingUseSSL = SSLConfig
SSLFalse
        , reverseTimeout :: Maybe Int
reverseTimeout = Maybe Int
forall a. Maybe a
Nothing
        , rewriteResponseRules :: Set RewriteRule
rewriteResponseRules = Set RewriteRule
forall a. Set a
Set.empty
        , rewriteRequestRules :: Set RewriteRule
rewriteRequestRules = Set RewriteRule
forall a. Set a
Set.empty
        }

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
/= :: RewriteRule -> RewriteRule -> Bool
$c/= :: RewriteRule -> RewriteRule -> Bool
== :: RewriteRule -> RewriteRule -> Bool
$c== :: 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
min :: RewriteRule -> RewriteRule -> RewriteRule
$cmin :: RewriteRule -> RewriteRule -> RewriteRule
max :: RewriteRule -> RewriteRule -> RewriteRule
$cmax :: RewriteRule -> RewriteRule -> RewriteRule
>= :: RewriteRule -> RewriteRule -> Bool
$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
compare :: RewriteRule -> RewriteRule -> Ordering
$ccompare :: RewriteRule -> RewriteRule -> Ordering
$cp1Ord :: Eq 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
showList :: [RewriteRule] -> ShowS
$cshowList :: [RewriteRule] -> ShowS
show :: RewriteRule -> String
$cshow :: RewriteRule -> String
showsPrec :: Int -> RewriteRule -> ShowS
$cshowsPrec :: Int -> 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 (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 (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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wanted an object"

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