{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeFamilies       #-}

module Keter.Types.Common
    ( module Keter.Types.Common
    , FilePath
    , Text
    , ByteString
    , Set
    , Map
    , Exception
    , SomeException
    ) where

import           Control.Exception          (Exception, SomeException)
import           Data.Aeson                 (FromJSON, Object, ToJSON,
                                             Value (Bool), object, withBool,
                                             withObject, (.!=), (.:?), (.=))
import           Data.ByteString            (ByteString)
import           Data.CaseInsensitive       (CI, original)
import           Data.Map                   (Map)
import           Data.Set                   (Set)
import qualified Data.Set                   as Set
import           Data.Text                  (Text, pack, unpack)
import           Data.Typeable              (Typeable)
import           Data.Vector                (Vector)
import qualified Data.Vector                as V
import qualified Data.Yaml
import           Data.Yaml.FilePath
import qualified Language.Haskell.TH.Syntax as TH
import           Network.Socket             (AddrInfo, SockAddr)
import           System.Exit                (ExitCode)
import           System.FilePath            (FilePath, takeBaseName)

-- | Name of the application. Should just be the basename of the application
-- file.
type Appname = Text

data Plugin = Plugin
    { Plugin -> Appname -> Object -> IO [(Appname, Appname)]
pluginGetEnv :: Appname -> Object -> IO [(Text, Text)]
    }

type Plugins = [Plugin]

-- | Used for versioning data types.
class ToCurrent a where
    type Previous a
    toCurrent :: Previous a -> a
instance ToCurrent a => ToCurrent (Maybe a) where
    type Previous (Maybe a) = Maybe (Previous a)
    toCurrent :: Previous (Maybe a) -> Maybe a
toCurrent = (Previous a -> a) -> Maybe (Previous a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Previous a -> a
forall a. ToCurrent a => Previous a -> a
toCurrent

-- | A port for an individual app to listen on.
type Port = Int

-- | A virtual host we want to serve content from.
type Host = CI Text

type HostBS = CI ByteString

getAppname :: FilePath -> Text
getAppname :: FilePath -> Appname
getAppname = FilePath -> Appname
pack (FilePath -> Appname)
-> (FilePath -> FilePath) -> FilePath -> Appname
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeBaseName

data LogMessage
    = ProcessCreated FilePath
    | InvalidBundle FilePath SomeException
    | ProcessDidNotStart FilePath
    | ExceptionThrown Text SomeException
    | RemovingPort Int
    | UnpackingBundle FilePath
    | TerminatingApp Text
    | FinishedReloading Text
    | TerminatingOldProcess AppId
    | RemovingOldFolder FilePath
    | ReceivedInotifyEvent Text
    | ProcessWaiting FilePath
    | OtherMessage Text
    | ErrorStartingBundle Text SomeException
    | SanityChecksPassed
    | ReservingHosts AppId (Set Host)
    | ForgetingReservations AppId (Set Host)
    | ActivatingApp AppId (Set Host)
    | DeactivatingApp AppId (Set Host)
    | ReactivatingApp AppId (Set Host) (Set Host)
    | WatchedFile Text FilePath
    | ReloadFrom (Maybe String) String
    | Terminating String
    | LaunchInitial
    | LaunchCli
    | StartWatching
    | StartListening
    | BindCli AddrInfo
    | ReceivedCliConnection SockAddr
    | KillingApp Port Text

instance Show LogMessage where
    show :: LogMessage -> FilePath
show (ProcessCreated FilePath
f) = FilePath
"Created process: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f
    show (ReloadFrom Maybe FilePath
app FilePath
input) = FilePath
"Reloading from: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe FilePath -> FilePath
forall a. Show a => a -> FilePath
show Maybe FilePath
app  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
input
    show (Terminating FilePath
app) = FilePath
"Terminating " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
app
    show (InvalidBundle FilePath
f SomeException
e) = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ FilePath
"Unable to parse bundle file '"
        , FilePath
f
        , FilePath
"': "
        , SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
        ]
    show (ProcessDidNotStart FilePath
fp) = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ FilePath
"Could not start process within timeout period: "
        , FilePath
fp
        ]
    show (ExceptionThrown Appname
t SomeException
e) = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ Appname -> FilePath
unpack Appname
t
        , FilePath
": "
        , SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
        ]
    show (RemovingPort Int
p) = FilePath
"Port in use, removing from port pool: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
p
    show (UnpackingBundle FilePath
b) = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ FilePath
"Unpacking bundle '"
        , FilePath
b
        , FilePath
"'"
        ]
    show (TerminatingApp Appname
t) = FilePath
"Shutting down app: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Appname -> FilePath
unpack Appname
t
    show (FinishedReloading Appname
t) = FilePath
"App finished reloading: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Appname -> FilePath
unpack Appname
t
    show (TerminatingOldProcess (AINamed Appname
t)) = FilePath
"Sending old process TERM signal: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Appname -> FilePath
unpack Appname
t
    show (TerminatingOldProcess AppId
AIBuiltin) = FilePath
"Sending old process TERM signal: builtin"
    show (RemovingOldFolder FilePath
fp) = FilePath
"Removing unneeded folder: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fp
    show (ReceivedInotifyEvent Appname
t) = FilePath
"Received unknown INotify event: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Appname -> FilePath
unpack Appname
t
    show (ProcessWaiting FilePath
f) = FilePath
"Process restarting too quickly, waiting before trying again: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f
    show (OtherMessage Appname
t) = Appname -> FilePath
unpack Appname
t
    show (ErrorStartingBundle Appname
name SomeException
e) = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ FilePath
"Error occured when launching bundle "
        , Appname -> FilePath
unpack Appname
name
        , FilePath
": "
        , SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
        ]
    show LogMessage
SanityChecksPassed = FilePath
"Sanity checks passed"
    show (ReservingHosts AppId
app Set Host
hosts) = FilePath
"Reserving hosts for app " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AppId -> FilePath
forall a. Show a => a -> FilePath
show AppId
app FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ((Host -> FilePath) -> [Host] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Appname -> FilePath
unpack (Appname -> FilePath) -> (Host -> Appname) -> Host -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Appname
forall s. CI s -> s
original) ([Host] -> [FilePath]) -> [Host] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set Host -> [Host]
forall a. Set a -> [a]
Set.toList Set Host
hosts)
    show (ForgetingReservations AppId
app Set Host
hosts) = FilePath
"Forgetting host reservations for app " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AppId -> FilePath
forall a. Show a => a -> FilePath
show AppId
app FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ((Host -> FilePath) -> [Host] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Appname -> FilePath
unpack (Appname -> FilePath) -> (Host -> Appname) -> Host -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Appname
forall s. CI s -> s
original) ([Host] -> [FilePath]) -> [Host] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set Host -> [Host]
forall a. Set a -> [a]
Set.toList Set Host
hosts)
    show (ActivatingApp AppId
app Set Host
hosts) = FilePath
"Activating app " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AppId -> FilePath
forall a. Show a => a -> FilePath
show AppId
app FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" with hosts: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ((Host -> FilePath) -> [Host] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Appname -> FilePath
unpack (Appname -> FilePath) -> (Host -> Appname) -> Host -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Appname
forall s. CI s -> s
original) ([Host] -> [FilePath]) -> [Host] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set Host -> [Host]
forall a. Set a -> [a]
Set.toList Set Host
hosts)
    show (DeactivatingApp AppId
app Set Host
hosts) = FilePath
"Deactivating app " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AppId -> FilePath
forall a. Show a => a -> FilePath
show AppId
app FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" with hosts: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ((Host -> FilePath) -> [Host] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Appname -> FilePath
unpack (Appname -> FilePath) -> (Host -> Appname) -> Host -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Appname
forall s. CI s -> s
original) ([Host] -> [FilePath]) -> [Host] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set Host -> [Host]
forall a. Set a -> [a]
Set.toList Set Host
hosts)
    show (ReactivatingApp AppId
app Set Host
old Set Host
new) = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ FilePath
"Reactivating app "
        , AppId -> FilePath
forall a. Show a => a -> FilePath
show AppId
app
        , FilePath
".  Old hosts: "
        , [FilePath] -> FilePath
unwords ((Host -> FilePath) -> [Host] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Appname -> FilePath
unpack (Appname -> FilePath) -> (Host -> Appname) -> Host -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Appname
forall s. CI s -> s
original) ([Host] -> [FilePath]) -> [Host] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set Host -> [Host]
forall a. Set a -> [a]
Set.toList Set Host
old)
        , FilePath
". New hosts: "
        , [FilePath] -> FilePath
unwords ((Host -> FilePath) -> [Host] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Appname -> FilePath
unpack (Appname -> FilePath) -> (Host -> Appname) -> Host -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Appname
forall s. CI s -> s
original) ([Host] -> [FilePath]) -> [Host] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set Host -> [Host]
forall a. Set a -> [a]
Set.toList Set Host
new)
        , FilePath
"."
        ]
    show (WatchedFile Appname
action FilePath
fp) = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ FilePath
"Watched file "
        , Appname -> FilePath
unpack Appname
action
        , FilePath
": "
        , FilePath
fp
        ]
    show LogMessage
LaunchInitial = FilePath
"Launching initial"
    show (KillingApp Int
port Appname
txt) = FilePath
"Killing " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Appname -> FilePath
unpack Appname
txt FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" running on port: "  FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
port
    show LogMessage
LaunchCli     = FilePath
"Launching cli"
    show LogMessage
StartWatching = FilePath
"Started watching"
    show LogMessage
StartListening = FilePath
"Started listening"
    show (BindCli AddrInfo
addr) = FilePath
"Bound cli to " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> AddrInfo -> FilePath
forall a. Show a => a -> FilePath
show AddrInfo
addr
    show (ReceivedCliConnection SockAddr
peer) = FilePath
"CLI Connection from " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
peer

data KeterException = CannotParsePostgres FilePath
                    | ExitCodeFailure FilePath ExitCode
                    | NoPortsAvailable
                    | InvalidConfigFile Data.Yaml.ParseException
                    | InvalidKeterConfigFile !FilePath !Data.Yaml.ParseException
                    | CannotReserveHosts !AppId !(Map Host AppId)
                    | FileNotExecutable !FilePath
                    | ExecutableNotFound !FilePath
                    | EnsureAliveShouldBeBiggerThenZero { KeterException -> Int
keterExceptionGot:: !Int }
    deriving (Int -> KeterException -> FilePath -> FilePath
[KeterException] -> FilePath -> FilePath
KeterException -> FilePath
(Int -> KeterException -> FilePath -> FilePath)
-> (KeterException -> FilePath)
-> ([KeterException] -> FilePath -> FilePath)
-> Show KeterException
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [KeterException] -> FilePath -> FilePath
$cshowList :: [KeterException] -> FilePath -> FilePath
show :: KeterException -> FilePath
$cshow :: KeterException -> FilePath
showsPrec :: Int -> KeterException -> FilePath -> FilePath
$cshowsPrec :: Int -> KeterException -> FilePath -> FilePath
Show, Typeable)
instance Exception KeterException

logEx :: TH.Q TH.Exp
logEx :: Q Exp
logEx = do
    let showLoc :: Loc -> FilePath
showLoc TH.Loc { loc_module :: Loc -> FilePath
TH.loc_module = FilePath
m, loc_start :: Loc -> CharPos
TH.loc_start = (Int
l, Int
c) } = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ FilePath
m
            , FilePath
":"
            , Int -> FilePath
forall a. Show a => a -> FilePath
show Int
l
            , FilePath
":"
            , Int -> FilePath
forall a. Show a => a -> FilePath
show Int
c
            ]
    FilePath
loc <- (Loc -> FilePath) -> Q Loc -> Q FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> FilePath
showLoc Q Loc
forall (m :: * -> *). Quasi m => m Loc
TH.qLocation
    [|(. ExceptionThrown (pack $(TH.lift loc)))|]

data AppId = AIBuiltin | AINamed !Appname
    deriving (AppId -> AppId -> Bool
(AppId -> AppId -> Bool) -> (AppId -> AppId -> Bool) -> Eq AppId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AppId -> AppId -> Bool
$c/= :: AppId -> AppId -> Bool
== :: AppId -> AppId -> Bool
$c== :: AppId -> AppId -> Bool
Eq, Eq AppId
Eq AppId
-> (AppId -> AppId -> Ordering)
-> (AppId -> AppId -> Bool)
-> (AppId -> AppId -> Bool)
-> (AppId -> AppId -> Bool)
-> (AppId -> AppId -> Bool)
-> (AppId -> AppId -> AppId)
-> (AppId -> AppId -> AppId)
-> Ord AppId
AppId -> AppId -> Bool
AppId -> AppId -> Ordering
AppId -> AppId -> AppId
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 :: AppId -> AppId -> AppId
$cmin :: AppId -> AppId -> AppId
max :: AppId -> AppId -> AppId
$cmax :: AppId -> AppId -> AppId
>= :: AppId -> AppId -> Bool
$c>= :: AppId -> AppId -> Bool
> :: AppId -> AppId -> Bool
$c> :: AppId -> AppId -> Bool
<= :: AppId -> AppId -> Bool
$c<= :: AppId -> AppId -> Bool
< :: AppId -> AppId -> Bool
$c< :: AppId -> AppId -> Bool
compare :: AppId -> AppId -> Ordering
$ccompare :: AppId -> AppId -> Ordering
$cp1Ord :: Eq AppId
Ord)
instance Show AppId where
    show :: AppId -> FilePath
show AppId
AIBuiltin   = FilePath
"/builtin/"
    show (AINamed Appname
t) = Appname -> FilePath
unpack Appname
t

data SSLConfig
    = SSLFalse
    | SSLTrue
    | SSL !FilePath !(Vector FilePath) !FilePath
    deriving (Int -> SSLConfig -> FilePath -> FilePath
[SSLConfig] -> FilePath -> FilePath
SSLConfig -> FilePath
(Int -> SSLConfig -> FilePath -> FilePath)
-> (SSLConfig -> FilePath)
-> ([SSLConfig] -> FilePath -> FilePath)
-> Show SSLConfig
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [SSLConfig] -> FilePath -> FilePath
$cshowList :: [SSLConfig] -> FilePath -> FilePath
show :: SSLConfig -> FilePath
$cshow :: SSLConfig -> FilePath
showsPrec :: Int -> SSLConfig -> FilePath -> FilePath
$cshowsPrec :: Int -> SSLConfig -> FilePath -> FilePath
Show, SSLConfig -> SSLConfig -> Bool
(SSLConfig -> SSLConfig -> Bool)
-> (SSLConfig -> SSLConfig -> Bool) -> Eq SSLConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SSLConfig -> SSLConfig -> Bool
$c/= :: SSLConfig -> SSLConfig -> Bool
== :: SSLConfig -> SSLConfig -> Bool
$c== :: SSLConfig -> SSLConfig -> Bool
Eq, Eq SSLConfig
Eq SSLConfig
-> (SSLConfig -> SSLConfig -> Ordering)
-> (SSLConfig -> SSLConfig -> Bool)
-> (SSLConfig -> SSLConfig -> Bool)
-> (SSLConfig -> SSLConfig -> Bool)
-> (SSLConfig -> SSLConfig -> Bool)
-> (SSLConfig -> SSLConfig -> SSLConfig)
-> (SSLConfig -> SSLConfig -> SSLConfig)
-> Ord SSLConfig
SSLConfig -> SSLConfig -> Bool
SSLConfig -> SSLConfig -> Ordering
SSLConfig -> SSLConfig -> SSLConfig
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 :: SSLConfig -> SSLConfig -> SSLConfig
$cmin :: SSLConfig -> SSLConfig -> SSLConfig
max :: SSLConfig -> SSLConfig -> SSLConfig
$cmax :: SSLConfig -> SSLConfig -> SSLConfig
>= :: SSLConfig -> SSLConfig -> Bool
$c>= :: SSLConfig -> SSLConfig -> Bool
> :: SSLConfig -> SSLConfig -> Bool
$c> :: SSLConfig -> SSLConfig -> Bool
<= :: SSLConfig -> SSLConfig -> Bool
$c<= :: SSLConfig -> SSLConfig -> Bool
< :: SSLConfig -> SSLConfig -> Bool
$c< :: SSLConfig -> SSLConfig -> Bool
compare :: SSLConfig -> SSLConfig -> Ordering
$ccompare :: SSLConfig -> SSLConfig -> Ordering
$cp1Ord :: Eq SSLConfig
Ord)

instance ParseYamlFile SSLConfig where
    parseYamlFile :: BaseDir -> Value -> Parser SSLConfig
parseYamlFile BaseDir
_ v :: Value
v@(Bool Bool
_) =
        FilePath -> (Bool -> Parser SSLConfig) -> Value -> Parser SSLConfig
forall a. FilePath -> (Bool -> Parser a) -> Value -> Parser a
withBool FilePath
"ssl" ( \Bool
b ->
            SSLConfig -> Parser SSLConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
b then SSLConfig
SSLTrue else SSLConfig
SSLFalse) ) Value
v
    parseYamlFile BaseDir
basedir Value
v =  FilePath
-> (Object -> Parser SSLConfig) -> Value -> Parser SSLConfig
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"ssl" ( \Object
o -> do
             Maybe FilePath
mcert <- BaseDir -> Object -> Appname -> Parser (Maybe FilePath)
forall a.
ParseYamlFile a =>
BaseDir -> Object -> Appname -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Appname
"certificate"
             Maybe FilePath
mkey <- BaseDir -> Object -> Appname -> Parser (Maybe FilePath)
forall a.
ParseYamlFile a =>
BaseDir -> Object -> Appname -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Appname
"key"
             case (Maybe FilePath
mcert, Maybe FilePath
mkey) of
                 (Just FilePath
cert, Just FilePath
key) -> do
                     Vector FilePath
chainCerts <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"chain-certificates"
                         Parser (Maybe Value)
-> (Maybe Value -> Parser (Vector FilePath))
-> Parser (Vector FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser (Vector FilePath)
-> (Value -> Parser (Vector FilePath))
-> Maybe Value
-> Parser (Vector FilePath)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Vector FilePath -> Parser (Vector FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Vector FilePath
forall a. Vector a
V.empty) (BaseDir -> Value -> Parser (Vector FilePath)
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir)
                     SSLConfig -> Parser SSLConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLConfig -> Parser SSLConfig) -> SSLConfig -> Parser SSLConfig
forall a b. (a -> b) -> a -> b
$ FilePath -> Vector FilePath -> FilePath -> SSLConfig
SSL FilePath
cert Vector FilePath
chainCerts FilePath
key
                 (Maybe FilePath, Maybe FilePath)
_ -> SSLConfig -> Parser SSLConfig
forall (m :: * -> *) a. Monad m => a -> m a
return SSLConfig
SSLFalse
            ) Value
v

instance ToJSON SSLConfig where
    toJSON :: SSLConfig -> Value
toJSON SSLConfig
SSLTrue = Bool -> Value
Bool Bool
True
    toJSON SSLConfig
SSLFalse = Bool -> Value
Bool Bool
False
    toJSON (SSL FilePath
c Vector FilePath
cc FilePath
k) = [Pair] -> Value
object [ Key
"certificate" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
c
                                 , Key
"chain-certificates" Key -> Vector FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Vector FilePath
cc
                                 , Key
"key" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
k
                                 ]
instance FromJSON SSLConfig where
    parseJSON :: Value -> Parser SSLConfig
parseJSON v :: Value
v@(Bool Bool
_) = FilePath -> (Bool -> Parser SSLConfig) -> Value -> Parser SSLConfig
forall a. FilePath -> (Bool -> Parser a) -> Value -> Parser a
withBool FilePath
"ssl" ( \Bool
b ->
                    SSLConfig -> Parser SSLConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
b then SSLConfig
SSLTrue else SSLConfig
SSLFalse) ) Value
v
    parseJSON Value
v = FilePath
-> (Object -> Parser SSLConfig) -> Value -> Parser SSLConfig
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"ssl" ( \Object
o -> do
                    Maybe FilePath
mcert <- Object
o Object -> Key -> Parser (Maybe FilePath)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"certificate"
                    Maybe FilePath
mkey <- Object
o Object -> Key -> Parser (Maybe FilePath)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"key"
                    case (Maybe FilePath
mcert, Maybe FilePath
mkey) of
                        (Just FilePath
cert, Just FilePath
key) -> do
                            Vector FilePath
chainCerts <- Object
o Object -> Key -> Parser (Maybe (Vector FilePath))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"chain-certificates" Parser (Maybe (Vector FilePath))
-> Vector FilePath -> Parser (Vector FilePath)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Vector FilePath
forall a. Vector a
V.empty
                            SSLConfig -> Parser SSLConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLConfig -> Parser SSLConfig) -> SSLConfig -> Parser SSLConfig
forall a b. (a -> b) -> a -> b
$ FilePath -> Vector FilePath -> FilePath -> SSLConfig
SSL FilePath
cert Vector FilePath
chainCerts FilePath
key
                        (Maybe FilePath, Maybe FilePath)
_ -> SSLConfig -> Parser SSLConfig
forall (m :: * -> *) a. Monad m => a -> m a
return SSLConfig
SSLFalse -- fail "Must provide both certificate and key files"
                    ) Value
v