Common.hs

{-# 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
    { 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 = fmap 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 = pack . 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 { keterExceptionGot:: !Int }
    deriving (Show, Typeable)
instance Exception KeterException

data AppId = AIBuiltin | AINamed !Appname
    deriving (Eq, Ord)
instance Show AppId where
    show AIBuiltin   = "/builtin/"
    show (AINamed t) = unpack t

data SSLConfig
    = SSLFalse
    | SSLTrue
    | SSL !FilePath !(Vector FilePath) !FilePath
    deriving (Show, Eq, Ord)

instance ParseYamlFile SSLConfig where
    parseYamlFile _ v@(Bool _) =
        withBool "ssl" ( \b ->
            return (if b then SSLTrue else SSLFalse) ) v
    parseYamlFile basedir v =  withObject "ssl" ( \o -> do
             mcert <- lookupBaseMaybe basedir o "certificate"
             mkey <- lookupBaseMaybe basedir o "key"
             case (mcert, mkey) of
                 (Just cert, Just key) -> do
                     chainCerts <- o .:? "chain-certificates"
                         >>= maybe (return V.empty) (parseYamlFile basedir)
                     return $ SSL cert chainCerts key
                 _ -> return SSLFalse
            ) v

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