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

-- | Provides logging, versioning and some type aliases
module Keter.Common where

import Control.Exception (Exception)
import Data.Aeson
       ( FromJSON
       , Object
       , ToJSON
       , Value(Bool)
       , object
       , withBool
       , withObject
       , (.!=)
       , (.:?)
       , (.=)
       )
import Data.ByteString (ByteString)
import Data.CaseInsensitive (CI)
import Data.Map (Map)
import Data.Text (Text, pack, unpack)
import Data.Typeable (Typeable)
import Data.Vector (Vector)
import Data.Vector qualified as V
import Data.Yaml qualified
import Keter.Yaml.FilePath
import System.Exit (ExitCode)
import System.FilePath (takeBaseName)

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

{-# ANN type Plugin ("HLint: ignore Use newtype instead of data" :: String) #-}
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