{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeFamilies      #-}
module Keter.Config.V10 where

import           Control.Applicative               ((<$>), (<*>), (<|>))
import           Data.Aeson                        (FromJSON (..), ToJSON (..), Object,
                                                    Value (Object, String, Bool),
                                                    withObject, (.!=), (.:),
                                                    (.:?), object, (.=))
import           Keter.Aeson.KeyHelper              as AK (lookup, singleton, empty, insert)
import qualified Data.CaseInsensitive              as CI
import           Data.Conduit.Network              (HostPreference)
import qualified Data.Map                          as Map
import           Data.Maybe                        (catMaybes, fromMaybe, isJust)
import qualified Data.Set                          as Set
import           Data.String                       (fromString)
import           Data.Vector                       (Vector)
import qualified Data.Vector                       as V
import           Data.Word                         (Word)
import           Keter.Yaml.FilePath
import qualified System.FilePath                   as F
import           Keter.Common
import           Keter.Config.Middleware
import qualified Keter.Config.V04                   as V04
import qualified Network.Wai.Handler.Warp          as Warp
import qualified Network.Wai.Handler.WarpTLS       as WarpTLS
import           System.Posix.Types                (EpochTime)
import           Keter.Rewrite(ReverseProxyConfig)
import           Data.Text                  (Text)
import           System.FilePath            (FilePath)
import           Data.Set                   (Set)
import           Data.Map                   (Map)

data BundleConfig = BundleConfig
    { BundleConfig -> Vector (Stanza ())
bconfigStanzas :: !(Vector (Stanza ()))
    , BundleConfig -> Object
bconfigPlugins :: !Object -- ^ settings used for plugins
    } deriving Int -> BundleConfig -> ShowS
[BundleConfig] -> ShowS
BundleConfig -> String
(Int -> BundleConfig -> ShowS)
-> (BundleConfig -> String)
-> ([BundleConfig] -> ShowS)
-> Show BundleConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BundleConfig -> ShowS
showsPrec :: Int -> BundleConfig -> ShowS
$cshow :: BundleConfig -> String
show :: BundleConfig -> String
$cshowList :: [BundleConfig] -> ShowS
showList :: [BundleConfig] -> ShowS
Show

instance ToCurrent BundleConfig where
    type Previous BundleConfig = V04.BundleConfig
    toCurrent :: Previous BundleConfig -> BundleConfig
toCurrent (V04.BundleConfig Maybe AppConfig
webapp Set StaticHost
statics Set Redirect
redirs) = BundleConfig
        { bconfigStanzas :: Vector (Stanza ())
bconfigStanzas = [Vector (Stanza ())] -> Vector (Stanza ())
forall a. [Vector a] -> Vector a
V.concat
            [ Vector (Stanza ())
-> (Stanza () -> Vector (Stanza ()))
-> Maybe (Stanza ())
-> Vector (Stanza ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Vector (Stanza ())
forall a. Vector a
V.empty Stanza () -> Vector (Stanza ())
forall a. a -> Vector a
V.singleton (Maybe (Stanza ()) -> Vector (Stanza ()))
-> Maybe (Stanza ()) -> Vector (Stanza ())
forall a b. (a -> b) -> a -> b
$ (AppConfig -> Stanza ()) -> Maybe AppConfig -> Maybe (Stanza ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((StanzaRaw () -> RequiresSecure -> Stanza ())
-> RequiresSecure -> StanzaRaw () -> Stanza ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StanzaRaw () -> RequiresSecure -> Stanza ()
forall port. StanzaRaw port -> RequiresSecure -> Stanza port
Stanza RequiresSecure
False (StanzaRaw () -> Stanza ())
-> (AppConfig -> StanzaRaw ()) -> AppConfig -> Stanza ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebAppConfig () -> StanzaRaw ()
forall port. WebAppConfig port -> StanzaRaw port
StanzaWebApp (WebAppConfig () -> StanzaRaw ())
-> (AppConfig -> WebAppConfig ()) -> AppConfig -> StanzaRaw ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Previous (WebAppConfig ()) -> WebAppConfig ()
AppConfig -> WebAppConfig ()
forall a. ToCurrent a => Previous a -> a
toCurrent) Maybe AppConfig
webapp
            , [Stanza ()] -> Vector (Stanza ())
forall a. [a] -> Vector a
V.fromList ([Stanza ()] -> Vector (Stanza ()))
-> [Stanza ()] -> Vector (Stanza ())
forall a b. (a -> b) -> a -> b
$ (StaticHost -> Stanza ()) -> [StaticHost] -> [Stanza ()]
forall a b. (a -> b) -> [a] -> [b]
map ((StanzaRaw () -> RequiresSecure -> Stanza ())
-> RequiresSecure -> StanzaRaw () -> Stanza ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StanzaRaw () -> RequiresSecure -> Stanza ()
forall port. StanzaRaw port -> RequiresSecure -> Stanza port
Stanza RequiresSecure
False (StanzaRaw () -> Stanza ())
-> (StaticHost -> StanzaRaw ()) -> StaticHost -> Stanza ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaticFilesConfig -> StanzaRaw ()
forall port. StaticFilesConfig -> StanzaRaw port
StanzaStaticFiles (StaticFilesConfig -> StanzaRaw ())
-> (StaticHost -> StaticFilesConfig) -> StaticHost -> StanzaRaw ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Previous StaticFilesConfig -> StaticFilesConfig
StaticHost -> StaticFilesConfig
forall a. ToCurrent a => Previous a -> a
toCurrent) ([StaticHost] -> [Stanza ()]) -> [StaticHost] -> [Stanza ()]
forall a b. (a -> b) -> a -> b
$ Set StaticHost -> [StaticHost]
forall a. Set a -> [a]
Set.toList Set StaticHost
statics
            , [Stanza ()] -> Vector (Stanza ())
forall a. [a] -> Vector a
V.fromList ([Stanza ()] -> Vector (Stanza ()))
-> [Stanza ()] -> Vector (Stanza ())
forall a b. (a -> b) -> a -> b
$ (Redirect -> Stanza ()) -> [Redirect] -> [Stanza ()]
forall a b. (a -> b) -> [a] -> [b]
map ((StanzaRaw () -> RequiresSecure -> Stanza ())
-> RequiresSecure -> StanzaRaw () -> Stanza ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StanzaRaw () -> RequiresSecure -> Stanza ()
forall port. StanzaRaw port -> RequiresSecure -> Stanza port
Stanza RequiresSecure
False (StanzaRaw () -> Stanza ())
-> (Redirect -> StanzaRaw ()) -> Redirect -> Stanza ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedirectConfig -> StanzaRaw ()
forall port. RedirectConfig -> StanzaRaw port
StanzaRedirect (RedirectConfig -> StanzaRaw ())
-> (Redirect -> RedirectConfig) -> Redirect -> StanzaRaw ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Previous RedirectConfig -> RedirectConfig
Redirect -> RedirectConfig
forall a. ToCurrent a => Previous a -> a
toCurrent) ([Redirect] -> [Stanza ()]) -> [Redirect] -> [Stanza ()]
forall a b. (a -> b) -> a -> b
$ Set Redirect -> [Redirect]
forall a. Set a -> [a]
Set.toList Set Redirect
redirs
            ]
        , bconfigPlugins :: Object
bconfigPlugins =
            case Maybe AppConfig
webapp Maybe AppConfig -> (AppConfig -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
AK.lookup Key
"postgres" (Object -> Maybe Value)
-> (AppConfig -> Object) -> AppConfig -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppConfig -> Object
V04.configRaw of
                Just (Bool RequiresSecure
True) -> Key -> Value -> Object
forall v. Key -> v -> KeyMap v
AK.singleton Key
"postgres" (RequiresSecure -> Value
Bool RequiresSecure
True)
                Maybe Value
_ -> Object
forall v. KeyMap v
AK.empty
        }

instance ParseYamlFile BundleConfig where
    parseYamlFile :: BaseDir -> Value -> Parser BundleConfig
parseYamlFile BaseDir
basedir = String
-> (Object -> Parser BundleConfig) -> Value -> Parser BundleConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"BundleConfig" ((Object -> Parser BundleConfig) -> Value -> Parser BundleConfig)
-> (Object -> Parser BundleConfig) -> Value -> Parser BundleConfig
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
AK.lookup Key
"stanzas" Object
o of
            Maybe Value
Nothing -> (Previous BundleConfig -> BundleConfig
BundleConfig -> BundleConfig
forall a. ToCurrent a => Previous a -> a
toCurrent :: V04.BundleConfig -> BundleConfig) (BundleConfig -> BundleConfig)
-> Parser BundleConfig -> Parser BundleConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Value -> Parser BundleConfig
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir (Object -> Value
Object Object
o)
            Just Value
_ -> Object -> Parser BundleConfig
current Object
o
      where
        current :: Object -> Parser BundleConfig
current Object
o = Vector (Stanza ()) -> Object -> BundleConfig
BundleConfig
            (Vector (Stanza ()) -> Object -> BundleConfig)
-> Parser (Vector (Stanza ())) -> Parser (Object -> BundleConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Object -> Text -> Parser (Vector (Stanza ()))
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"stanzas"
            Parser (Object -> BundleConfig)
-> Parser Object -> Parser BundleConfig
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 Object)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"plugins" Parser (Maybe Object) -> Object -> Parser Object
forall a. Parser (Maybe a) -> a -> Parser a
.!= Object
forall v. KeyMap v
AK.empty

instance ToJSON BundleConfig where
    toJSON :: BundleConfig -> Value
toJSON BundleConfig {Object
Vector (Stanza ())
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: Object
..} = [Pair] -> Value
object
        [ Key
"stanzas" Key -> Vector (Stanza ()) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Vector (Stanza ())
bconfigStanzas
        , Key
"plugins" Key -> Object -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Object
bconfigPlugins
        ]

data ListeningPort = LPSecure !HostPreference !Port
                              !F.FilePath !(V.Vector F.FilePath) !F.FilePath
                              !Bool
                   | LPInsecure !HostPreference !Port

instance ParseYamlFile ListeningPort where
    parseYamlFile :: BaseDir -> Value -> Parser ListeningPort
parseYamlFile BaseDir
basedir = String
-> (Object -> Parser ListeningPort)
-> Value
-> Parser ListeningPort
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ListeningPort" ((Object -> Parser ListeningPort) -> Value -> Parser ListeningPort)
-> (Object -> Parser ListeningPort)
-> Value
-> Parser ListeningPort
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        HostPreference
host <- ((String -> HostPreference) -> Maybe String -> Maybe HostPreference
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> HostPreference
forall a. IsString a => String -> a
fromString (Maybe String -> Maybe HostPreference)
-> Parser (Maybe String) -> Parser (Maybe HostPreference)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"host") Parser (Maybe HostPreference)
-> HostPreference -> Parser HostPreference
forall a. Parser (Maybe a) -> a -> Parser a
.!= HostPreference
"*"
        Maybe String
mcert <- BaseDir -> Object -> Text -> Parser (Maybe String)
forall a.
ParseYamlFile a =>
BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Text
"certificate"
        Maybe String
mkey <- BaseDir -> Object -> Text -> Parser (Maybe String)
forall a.
ParseYamlFile a =>
BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Text
"key"
        RequiresSecure
session <- Object
o Object -> Key -> Parser (Maybe RequiresSecure)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"session" Parser (Maybe RequiresSecure)
-> RequiresSecure -> Parser RequiresSecure
forall a. Parser (Maybe a) -> a -> Parser a
.!= RequiresSecure
False
        case (Maybe String
mcert, Maybe String
mkey) of
            (Maybe String
Nothing, Maybe String
Nothing) -> do
                Int
port <- Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
80
                ListeningPort -> Parser ListeningPort
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (ListeningPort -> Parser ListeningPort)
-> ListeningPort -> Parser ListeningPort
forall a b. (a -> b) -> a -> b
$ HostPreference -> Int -> ListeningPort
LPInsecure HostPreference
host Int
port
            (Just String
cert, Just String
key) -> do
                Int
port <- Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
443
                Vector String
chainCerts <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"chain-certificates"
                    Parser (Maybe Value)
-> (Maybe Value -> Parser (Vector String))
-> Parser (Vector String)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser (Vector String)
-> (Value -> Parser (Vector String))
-> Maybe Value
-> Parser (Vector String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Vector String -> Parser (Vector String)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Vector String
forall a. Vector a
V.empty) (BaseDir -> Value -> Parser (Vector String)
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir)
                ListeningPort -> Parser ListeningPort
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (ListeningPort -> Parser ListeningPort)
-> ListeningPort -> Parser ListeningPort
forall a b. (a -> b) -> a -> b
$ HostPreference
-> Int
-> String
-> Vector String
-> String
-> RequiresSecure
-> ListeningPort
LPSecure HostPreference
host Int
port String
cert Vector String
chainCerts String
key RequiresSecure
session
            (Maybe String, Maybe String)
_ -> String -> Parser ListeningPort
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Must provide both certificate and key files"

data KeterConfig = KeterConfig
    { KeterConfig -> String
kconfigDir                 :: F.FilePath
    , KeterConfig -> PortSettings
kconfigPortPool            :: V04.PortSettings
    , KeterConfig -> NonEmptyVector ListeningPort
kconfigListeners           :: !(NonEmptyVector ListeningPort)
    , KeterConfig -> Maybe Text
kconfigSetuid              :: Maybe Text
    , KeterConfig -> Vector (Stanza ())
kconfigBuiltinStanzas      :: !(V.Vector (Stanza ()))
    , KeterConfig -> RequiresSecure
kconfigIpFromHeader        :: Bool
    , KeterConfig -> Int
kconfigExternalHttpPort    :: !Int
    -- ^ External HTTP port when generating APPROOTs.
    , KeterConfig -> Int
kconfigExternalHttpsPort   :: !Int
    -- ^ External HTTPS port when generating APPROOTs.
    , KeterConfig -> Map Text Text
kconfigEnvironment         :: !(Map Text Text)
    -- ^ Environment variables to be passed to all apps.
    , KeterConfig -> Int
kconfigConnectionTimeBound :: !Int
    -- ^ Maximum request time in milliseconds per connection.
    , KeterConfig -> Maybe Int
kconfigCliPort             :: !(Maybe Port)
    -- ^ Port for the cli to listen on

    , KeterConfig -> Maybe String
kconfigUnknownHostResponse  :: !(Maybe F.FilePath)
    , KeterConfig -> Maybe String
kconfigMissingHostResponse  :: !(Maybe F.FilePath)
    , KeterConfig -> Maybe String
kconfigProxyException       :: !(Maybe F.FilePath)

    , KeterConfig -> RequiresSecure
kconfigRotateLogs           :: !Bool
    , KeterConfig -> Maybe Text
kconfigHealthcheckPath      :: !(Maybe Text)
    }

instance ToCurrent KeterConfig where
    type Previous KeterConfig = V04.KeterConfig
    toCurrent :: Previous KeterConfig -> KeterConfig
toCurrent (V04.KeterConfig String
dir PortSettings
portman HostPreference
host Int
port Maybe TLSConfig
ssl Maybe Text
setuid Set ReverseProxyConfig
rproxy RequiresSecure
ipFromHeader Int
connectionTimeBound) = KeterConfig
        { kconfigDir :: String
kconfigDir = String
dir
        , kconfigPortPool :: PortSettings
kconfigPortPool = PortSettings
portman
        , kconfigListeners :: NonEmptyVector ListeningPort
kconfigListeners = ListeningPort
-> Vector ListeningPort -> NonEmptyVector ListeningPort
forall a. a -> Vector a -> NonEmptyVector a
NonEmptyVector (HostPreference -> Int -> ListeningPort
LPInsecure HostPreference
host Int
port) (Maybe TLSConfig -> Vector ListeningPort
getSSL Maybe TLSConfig
ssl)
        , kconfigSetuid :: Maybe Text
kconfigSetuid = Maybe Text
setuid
        , kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigBuiltinStanzas = [Stanza ()] -> Vector (Stanza ())
forall a. [a] -> Vector a
V.fromList ([Stanza ()] -> Vector (Stanza ()))
-> [Stanza ()] -> Vector (Stanza ())
forall a b. (a -> b) -> a -> b
$ (ReverseProxyConfig -> Stanza ())
-> [ReverseProxyConfig] -> [Stanza ()]
forall a b. (a -> b) -> [a] -> [b]
map ((StanzaRaw () -> RequiresSecure -> Stanza ())
-> RequiresSecure -> StanzaRaw () -> Stanza ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StanzaRaw () -> RequiresSecure -> Stanza ()
forall port. StanzaRaw port -> RequiresSecure -> Stanza port
Stanza RequiresSecure
False (StanzaRaw () -> Stanza ())
-> (ReverseProxyConfig -> StanzaRaw ())
-> ReverseProxyConfig
-> Stanza ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ReverseProxyConfig
rp -> ReverseProxyConfig
-> [MiddlewareConfig] -> Maybe Int -> StanzaRaw ()
forall port.
ReverseProxyConfig
-> [MiddlewareConfig] -> Maybe Int -> StanzaRaw port
StanzaReverseProxy ReverseProxyConfig
rp [] Maybe Int
forall a. Maybe a
Nothing)) ([ReverseProxyConfig] -> [Stanza ()])
-> [ReverseProxyConfig] -> [Stanza ()]
forall a b. (a -> b) -> a -> b
$ Set ReverseProxyConfig -> [ReverseProxyConfig]
forall a. Set a -> [a]
Set.toList Set ReverseProxyConfig
rproxy
        , kconfigIpFromHeader :: RequiresSecure
kconfigIpFromHeader = RequiresSecure
ipFromHeader
        , kconfigExternalHttpPort :: Int
kconfigExternalHttpPort = Int
80
        , kconfigExternalHttpsPort :: Int
kconfigExternalHttpsPort = Int
443
        , kconfigEnvironment :: Map Text Text
kconfigEnvironment = Map Text Text
forall k a. Map k a
Map.empty
        , kconfigConnectionTimeBound :: Int
kconfigConnectionTimeBound = Int
connectionTimeBound
        , kconfigCliPort :: Maybe Int
kconfigCliPort             = Maybe Int
forall a. Maybe a
Nothing
        , kconfigUnknownHostResponse :: Maybe String
kconfigUnknownHostResponse = Maybe String
forall a. Maybe a
Nothing
        , kconfigMissingHostResponse :: Maybe String
kconfigMissingHostResponse = Maybe String
forall a. Maybe a
Nothing
        , kconfigProxyException :: Maybe String
kconfigProxyException = Maybe String
forall a. Maybe a
Nothing
        , kconfigRotateLogs :: RequiresSecure
kconfigRotateLogs = RequiresSecure
True
        , kconfigHealthcheckPath :: Maybe Text
kconfigHealthcheckPath = Maybe Text
forall a. Maybe a
Nothing
        }
      where
        getSSL :: Maybe TLSConfig -> Vector ListeningPort
getSSL Maybe TLSConfig
Nothing = Vector ListeningPort
forall a. Vector a
V.empty
        getSSL (Just (V04.TLSConfig Settings
s String
cert String
key Maybe Config
session)) = ListeningPort -> Vector ListeningPort
forall a. a -> Vector a
V.singleton (ListeningPort -> Vector ListeningPort)
-> ListeningPort -> Vector ListeningPort
forall a b. (a -> b) -> a -> b
$ HostPreference
-> Int
-> String
-> Vector String
-> String
-> RequiresSecure
-> ListeningPort
LPSecure
            (Settings -> HostPreference
Warp.getHost Settings
s)
            (Settings -> Int
Warp.getPort Settings
s)
            String
cert
            Vector String
forall a. Vector a
V.empty
            String
key
            (Maybe Config -> RequiresSecure
forall a. Maybe a -> RequiresSecure
isJust Maybe Config
session)

defaultKeterConfig :: KeterConfig
defaultKeterConfig :: KeterConfig
defaultKeterConfig = KeterConfig
        { kconfigDir :: String
kconfigDir = String
"."
        , kconfigPortPool :: PortSettings
kconfigPortPool = PortSettings
V04.defaultPortSettings
        , kconfigListeners :: NonEmptyVector ListeningPort
kconfigListeners = ListeningPort
-> Vector ListeningPort -> NonEmptyVector ListeningPort
forall a. a -> Vector a -> NonEmptyVector a
NonEmptyVector (HostPreference -> Int -> ListeningPort
LPInsecure HostPreference
"*" Int
80) Vector ListeningPort
forall a. Vector a
V.empty
        , kconfigSetuid :: Maybe Text
kconfigSetuid = Maybe Text
forall a. Maybe a
Nothing
        , kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigBuiltinStanzas = Vector (Stanza ())
forall a. Vector a
V.empty
        , kconfigIpFromHeader :: RequiresSecure
kconfigIpFromHeader = RequiresSecure
False
        , kconfigExternalHttpPort :: Int
kconfigExternalHttpPort = Int
80
        , kconfigExternalHttpsPort :: Int
kconfigExternalHttpsPort = Int
443
        , kconfigEnvironment :: Map Text Text
kconfigEnvironment = Map Text Text
forall k a. Map k a
Map.empty
        , kconfigConnectionTimeBound :: Int
kconfigConnectionTimeBound = Int
V04.fiveMinutes
        , kconfigCliPort :: Maybe Int
kconfigCliPort = Maybe Int
forall a. Maybe a
Nothing
        , kconfigUnknownHostResponse :: Maybe String
kconfigUnknownHostResponse = Maybe String
forall a. Maybe a
Nothing
        , kconfigMissingHostResponse :: Maybe String
kconfigMissingHostResponse = Maybe String
forall a. Maybe a
Nothing
        , kconfigProxyException :: Maybe String
kconfigProxyException = Maybe String
forall a. Maybe a
Nothing
        , kconfigRotateLogs :: RequiresSecure
kconfigRotateLogs = RequiresSecure
True
        , kconfigHealthcheckPath :: Maybe Text
kconfigHealthcheckPath = Maybe Text
forall a. Maybe a
Nothing
        }

instance ParseYamlFile KeterConfig where
    parseYamlFile :: BaseDir -> Value -> Parser KeterConfig
parseYamlFile BaseDir
basedir = String
-> (Object -> Parser KeterConfig) -> Value -> Parser KeterConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"KeterConfig" ((Object -> Parser KeterConfig) -> Value -> Parser KeterConfig)
-> (Object -> Parser KeterConfig) -> Value -> Parser KeterConfig
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
AK.lookup Key
"listeners" Object
o of
            Just Value
_ -> Object -> Parser KeterConfig
current Object
o
            Maybe Value
Nothing -> Object -> Parser KeterConfig
old Object
o Parser KeterConfig -> Parser KeterConfig -> Parser KeterConfig
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object -> Parser KeterConfig
current Object
o
      where
        old :: Object -> Parser KeterConfig
old Object
o = (Previous KeterConfig -> KeterConfig
KeterConfig -> KeterConfig
forall a. ToCurrent a => Previous a -> a
toCurrent :: V04.KeterConfig -> KeterConfig) (KeterConfig -> KeterConfig)
-> Parser KeterConfig -> Parser KeterConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Value -> Parser KeterConfig
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir (Object -> Value
Object Object
o)
        current :: Object -> Parser KeterConfig
current Object
o = String
-> PortSettings
-> NonEmptyVector ListeningPort
-> Maybe Text
-> Vector (Stanza ())
-> RequiresSecure
-> Int
-> Int
-> Map Text Text
-> Int
-> Maybe Int
-> Maybe String
-> Maybe String
-> Maybe String
-> RequiresSecure
-> Maybe Text
-> KeterConfig
KeterConfig
            (String
 -> PortSettings
 -> NonEmptyVector ListeningPort
 -> Maybe Text
 -> Vector (Stanza ())
 -> RequiresSecure
 -> Int
 -> Int
 -> Map Text Text
 -> Int
 -> Maybe Int
 -> Maybe String
 -> Maybe String
 -> Maybe String
 -> RequiresSecure
 -> Maybe Text
 -> KeterConfig)
-> Parser String
-> Parser
     (PortSettings
      -> NonEmptyVector ListeningPort
      -> Maybe Text
      -> Vector (Stanza ())
      -> RequiresSecure
      -> Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Object -> Text -> Parser String
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"root"
            Parser
  (PortSettings
   -> NonEmptyVector ListeningPort
   -> Maybe Text
   -> Vector (Stanza ())
   -> RequiresSecure
   -> Int
   -> Int
   -> Map Text Text
   -> Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser PortSettings
-> Parser
     (NonEmptyVector ListeningPort
      -> Maybe Text
      -> Vector (Stanza ())
      -> RequiresSecure
      -> Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
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 PortSettings)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port-manager" Parser (Maybe PortSettings) -> PortSettings -> Parser PortSettings
forall a. Parser (Maybe a) -> a -> Parser a
.!= PortSettings
V04.defaultPortSettings
            Parser
  (NonEmptyVector ListeningPort
   -> Maybe Text
   -> Vector (Stanza ())
   -> RequiresSecure
   -> Int
   -> Int
   -> Map Text Text
   -> Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser (NonEmptyVector ListeningPort)
-> Parser
     (Maybe Text
      -> Vector (Stanza ())
      -> RequiresSecure
      -> Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe (NonEmptyVector ListeningPort)
 -> NonEmptyVector ListeningPort)
-> Parser (Maybe (NonEmptyVector ListeningPort))
-> Parser (NonEmptyVector ListeningPort)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NonEmptyVector ListeningPort
-> Maybe (NonEmptyVector ListeningPort)
-> NonEmptyVector ListeningPort
forall a. a -> Maybe a -> a
fromMaybe (KeterConfig -> NonEmptyVector ListeningPort
kconfigListeners KeterConfig
defaultKeterConfig)) (BaseDir
-> Object -> Text -> Parser (Maybe (NonEmptyVector ListeningPort))
forall a.
ParseYamlFile a =>
BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Text
"listeners")
            Parser
  (Maybe Text
   -> Vector (Stanza ())
   -> RequiresSecure
   -> Int
   -> Int
   -> Map Text Text
   -> Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser (Maybe Text)
-> Parser
     (Vector (Stanza ())
      -> RequiresSecure
      -> Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
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 Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"setuid"
            Parser
  (Vector (Stanza ())
   -> RequiresSecure
   -> Int
   -> Int
   -> Map Text Text
   -> Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser (Vector (Stanza ()))
-> Parser
     (RequiresSecure
      -> Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Vector (Stanza ()) -> Parser (Vector (Stanza ()))
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Vector (Stanza ())
forall a. Vector a
V.empty
            Parser
  (RequiresSecure
   -> Int
   -> Int
   -> Map Text Text
   -> Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser RequiresSecure
-> Parser
     (Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
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 RequiresSecure)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ip-from-header" Parser (Maybe RequiresSecure)
-> RequiresSecure -> Parser RequiresSecure
forall a. Parser (Maybe a) -> a -> Parser a
.!= RequiresSecure
False
            Parser
  (Int
   -> Int
   -> Map Text Text
   -> Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser Int
-> Parser
     (Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"external-http-port" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
80
            Parser
  (Int
   -> Map Text Text
   -> Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser Int
-> Parser
     (Map Text Text
      -> Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"external-https-port" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
443
            Parser
  (Map Text Text
   -> Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser (Map Text Text)
-> Parser
     (Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
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 (Map Text Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"env" Parser (Maybe (Map Text Text))
-> Map Text Text -> Parser (Map Text Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Text Text
forall k a. Map k a
Map.empty
            Parser
  (Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser Int
-> Parser
     (Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"connection-time-bound" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
V04.fiveMinutes
            Parser
  (Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser (Maybe Int)
-> Parser
     (Maybe String
      -> Maybe String
      -> Maybe String
      -> RequiresSecure
      -> Maybe Text
      -> KeterConfig)
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"cli-port"
            Parser
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> RequiresSecure
   -> Maybe Text
   -> KeterConfig)
-> Parser (Maybe String)
-> Parser
     (Maybe String
      -> Maybe String -> RequiresSecure -> Maybe Text -> KeterConfig)
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 String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"unknown-host-response-file"
            Parser
  (Maybe String
   -> Maybe String -> RequiresSecure -> Maybe Text -> KeterConfig)
-> Parser (Maybe String)
-> Parser
     (Maybe String -> RequiresSecure -> Maybe Text -> KeterConfig)
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 String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"missing-host-response-file"
            Parser
  (Maybe String -> RequiresSecure -> Maybe Text -> KeterConfig)
-> Parser (Maybe String)
-> Parser (RequiresSecure -> Maybe Text -> KeterConfig)
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 String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"proxy-exception-response-file"
            Parser (RequiresSecure -> Maybe Text -> KeterConfig)
-> Parser RequiresSecure -> Parser (Maybe Text -> KeterConfig)
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 RequiresSecure)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"rotate-logs" Parser (Maybe RequiresSecure)
-> RequiresSecure -> Parser RequiresSecure
forall a. Parser (Maybe a) -> a -> Parser a
.!= RequiresSecure
True
            Parser (Maybe Text -> KeterConfig)
-> Parser (Maybe Text) -> Parser KeterConfig
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 Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"app-crash-hook"

-- | Whether we should force redirect to HTTPS routes.
type RequiresSecure = Bool

data Stanza port = Stanza (StanzaRaw port) RequiresSecure
  deriving Int -> Stanza port -> ShowS
[Stanza port] -> ShowS
Stanza port -> String
(Int -> Stanza port -> ShowS)
-> (Stanza port -> String)
-> ([Stanza port] -> ShowS)
-> Show (Stanza port)
forall port. Show port => Int -> Stanza port -> ShowS
forall port. Show port => [Stanza port] -> ShowS
forall port. Show port => Stanza port -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall port. Show port => Int -> Stanza port -> ShowS
showsPrec :: Int -> Stanza port -> ShowS
$cshow :: forall port. Show port => Stanza port -> String
show :: Stanza port -> String
$cshowList :: forall port. Show port => [Stanza port] -> ShowS
showList :: [Stanza port] -> ShowS
Show

data StanzaRaw port
    = StanzaStaticFiles !StaticFilesConfig
    | StanzaRedirect !RedirectConfig
    | StanzaWebApp !(WebAppConfig port)
    | StanzaReverseProxy !ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)
    | StanzaBackground !BackgroundConfig
            -- FIXME console app
    deriving Int -> StanzaRaw port -> ShowS
[StanzaRaw port] -> ShowS
StanzaRaw port -> String
(Int -> StanzaRaw port -> ShowS)
-> (StanzaRaw port -> String)
-> ([StanzaRaw port] -> ShowS)
-> Show (StanzaRaw port)
forall port. Show port => Int -> StanzaRaw port -> ShowS
forall port. Show port => [StanzaRaw port] -> ShowS
forall port. Show port => StanzaRaw port -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall port. Show port => Int -> StanzaRaw port -> ShowS
showsPrec :: Int -> StanzaRaw port -> ShowS
$cshow :: forall port. Show port => StanzaRaw port -> String
show :: StanzaRaw port -> String
$cshowList :: forall port. Show port => [StanzaRaw port] -> ShowS
showList :: [StanzaRaw port] -> ShowS
Show

-- | An action to be performed for a requested hostname.
--
-- This datatype is very similar to Stanza, but is necessarily separate since:
--
-- 1. Webapps will be assigned ports.
--
-- 2. Not all stanzas have an associated proxy action.
data ProxyActionRaw
    = PAPort Port !(Maybe Int)
    | PAStatic StaticFilesConfig
    | PARedirect RedirectConfig
    | PAReverseProxy ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)
    deriving Int -> ProxyActionRaw -> ShowS
[ProxyActionRaw] -> ShowS
ProxyActionRaw -> String
(Int -> ProxyActionRaw -> ShowS)
-> (ProxyActionRaw -> String)
-> ([ProxyActionRaw] -> ShowS)
-> Show ProxyActionRaw
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProxyActionRaw -> ShowS
showsPrec :: Int -> ProxyActionRaw -> ShowS
$cshow :: ProxyActionRaw -> String
show :: ProxyActionRaw -> String
$cshowList :: [ProxyActionRaw] -> ShowS
showList :: [ProxyActionRaw] -> ShowS
Show

type ProxyAction = (ProxyActionRaw, RequiresSecure)

instance ParseYamlFile (Stanza ()) where
    parseYamlFile :: BaseDir -> Value -> Parser (Stanza ())
parseYamlFile BaseDir
basedir = String
-> (Object -> Parser (Stanza ())) -> Value -> Parser (Stanza ())
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Stanza" ((Object -> Parser (Stanza ())) -> Value -> Parser (Stanza ()))
-> (Object -> Parser (Stanza ())) -> Value -> Parser (Stanza ())
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        String
typ <- Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
        RequiresSecure
needsHttps <- Object
o Object -> Key -> Parser (Maybe RequiresSecure)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"requires-secure" Parser (Maybe RequiresSecure)
-> RequiresSecure -> Parser RequiresSecure
forall a. Parser (Maybe a) -> a -> Parser a
.!= RequiresSecure
False
        StanzaRaw ()
raw <- case String
typ of
            String
"static-files"  -> (StaticFilesConfig -> StanzaRaw ())
-> Parser StaticFilesConfig -> Parser (StanzaRaw ())
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StaticFilesConfig -> StanzaRaw ()
forall port. StaticFilesConfig -> StanzaRaw port
StanzaStaticFiles (Parser StaticFilesConfig -> Parser (StanzaRaw ()))
-> Parser StaticFilesConfig -> Parser (StanzaRaw ())
forall a b. (a -> b) -> a -> b
$ BaseDir -> Value -> Parser StaticFilesConfig
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir (Value -> Parser StaticFilesConfig)
-> Value -> Parser StaticFilesConfig
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o
            String
"redirect"      -> (RedirectConfig -> StanzaRaw ())
-> Parser RedirectConfig -> Parser (StanzaRaw ())
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RedirectConfig -> StanzaRaw ()
forall port. RedirectConfig -> StanzaRaw port
StanzaRedirect (Parser RedirectConfig -> Parser (StanzaRaw ()))
-> Parser RedirectConfig -> Parser (StanzaRaw ())
forall a b. (a -> b) -> a -> b
$ BaseDir -> Value -> Parser RedirectConfig
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir (Value -> Parser RedirectConfig) -> Value -> Parser RedirectConfig
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o
            String
"webapp"        -> (WebAppConfig () -> StanzaRaw ())
-> Parser (WebAppConfig ()) -> Parser (StanzaRaw ())
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WebAppConfig () -> StanzaRaw ()
forall port. WebAppConfig port -> StanzaRaw port
StanzaWebApp (Parser (WebAppConfig ()) -> Parser (StanzaRaw ()))
-> Parser (WebAppConfig ()) -> Parser (StanzaRaw ())
forall a b. (a -> b) -> a -> b
$ BaseDir -> Value -> Parser (WebAppConfig ())
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir (Value -> Parser (WebAppConfig ()))
-> Value -> Parser (WebAppConfig ())
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o
            String
"reverse-proxy" -> ReverseProxyConfig
-> [MiddlewareConfig] -> Maybe Int -> StanzaRaw ()
forall port.
ReverseProxyConfig
-> [MiddlewareConfig] -> Maybe Int -> StanzaRaw port
StanzaReverseProxy (ReverseProxyConfig
 -> [MiddlewareConfig] -> Maybe Int -> StanzaRaw ())
-> Parser ReverseProxyConfig
-> Parser ([MiddlewareConfig] -> Maybe Int -> StanzaRaw ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser ReverseProxyConfig
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
                                                  Parser ([MiddlewareConfig] -> Maybe Int -> StanzaRaw ())
-> Parser [MiddlewareConfig] -> Parser (Maybe Int -> StanzaRaw ())
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 [MiddlewareConfig])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"middleware" Parser (Maybe [MiddlewareConfig])
-> [MiddlewareConfig] -> Parser [MiddlewareConfig]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
                                                  Parser (Maybe Int -> StanzaRaw ())
-> Parser (Maybe Int) -> Parser (StanzaRaw ())
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"connection-time-bound"
            String
"background"    -> (BackgroundConfig -> StanzaRaw ())
-> Parser BackgroundConfig -> Parser (StanzaRaw ())
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BackgroundConfig -> StanzaRaw ()
forall port. BackgroundConfig -> StanzaRaw port
StanzaBackground (Parser BackgroundConfig -> Parser (StanzaRaw ()))
-> Parser BackgroundConfig -> Parser (StanzaRaw ())
forall a b. (a -> b) -> a -> b
$ BaseDir -> Value -> Parser BackgroundConfig
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir (Value -> Parser BackgroundConfig)
-> Value -> Parser BackgroundConfig
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o
            String
_ -> String -> Parser (StanzaRaw ())
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (StanzaRaw ()))
-> String -> Parser (StanzaRaw ())
forall a b. (a -> b) -> a -> b
$ String
"Unknown stanza type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
typ
        Stanza () -> Parser (Stanza ())
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stanza () -> Parser (Stanza ()))
-> Stanza () -> Parser (Stanza ())
forall a b. (a -> b) -> a -> b
$ StanzaRaw () -> RequiresSecure -> Stanza ()
forall port. StanzaRaw port -> RequiresSecure -> Stanza port
Stanza StanzaRaw ()
raw RequiresSecure
needsHttps

instance ToJSON (Stanza ()) where
    toJSON :: Stanza () -> Value
toJSON (Stanza StanzaRaw ()
raw RequiresSecure
rs) = RequiresSecure -> StanzaRaw () -> Value
forall a. ToJSON a => RequiresSecure -> a -> Value
addRequiresSecure RequiresSecure
rs StanzaRaw ()
raw

addRequiresSecure :: ToJSON a => Bool -> a -> Value
addRequiresSecure :: forall a. ToJSON a => RequiresSecure -> a -> Value
addRequiresSecure RequiresSecure
rs a
x =
    case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x of
        Object Object
o -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
AK.insert Key
"requires-secure" (RequiresSecure -> Value
forall a. ToJSON a => a -> Value
toJSON RequiresSecure
rs) Object
o
        Value
v -> Value
v

instance ToJSON (StanzaRaw ()) where
    toJSON :: StanzaRaw () -> Value
toJSON (StanzaStaticFiles StaticFilesConfig
x) = Value -> StaticFilesConfig -> Value
forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
"static-files" StaticFilesConfig
x
    toJSON (StanzaRedirect RedirectConfig
x) = Value -> RedirectConfig -> Value
forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
"redirect" RedirectConfig
x
    toJSON (StanzaWebApp WebAppConfig ()
x) = Value -> WebAppConfig () -> Value
forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
"webapp" WebAppConfig ()
x
    toJSON (StanzaReverseProxy ReverseProxyConfig
x [MiddlewareConfig]
_ Maybe Int
_) = Value -> ReverseProxyConfig -> Value
forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
"reverse-proxy" ReverseProxyConfig
x
    toJSON (StanzaBackground BackgroundConfig
x) = Value -> BackgroundConfig -> Value
forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
"background" BackgroundConfig
x

addStanzaType :: ToJSON a => Value -> a -> Value
addStanzaType :: forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
t a
x =
    case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x of
        Object Object
o -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
AK.insert Key
"type" Value
t Object
o
        Value
v -> Value
v

data StaticFilesConfig = StaticFilesConfig
    { StaticFilesConfig -> String
sfconfigRoot       :: !F.FilePath
    , StaticFilesConfig -> Set Host
sfconfigHosts      :: !(Set Host)
    , StaticFilesConfig -> RequiresSecure
sfconfigListings   :: !Bool
    -- FIXME basic auth
    , StaticFilesConfig -> [MiddlewareConfig]
sfconfigMiddleware :: ![ MiddlewareConfig ]
    , StaticFilesConfig -> Maybe Int
sfconfigTimeout    :: !(Maybe Int)
    , StaticFilesConfig -> SSLConfig
sfconfigSsl        :: !SSLConfig
    }
    deriving Int -> StaticFilesConfig -> ShowS
[StaticFilesConfig] -> ShowS
StaticFilesConfig -> String
(Int -> StaticFilesConfig -> ShowS)
-> (StaticFilesConfig -> String)
-> ([StaticFilesConfig] -> ShowS)
-> Show StaticFilesConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StaticFilesConfig -> ShowS
showsPrec :: Int -> StaticFilesConfig -> ShowS
$cshow :: StaticFilesConfig -> String
show :: StaticFilesConfig -> String
$cshowList :: [StaticFilesConfig] -> ShowS
showList :: [StaticFilesConfig] -> ShowS
Show

instance ToCurrent StaticFilesConfig where
    type Previous StaticFilesConfig = V04.StaticHost
    toCurrent :: Previous StaticFilesConfig -> StaticFilesConfig
toCurrent (V04.StaticHost Text
host String
root) = StaticFilesConfig
        { sfconfigRoot :: String
sfconfigRoot       = String
root
        , sfconfigHosts :: Set Host
sfconfigHosts      = Host -> Set Host
forall a. a -> Set a
Set.singleton (Host -> Set Host) -> Host -> Set Host
forall a b. (a -> b) -> a -> b
$ Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk Text
host
        , sfconfigListings :: RequiresSecure
sfconfigListings   = RequiresSecure
True
        , sfconfigMiddleware :: [MiddlewareConfig]
sfconfigMiddleware = []
        , sfconfigTimeout :: Maybe Int
sfconfigTimeout    = Maybe Int
forall a. Maybe a
Nothing
        , sfconfigSsl :: SSLConfig
sfconfigSsl        = SSLConfig
SSLFalse
        }

instance ParseYamlFile StaticFilesConfig where
    parseYamlFile :: BaseDir -> Value -> Parser StaticFilesConfig
parseYamlFile BaseDir
basedir = String
-> (Object -> Parser StaticFilesConfig)
-> Value
-> Parser StaticFilesConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"StaticFilesConfig" ((Object -> Parser StaticFilesConfig)
 -> Value -> Parser StaticFilesConfig)
-> (Object -> Parser StaticFilesConfig)
-> Value
-> Parser StaticFilesConfig
forall a b. (a -> b) -> a -> b
$ \Object
o -> String
-> Set Host
-> RequiresSecure
-> [MiddlewareConfig]
-> Maybe Int
-> SSLConfig
-> StaticFilesConfig
StaticFilesConfig
        (String
 -> Set Host
 -> RequiresSecure
 -> [MiddlewareConfig]
 -> Maybe Int
 -> SSLConfig
 -> StaticFilesConfig)
-> Parser String
-> Parser
     (Set Host
      -> RequiresSecure
      -> [MiddlewareConfig]
      -> Maybe Int
      -> SSLConfig
      -> StaticFilesConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Object -> Text -> Parser String
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"root"
        Parser
  (Set Host
   -> RequiresSecure
   -> [MiddlewareConfig]
   -> Maybe Int
   -> SSLConfig
   -> StaticFilesConfig)
-> Parser (Set Host)
-> Parser
     (RequiresSecure
      -> [MiddlewareConfig]
      -> Maybe Int
      -> SSLConfig
      -> StaticFilesConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text -> Host) -> Set Text -> Set Host
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk (Set Text -> Set Host) -> Parser (Set Text) -> Parser (Set Host)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser (Set Text)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hosts" Parser (Set Text) -> Parser (Set Text) -> Parser (Set Text)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Set Text
forall a. a -> Set a
Set.singleton (Text -> Set Text) -> Parser Text -> Parser (Set Text)
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
"host"))))
        Parser
  (RequiresSecure
   -> [MiddlewareConfig]
   -> Maybe Int
   -> SSLConfig
   -> StaticFilesConfig)
-> Parser RequiresSecure
-> Parser
     ([MiddlewareConfig] -> Maybe Int -> SSLConfig -> StaticFilesConfig)
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 RequiresSecure)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"directory-listing" Parser (Maybe RequiresSecure)
-> RequiresSecure -> Parser RequiresSecure
forall a. Parser (Maybe a) -> a -> Parser a
.!= RequiresSecure
False
        Parser
  ([MiddlewareConfig] -> Maybe Int -> SSLConfig -> StaticFilesConfig)
-> Parser [MiddlewareConfig]
-> Parser (Maybe Int -> SSLConfig -> StaticFilesConfig)
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 [MiddlewareConfig])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"middleware" Parser (Maybe [MiddlewareConfig])
-> [MiddlewareConfig] -> Parser [MiddlewareConfig]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
        Parser (Maybe Int -> SSLConfig -> StaticFilesConfig)
-> Parser (Maybe Int) -> Parser (SSLConfig -> StaticFilesConfig)
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"connection-time-bound"
        Parser (SSLConfig -> StaticFilesConfig)
-> Parser SSLConfig -> Parser StaticFilesConfig
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

instance ToJSON StaticFilesConfig where
    toJSON :: StaticFilesConfig -> Value
toJSON StaticFilesConfig {RequiresSecure
String
[MiddlewareConfig]
Maybe Int
Set Host
SSLConfig
sfconfigRoot :: StaticFilesConfig -> String
sfconfigHosts :: StaticFilesConfig -> Set Host
sfconfigListings :: StaticFilesConfig -> RequiresSecure
sfconfigMiddleware :: StaticFilesConfig -> [MiddlewareConfig]
sfconfigTimeout :: StaticFilesConfig -> Maybe Int
sfconfigSsl :: StaticFilesConfig -> SSLConfig
sfconfigRoot :: String
sfconfigHosts :: Set Host
sfconfigListings :: RequiresSecure
sfconfigMiddleware :: [MiddlewareConfig]
sfconfigTimeout :: Maybe Int
sfconfigSsl :: SSLConfig
..} = [Pair] -> Value
object
        [ Key
"root" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
sfconfigRoot
        , Key
"hosts" Key -> Set Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Host -> Text) -> Set Host -> Set Text
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Host -> Text
forall s. CI s -> s
CI.original Set Host
sfconfigHosts
        , Key
"directory-listing" Key -> RequiresSecure -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequiresSecure
sfconfigListings
        , Key
"middleware" Key -> [MiddlewareConfig] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [MiddlewareConfig]
sfconfigMiddleware
        , Key
"connection-time-bound" 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
sfconfigTimeout
        , 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
sfconfigSsl
        ]

data RedirectConfig = RedirectConfig
    { RedirectConfig -> Set Host
redirconfigHosts   :: !(Set Host)
    , RedirectConfig -> Int
redirconfigStatus  :: !Int
    , RedirectConfig -> Vector RedirectAction
redirconfigActions :: !(Vector RedirectAction)
    , RedirectConfig -> SSLConfig
redirconfigSsl     :: !SSLConfig
    }
    deriving Int -> RedirectConfig -> ShowS
[RedirectConfig] -> ShowS
RedirectConfig -> String
(Int -> RedirectConfig -> ShowS)
-> (RedirectConfig -> String)
-> ([RedirectConfig] -> ShowS)
-> Show RedirectConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RedirectConfig -> ShowS
showsPrec :: Int -> RedirectConfig -> ShowS
$cshow :: RedirectConfig -> String
show :: RedirectConfig -> String
$cshowList :: [RedirectConfig] -> ShowS
showList :: [RedirectConfig] -> ShowS
Show

instance ToCurrent RedirectConfig where
    type Previous RedirectConfig = V04.Redirect
    toCurrent :: Previous RedirectConfig -> RedirectConfig
toCurrent (V04.Redirect Text
from Text
to) = RedirectConfig
        { redirconfigHosts :: Set Host
redirconfigHosts = Host -> Set Host
forall a. a -> Set a
Set.singleton (Host -> Set Host) -> Host -> Set Host
forall a b. (a -> b) -> a -> b
$ Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk Text
from
        , redirconfigStatus :: Int
redirconfigStatus = Int
301
        , redirconfigActions :: Vector RedirectAction
redirconfigActions = RedirectAction -> Vector RedirectAction
forall a. a -> Vector a
V.singleton (RedirectAction -> Vector RedirectAction)
-> RedirectAction -> Vector RedirectAction
forall a b. (a -> b) -> a -> b
$ SourcePath -> RedirectDest -> RedirectAction
RedirectAction SourcePath
SPAny
                             (RedirectDest -> RedirectAction) -> RedirectDest -> RedirectAction
forall a b. (a -> b) -> a -> b
$ RequiresSecure -> Host -> Maybe Int -> RedirectDest
RDPrefix RequiresSecure
False (Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk Text
to) Maybe Int
forall a. Maybe a
Nothing
        , redirconfigSsl :: SSLConfig
redirconfigSsl = SSLConfig
SSLFalse
        }

instance ParseYamlFile RedirectConfig where
    parseYamlFile :: BaseDir -> Value -> Parser RedirectConfig
parseYamlFile BaseDir
_ = String
-> (Object -> Parser RedirectConfig)
-> Value
-> Parser RedirectConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RedirectConfig" ((Object -> Parser RedirectConfig)
 -> Value -> Parser RedirectConfig)
-> (Object -> Parser RedirectConfig)
-> Value
-> Parser RedirectConfig
forall a b. (a -> b) -> a -> b
$ \Object
o -> Set Host
-> Int -> Vector RedirectAction -> SSLConfig -> RedirectConfig
RedirectConfig
        (Set Host
 -> Int -> Vector RedirectAction -> SSLConfig -> RedirectConfig)
-> Parser (Set Host)
-> Parser
     (Int -> Vector RedirectAction -> SSLConfig -> RedirectConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text -> Host) -> Set Text -> Set Host
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk (Set Text -> Set Host) -> Parser (Set Text) -> Parser (Set Host)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser (Set Text)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hosts" Parser (Set Text) -> Parser (Set Text) -> Parser (Set Text)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Set Text
forall a. a -> Set a
Set.singleton (Text -> Set Text) -> Parser Text -> Parser (Set Text)
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
"host"))
        Parser
  (Int -> Vector RedirectAction -> SSLConfig -> RedirectConfig)
-> Parser Int
-> Parser (Vector RedirectAction -> SSLConfig -> RedirectConfig)
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"status" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
303
        Parser (Vector RedirectAction -> SSLConfig -> RedirectConfig)
-> Parser (Vector RedirectAction)
-> Parser (SSLConfig -> RedirectConfig)
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 (Vector RedirectAction)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"actions"
        Parser (SSLConfig -> RedirectConfig)
-> Parser SSLConfig -> Parser RedirectConfig
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

instance ToJSON RedirectConfig where
    toJSON :: RedirectConfig -> Value
toJSON RedirectConfig {Int
Vector RedirectAction
Set Host
SSLConfig
redirconfigHosts :: RedirectConfig -> Set Host
redirconfigStatus :: RedirectConfig -> Int
redirconfigActions :: RedirectConfig -> Vector RedirectAction
redirconfigSsl :: RedirectConfig -> SSLConfig
redirconfigHosts :: Set Host
redirconfigStatus :: Int
redirconfigActions :: Vector RedirectAction
redirconfigSsl :: SSLConfig
..} = [Pair] -> Value
object
        [ Key
"hosts" Key -> Set Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Host -> Text) -> Set Host -> Set Text
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Host -> Text
forall s. CI s -> s
CI.original Set Host
redirconfigHosts
        , Key
"status" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
redirconfigStatus
        , Key
"actions" Key -> Vector RedirectAction -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Vector RedirectAction
redirconfigActions
        , 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
redirconfigSsl
        ]

data RedirectAction = RedirectAction !SourcePath !RedirectDest
    deriving Int -> RedirectAction -> ShowS
[RedirectAction] -> ShowS
RedirectAction -> String
(Int -> RedirectAction -> ShowS)
-> (RedirectAction -> String)
-> ([RedirectAction] -> ShowS)
-> Show RedirectAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RedirectAction -> ShowS
showsPrec :: Int -> RedirectAction -> ShowS
$cshow :: RedirectAction -> String
show :: RedirectAction -> String
$cshowList :: [RedirectAction] -> ShowS
showList :: [RedirectAction] -> ShowS
Show

instance FromJSON RedirectAction where
    parseJSON :: Value -> Parser RedirectAction
parseJSON = String
-> (Object -> Parser RedirectAction)
-> Value
-> Parser RedirectAction
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RedirectAction" ((Object -> Parser RedirectAction)
 -> Value -> Parser RedirectAction)
-> (Object -> Parser RedirectAction)
-> Value
-> Parser RedirectAction
forall a b. (a -> b) -> a -> b
$ \Object
o -> SourcePath -> RedirectDest -> RedirectAction
RedirectAction
        (SourcePath -> RedirectDest -> RedirectAction)
-> Parser SourcePath -> Parser (RedirectDest -> RedirectAction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SourcePath -> (Text -> SourcePath) -> Maybe Text -> SourcePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SourcePath
SPAny Text -> SourcePath
SPSpecific (Maybe Text -> SourcePath)
-> Parser (Maybe Text) -> Parser SourcePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"path"))
        Parser (RedirectDest -> RedirectAction)
-> Parser RedirectDest -> Parser RedirectAction
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser RedirectDest
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)

instance ToJSON RedirectAction where
    toJSON :: RedirectAction -> Value
toJSON (RedirectAction SourcePath
path RedirectDest
dest) =
        case RedirectDest -> Value
forall a. ToJSON a => a -> Value
toJSON RedirectDest
dest of
            Object Object
o ->
                case SourcePath
path of
                    SourcePath
SPAny -> Object -> Value
Object Object
o
                    SPSpecific Text
x -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
AK.insert Key
"path" (Text -> Value
String Text
x) Object
o
            Value
v -> Value
v

data SourcePath = SPAny
                | SPSpecific !Text
    deriving Int -> SourcePath -> ShowS
[SourcePath] -> ShowS
SourcePath -> String
(Int -> SourcePath -> ShowS)
-> (SourcePath -> String)
-> ([SourcePath] -> ShowS)
-> Show SourcePath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SourcePath -> ShowS
showsPrec :: Int -> SourcePath -> ShowS
$cshow :: SourcePath -> String
show :: SourcePath -> String
$cshowList :: [SourcePath] -> ShowS
showList :: [SourcePath] -> ShowS
Show

data RedirectDest = RDUrl !Text
                  | RDPrefix !IsSecure !Host !(Maybe Port)
    deriving Int -> RedirectDest -> ShowS
[RedirectDest] -> ShowS
RedirectDest -> String
(Int -> RedirectDest -> ShowS)
-> (RedirectDest -> String)
-> ([RedirectDest] -> ShowS)
-> Show RedirectDest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RedirectDest -> ShowS
showsPrec :: Int -> RedirectDest -> ShowS
$cshow :: RedirectDest -> String
show :: RedirectDest -> String
$cshowList :: [RedirectDest] -> ShowS
showList :: [RedirectDest] -> ShowS
Show

instance FromJSON RedirectDest where
    parseJSON :: Value -> Parser RedirectDest
parseJSON = String
-> (Object -> Parser RedirectDest) -> Value -> Parser RedirectDest
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RedirectDest" ((Object -> Parser RedirectDest) -> Value -> Parser RedirectDest)
-> (Object -> Parser RedirectDest) -> Value -> Parser RedirectDest
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Object -> Parser RedirectDest
url Object
o Parser RedirectDest -> Parser RedirectDest -> Parser RedirectDest
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object -> Parser RedirectDest
prefix Object
o
      where
        url :: Object -> Parser RedirectDest
url Object
o = Text -> RedirectDest
RDUrl (Text -> RedirectDest) -> Parser Text -> Parser RedirectDest
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
"url"
        prefix :: Object -> Parser RedirectDest
prefix Object
o = RequiresSecure -> Host -> Maybe Int -> RedirectDest
RDPrefix
            (RequiresSecure -> Host -> Maybe Int -> RedirectDest)
-> Parser RequiresSecure
-> Parser (Host -> Maybe Int -> RedirectDest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe RequiresSecure)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"secure" Parser (Maybe RequiresSecure)
-> RequiresSecure -> Parser RequiresSecure
forall a. Parser (Maybe a) -> a -> Parser a
.!= RequiresSecure
False
            Parser (Host -> Maybe Int -> RedirectDest)
-> Parser Host -> Parser (Maybe Int -> RedirectDest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk (Text -> Host) -> Parser Text -> Parser Host
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
"host")
            Parser (Maybe Int -> RedirectDest)
-> Parser (Maybe Int) -> Parser RedirectDest
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port"

instance ToJSON RedirectDest where
    toJSON :: RedirectDest -> Value
toJSON (RDUrl Text
url) = [Pair] -> Value
object [Key
"url" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
url]
    toJSON (RDPrefix RequiresSecure
secure Host
host Maybe Int
mport) = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
        [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"secure" Key -> RequiresSecure -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequiresSecure
secure
        , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"host" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Host -> Text
forall s. CI s -> s
CI.original Host
host
        , case Maybe Int
mport of
            Maybe Int
Nothing -> Maybe Pair
forall a. Maybe a
Nothing
            Just Int
port -> Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"port" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
port
        ]

type IsSecure = Bool

data WebAppConfig port = WebAppConfig
    { forall port. WebAppConfig port -> String
waconfigExec        :: !F.FilePath
    , forall port. WebAppConfig port -> Vector Text
waconfigArgs        :: !(Vector Text)
    , forall port. WebAppConfig port -> Map Text Text
waconfigEnvironment :: !(Map Text Text)
    , forall port. WebAppConfig port -> Host
waconfigApprootHost :: !Host -- ^ primary host, used for approot
    , forall port. WebAppConfig port -> Set Host
waconfigHosts       :: !(Set Host) -- ^ all hosts, not including the approot host
    , forall port. WebAppConfig port -> SSLConfig
waconfigSsl         :: !SSLConfig
    , forall port. WebAppConfig port -> port
waconfigPort        :: !port
    , forall port. WebAppConfig port -> Set Text
waconfigForwardEnv  :: !(Set Text)
     -- | how long are connections supposed to last
    , forall port. WebAppConfig port -> Maybe Int
waconfigTimeout     :: !(Maybe Int)
     -- | how long in microseconds the app gets before we expect it to bind to
     --   a port (default 90 seconds)
    , forall port. WebAppConfig port -> Maybe Int
waconfigEnsureAliveTimeout :: !(Maybe Int)
    }
    deriving Int -> WebAppConfig port -> ShowS
[WebAppConfig port] -> ShowS
WebAppConfig port -> String
(Int -> WebAppConfig port -> ShowS)
-> (WebAppConfig port -> String)
-> ([WebAppConfig port] -> ShowS)
-> Show (WebAppConfig port)
forall port. Show port => Int -> WebAppConfig port -> ShowS
forall port. Show port => [WebAppConfig port] -> ShowS
forall port. Show port => WebAppConfig port -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall port. Show port => Int -> WebAppConfig port -> ShowS
showsPrec :: Int -> WebAppConfig port -> ShowS
$cshow :: forall port. Show port => WebAppConfig port -> String
show :: WebAppConfig port -> String
$cshowList :: forall port. Show port => [WebAppConfig port] -> ShowS
showList :: [WebAppConfig port] -> ShowS
Show

instance ToCurrent (WebAppConfig ()) where
    type Previous (WebAppConfig ()) = V04.AppConfig
    toCurrent :: Previous (WebAppConfig ()) -> WebAppConfig ()
toCurrent (V04.AppConfig String
exec [Text]
args Text
host RequiresSecure
ssl Set Text
hosts Object
_raw) = WebAppConfig
        { waconfigExec :: String
waconfigExec = String
exec
        , waconfigArgs :: Vector Text
waconfigArgs = [Text] -> Vector Text
forall a. [a] -> Vector a
V.fromList [Text]
args
        , waconfigEnvironment :: Map Text Text
waconfigEnvironment = Map Text Text
forall k a. Map k a
Map.empty
        , waconfigApprootHost :: Host
waconfigApprootHost = Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk Text
host
        , waconfigHosts :: Set Host
waconfigHosts = (Text -> Host) -> Set Text -> Set Host
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk Set Text
hosts
        , waconfigSsl :: SSLConfig
waconfigSsl = if RequiresSecure
ssl then SSLConfig
SSLTrue else SSLConfig
SSLFalse
        , waconfigPort :: ()
waconfigPort = ()
        , waconfigForwardEnv :: Set Text
waconfigForwardEnv = Set Text
forall a. Set a
Set.empty
        , waconfigTimeout :: Maybe Int
waconfigTimeout = Maybe Int
forall a. Maybe a
Nothing
        , waconfigEnsureAliveTimeout :: Maybe Int
waconfigEnsureAliveTimeout = Maybe Int
forall a. Maybe a
Nothing
        }

instance ParseYamlFile (WebAppConfig ()) where
    parseYamlFile :: BaseDir -> Value -> Parser (WebAppConfig ())
parseYamlFile BaseDir
basedir = String
-> (Object -> Parser (WebAppConfig ()))
-> Value
-> Parser (WebAppConfig ())
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"WebAppConfig" ((Object -> Parser (WebAppConfig ()))
 -> Value -> Parser (WebAppConfig ()))
-> (Object -> Parser (WebAppConfig ()))
-> Value
-> Parser (WebAppConfig ())
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        (Host
ahost, Set Host
hosts) <-
            (do
                Text
h <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"host"
                (Host, Set Host) -> Parser (Host, Set Host)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk Text
h, Set Host
forall a. Set a
Set.empty)) Parser (Host, Set Host)
-> Parser (Host, Set Host) -> Parser (Host, Set Host)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
            (do
                [Text]
hs <- Object
o Object -> Key -> Parser [Text]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hosts"
                case [Text]
hs of
                    [] -> String -> Parser (Host, Set Host)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Must provide at least one host"
                    Text
h:[Text]
hs' -> (Host, Set Host) -> Parser (Host, Set Host)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk Text
h, [Host] -> Set Host
forall a. Ord a => [a] -> Set a
Set.fromList ([Host] -> Set Host) -> [Host] -> Set Host
forall a b. (a -> b) -> a -> b
$ (Text -> Host) -> [Text] -> [Host]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk [Text]
hs'))
        String
-> Vector Text
-> Map Text Text
-> Host
-> Set Host
-> SSLConfig
-> ()
-> Set Text
-> Maybe Int
-> Maybe Int
-> WebAppConfig ()
forall port.
String
-> Vector Text
-> Map Text Text
-> Host
-> Set Host
-> SSLConfig
-> port
-> Set Text
-> Maybe Int
-> Maybe Int
-> WebAppConfig port
WebAppConfig
            (String
 -> Vector Text
 -> Map Text Text
 -> Host
 -> Set Host
 -> SSLConfig
 -> ()
 -> Set Text
 -> Maybe Int
 -> Maybe Int
 -> WebAppConfig ())
-> Parser String
-> Parser
     (Vector Text
      -> Map Text Text
      -> Host
      -> Set Host
      -> SSLConfig
      -> ()
      -> Set Text
      -> Maybe Int
      -> Maybe Int
      -> WebAppConfig ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Object -> Text -> Parser String
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"exec"
            Parser
  (Vector Text
   -> Map Text Text
   -> Host
   -> Set Host
   -> SSLConfig
   -> ()
   -> Set Text
   -> Maybe Int
   -> Maybe Int
   -> WebAppConfig ())
-> Parser (Vector Text)
-> Parser
     (Map Text Text
      -> Host
      -> Set Host
      -> SSLConfig
      -> ()
      -> Set Text
      -> Maybe Int
      -> Maybe Int
      -> WebAppConfig ())
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 (Vector Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"args" Parser (Maybe (Vector Text)) -> Vector Text -> Parser (Vector Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Vector Text
forall a. Vector a
V.empty
            Parser
  (Map Text Text
   -> Host
   -> Set Host
   -> SSLConfig
   -> ()
   -> Set Text
   -> Maybe Int
   -> Maybe Int
   -> WebAppConfig ())
-> Parser (Map Text Text)
-> Parser
     (Host
      -> Set Host
      -> SSLConfig
      -> ()
      -> Set Text
      -> Maybe Int
      -> Maybe Int
      -> WebAppConfig ())
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 (Map Text Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"env" Parser (Maybe (Map Text Text))
-> Map Text Text -> Parser (Map Text Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Text Text
forall k a. Map k a
Map.empty
            Parser
  (Host
   -> Set Host
   -> SSLConfig
   -> ()
   -> Set Text
   -> Maybe Int
   -> Maybe Int
   -> WebAppConfig ())
-> Parser Host
-> Parser
     (Set Host
      -> SSLConfig
      -> ()
      -> Set Text
      -> Maybe Int
      -> Maybe Int
      -> WebAppConfig ())
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Host -> Parser Host
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Host
ahost
            Parser
  (Set Host
   -> SSLConfig
   -> ()
   -> Set Text
   -> Maybe Int
   -> Maybe Int
   -> WebAppConfig ())
-> Parser (Set Host)
-> Parser
     (SSLConfig
      -> () -> Set Text -> Maybe Int -> Maybe Int -> WebAppConfig ())
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Host -> Parser (Set Host)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Set Host
hosts
            Parser
  (SSLConfig
   -> () -> Set Text -> Maybe Int -> Maybe Int -> WebAppConfig ())
-> Parser SSLConfig
-> Parser
     (() -> Set Text -> Maybe Int -> Maybe Int -> WebAppConfig ())
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
  (() -> Set Text -> Maybe Int -> Maybe Int -> WebAppConfig ())
-> Parser ()
-> Parser (Set Text -> Maybe Int -> Maybe Int -> WebAppConfig ())
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> Parser ()
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Parser (Set Text -> Maybe Int -> Maybe Int -> WebAppConfig ())
-> Parser (Set Text)
-> Parser (Maybe Int -> Maybe Int -> WebAppConfig ())
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 Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"forward-env" Parser (Maybe (Set Text)) -> Set Text -> Parser (Set Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set Text
forall a. Set a
Set.empty
            Parser (Maybe Int -> Maybe Int -> WebAppConfig ())
-> Parser (Maybe Int) -> Parser (Maybe Int -> WebAppConfig ())
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"connection-time-bound"
            Parser (Maybe Int -> WebAppConfig ())
-> Parser (Maybe Int) -> Parser (WebAppConfig ())
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ensure-alive-time-bound"

instance ToJSON (WebAppConfig ()) where
    toJSON :: WebAppConfig () -> Value
toJSON WebAppConfig {String
Maybe Int
()
Map Text Text
Vector Text
Host
Set Text
Set Host
SSLConfig
waconfigExec :: forall port. WebAppConfig port -> String
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
waconfigPort :: forall port. WebAppConfig port -> port
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigExec :: String
waconfigArgs :: Vector Text
waconfigEnvironment :: Map Text Text
waconfigApprootHost :: Host
waconfigHosts :: Set Host
waconfigSsl :: SSLConfig
waconfigPort :: ()
waconfigForwardEnv :: Set Text
waconfigTimeout :: Maybe Int
waconfigEnsureAliveTimeout :: Maybe Int
..} = [Pair] -> Value
object
        [ Key
"exec" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
waconfigExec
        , Key
"args" Key -> Vector Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Vector Text
waconfigArgs
        , Key
"env" Key -> Map Text Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map Text Text
waconfigEnvironment
        , Key
"hosts" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Host -> Text) -> [Host] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Host -> Text
forall s. CI s -> s
CI.original (Host
waconfigApprootHost Host -> [Host] -> [Host]
forall a. a -> [a] -> [a]
: Set Host -> [Host]
forall a. Set a -> [a]
Set.toList Set Host
waconfigHosts)
        , 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
waconfigSsl
        , Key
"forward-env" Key -> Set Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Set Text
waconfigForwardEnv
        , Key
"connection-time-bound" 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
waconfigTimeout
        ]

data AppInput = AIBundle !FilePath !EpochTime
              | AIData !BundleConfig
              deriving Int -> AppInput -> ShowS
[AppInput] -> ShowS
AppInput -> String
(Int -> AppInput -> ShowS)
-> (AppInput -> String) -> ([AppInput] -> ShowS) -> Show AppInput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AppInput -> ShowS
showsPrec :: Int -> AppInput -> ShowS
$cshow :: AppInput -> String
show :: AppInput -> String
$cshowList :: [AppInput] -> ShowS
showList :: [AppInput] -> ShowS
Show

data BackgroundConfig = BackgroundConfig
    { BackgroundConfig -> String
bgconfigExec                :: !F.FilePath
    , BackgroundConfig -> Vector Text
bgconfigArgs                :: !(Vector Text)
    , BackgroundConfig -> Map Text Text
bgconfigEnvironment         :: !(Map Text Text)
    , BackgroundConfig -> RestartCount
bgconfigRestartCount        :: !RestartCount
    , BackgroundConfig -> Word
bgconfigRestartDelaySeconds :: !Word
    , BackgroundConfig -> Set Text
bgconfigForwardEnv          :: !(Set Text)
    }
    deriving Int -> BackgroundConfig -> ShowS
[BackgroundConfig] -> ShowS
BackgroundConfig -> String
(Int -> BackgroundConfig -> ShowS)
-> (BackgroundConfig -> String)
-> ([BackgroundConfig] -> ShowS)
-> Show BackgroundConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BackgroundConfig -> ShowS
showsPrec :: Int -> BackgroundConfig -> ShowS
$cshow :: BackgroundConfig -> String
show :: BackgroundConfig -> String
$cshowList :: [BackgroundConfig] -> ShowS
showList :: [BackgroundConfig] -> ShowS
Show

data RestartCount = UnlimitedRestarts | LimitedRestarts !Word
    deriving Int -> RestartCount -> ShowS
[RestartCount] -> ShowS
RestartCount -> String
(Int -> RestartCount -> ShowS)
-> (RestartCount -> String)
-> ([RestartCount] -> ShowS)
-> Show RestartCount
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RestartCount -> ShowS
showsPrec :: Int -> RestartCount -> ShowS
$cshow :: RestartCount -> String
show :: RestartCount -> String
$cshowList :: [RestartCount] -> ShowS
showList :: [RestartCount] -> ShowS
Show

instance FromJSON RestartCount where
    parseJSON :: Value -> Parser RestartCount
parseJSON (String Text
"unlimited") = RestartCount -> Parser RestartCount
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return RestartCount
UnlimitedRestarts
    parseJSON Value
v = Word -> RestartCount
LimitedRestarts (Word -> RestartCount) -> Parser Word -> Parser RestartCount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Word
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

instance ParseYamlFile BackgroundConfig where
    parseYamlFile :: BaseDir -> Value -> Parser BackgroundConfig
parseYamlFile BaseDir
basedir = String
-> (Object -> Parser BackgroundConfig)
-> Value
-> Parser BackgroundConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"BackgroundConfig" ((Object -> Parser BackgroundConfig)
 -> Value -> Parser BackgroundConfig)
-> (Object -> Parser BackgroundConfig)
-> Value
-> Parser BackgroundConfig
forall a b. (a -> b) -> a -> b
$ \Object
o -> String
-> Vector Text
-> Map Text Text
-> RestartCount
-> Word
-> Set Text
-> BackgroundConfig
BackgroundConfig
        (String
 -> Vector Text
 -> Map Text Text
 -> RestartCount
 -> Word
 -> Set Text
 -> BackgroundConfig)
-> Parser String
-> Parser
     (Vector Text
      -> Map Text Text
      -> RestartCount
      -> Word
      -> Set Text
      -> BackgroundConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Object -> Text -> Parser String
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"exec"
        Parser
  (Vector Text
   -> Map Text Text
   -> RestartCount
   -> Word
   -> Set Text
   -> BackgroundConfig)
-> Parser (Vector Text)
-> Parser
     (Map Text Text
      -> RestartCount -> Word -> Set Text -> BackgroundConfig)
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 (Vector Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"args" Parser (Maybe (Vector Text)) -> Vector Text -> Parser (Vector Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Vector Text
forall a. Vector a
V.empty
        Parser
  (Map Text Text
   -> RestartCount -> Word -> Set Text -> BackgroundConfig)
-> Parser (Map Text Text)
-> Parser (RestartCount -> Word -> Set Text -> BackgroundConfig)
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 (Map Text Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"env" Parser (Maybe (Map Text Text))
-> Map Text Text -> Parser (Map Text Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Text Text
forall k a. Map k a
Map.empty
        Parser (RestartCount -> Word -> Set Text -> BackgroundConfig)
-> Parser RestartCount
-> Parser (Word -> Set Text -> BackgroundConfig)
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 RestartCount)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"restart-count" Parser (Maybe RestartCount) -> RestartCount -> Parser RestartCount
forall a. Parser (Maybe a) -> a -> Parser a
.!= RestartCount
UnlimitedRestarts
        Parser (Word -> Set Text -> BackgroundConfig)
-> Parser Word -> Parser (Set Text -> BackgroundConfig)
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 Word)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"restart-delay-seconds" Parser (Maybe Word) -> Word -> Parser Word
forall a. Parser (Maybe a) -> a -> Parser a
.!= Word
5
        Parser (Set Text -> BackgroundConfig)
-> Parser (Set Text) -> Parser BackgroundConfig
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 Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"forward-env" Parser (Maybe (Set Text)) -> Set Text -> Parser (Set Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set Text
forall a. Set a
Set.empty

instance ToJSON BackgroundConfig where
    toJSON :: BackgroundConfig -> Value
toJSON BackgroundConfig {String
Word
Map Text Text
Vector Text
Set Text
RestartCount
bgconfigExec :: BackgroundConfig -> String
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigExec :: String
bgconfigArgs :: Vector Text
bgconfigEnvironment :: Map Text Text
bgconfigRestartCount :: RestartCount
bgconfigRestartDelaySeconds :: Word
bgconfigForwardEnv :: Set Text
..} = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
        [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"exec" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
bgconfigExec
        , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"args" Key -> Vector Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Vector Text
bgconfigArgs
        , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"env" Key -> Map Text Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map Text Text
bgconfigEnvironment
        , case RestartCount
bgconfigRestartCount of
            RestartCount
UnlimitedRestarts -> Maybe Pair
forall a. Maybe a
Nothing
            LimitedRestarts Word
count -> Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"restart-count" Key -> Word -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word
count
        , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"restart-delay-seconds" Key -> Word -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word
bgconfigRestartDelaySeconds
        , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"forward-env" Key -> Set Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Set Text
bgconfigForwardEnv
        ]