V10.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module Keter.Config.V10 where

import Control.Applicative ((<|>))
import Data.Aeson
       ( FromJSON(..)
       , Object
       , ToJSON(..)
       , Value(Bool, Object, String)
       , object
       , withObject
       , (.!=)
       , (.:)
       , (.:?)
       , (.=)
       )
import Data.CaseInsensitive qualified as CI
import Data.Conduit.Network (HostPreference)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.String (fromString)
import Data.Text (Text)
import Data.Vector (Vector)
import Data.Vector qualified as V
import Keter.Aeson.KeyHelper as AK (empty, insert, lookup, singleton)
import Keter.Common
import Keter.Config.Middleware
import Keter.Config.V04 qualified as V04
import Keter.Rewrite (ReverseProxyConfig)
import Keter.Yaml.FilePath
import Network.Wai.Handler.Warp qualified as Warp
import System.FilePath qualified as F
import System.Posix.Types (EpochTime)

data BundleConfig = BundleConfig
    { bconfigStanzas :: !(Vector (Stanza ()))
    , bconfigPlugins :: !Object -- ^ settings used for plugins
    } deriving Show

instance ToCurrent BundleConfig where
    type Previous BundleConfig = V04.BundleConfig
    toCurrent (V04.BundleConfig webapp statics redirs) = BundleConfig
        { bconfigStanzas = V.concat
            [ maybe V.empty (V.singleton . flip Stanza False . StanzaWebApp . toCurrent) webapp
            , V.fromList $ map (flip Stanza False . StanzaStaticFiles . toCurrent) $ Set.toList statics
            , V.fromList $ map (flip Stanza False . StanzaRedirect . toCurrent) $ Set.toList redirs
            ]
        , bconfigPlugins =
            case webapp >>= AK.lookup "postgres" . V04.configRaw of
                Just (Bool True) -> AK.singleton "postgres" (Bool True)
                _ -> AK.empty
        }

instance ParseYamlFile BundleConfig where
    parseYamlFile basedir = withObject "BundleConfig" $ \o ->
        case AK.lookup "stanzas" o of
            Nothing -> (toCurrent :: V04.BundleConfig -> BundleConfig) <$> parseYamlFile basedir (Object o)
            Just _ -> current o
      where
        current o = BundleConfig
            <$> lookupBase basedir o "stanzas"
            <*> o .:? "plugins" .!= AK.empty

instance ToJSON BundleConfig where
    toJSON BundleConfig {..} = object
        [ "stanzas" .= bconfigStanzas
        , "plugins" .= bconfigPlugins
        ]

data ListeningPort = LPSecure !HostPreference !Port
                              !F.FilePath !(V.Vector F.FilePath) !F.FilePath
                              !Bool
                   | LPInsecure !HostPreference !Port

instance ParseYamlFile ListeningPort where
    parseYamlFile basedir = withObject "ListeningPort" $ \o -> do
        host <- (fmap fromString <$> o .:? "host") .!= "*"
        mcert <- lookupBaseMaybe basedir o "certificate"
        mkey <- lookupBaseMaybe basedir o "key"
        session <- o .:? "session" .!= False
        case (mcert, mkey) of
            (Nothing, Nothing) -> do
                port <- o .:? "port" .!= 80
                return $ LPInsecure host port
            (Just cert, Just key) -> do
                port <- o .:? "port" .!= 443
                chainCerts <- o .:? "chain-certificates"
                    >>= maybe (return V.empty) (parseYamlFile basedir)
                return $ LPSecure host port cert chainCerts key session
            _ -> fail "Must provide both certificate and key files"

data KeterConfig = KeterConfig
    { kconfigDir                 :: F.FilePath
    , kconfigPortPool            :: V04.PortSettings
    , kconfigListeners           :: !(NonEmptyVector ListeningPort)
    , kconfigSetuid              :: Maybe Text
    , kconfigBuiltinStanzas      :: !(V.Vector (Stanza ()))
    , kconfigIpFromHeader        :: Bool
    , kconfigExternalHttpPort    :: !Int
    -- ^ External HTTP port when generating APPROOTs.
    , kconfigExternalHttpsPort   :: !Int
    -- ^ External HTTPS port when generating APPROOTs.
    , kconfigEnvironment         :: !(Map Text Text)
    -- ^ Environment variables to be passed to all apps.
    , kconfigConnectionTimeBound :: !Int
    -- ^ Maximum request time in milliseconds per connection.
    , kconfigCliPort             :: !(Maybe Port)
    -- ^ Port for the cli to listen on

    , kconfigUnknownHostResponse  :: !(Maybe F.FilePath)
    , kconfigMissingHostResponse  :: !(Maybe F.FilePath)
    , kconfigProxyException       :: !(Maybe F.FilePath)

    , kconfigRotateLogs           :: !Bool
    , kconfigHealthcheckPath      :: !(Maybe Text)
    }

instance ToCurrent KeterConfig where
    type Previous KeterConfig = V04.KeterConfig
    toCurrent (V04.KeterConfig dir portman host port ssl setuid rproxy ipFromHeader connectionTimeBound) = KeterConfig
        { kconfigDir = dir
        , kconfigPortPool = portman
        , kconfigListeners = NonEmptyVector (LPInsecure host port) (getSSL ssl)
        , kconfigSetuid = setuid
        , kconfigBuiltinStanzas = V.fromList $ map (flip Stanza False . (\rp -> StanzaReverseProxy rp [] Nothing)) $ Set.toList rproxy
        , kconfigIpFromHeader = ipFromHeader
        , kconfigExternalHttpPort = 80
        , kconfigExternalHttpsPort = 443
        , kconfigEnvironment = Map.empty
        , kconfigConnectionTimeBound = connectionTimeBound
        , kconfigCliPort             = Nothing
        , kconfigUnknownHostResponse = Nothing
        , kconfigMissingHostResponse = Nothing
        , kconfigProxyException = Nothing
        , kconfigRotateLogs = True
        , kconfigHealthcheckPath = Nothing
        }
      where
        getSSL Nothing = V.empty
        getSSL (Just (V04.TLSConfig s cert key session)) = V.singleton $ LPSecure
            (Warp.getHost s)
            (Warp.getPort s)
            cert
            V.empty
            key
            (isJust session)

defaultKeterConfig :: KeterConfig
defaultKeterConfig = KeterConfig
        { kconfigDir = "."
        , kconfigPortPool = V04.defaultPortSettings
        , kconfigListeners = NonEmptyVector (LPInsecure "*" 80) V.empty
        , kconfigSetuid = Nothing
        , kconfigBuiltinStanzas = V.empty
        , kconfigIpFromHeader = False
        , kconfigExternalHttpPort = 80
        , kconfigExternalHttpsPort = 443
        , kconfigEnvironment = Map.empty
        , kconfigConnectionTimeBound = V04.fiveMinutes
        , kconfigCliPort = Nothing
        , kconfigUnknownHostResponse = Nothing
        , kconfigMissingHostResponse = Nothing
        , kconfigProxyException = Nothing
        , kconfigRotateLogs = True
        , kconfigHealthcheckPath = Nothing
        }

instance ParseYamlFile KeterConfig where
    parseYamlFile basedir = withObject "KeterConfig" $ \o ->
        case AK.lookup "listeners" o of
            Just _ -> current o
            Nothing -> old o <|> current o
      where
        old o = (toCurrent :: V04.KeterConfig -> KeterConfig) <$> parseYamlFile basedir (Object o)
        current o = KeterConfig
            <$> lookupBase basedir o "root"
            <*> o .:? "port-manager" .!= V04.defaultPortSettings
            <*> fmap (fromMaybe (kconfigListeners defaultKeterConfig)) (lookupBaseMaybe basedir o "listeners")
            <*> o .:? "setuid"
            <*> return V.empty
            <*> o .:? "ip-from-header" .!= False
            <*> o .:? "external-http-port" .!= 80
            <*> o .:? "external-https-port" .!= 443
            <*> o .:? "env" .!= Map.empty
            <*> o .:? "connection-time-bound" .!= V04.fiveMinutes
            <*> o .:? "cli-port"
            <*> o .:? "unknown-host-response-file"
            <*> o .:? "missing-host-response-file"
            <*> o .:? "proxy-exception-response-file"
            <*> o .:? "rotate-logs" .!= True
            <*> o .:? "app-crash-hook"

-- | Whether we should force redirect to HTTPS routes.
type RequiresSecure = Bool

data Stanza port = Stanza (StanzaRaw port) RequiresSecure
  deriving Show

data StanzaRaw port
    = StanzaStaticFiles !StaticFilesConfig
    | StanzaRedirect !RedirectConfig
    | StanzaWebApp !(WebAppConfig port)
    | StanzaReverseProxy !ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)
    | StanzaBackground !BackgroundConfig
            -- FIXME console app
    deriving Show

-- | An action to be performed for a requested hostname.
--
-- This datatype is very similar to Stanza, but is necessarily separate since:
--
-- 1. Webapps will be assigned ports.
--
-- 2. Not all stanzas have an associated proxy action.
data ProxyActionRaw
    = PAPort Port !(Maybe Int)
    | PAStatic StaticFilesConfig
    | PARedirect RedirectConfig
    | PAReverseProxy ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)
    deriving Show

type ProxyAction = (ProxyActionRaw, RequiresSecure)

instance ParseYamlFile (Stanza ()) where
    parseYamlFile basedir = withObject "Stanza" $ \o -> do
        typ <- o .: "type"
        needsHttps <- o .:? "requires-secure" .!= False
        raw <- case typ of
            "static-files"  -> fmap StanzaStaticFiles $ parseYamlFile basedir $ Object o
            "redirect"      -> fmap StanzaRedirect $ parseYamlFile basedir $ Object o
            "webapp"        -> fmap StanzaWebApp $ parseYamlFile basedir $ Object o
            "reverse-proxy" -> StanzaReverseProxy <$> parseJSON (Object o)
                                                  <*> o .:? "middleware" .!= []
                                                  <*> o .:? "connection-time-bound"
            "background"    -> fmap StanzaBackground $ parseYamlFile basedir $ Object o
            _ -> fail $ "Unknown stanza type: " ++ typ
        return $ Stanza raw needsHttps

instance ToJSON (Stanza ()) where
    toJSON (Stanza raw rs) = addRequiresSecure rs raw

addRequiresSecure :: ToJSON a => Bool -> a -> Value
addRequiresSecure rs x =
    case toJSON x of
        Object o -> Object $ AK.insert "requires-secure" (toJSON rs) o
        v -> v

instance ToJSON (StanzaRaw ()) where
    toJSON (StanzaStaticFiles x) = addStanzaType "static-files" x
    toJSON (StanzaRedirect x) = addStanzaType "redirect" x
    toJSON (StanzaWebApp x) = addStanzaType "webapp" x
    toJSON (StanzaReverseProxy x _ _) = addStanzaType "reverse-proxy" x
    toJSON (StanzaBackground x) = addStanzaType "background" x

addStanzaType :: ToJSON a => Value -> a -> Value
addStanzaType t x =
    case toJSON x of
        Object o -> Object $ AK.insert "type" t o
        v -> v

data StaticFilesConfig = StaticFilesConfig
    { sfconfigRoot       :: !F.FilePath
    , sfconfigHosts      :: !(Set Host)
    , sfconfigListings   :: !Bool
    -- FIXME basic auth
    , sfconfigMiddleware :: ![ MiddlewareConfig ]
    , sfconfigTimeout    :: !(Maybe Int)
    , sfconfigSsl        :: !SSLConfig
    }
    deriving Show

instance ToCurrent StaticFilesConfig where
    type Previous StaticFilesConfig = V04.StaticHost
    toCurrent (V04.StaticHost host root) = StaticFilesConfig
        { sfconfigRoot       = root
        , sfconfigHosts      = Set.singleton $ CI.mk host
        , sfconfigListings   = True
        , sfconfigMiddleware = []
        , sfconfigTimeout    = Nothing
        , sfconfigSsl        = SSLFalse
        }

instance ParseYamlFile StaticFilesConfig where
    parseYamlFile basedir = withObject "StaticFilesConfig" $ \o -> StaticFilesConfig
        <$> lookupBase basedir o "root"
        <*> (Set.map CI.mk <$> (o .: "hosts" <|> (Set.singleton <$> (o .: "host"))))
        <*> o .:? "directory-listing" .!= False
        <*> o .:? "middleware" .!= []
        <*> o .:? "connection-time-bound"
        <*> o .:? "ssl" .!= SSLFalse

instance ToJSON StaticFilesConfig where
    toJSON StaticFilesConfig {..} = object
        [ "root" .= sfconfigRoot
        , "hosts" .= Set.map CI.original sfconfigHosts
        , "directory-listing" .= sfconfigListings
        , "middleware" .= sfconfigMiddleware
        , "connection-time-bound" .= sfconfigTimeout
        , "ssl" .= sfconfigSsl
        ]

data RedirectConfig = RedirectConfig
    { redirconfigHosts   :: !(Set Host)
    , redirconfigStatus  :: !Int
    , redirconfigActions :: !(Vector RedirectAction)
    , redirconfigSsl     :: !SSLConfig
    }
    deriving Show

instance ToCurrent RedirectConfig where
    type Previous RedirectConfig = V04.Redirect
    toCurrent (V04.Redirect from to) = RedirectConfig
        { redirconfigHosts = Set.singleton $ CI.mk from
        , redirconfigStatus = 301
        , redirconfigActions = V.singleton $ RedirectAction SPAny
                             $ RDPrefix False (CI.mk to) Nothing
        , redirconfigSsl = SSLFalse
        }

instance ParseYamlFile RedirectConfig where
    parseYamlFile _ = withObject "RedirectConfig" $ \o -> RedirectConfig
        <$> (Set.map CI.mk <$> (o .: "hosts" <|> Set.singleton <$> o .: "host"))
        <*> o .:? "status" .!= 303
        <*> o .: "actions"
        <*> o .:? "ssl" .!= SSLFalse

instance ToJSON RedirectConfig where
    toJSON RedirectConfig {..} = object
        [ "hosts" .= Set.map CI.original redirconfigHosts
        , "status" .= redirconfigStatus
        , "actions" .= redirconfigActions
        , "ssl" .= redirconfigSsl
        ]

data RedirectAction = RedirectAction !SourcePath !RedirectDest
    deriving Show

instance FromJSON RedirectAction where
    parseJSON = withObject "RedirectAction" $ \o -> RedirectAction
        <$> (maybe SPAny SPSpecific <$> (o .:? "path"))
        <*> parseJSON (Object o)

instance ToJSON RedirectAction where
    toJSON (RedirectAction path dest) =
        case toJSON dest of
            Object o ->
                case path of
                    SPAny -> Object o
                    SPSpecific x -> Object $ AK.insert "path" (String x) o
            v -> v

data SourcePath = SPAny
                | SPSpecific !Text
    deriving Show

data RedirectDest = RDUrl !Text
                  | RDPrefix !IsSecure !Host !(Maybe Port)
    deriving Show

instance FromJSON RedirectDest where
    parseJSON = withObject "RedirectDest" $ \o ->
        url o <|> prefix o
      where
        url o = RDUrl <$> o .: "url"
        prefix o = RDPrefix
            <$> o .:? "secure" .!= False
            <*> (CI.mk <$> o .: "host")
            <*> o .:? "port"

instance ToJSON RedirectDest where
    toJSON (RDUrl url) = object ["url" .= url]
    toJSON (RDPrefix secure host mport) = object $ catMaybes
        [ Just $ "secure" .= secure
        , Just $ "host" .= CI.original host
        , case mport of
            Nothing -> Nothing
            Just port -> Just $ "port" .= port
        ]

type IsSecure = Bool

data WebAppConfig port = WebAppConfig
    { waconfigExec        :: !F.FilePath
    , waconfigArgs        :: !(Vector Text)
    , waconfigEnvironment :: !(Map Text Text)
    , waconfigApprootHost :: !Host -- ^ primary host, used for approot
    , waconfigHosts       :: !(Set Host) -- ^ all hosts, not including the approot host
    , waconfigSsl         :: !SSLConfig
    , waconfigPort        :: !port
    , waconfigForwardEnv  :: !(Set Text)
     -- | how long are connections supposed to last
    , waconfigTimeout     :: !(Maybe Int)
     -- | how long in microseconds the app gets before we expect it to bind to
     --   a port (default 90 seconds)
    , waconfigEnsureAliveTimeout :: !(Maybe Int)
    }
    deriving Show

instance ToCurrent (WebAppConfig ()) where
    type Previous (WebAppConfig ()) = V04.AppConfig
    toCurrent (V04.AppConfig exec args host ssl hosts _raw) = WebAppConfig
        { waconfigExec = exec
        , waconfigArgs = V.fromList args
        , waconfigEnvironment = Map.empty
        , waconfigApprootHost = CI.mk host
        , waconfigHosts = Set.map CI.mk hosts
        , waconfigSsl = if ssl then SSLTrue else SSLFalse
        , waconfigPort = ()
        , waconfigForwardEnv = Set.empty
        , waconfigTimeout = Nothing
        , waconfigEnsureAliveTimeout = Nothing
        }

instance ParseYamlFile (WebAppConfig ()) where
    parseYamlFile basedir = withObject "WebAppConfig" $ \o -> do
        (ahost, hosts) <-
            (do
                h <- o .: "host"
                return (CI.mk h, Set.empty)) <|>
            (do
                hs <- o .: "hosts"
                case hs of
                    [] -> fail "Must provide at least one host"
                    h:hs' -> return (CI.mk h, Set.fromList $ map CI.mk hs'))
        WebAppConfig
            <$> lookupBase basedir o "exec"
            <*> o .:? "args" .!= V.empty
            <*> o .:? "env" .!= Map.empty
            <*> return ahost
            <*> return hosts
            <*> o .:? "ssl" .!= SSLFalse
            <*> return ()
            <*> o .:? "forward-env" .!= Set.empty
            <*> o .:? "connection-time-bound"
            <*> o .:? "ensure-alive-time-bound"

instance ToJSON (WebAppConfig ()) where
    toJSON WebAppConfig {..} = object
        [ "exec" .= waconfigExec
        , "args" .= waconfigArgs
        , "env" .= waconfigEnvironment
        , "hosts" .= map CI.original (waconfigApprootHost : Set.toList waconfigHosts)
        , "ssl" .= waconfigSsl
        , "forward-env" .= waconfigForwardEnv
        , "connection-time-bound" .= waconfigTimeout
        ]

data AppInput = AIBundle !FilePath !EpochTime
              | AIData !BundleConfig
              deriving Show

data BackgroundConfig = BackgroundConfig
    { bgconfigExec                :: !F.FilePath
    , bgconfigArgs                :: !(Vector Text)
    , bgconfigEnvironment         :: !(Map Text Text)
    , bgconfigRestartCount        :: !RestartCount
    , bgconfigRestartDelaySeconds :: !Word
    , bgconfigForwardEnv          :: !(Set Text)
    }
    deriving Show

data RestartCount = UnlimitedRestarts | LimitedRestarts !Word
    deriving Show

instance FromJSON RestartCount where
    parseJSON (String "unlimited") = return UnlimitedRestarts
    parseJSON v = LimitedRestarts <$> parseJSON v

instance ParseYamlFile BackgroundConfig where
    parseYamlFile basedir = withObject "BackgroundConfig" $ \o -> BackgroundConfig
        <$> lookupBase basedir o "exec"
        <*> o .:? "args" .!= V.empty
        <*> o .:? "env" .!= Map.empty
        <*> o .:? "restart-count" .!= UnlimitedRestarts
        <*> o .:? "restart-delay-seconds" .!= 5
        <*> o .:? "forward-env" .!= Set.empty

instance ToJSON BackgroundConfig where
    toJSON BackgroundConfig {..} = object $ catMaybes
        [ Just $ "exec" .= bgconfigExec
        , Just $ "args" .= bgconfigArgs
        , Just $ "env" .= bgconfigEnvironment
        , case bgconfigRestartCount of
            UnlimitedRestarts -> Nothing
            LimitedRestarts count -> Just $ "restart-count" .= count
        , Just $ "restart-delay-seconds" .= bgconfigRestartDelaySeconds
        , Just $ "forward-env" .= bgconfigForwardEnv
        ]