{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Keter.Common where
import qualified Network.Wai as Wai
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 Keter.Yaml.FilePath
import qualified Language.Haskell.TH.Syntax as TH
import Network.Socket (AddrInfo, SockAddr)
import System.Exit (ExitCode)
import System.FilePath (FilePath, takeBaseName)
type Appname = Text
data Plugin = Plugin
{ Plugin -> Appname -> Object -> IO [(Appname, Appname)]
pluginGetEnv :: Appname -> Object -> IO [(Text, Text)]
}
type Plugins = [Plugin]
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
type Port = Int
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
| ProxyException Wai.Request SomeException
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
show (ProxyException Request
req SomeException
except) = FilePath
"Got a proxy exception on request " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Request -> FilePath
forall a. Show a => a -> FilePath
show Request
req FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" with exception " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
except
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
) Value
v