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

-- | Provides logging, versioning and some type aliases
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)

-- | 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 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

-- | 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 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 -- fail "Must provide both certificate and key files"
                    ) Value
v