{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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 a b. (a -> b) -> Maybe a -> Maybe b
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 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
$cshowsPrec :: Int -> KeterException -> FilePath -> FilePath
showsPrec :: Int -> KeterException -> FilePath -> FilePath
$cshow :: KeterException -> FilePath
show :: KeterException -> FilePath
$cshowList :: [KeterException] -> FilePath -> FilePath
showList :: [KeterException] -> FilePath -> FilePath
Show, Typeable)
instance Exception KeterException
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
$c== :: AppId -> AppId -> Bool
== :: AppId -> AppId -> Bool
$c/= :: AppId -> AppId -> Bool
/= :: 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
$ccompare :: AppId -> AppId -> Ordering
compare :: AppId -> AppId -> Ordering
$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
>= :: AppId -> AppId -> Bool
$cmax :: AppId -> AppId -> AppId
max :: AppId -> AppId -> AppId
$cmin :: AppId -> AppId -> AppId
min :: AppId -> AppId -> 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
$cshowsPrec :: Int -> SSLConfig -> FilePath -> FilePath
showsPrec :: Int -> SSLConfig -> FilePath -> FilePath
$cshow :: SSLConfig -> FilePath
show :: SSLConfig -> FilePath
$cshowList :: [SSLConfig] -> FilePath -> FilePath
showList :: [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
$c== :: SSLConfig -> SSLConfig -> Bool
== :: SSLConfig -> SSLConfig -> Bool
$c/= :: SSLConfig -> SSLConfig -> Bool
/= :: 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
$ccompare :: SSLConfig -> SSLConfig -> Ordering
compare :: SSLConfig -> SSLConfig -> Ordering
$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
>= :: SSLConfig -> SSLConfig -> Bool
$cmax :: SSLConfig -> SSLConfig -> SSLConfig
max :: SSLConfig -> SSLConfig -> SSLConfig
$cmin :: SSLConfig -> SSLConfig -> SSLConfig
min :: SSLConfig -> SSLConfig -> 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 a. a -> Parser a
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 a b. Parser a -> (a -> Parser b) -> Parser b
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 a. a -> Parser a
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 a. a -> Parser a
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 a. a -> Parser a
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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FilePath
c
, Key
"chain-certificates" Key -> Vector FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Vector FilePath
cc
, Key
"key" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e 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 a. a -> Parser a
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 a. a -> Parser a
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 a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return SSLConfig
SSLFalse
) Value
v