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

import           Control.Applicative               ((<$>), (<*>), (<|>))
import           Data.Aeson                        (FromJSON (..), ToJSON (..), Object,
                                                    Value (Object, String, Bool),
                                                    withObject, (.!=), (.:),
                                                    (.:?), object, (.=))
import           Data.Aeson.KeyHelper              as AK (lookup, singleton, empty, insert)
import qualified Data.CaseInsensitive              as CI
import           Data.Conduit.Network              (HostPreference)
import           Data.Default
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           Data.Yaml.FilePath
import qualified System.FilePath                   as F
import           Keter.Types.Common
import           Keter.Types.Middleware
import qualified Keter.Types.V04                   as V04
import           Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig)
import qualified Network.Wai.Handler.Warp          as Warp
import qualified Network.Wai.Handler.WarpTLS       as WarpTLS
import           System.Posix.Types                (EpochTime)

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
showList :: [BundleConfig] -> ShowS
$cshowList :: [BundleConfig] -> ShowS
show :: BundleConfig -> String
$cshow :: BundleConfig -> String
showsPrec :: Int -> BundleConfig -> ShowS
$cshowsPrec :: Int -> BundleConfig -> ShowS
Show

instance ToCurrent BundleConfig where
    type Previous BundleConfig = V04.BundleConfig
    toCurrent :: Previous BundleConfig -> BundleConfig
toCurrent (V04.BundleConfig webapp statics redirs) = BundleConfig :: Vector (Stanza ()) -> Object -> BundleConfig
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 (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
. 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
. 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
. 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 (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 -> (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 (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 ())
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} = [Pair] -> Value
object
        [ Key
"stanzas" Key -> Vector (Stanza ()) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Vector (Stanza ())
bconfigStanzas
        , Key
"plugins" Key -> Object -> Pair
forall kv v. (KeyValue 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 (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 (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 (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 (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 (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 (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
    }

instance ToCurrent KeterConfig where
    type Previous KeterConfig = V04.KeterConfig
    toCurrent :: Previous KeterConfig -> KeterConfig
toCurrent (V04.KeterConfig dir portman host port ssl setuid rproxy ipFromHeader connectionTimeBound) = KeterConfig :: String
-> PortSettings
-> NonEmptyVector ListeningPort
-> Maybe Text
-> Vector (Stanza ())
-> RequiresSecure
-> Int
-> Int
-> Map Text Text
-> Int
-> Maybe Int
-> KeterConfig
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
        }
      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)

instance Default KeterConfig where
    def :: KeterConfig
def = KeterConfig :: String
-> PortSettings
-> NonEmptyVector ListeningPort
-> Maybe Text
-> Vector (Stanza ())
-> RequiresSecure
-> Int
-> Int
-> Map Text Text
-> Int
-> Maybe Int
-> KeterConfig
KeterConfig
        { kconfigDir :: String
kconfigDir = String
"."
        , kconfigPortPool :: PortSettings
kconfigPortPool = PortSettings
forall a. Default a => a
def
        , 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
        }

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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object -> Parser KeterConfig
current Object
o
      where
        old :: Object -> Parser KeterConfig
old Object
o = (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
-> KeterConfig
KeterConfig
            (String
 -> PortSettings
 -> NonEmptyVector ListeningPort
 -> Maybe Text
 -> Vector (Stanza ())
 -> RequiresSecure
 -> Int
 -> Int
 -> Map Text Text
 -> Int
 -> Maybe Int
 -> KeterConfig)
-> Parser String
-> Parser
     (PortSettings
      -> NonEmptyVector ListeningPort
      -> Maybe Text
      -> Vector (Stanza ())
      -> RequiresSecure
      -> Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> 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
   -> KeterConfig)
-> Parser PortSettings
-> Parser
     (NonEmptyVector ListeningPort
      -> Maybe Text
      -> Vector (Stanza ())
      -> RequiresSecure
      -> Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> KeterConfig)
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
forall a. Default a => a
def
            Parser
  (NonEmptyVector ListeningPort
   -> Maybe Text
   -> Vector (Stanza ())
   -> RequiresSecure
   -> Int
   -> Int
   -> Map Text Text
   -> Int
   -> Maybe Int
   -> KeterConfig)
-> Parser (NonEmptyVector ListeningPort)
-> Parser
     (Maybe Text
      -> Vector (Stanza ())
      -> RequiresSecure
      -> Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> KeterConfig)
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 (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
forall a. Default a => a
def)) (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
   -> KeterConfig)
-> Parser (Maybe Text)
-> Parser
     (Vector (Stanza ())
      -> RequiresSecure
      -> Int
      -> Int
      -> Map Text Text
      -> Int
      -> Maybe Int
      -> KeterConfig)
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
   -> KeterConfig)
-> Parser (Vector (Stanza ()))
-> Parser
     (RequiresSecure
      -> Int -> Int -> Map Text Text -> Int -> Maybe Int -> KeterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Vector (Stanza ()) -> Parser (Vector (Stanza ()))
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 -> KeterConfig)
-> Parser RequiresSecure
-> Parser
     (Int -> Int -> Map Text Text -> Int -> Maybe Int -> KeterConfig)
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 -> KeterConfig)
-> Parser Int
-> Parser (Int -> Map Text Text -> Int -> Maybe Int -> KeterConfig)
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 -> KeterConfig)
-> Parser Int
-> Parser (Map Text Text -> Int -> Maybe Int -> KeterConfig)
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 -> KeterConfig)
-> Parser (Map Text Text)
-> Parser (Int -> Maybe Int -> KeterConfig)
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 -> KeterConfig)
-> Parser Int -> Parser (Maybe Int -> KeterConfig)
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 -> KeterConfig)
-> Parser (Maybe Int) -> Parser KeterConfig
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"

-- | 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
showList :: [Stanza port] -> ShowS
$cshowList :: forall port. Show port => [Stanza port] -> ShowS
show :: Stanza port -> String
$cshow :: forall port. Show port => Stanza port -> String
showsPrec :: Int -> Stanza port -> ShowS
$cshowsPrec :: forall port. Show port => Int -> 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
showList :: [StanzaRaw port] -> ShowS
$cshowList :: forall port. Show port => [StanzaRaw port] -> ShowS
show :: StanzaRaw port -> String
$cshow :: forall port. Show port => StanzaRaw port -> String
showsPrec :: Int -> StanzaRaw port -> ShowS
$cshowsPrec :: forall port. Show port => Int -> 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
showList :: [ProxyActionRaw] -> ShowS
$cshowList :: [ProxyActionRaw] -> ShowS
show :: ProxyActionRaw -> String
$cshow :: ProxyActionRaw -> String
showsPrec :: Int -> ProxyActionRaw -> ShowS
$cshowsPrec :: Int -> 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 (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 (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 (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 (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 (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 (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 (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 (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 :: 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 :: 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
showList :: [StaticFilesConfig] -> ShowS
$cshowList :: [StaticFilesConfig] -> ShowS
show :: StaticFilesConfig -> String
$cshow :: StaticFilesConfig -> String
showsPrec :: Int -> StaticFilesConfig -> ShowS
$cshowsPrec :: Int -> StaticFilesConfig -> ShowS
Show

instance ToCurrent StaticFilesConfig where
    type Previous StaticFilesConfig = V04.StaticHost
    toCurrent :: Previous StaticFilesConfig -> StaticFilesConfig
toCurrent (V04.StaticHost host root) = StaticFilesConfig :: String
-> Set Host
-> RequiresSecure
-> [MiddlewareConfig]
-> Maybe Int
-> SSLConfig
-> StaticFilesConfig
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 (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 (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 (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 (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 (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 (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
sfconfigSsl :: SSLConfig
sfconfigTimeout :: Maybe Int
sfconfigMiddleware :: [MiddlewareConfig]
sfconfigListings :: RequiresSecure
sfconfigHosts :: Set Host
sfconfigRoot :: String
sfconfigSsl :: StaticFilesConfig -> SSLConfig
sfconfigTimeout :: StaticFilesConfig -> Maybe Int
sfconfigMiddleware :: StaticFilesConfig -> [MiddlewareConfig]
sfconfigListings :: StaticFilesConfig -> RequiresSecure
sfconfigHosts :: StaticFilesConfig -> Set Host
sfconfigRoot :: StaticFilesConfig -> String
..} = [Pair] -> Value
object
        [ Key
"root" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
sfconfigRoot
        , Key
"hosts" Key -> Set Text -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RequiresSecure
sfconfigListings
        , Key
"middleware" Key -> [MiddlewareConfig] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [MiddlewareConfig]
sfconfigMiddleware
        , Key
"connection-time-bound" Key -> Maybe Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
sfconfigTimeout
        , Key
"ssl" Key -> SSLConfig -> Pair
forall kv v. (KeyValue 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
showList :: [RedirectConfig] -> ShowS
$cshowList :: [RedirectConfig] -> ShowS
show :: RedirectConfig -> String
$cshow :: RedirectConfig -> String
showsPrec :: Int -> RedirectConfig -> ShowS
$cshowsPrec :: Int -> RedirectConfig -> ShowS
Show

instance ToCurrent RedirectConfig where
    type Previous RedirectConfig = V04.Redirect
    toCurrent :: Previous RedirectConfig -> RedirectConfig
toCurrent (V04.Redirect from to) = RedirectConfig :: Set Host
-> Int -> Vector RedirectAction -> SSLConfig -> RedirectConfig
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 (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 (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 (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 (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
Set Host
Vector RedirectAction
SSLConfig
redirconfigSsl :: SSLConfig
redirconfigActions :: Vector RedirectAction
redirconfigStatus :: Int
redirconfigHosts :: Set Host
redirconfigSsl :: RedirectConfig -> SSLConfig
redirconfigActions :: RedirectConfig -> Vector RedirectAction
redirconfigStatus :: RedirectConfig -> Int
redirconfigHosts :: RedirectConfig -> Set Host
..} = [Pair] -> Value
object
        [ Key
"hosts" Key -> Set Text -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
redirconfigStatus
        , Key
"actions" Key -> Vector RedirectAction -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Vector RedirectAction
redirconfigActions
        , Key
"ssl" Key -> SSLConfig -> Pair
forall kv v. (KeyValue 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
showList :: [RedirectAction] -> ShowS
$cshowList :: [RedirectAction] -> ShowS
show :: RedirectAction -> String
$cshow :: RedirectAction -> String
showsPrec :: Int -> RedirectAction -> ShowS
$cshowsPrec :: Int -> 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 (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
showList :: [SourcePath] -> ShowS
$cshowList :: [SourcePath] -> ShowS
show :: SourcePath -> String
$cshow :: SourcePath -> String
showsPrec :: Int -> SourcePath -> ShowS
$cshowsPrec :: Int -> 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
showList :: [RedirectDest] -> ShowS
$cshowList :: [RedirectDest] -> ShowS
show :: RedirectDest -> String
$cshow :: RedirectDest -> String
showsPrec :: Int -> RedirectDest -> ShowS
$cshowsPrec :: Int -> 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 (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 (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 (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 kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
port
        ]

type IsSecure = Bool

data WebAppConfig port = WebAppConfig
    { WebAppConfig port -> String
waconfigExec        :: !F.FilePath
    , WebAppConfig port -> Vector Text
waconfigArgs        :: !(Vector Text)
    , WebAppConfig port -> Map Text Text
waconfigEnvironment :: !(Map Text Text)
    , WebAppConfig port -> Host
waconfigApprootHost :: !Host -- ^ primary host, used for approot
    , WebAppConfig port -> Set Host
waconfigHosts       :: !(Set Host) -- ^ all hosts, not including the approot host
    , WebAppConfig port -> SSLConfig
waconfigSsl         :: !SSLConfig
    , WebAppConfig port -> port
waconfigPort        :: !port
    , WebAppConfig port -> Set Text
waconfigForwardEnv  :: !(Set Text)
     -- | how long are connections supposed to last
    , 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)
    , 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
showList :: [WebAppConfig port] -> ShowS
$cshowList :: forall port. Show port => [WebAppConfig port] -> ShowS
show :: WebAppConfig port -> String
$cshow :: forall port. Show port => WebAppConfig port -> String
showsPrec :: Int -> WebAppConfig port -> ShowS
$cshowsPrec :: forall port. Show port => Int -> WebAppConfig port -> ShowS
Show

instance ToCurrent (WebAppConfig ()) where
    type Previous (WebAppConfig ()) = V04.AppConfig
    toCurrent :: Previous (WebAppConfig ()) -> WebAppConfig ()
toCurrent (V04.AppConfig exec args host ssl hosts _raw) = WebAppConfig :: forall port.
String
-> Vector Text
-> Map Text Text
-> Host
-> Set Host
-> SSLConfig
-> port
-> Set Text
-> Maybe Int
-> Maybe Int
-> WebAppConfig port
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 (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 (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 (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 (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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Host -> Parser Host
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Host -> Parser (Set Host)
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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> Parser ()
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 (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 (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 (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
Host
Set Text
Set Host
Vector Text
SSLConfig
waconfigEnsureAliveTimeout :: Maybe Int
waconfigTimeout :: Maybe Int
waconfigForwardEnv :: Set Text
waconfigPort :: ()
waconfigSsl :: SSLConfig
waconfigHosts :: Set Host
waconfigApprootHost :: Host
waconfigEnvironment :: Map Text Text
waconfigArgs :: Vector Text
waconfigExec :: String
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigPort :: forall port. WebAppConfig port -> port
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigExec :: forall port. WebAppConfig port -> String
..} = [Pair] -> Value
object
        [ Key
"exec" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
waconfigExec
        , Key
"args" Key -> Vector Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Vector Text
waconfigArgs
        , Key
"env" Key -> Map Text Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Map Text Text
waconfigEnvironment
        , Key
"hosts" Key -> [Text] -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SSLConfig
waconfigSsl
        , Key
"forward-env" Key -> Set Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Set Text
waconfigForwardEnv
        , Key
"connection-time-bound" Key -> Maybe Int -> Pair
forall kv v. (KeyValue 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
showList :: [AppInput] -> ShowS
$cshowList :: [AppInput] -> ShowS
show :: AppInput -> String
$cshow :: AppInput -> String
showsPrec :: Int -> AppInput -> ShowS
$cshowsPrec :: Int -> 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
showList :: [BackgroundConfig] -> ShowS
$cshowList :: [BackgroundConfig] -> ShowS
show :: BackgroundConfig -> String
$cshow :: BackgroundConfig -> String
showsPrec :: Int -> BackgroundConfig -> ShowS
$cshowsPrec :: Int -> 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
showList :: [RestartCount] -> ShowS
$cshowList :: [RestartCount] -> ShowS
show :: RestartCount -> String
$cshow :: RestartCount -> String
showsPrec :: Int -> RestartCount -> ShowS
$cshowsPrec :: Int -> RestartCount -> ShowS
Show

instance FromJSON RestartCount where
    parseJSON :: Value -> Parser RestartCount
parseJSON (String Text
"unlimited") = RestartCount -> Parser RestartCount
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 (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 (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 (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 (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 (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
Set Text
Vector Text
RestartCount
bgconfigForwardEnv :: Set Text
bgconfigRestartDelaySeconds :: Word
bgconfigRestartCount :: RestartCount
bgconfigEnvironment :: Map Text Text
bgconfigArgs :: Vector Text
bgconfigExec :: String
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigExec :: BackgroundConfig -> String
..} = [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 kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Set Text
bgconfigForwardEnv
        ]