{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 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
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

data AppId = AIBuiltin | AINamed !Appname
    deriving (AppId -> AppId -> Bool
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
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
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
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
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
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
Ord)

instance ParseYamlFile SSLConfig where
    parseYamlFile :: BaseDir -> Value -> Parser SSLConfig
parseYamlFile BaseDir
_ v :: Value
v@(Bool Bool
_) =
        forall a. FilePath -> (Bool -> Parser a) -> Value -> Parser a
withBool FilePath
"ssl" ( \Bool
b ->
            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 =  forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"ssl" ( \Object
o -> do
             Maybe FilePath
mcert <- forall a.
ParseYamlFile a =>
BaseDir -> Object -> Appname -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Appname
"certificate"
             Maybe FilePath
mkey <- 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 forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"chain-certificates"
                         forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Vector a
V.empty) (forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir)
                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> Vector FilePath -> FilePath -> SSLConfig
SSL FilePath
cert Vector FilePath
chainCerts FilePath
key
                 (Maybe FilePath, Maybe FilePath)
_ -> 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
c
                                 , Key
"chain-certificates" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Vector FilePath
cc
                                 , Key
"key" 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
_) = forall a. FilePath -> (Bool -> Parser a) -> Value -> Parser a
withBool FilePath
"ssl" ( \Bool
b ->
                    forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
b then SSLConfig
SSLTrue else SSLConfig
SSLFalse) ) Value
v
    parseJSON Value
v = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"ssl" ( \Object
o -> do
                    Maybe FilePath
mcert <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"certificate"
                    Maybe FilePath
mkey <- Object
o 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 forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"chain-certificates" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Vector a
V.empty
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> Vector FilePath -> FilePath -> SSLConfig
SSL FilePath
cert Vector FilePath
chainCerts FilePath
key
                        (Maybe FilePath, Maybe FilePath)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return SSLConfig
SSLFalse -- fail "Must provide both certificate and key files"
                    ) Value
v