{-# 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 = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"AppConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> FilePath
-> [Text] -> Text -> Bool -> Set Text -> Object -> AppConfig
AppConfig
        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 (f :: * -> *) a b. Applicative f => 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
"ssl" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
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
"extra-hosts" 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
<*> 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 = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"BundleConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> Maybe AppConfig -> Set StaticHost -> Set Redirect -> BundleConfig
BundleConfig
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a. a -> Maybe a
Just 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)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ParseYamlFile a =>
BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Text
"static-hosts" 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
"redirects" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Set a
Set.empty

data StaticHost = StaticHost
    { StaticHost -> Text
shHost :: Text
    , StaticHost -> FilePath
shRoot :: FilePath
    }
    deriving (StaticHost -> StaticHost -> Bool
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
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
Ord)

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

instance FromJSON Redirect where
    parseJSON :: Value -> Parser Redirect
parseJSON (Object Object
o) = Text -> Text -> Redirect
Redirect
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"from"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"to"
    parseJSON Value
_ = 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
        { kconfigDir :: FilePath
kconfigDir = FilePath
"."
        , kconfigPortMan :: PortSettings
kconfigPortMan = PortSettings
defaultPortSettings
        , kconfigHost :: HostPreference
kconfigHost = HostPreference
"*"
        , kconfigPort :: Port
kconfigPort = Port
80
        , kconfigSsl :: Maybe TLSConfig
kconfigSsl = forall a. Maybe a
Nothing
        , kconfigSetuid :: Maybe Text
kconfigSetuid = forall a. Maybe a
Nothing
        , kconfigReverseProxy :: Set ReverseProxyConfig
kconfigReverseProxy = 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 forall a. Num a => a -> a -> a
* Port
60 forall a. Num a => a -> a -> a
* Port
1000

instance ParseYamlFile KeterConfig where
    parseYamlFile :: BaseDir -> Value -> Parser KeterConfig
parseYamlFile BaseDir
basedir = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"KeterConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> FilePath
-> PortSettings
-> HostPreference
-> Port
-> Maybe TLSConfig
-> Maybe Text
-> Set ReverseProxyConfig
-> Bool
-> Port
-> 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
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. IsString a => FilePath -> 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
.!= KeterConfig -> HostPreference
kconfigHost KeterConfig
defaultKeterConfig
        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" forall a. Parser (Maybe a) -> a -> Parser a
.!= KeterConfig -> Port
kconfigPort KeterConfig
defaultKeterConfig
        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 (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. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir))
        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
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"reverse-proxy" 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
"ip-from-header" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
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
"connection-time-bound" 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 = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"TLSConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        FilePath
cert <- forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"certificate"
        FilePath
key <- forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
"key"
        HostPreference
host <- (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. IsString a => FilePath -> 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
"*"
        Port
port <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port" forall a. Parser (Maybe a) -> a -> Parser a
.!= Port
443
        Maybe Config
session <- forall a. a -> a -> Bool -> a
bool forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Config
TLSSession.defaultConfig) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"session" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Settings -> FilePath -> FilePath -> Maybe Config -> TLSConfig
TLSConfig
            (HostPreference -> Settings -> Settings
Warp.setHost HostPreference
host 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
        -- Top 10 Largest IANA unassigned port ranges with no unauthorized uses known
        { portRange :: [Port]
portRange = [Port
43124..Port
44320]
                      forall a. [a] -> [a] -> [a]
++ [Port
28120..Port
29166]
                      forall a. [a] -> [a] -> [a]
++ [Port
45967..Port
46997]
                      forall a. [a] -> [a] -> [a]
++ [Port
28241..Port
29117]
                      forall a. [a] -> [a] -> [a]
++ [Port
40001..Port
40840]
                      forall a. [a] -> [a] -> [a]
++ [Port
29170..Port
29998]
                      forall a. [a] -> [a] -> [a]
++ [Port
38866..Port
39680]
                      forall a. [a] -> [a] -> [a]
++ [Port
43442..Port
44122]
                      forall a. [a] -> [a] -> [a]
++ [Port
41122..Port
41793]
                      forall a. [a] -> [a] -> [a]
++ [Port
35358..Port
36000]
        }

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