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

instance ParseYamlFile BundleConfig where
    parseYamlFile :: BaseDir -> Value -> Parser BundleConfig
parseYamlFile BaseDir
basedir = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"BundleConfig" forall a b. (a -> b) -> a -> b
$ \Object
o ->
        case forall v. Key -> KeyMap v -> Maybe v
AK.lookup Key
"stanzas" Object
o of
            Maybe Value
Nothing -> (forall a. ToCurrent a => Previous a -> a
toCurrent :: V04.BundleConfig -> BundleConfig) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"stanzas"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"plugins" forall a. Parser (Maybe a) -> a -> Parser a
.!= 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Vector (Stanza ())
bconfigStanzas
        , Key
"plugins" 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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ListeningPort" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        HostPreference
host <- (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. IsString a => String -> a
fromString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"host") forall a. Parser (Maybe a) -> a -> Parser a
.!= HostPreference
"*"
        Maybe String
mcert <- forall a.
ParseYamlFile a =>
BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Text
"certificate"
        Maybe String
mkey <- forall a.
ParseYamlFile a =>
BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Text
"key"
        RequiresSecure
session <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"session" 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 forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port" forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
80
                forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port" forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
443
                Vector String
chainCerts <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"chain-certificates"
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Vector a
V.empty) (forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir)
                forall (m :: * -> *) a. Monad m => a -> m a
return 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)
_ -> 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
    }

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 = 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 = forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall port. StanzaRaw port -> RequiresSecure -> Stanza port
Stanza RequiresSecure
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ReverseProxyConfig
rp -> forall port.
ReverseProxyConfig
-> [MiddlewareConfig] -> Maybe Int -> StanzaRaw port
StanzaReverseProxy ReverseProxyConfig
rp [] forall a. Maybe a
Nothing)) forall a b. (a -> b) -> a -> b
$ 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 = forall k a. Map k a
Map.empty
        , kconfigConnectionTimeBound :: Int
kconfigConnectionTimeBound = Int
connectionTimeBound
        , kconfigCliPort :: Maybe Int
kconfigCliPort             = forall a. Maybe a
Nothing
        , kconfigUnknownHostResponse :: Maybe String
kconfigUnknownHostResponse  = forall a. Maybe a
Nothing
        , kconfigMissingHostResponse :: Maybe String
kconfigMissingHostResponse = forall a. Maybe a
Nothing
        , kconfigProxyException :: Maybe String
kconfigProxyException      = forall a. Maybe a
Nothing
        , kconfigRotateLogs :: RequiresSecure
kconfigRotateLogs = RequiresSecure
True
        }
      where
        getSSL :: Maybe TLSConfig -> Vector ListeningPort
getSSL Maybe TLSConfig
Nothing = forall a. Vector a
V.empty
        getSSL (Just (V04.TLSConfig Settings
s String
cert String
key Maybe Config
session)) = forall a. a -> Vector a
V.singleton 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
            forall a. Vector a
V.empty
            String
key
            (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 = forall a. a -> Vector a -> NonEmptyVector a
NonEmptyVector (HostPreference -> Int -> ListeningPort
LPInsecure HostPreference
"*" Int
80) forall a. Vector a
V.empty
        , kconfigSetuid :: Maybe Text
kconfigSetuid = forall a. Maybe a
Nothing
        , kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigBuiltinStanzas = 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 = forall k a. Map k a
Map.empty
        , kconfigConnectionTimeBound :: Int
kconfigConnectionTimeBound = Int
V04.fiveMinutes
        , kconfigCliPort :: Maybe Int
kconfigCliPort = forall a. Maybe a
Nothing
        , kconfigUnknownHostResponse :: Maybe String
kconfigUnknownHostResponse = forall a. Maybe a
Nothing
        , kconfigMissingHostResponse :: Maybe String
kconfigMissingHostResponse = forall a. Maybe a
Nothing
        , kconfigProxyException :: Maybe String
kconfigProxyException = forall a. Maybe a
Nothing
        , kconfigRotateLogs :: RequiresSecure
kconfigRotateLogs = RequiresSecure
True
        }

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

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

data Stanza port = Stanza (StanzaRaw port) RequiresSecure
  deriving Int -> Stanza port -> ShowS
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
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
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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Stanza" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        String
typ <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
        RequiresSecure
needsHttps <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"requires-secure" forall a. Parser (Maybe a) -> a -> Parser a
.!= RequiresSecure
False
        StanzaRaw ()
raw <- case String
typ of
            String
"static-files"  -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall port. StaticFilesConfig -> StanzaRaw port
StanzaStaticFiles forall a b. (a -> b) -> a -> b
$ forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o
            String
"redirect"      -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall port. RedirectConfig -> StanzaRaw port
StanzaRedirect forall a b. (a -> b) -> a -> b
$ forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o
            String
"webapp"        -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall port. WebAppConfig port -> StanzaRaw port
StanzaWebApp forall a b. (a -> b) -> a -> b
$ forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o
            String
"reverse-proxy" -> forall port.
ReverseProxyConfig
-> [MiddlewareConfig] -> Maybe Int -> StanzaRaw port
StanzaReverseProxy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
                                                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"middleware" forall a. Parser (Maybe a) -> a -> Parser a
.!= []
                                                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"connection-time-bound"
            String
"background"    -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall port. BackgroundConfig -> StanzaRaw port
StanzaBackground forall a b. (a -> b) -> a -> b
$ forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o
            String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unknown stanza type: " forall a. [a] -> [a] -> [a]
++ String
typ
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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) = 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 forall a. ToJSON a => a -> Value
toJSON a
x of
        Object Object
o -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall v. Key -> v -> KeyMap v -> KeyMap v
AK.insert Key
"requires-secure" (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) = forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
"static-files" StaticFilesConfig
x
    toJSON (StanzaRedirect RedirectConfig
x) = forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
"redirect" RedirectConfig
x
    toJSON (StanzaWebApp WebAppConfig ()
x) = forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
"webapp" WebAppConfig ()
x
    toJSON (StanzaReverseProxy ReverseProxyConfig
x [MiddlewareConfig]
_ Maybe Int
_) = forall a. ToJSON a => Value -> a -> Value
addStanzaType Value
"reverse-proxy" ReverseProxyConfig
x
    toJSON (StanzaBackground BackgroundConfig
x) = 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 forall a. ToJSON a => a -> Value
toJSON a
x of
        Object Object
o -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$ 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
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 Text
host String
root) = StaticFilesConfig
        { sfconfigRoot :: String
sfconfigRoot       = String
root
        , sfconfigHosts :: Set Host
sfconfigHosts      = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall s. FoldCase s => s -> CI s
CI.mk Text
host
        , sfconfigListings :: RequiresSecure
sfconfigListings   = RequiresSecure
True
        , sfconfigMiddleware :: [MiddlewareConfig]
sfconfigMiddleware = []
        , sfconfigTimeout :: Maybe Int
sfconfigTimeout    = forall a. Maybe a
Nothing
        , sfconfigSsl :: SSLConfig
sfconfigSsl        = SSLConfig
SSLFalse
        }

instance ParseYamlFile StaticFilesConfig where
    parseYamlFile :: BaseDir -> Value -> Parser StaticFilesConfig
parseYamlFile BaseDir
basedir = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"StaticFilesConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> String
-> Set Host
-> RequiresSecure
-> [MiddlewareConfig]
-> Maybe Int
-> SSLConfig
-> StaticFilesConfig
StaticFilesConfig
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"root"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hosts" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a. a -> Set a
Set.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"host"))))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"directory-listing" forall a. Parser (Maybe a) -> a -> Parser a
.!= RequiresSecure
False
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"middleware" forall a. Parser (Maybe a) -> a -> Parser a
.!= []
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"connection-time-bound"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ssl" 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
sfconfigRoot
        , Key
"hosts" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall s. CI s -> s
CI.original Set Host
sfconfigHosts
        , Key
"directory-listing" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RequiresSecure
sfconfigListings
        , Key
"middleware" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [MiddlewareConfig]
sfconfigMiddleware
        , Key
"connection-time-bound" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
sfconfigTimeout
        , Key
"ssl" 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
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 Text
from Text
to) = RedirectConfig
        { redirconfigHosts :: Set Host
redirconfigHosts = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall s. FoldCase s => s -> CI s
CI.mk Text
from
        , redirconfigStatus :: Int
redirconfigStatus = Int
301
        , redirconfigActions :: Vector RedirectAction
redirconfigActions = forall a. a -> Vector a
V.singleton forall a b. (a -> b) -> a -> b
$ SourcePath -> RedirectDest -> RedirectAction
RedirectAction SourcePath
SPAny
                             forall a b. (a -> b) -> a -> b
$ RequiresSecure -> Host -> Maybe Int -> RedirectDest
RDPrefix RequiresSecure
False (forall s. FoldCase s => s -> CI s
CI.mk Text
to) forall a. Maybe a
Nothing
        , redirconfigSsl :: SSLConfig
redirconfigSsl = SSLConfig
SSLFalse
        }

instance ParseYamlFile RedirectConfig where
    parseYamlFile :: BaseDir -> Value -> Parser RedirectConfig
parseYamlFile BaseDir
_ = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RedirectConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> Set Host
-> Int -> Vector RedirectAction -> SSLConfig -> RedirectConfig
RedirectConfig
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hosts" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a. a -> Set a
Set.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"host")))))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"status" forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
303
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"actions"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ssl" 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall s. CI s -> s
CI.original Set Host
redirconfigHosts
        , Key
"status" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
redirconfigStatus
        , Key
"actions" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Vector RedirectAction
redirconfigActions
        , Key
"ssl" 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
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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RedirectAction" forall a b. (a -> b) -> a -> b
$ \Object
o -> SourcePath -> RedirectDest -> RedirectAction
RedirectAction
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b a. b -> (a -> b) -> Maybe a -> b
maybe SourcePath
SPAny Text -> SourcePath
SPSpecific forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"path"))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 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 forall a b. (a -> b) -> a -> b
$ 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
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
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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RedirectDest" forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Object -> Parser RedirectDest
url Object
o 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"url"
        prefix :: Object -> Parser RedirectDest
prefix Object
o = RequiresSecure -> Host -> Maybe Int -> RedirectDest
RDPrefix
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"secure" forall a. Parser (Maybe a) -> a -> Parser a
.!= RequiresSecure
False
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"host")
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
url]
    toJSON (RDPrefix RequiresSecure
secure Host
host Maybe Int
mport) = [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
        [ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"secure" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RequiresSecure
secure
        , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"host" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s. CI s -> s
CI.original Host
host
        , case Maybe Int
mport of
            Maybe Int
Nothing -> forall a. Maybe a
Nothing
            Just Int
port -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"port" forall kv v. (KeyValue 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
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 String
exec [Text]
args Text
host RequiresSecure
ssl Set Text
hosts Object
_raw) = WebAppConfig
        { waconfigExec :: String
waconfigExec = String
exec
        , waconfigArgs :: Vector Text
waconfigArgs = forall a. [a] -> Vector a
V.fromList [Text]
args
        , waconfigEnvironment :: Map Text Text
waconfigEnvironment = forall k a. Map k a
Map.empty
        , waconfigApprootHost :: Host
waconfigApprootHost = forall s. FoldCase s => s -> CI s
CI.mk Text
host
        , waconfigHosts :: Set Host
waconfigHosts = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map 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 = forall a. Set a
Set.empty
        , waconfigTimeout :: Maybe Int
waconfigTimeout = forall a. Maybe a
Nothing
        , waconfigEnsureAliveTimeout :: Maybe Int
waconfigEnsureAliveTimeout = forall a. Maybe a
Nothing
        }

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

instance ParseYamlFile BackgroundConfig where
    parseYamlFile :: BaseDir -> Value -> Parser BackgroundConfig
parseYamlFile BaseDir
basedir = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"BackgroundConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> String
-> Vector Text
-> Map Text Text
-> RestartCount
-> Word
-> Set Text
-> BackgroundConfig
BackgroundConfig
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"exec"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"args" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Vector a
V.empty
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"env" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall k a. Map k a
Map.empty
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"restart-count" forall a. Parser (Maybe a) -> a -> Parser a
.!= RestartCount
UnlimitedRestarts
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"restart-delay-seconds" forall a. Parser (Maybe a) -> a -> Parser a
.!= Word
5
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"forward-env" forall a. Parser (Maybe a) -> a -> Parser a
.!= 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 forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
        [ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"exec" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
bgconfigExec
        , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"args" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Vector Text
bgconfigArgs
        , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"env" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Map Text Text
bgconfigEnvironment
        , case RestartCount
bgconfigRestartCount of
            RestartCount
UnlimitedRestarts -> forall a. Maybe a
Nothing
            LimitedRestarts Word
count -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"restart-count" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word
count
        , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"restart-delay-seconds" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word
bgconfigRestartDelaySeconds
        , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"forward-env" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Set Text
bgconfigForwardEnv
        ]