{-# LANGUAGE OverloadedStrings #-}
-- | Legacy types from Keter version 0.4. Retained to keep backwards
-- compatibility in config file format.
module Keter.Config.V04 where

import           Control.Applicative
import           Data.Aeson
import           Data.Bool
import           Data.Conduit.Network              (HostPreference)
import           Data.String                       (fromString)
import           Keter.Yaml.FilePath
import qualified System.FilePath                   as F
import           Keter.Common
import           Keter.Rewrite(ReverseProxyConfig)
import           Data.Text                  (Text)
import           System.FilePath            (FilePath)
import           Data.Set                   (Set)
import qualified Data.Set                   as Set
import qualified Network.Wai.Handler.Warp          as Warp
import qualified Network.Wai.Handler.WarpTLS       as WarpTLS
import qualified Network.TLS.SessionManager        as TLSSession
import           Prelude                           hiding (FilePath)

data AppConfig = AppConfig
    { AppConfig -> FilePath
configExec       :: F.FilePath
    , AppConfig -> [Text]
configArgs       :: [Text]
    , AppConfig -> Text
configHost       :: Text
    , AppConfig -> Bool
configSsl        :: Bool
    , AppConfig -> Set Text
configExtraHosts :: Set Text
    , AppConfig -> Object
configRaw        :: Object
    }

instance ParseYamlFile AppConfig where
    parseYamlFile :: BaseDir -> Value -> Parser AppConfig
parseYamlFile BaseDir
basedir = FilePath
-> (Object -> Parser AppConfig) -> Value -> Parser AppConfig
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"AppConfig" ((Object -> Parser AppConfig) -> Value -> Parser AppConfig)
-> (Object -> Parser AppConfig) -> Value -> Parser AppConfig
forall a b. (a -> b) -> a -> b
$ \Object
o -> FilePath
-> [Text] -> Text -> Bool -> Set Text -> Object -> AppConfig
AppConfig
        (FilePath
 -> [Text] -> Text -> Bool -> Set Text -> Object -> AppConfig)
-> Parser FilePath
-> Parser
     ([Text] -> Text -> Bool -> Set Text -> Object -> AppConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Object -> Text -> Parser FilePath
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"exec"
        Parser ([Text] -> Text -> Bool -> Set Text -> Object -> AppConfig)
-> Parser [Text]
-> Parser (Text -> Bool -> Set Text -> Object -> AppConfig)
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
"args" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
        Parser (Text -> Bool -> Set Text -> Object -> AppConfig)
-> Parser Text -> Parser (Bool -> Set Text -> Object -> AppConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"host"
        Parser (Bool -> Set Text -> Object -> AppConfig)
-> Parser Bool -> Parser (Set Text -> Object -> AppConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ssl" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
        Parser (Set Text -> Object -> AppConfig)
-> Parser (Set Text) -> Parser (Object -> AppConfig)
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
"extra-hosts" 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 (Object -> AppConfig) -> Parser Object -> Parser AppConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser Object
forall (m :: * -> *) a. Monad m => a -> m a
return Object
o

data BundleConfig = BundleConfig
    { BundleConfig -> Maybe AppConfig
bconfigApp         :: Maybe AppConfig
    , BundleConfig -> Set StaticHost
bconfigStaticHosts :: Set StaticHost
    , BundleConfig -> Set Redirect
bconfigRedirects   :: Set Redirect
    }

instance ParseYamlFile BundleConfig where
    parseYamlFile :: BaseDir -> Value -> Parser BundleConfig
parseYamlFile BaseDir
basedir = FilePath
-> (Object -> Parser BundleConfig) -> Value -> Parser BundleConfig
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"BundleConfig" ((Object -> Parser BundleConfig) -> Value -> Parser BundleConfig)
-> (Object -> Parser BundleConfig) -> Value -> Parser BundleConfig
forall a b. (a -> b) -> a -> b
$ \Object
o -> Maybe AppConfig -> Set StaticHost -> Set Redirect -> BundleConfig
BundleConfig
        (Maybe AppConfig -> Set StaticHost -> Set Redirect -> BundleConfig)
-> Parser (Maybe AppConfig)
-> Parser (Set StaticHost -> Set Redirect -> BundleConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((AppConfig -> Maybe AppConfig
forall a. a -> Maybe a
Just (AppConfig -> Maybe AppConfig)
-> Parser AppConfig -> Parser (Maybe AppConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Value -> Parser AppConfig
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir (Object -> Value
Object Object
o)) Parser (Maybe AppConfig)
-> Parser (Maybe AppConfig) -> Parser (Maybe AppConfig)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe AppConfig -> Parser (Maybe AppConfig)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AppConfig
forall a. Maybe a
Nothing)
        Parser (Set StaticHost -> Set Redirect -> BundleConfig)
-> Parser (Set StaticHost) -> Parser (Set Redirect -> BundleConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BaseDir -> Object -> Text -> Parser (Maybe (Set StaticHost))
forall a.
ParseYamlFile a =>
BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Text
"static-hosts" Parser (Maybe (Set StaticHost))
-> Set StaticHost -> Parser (Set StaticHost)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set StaticHost
forall a. Set a
Set.empty
        Parser (Set Redirect -> BundleConfig)
-> Parser (Set Redirect) -> Parser BundleConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe (Set Redirect))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"redirects" Parser (Maybe (Set Redirect))
-> Set Redirect -> Parser (Set Redirect)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set Redirect
forall a. Set a
Set.empty

data StaticHost = StaticHost
    { StaticHost -> Text
shHost :: Text
    , StaticHost -> FilePath
shRoot :: FilePath
    }
    deriving (StaticHost -> StaticHost -> Bool
(StaticHost -> StaticHost -> Bool)
-> (StaticHost -> StaticHost -> Bool) -> Eq StaticHost
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StaticHost -> StaticHost -> Bool
$c/= :: StaticHost -> StaticHost -> Bool
== :: StaticHost -> StaticHost -> Bool
$c== :: StaticHost -> StaticHost -> Bool
Eq, Eq StaticHost
Eq StaticHost
-> (StaticHost -> StaticHost -> Ordering)
-> (StaticHost -> StaticHost -> Bool)
-> (StaticHost -> StaticHost -> Bool)
-> (StaticHost -> StaticHost -> Bool)
-> (StaticHost -> StaticHost -> Bool)
-> (StaticHost -> StaticHost -> StaticHost)
-> (StaticHost -> StaticHost -> StaticHost)
-> Ord StaticHost
StaticHost -> StaticHost -> Bool
StaticHost -> StaticHost -> Ordering
StaticHost -> StaticHost -> StaticHost
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StaticHost -> StaticHost -> StaticHost
$cmin :: StaticHost -> StaticHost -> StaticHost
max :: StaticHost -> StaticHost -> StaticHost
$cmax :: StaticHost -> StaticHost -> StaticHost
>= :: StaticHost -> StaticHost -> Bool
$c>= :: StaticHost -> StaticHost -> Bool
> :: StaticHost -> StaticHost -> Bool
$c> :: StaticHost -> StaticHost -> Bool
<= :: StaticHost -> StaticHost -> Bool
$c<= :: StaticHost -> StaticHost -> Bool
< :: StaticHost -> StaticHost -> Bool
$c< :: StaticHost -> StaticHost -> Bool
compare :: StaticHost -> StaticHost -> Ordering
$ccompare :: StaticHost -> StaticHost -> Ordering
$cp1Ord :: Eq StaticHost
Ord)

instance ParseYamlFile StaticHost where
    parseYamlFile :: BaseDir -> Value -> Parser StaticHost
parseYamlFile BaseDir
basedir = FilePath
-> (Object -> Parser StaticHost) -> Value -> Parser StaticHost
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"StaticHost" ((Object -> Parser StaticHost) -> Value -> Parser StaticHost)
-> (Object -> Parser StaticHost) -> Value -> Parser StaticHost
forall a b. (a -> b) -> a -> b
$ \Object
o -> Text -> FilePath -> StaticHost
StaticHost
        (Text -> FilePath -> StaticHost)
-> Parser Text -> Parser (FilePath -> StaticHost)
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 (FilePath -> StaticHost)
-> Parser FilePath -> Parser StaticHost
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BaseDir -> Object -> Text -> Parser FilePath
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"root"

data Redirect = Redirect
    { Redirect -> Text
redFrom :: Text
    , Redirect -> Text
redTo   :: Text
    }
    deriving (Redirect -> Redirect -> Bool
(Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Bool) -> Eq Redirect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Redirect -> Redirect -> Bool
$c/= :: Redirect -> Redirect -> Bool
== :: Redirect -> Redirect -> Bool
$c== :: Redirect -> Redirect -> Bool
Eq, Eq Redirect
Eq Redirect
-> (Redirect -> Redirect -> Ordering)
-> (Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Redirect)
-> (Redirect -> Redirect -> Redirect)
-> Ord Redirect
Redirect -> Redirect -> Bool
Redirect -> Redirect -> Ordering
Redirect -> Redirect -> Redirect
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Redirect -> Redirect -> Redirect
$cmin :: Redirect -> Redirect -> Redirect
max :: Redirect -> Redirect -> Redirect
$cmax :: Redirect -> Redirect -> Redirect
>= :: Redirect -> Redirect -> Bool
$c>= :: Redirect -> Redirect -> Bool
> :: Redirect -> Redirect -> Bool
$c> :: Redirect -> Redirect -> Bool
<= :: Redirect -> Redirect -> Bool
$c<= :: Redirect -> Redirect -> Bool
< :: Redirect -> Redirect -> Bool
$c< :: Redirect -> Redirect -> Bool
compare :: Redirect -> Redirect -> Ordering
$ccompare :: Redirect -> Redirect -> Ordering
$cp1Ord :: Eq Redirect
Ord)

instance FromJSON Redirect where
    parseJSON :: Value -> Parser Redirect
parseJSON (Object Object
o) = Text -> Text -> Redirect
Redirect
        (Text -> Text -> Redirect)
-> Parser Text -> Parser (Text -> Redirect)
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
"from"
        Parser (Text -> Redirect) -> Parser Text -> Parser Redirect
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"to"
    parseJSON Value
_ = FilePath -> Parser Redirect
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Wanted an object"

data KeterConfig = KeterConfig
    { KeterConfig -> FilePath
kconfigDir                 :: F.FilePath
    , KeterConfig -> PortSettings
kconfigPortMan             :: PortSettings
    , KeterConfig -> HostPreference
kconfigHost                :: HostPreference
    , KeterConfig -> Port
kconfigPort                :: Port
    , KeterConfig -> Maybe TLSConfig
kconfigSsl                 :: Maybe TLSConfig
    , KeterConfig -> Maybe Text
kconfigSetuid              :: Maybe Text
    , KeterConfig -> Set ReverseProxyConfig
kconfigReverseProxy        :: Set ReverseProxyConfig
    , KeterConfig -> Bool
kconfigIpFromHeader        :: Bool
    , KeterConfig -> Port
kconfigConnectionTimeBound :: Int
    -- ^ Maximum request time in milliseconds per connection.
    }

defaultKeterConfig :: KeterConfig
defaultKeterConfig :: KeterConfig
defaultKeterConfig = KeterConfig :: FilePath
-> PortSettings
-> HostPreference
-> Port
-> Maybe TLSConfig
-> Maybe Text
-> Set ReverseProxyConfig
-> Bool
-> Port
-> KeterConfig
KeterConfig
        { kconfigDir :: FilePath
kconfigDir = FilePath
"."
        , kconfigPortMan :: PortSettings
kconfigPortMan = PortSettings
defaultPortSettings
        , kconfigHost :: HostPreference
kconfigHost = HostPreference
"*"
        , kconfigPort :: Port
kconfigPort = Port
80
        , kconfigSsl :: Maybe TLSConfig
kconfigSsl = Maybe TLSConfig
forall a. Maybe a
Nothing
        , kconfigSetuid :: Maybe Text
kconfigSetuid = Maybe Text
forall a. Maybe a
Nothing
        , kconfigReverseProxy :: Set ReverseProxyConfig
kconfigReverseProxy = Set ReverseProxyConfig
forall a. Set a
Set.empty
        , kconfigIpFromHeader :: Bool
kconfigIpFromHeader = Bool
False
        , kconfigConnectionTimeBound :: Port
kconfigConnectionTimeBound = Port
fiveMinutes
        }


-- | Default connection time bound in milliseconds.
fiveMinutes :: Int
fiveMinutes :: Port
fiveMinutes = Port
5 Port -> Port -> Port
forall a. Num a => a -> a -> a
* Port
60 Port -> Port -> Port
forall a. Num a => a -> a -> a
* Port
1000

instance ParseYamlFile KeterConfig where
    parseYamlFile :: BaseDir -> Value -> Parser KeterConfig
parseYamlFile BaseDir
basedir = FilePath
-> (Object -> Parser KeterConfig) -> Value -> Parser KeterConfig
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"KeterConfig" ((Object -> Parser KeterConfig) -> Value -> Parser KeterConfig)
-> (Object -> Parser KeterConfig) -> Value -> Parser KeterConfig
forall a b. (a -> b) -> a -> b
$ \Object
o -> FilePath
-> PortSettings
-> HostPreference
-> Port
-> Maybe TLSConfig
-> Maybe Text
-> Set ReverseProxyConfig
-> Bool
-> Port
-> KeterConfig
KeterConfig
        (FilePath
 -> PortSettings
 -> HostPreference
 -> Port
 -> Maybe TLSConfig
 -> Maybe Text
 -> Set ReverseProxyConfig
 -> Bool
 -> Port
 -> KeterConfig)
-> Parser FilePath
-> Parser
     (PortSettings
      -> HostPreference
      -> Port
      -> Maybe TLSConfig
      -> Maybe Text
      -> Set ReverseProxyConfig
      -> Bool
      -> Port
      -> KeterConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseDir -> Object -> Text -> Parser FilePath
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"root"
        Parser
  (PortSettings
   -> HostPreference
   -> Port
   -> Maybe TLSConfig
   -> Maybe Text
   -> Set ReverseProxyConfig
   -> Bool
   -> Port
   -> KeterConfig)
-> Parser PortSettings
-> Parser
     (HostPreference
      -> Port
      -> Maybe TLSConfig
      -> Maybe Text
      -> Set ReverseProxyConfig
      -> Bool
      -> Port
      -> 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
defaultPortSettings
        Parser
  (HostPreference
   -> Port
   -> Maybe TLSConfig
   -> Maybe Text
   -> Set ReverseProxyConfig
   -> Bool
   -> Port
   -> KeterConfig)
-> Parser HostPreference
-> Parser
     (Port
      -> Maybe TLSConfig
      -> Maybe Text
      -> Set ReverseProxyConfig
      -> Bool
      -> Port
      -> KeterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((FilePath -> HostPreference)
-> Maybe FilePath -> Maybe HostPreference
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> HostPreference
forall a. IsString a => FilePath -> a
fromString (Maybe FilePath -> Maybe HostPreference)
-> Parser (Maybe FilePath) -> Parser (Maybe HostPreference)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe FilePath)
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
.!= KeterConfig -> HostPreference
kconfigHost KeterConfig
defaultKeterConfig
        Parser
  (Port
   -> Maybe TLSConfig
   -> Maybe Text
   -> Set ReverseProxyConfig
   -> Bool
   -> Port
   -> KeterConfig)
-> Parser Port
-> Parser
     (Maybe TLSConfig
      -> Maybe Text
      -> Set ReverseProxyConfig
      -> Bool
      -> Port
      -> KeterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Port)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port" Parser (Maybe Port) -> Port -> Parser Port
forall a. Parser (Maybe a) -> a -> Parser a
.!= KeterConfig -> Port
kconfigPort KeterConfig
defaultKeterConfig
        Parser
  (Maybe TLSConfig
   -> Maybe Text
   -> Set ReverseProxyConfig
   -> Bool
   -> Port
   -> KeterConfig)
-> Parser (Maybe TLSConfig)
-> Parser
     (Maybe Text
      -> Set ReverseProxyConfig -> Bool -> Port -> KeterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ssl" Parser (Maybe Value)
-> (Maybe Value -> Parser (Maybe TLSConfig))
-> Parser (Maybe TLSConfig)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser (Maybe TLSConfig)
-> (Value -> Parser (Maybe TLSConfig))
-> Maybe Value
-> Parser (Maybe TLSConfig)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe TLSConfig -> Parser (Maybe TLSConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TLSConfig
forall a. Maybe a
Nothing) ((TLSConfig -> Maybe TLSConfig)
-> Parser TLSConfig -> Parser (Maybe TLSConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TLSConfig -> Maybe TLSConfig
forall a. a -> Maybe a
Just (Parser TLSConfig -> Parser (Maybe TLSConfig))
-> (Value -> Parser TLSConfig) -> Value -> Parser (Maybe TLSConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseDir -> Value -> Parser TLSConfig
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir))
        Parser
  (Maybe Text
   -> Set ReverseProxyConfig -> Bool -> Port -> KeterConfig)
-> Parser (Maybe Text)
-> Parser (Set ReverseProxyConfig -> Bool -> Port -> 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 (Set ReverseProxyConfig -> Bool -> Port -> KeterConfig)
-> Parser (Set ReverseProxyConfig)
-> Parser (Bool -> Port -> KeterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe (Set ReverseProxyConfig))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"reverse-proxy" Parser (Maybe (Set ReverseProxyConfig))
-> Set ReverseProxyConfig -> Parser (Set ReverseProxyConfig)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set ReverseProxyConfig
forall a. Set a
Set.empty
        Parser (Bool -> Port -> KeterConfig)
-> Parser Bool -> Parser (Port -> KeterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ip-from-header" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
        Parser (Port -> KeterConfig) -> Parser Port -> Parser KeterConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Port)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"connection-time-bound" Parser (Maybe Port) -> Port -> Parser Port
forall a. Parser (Maybe a) -> a -> Parser a
.!= Port
fiveMinutes

data TLSConfig = TLSConfig !Warp.Settings !FilePath !FilePath (Maybe TLSSession.Config)

instance ParseYamlFile TLSConfig where
    parseYamlFile :: BaseDir -> Value -> Parser TLSConfig
parseYamlFile BaseDir
basedir = FilePath
-> (Object -> Parser TLSConfig) -> Value -> Parser TLSConfig
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"TLSConfig" ((Object -> Parser TLSConfig) -> Value -> Parser TLSConfig)
-> (Object -> Parser TLSConfig) -> Value -> Parser TLSConfig
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        FilePath
cert <- BaseDir -> Object -> Text -> Parser FilePath
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"certificate"
        FilePath
key <- BaseDir -> Object -> Text -> Parser FilePath
forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"key"
        HostPreference
host <- ((FilePath -> HostPreference)
-> Maybe FilePath -> Maybe HostPreference
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> HostPreference
forall a. IsString a => FilePath -> a
fromString (Maybe FilePath -> Maybe HostPreference)
-> Parser (Maybe FilePath) -> Parser (Maybe HostPreference)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe FilePath)
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
"*"
        Port
port <- Object
o Object -> Key -> Parser (Maybe Port)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port" Parser (Maybe Port) -> Port -> Parser Port
forall a. Parser (Maybe a) -> a -> Parser a
.!= Port
443
        Maybe Config
session <- Maybe Config -> Maybe Config -> Bool -> Maybe Config
forall a. a -> a -> Bool -> a
bool Maybe Config
forall a. Maybe a
Nothing (Config -> Maybe Config
forall a. a -> Maybe a
Just Config
TLSSession.defaultConfig) (Bool -> Maybe Config) -> Parser Bool -> Parser (Maybe Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"session" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
        TLSConfig -> Parser TLSConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (TLSConfig -> Parser TLSConfig) -> TLSConfig -> Parser TLSConfig
forall a b. (a -> b) -> a -> b
$! Settings -> FilePath -> FilePath -> Maybe Config -> TLSConfig
TLSConfig
            (HostPreference -> Settings -> Settings
Warp.setHost HostPreference
host (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Port -> Settings -> Settings
Warp.setPort Port
port Settings
Warp.defaultSettings)
            FilePath
cert
            FilePath
key
            Maybe Config
session

-- | Controls execution of the nginx thread. Follows the settings type pattern.
-- See: <http://www.yesodweb.com/book/settings-types>.
data PortSettings = PortSettings
    { PortSettings -> [Port]
portRange :: [Port]
      -- ^ Which ports to assign to apps. Defaults to unassigned ranges from IANA
    }

defaultPortSettings :: PortSettings
defaultPortSettings :: PortSettings
defaultPortSettings = PortSettings :: [Port] -> PortSettings
PortSettings
        -- Top 10 Largest IANA unassigned port ranges with no unauthorized uses known
        { portRange :: [Port]
portRange = [Port
43124..Port
44320]
                      [Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++ [Port
28120..Port
29166]
                      [Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++ [Port
45967..Port
46997]
                      [Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++ [Port
28241..Port
29117]
                      [Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++ [Port
40001..Port
40840]
                      [Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++ [Port
29170..Port
29998]
                      [Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++ [Port
38866..Port
39680]
                      [Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++ [Port
43442..Port
44122]
                      [Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++ [Port
41122..Port
41793]
                      [Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++ [Port
35358..Port
36000]
        }

instance FromJSON PortSettings where
    parseJSON :: Value -> Parser PortSettings
parseJSON = FilePath
-> (Object -> Parser PortSettings) -> Value -> Parser PortSettings
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"PortSettings" ((Object -> Parser PortSettings) -> Value -> Parser PortSettings)
-> (Object -> Parser PortSettings) -> Value -> Parser PortSettings
forall a b. (a -> b) -> a -> b
$ \Object
_ -> [Port] -> PortSettings
PortSettings
        ([Port] -> PortSettings) -> Parser [Port] -> Parser PortSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Port] -> Parser [Port]
forall (m :: * -> *) a. Monad m => a -> m a
return (PortSettings -> [Port]
portRange PortSettings
defaultPortSettings)