mirror of
https://github.com/snoyberg/keter.git
synced 2024-12-15 01:23:09 +03:00
420 lines
15 KiB
Haskell
420 lines
15 KiB
Haskell
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
module Keter.Types.V10 where
|
|
|
|
import Prelude hiding (FilePath)
|
|
import System.Posix.Types (EpochTime)
|
|
import Data.Aeson (Object, ToJSON (..))
|
|
import qualified Data.CaseInsensitive as CI
|
|
import Keter.Types.Common
|
|
import qualified Keter.Types.V04 as V04
|
|
import Keter.Types.Middleware
|
|
import Data.Yaml.FilePath
|
|
import Data.Aeson (FromJSON (..), (.:), (.:?), Value (Object, String), withObject, (.!=))
|
|
import Control.Applicative ((<$>), (<*>), (<|>))
|
|
import qualified Data.Set as Set
|
|
import qualified Filesystem.Path.CurrentOS as F
|
|
import Data.Default
|
|
import Data.String (fromString)
|
|
import Data.Conduit.Network (HostPreference)
|
|
import Data.Vector (Vector)
|
|
import qualified Data.Vector as V
|
|
import Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig)
|
|
import Data.Maybe (fromMaybe, catMaybes)
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import qualified Network.Wai.Handler.WarpTLS as WarpTLS
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import qualified Data.Map as Map
|
|
import Data.Aeson ((.=), Value (Bool), object)
|
|
import Data.Word (Word)
|
|
|
|
data BundleConfig = BundleConfig
|
|
{ bconfigStanzas :: !(Vector (Stanza ()))
|
|
, bconfigPlugins :: !Object -- ^ settings used for plugins
|
|
}
|
|
|
|
instance ToCurrent BundleConfig where
|
|
type Previous BundleConfig = V04.BundleConfig
|
|
toCurrent (V04.BundleConfig webapp statics redirs) = BundleConfig
|
|
{ bconfigStanzas = V.concat
|
|
[ maybe V.empty V.singleton $ fmap (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 >>= HashMap.lookup "postgres" . V04.configRaw of
|
|
Just (Bool True) -> HashMap.singleton "postgres" (Bool True)
|
|
_ -> HashMap.empty
|
|
}
|
|
|
|
instance ParseYamlFile BundleConfig where
|
|
parseYamlFile basedir = withObject "BundleConfig" $ \o -> do
|
|
case HashMap.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" .!= HashMap.empty
|
|
|
|
instance ToJSON BundleConfig where
|
|
toJSON BundleConfig {..} = object
|
|
[ "stanzas" .= bconfigStanzas
|
|
, "plugins" .= bconfigPlugins
|
|
]
|
|
|
|
data ListeningPort = LPSecure !HostPreference !Port !F.FilePath !F.FilePath
|
|
| 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"
|
|
case (mcert, mkey) of
|
|
(Nothing, Nothing) -> do
|
|
port <- o .:? "port" .!= 80
|
|
return $ LPInsecure host port
|
|
(Just cert, Just key) -> do
|
|
port <- o .:? "port" .!= 443
|
|
return $ LPSecure host port cert key
|
|
_ -> 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.
|
|
}
|
|
|
|
instance ToCurrent KeterConfig where
|
|
type Previous KeterConfig = V04.KeterConfig
|
|
toCurrent (V04.KeterConfig dir portman host port ssl setuid rproxy ipFromHeader) = KeterConfig
|
|
{ kconfigDir = dir
|
|
, kconfigPortPool = portman
|
|
, kconfigListeners = NonEmptyVector (LPInsecure host port) (getSSL ssl)
|
|
, kconfigSetuid = setuid
|
|
, kconfigBuiltinStanzas = V.fromList $ map (flip Stanza False . StanzaReverseProxy) $ Set.toList rproxy
|
|
, kconfigIpFromHeader = ipFromHeader
|
|
, kconfigExternalHttpPort = 80
|
|
, kconfigExternalHttpsPort = 443
|
|
, kconfigEnvironment = Map.empty
|
|
}
|
|
where
|
|
getSSL Nothing = V.empty
|
|
getSSL (Just (V04.TLSConfig s ts)) = V.singleton $ LPSecure
|
|
(Warp.getHost s)
|
|
(Warp.getPort s)
|
|
(F.decodeString $ WarpTLS.certFile ts)
|
|
(F.decodeString $ WarpTLS.keyFile ts)
|
|
|
|
instance Default KeterConfig where
|
|
def = KeterConfig
|
|
{ kconfigDir = "."
|
|
, kconfigPortPool = def
|
|
, kconfigListeners = NonEmptyVector (LPInsecure "*" 80) V.empty
|
|
, kconfigSetuid = Nothing
|
|
, kconfigBuiltinStanzas = V.empty
|
|
, kconfigIpFromHeader = False
|
|
, kconfigExternalHttpPort = 80
|
|
, kconfigExternalHttpsPort = 443
|
|
, kconfigEnvironment = Map.empty
|
|
}
|
|
|
|
instance ParseYamlFile KeterConfig where
|
|
parseYamlFile basedir = withObject "KeterConfig" $ \o ->
|
|
case HashMap.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" .!= def
|
|
<*> fmap (fromMaybe (kconfigListeners def)) (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
|
|
|
|
-- | Whether we should force redirect to HTTPS routes.
|
|
type RequiresSecure = Bool
|
|
|
|
data Stanza port = Stanza (StanzaRaw port) RequiresSecure
|
|
|
|
data StanzaRaw port
|
|
= StanzaStaticFiles !StaticFilesConfig
|
|
| StanzaRedirect !RedirectConfig
|
|
| StanzaWebApp !(WebAppConfig port)
|
|
| StanzaReverseProxy !ReverseProxyConfig
|
|
| 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
|
|
| PAStatic StaticFilesConfig
|
|
| PARedirect RedirectConfig
|
|
| PAReverseProxy ReverseProxyConfig
|
|
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" -> fmap StanzaReverseProxy $ parseJSON $ Object o
|
|
"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 $ HashMap.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 $ HashMap.insert "type" t o
|
|
v -> v
|
|
|
|
data StaticFilesConfig = StaticFilesConfig
|
|
{ sfconfigRoot :: !F.FilePath
|
|
, sfconfigHosts :: !(Set Host)
|
|
, sfconfigListings :: !Bool
|
|
-- FIXME basic auth
|
|
, sfconfigMiddleware :: ![ MiddlewareConfig ]
|
|
}
|
|
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 = []
|
|
}
|
|
|
|
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" .!= []
|
|
|
|
instance ToJSON StaticFilesConfig where
|
|
toJSON StaticFilesConfig {..} = object
|
|
[ "root" .= F.encodeString sfconfigRoot
|
|
, "hosts" .= Set.map CI.original sfconfigHosts
|
|
, "directory-listing" .= sfconfigListings
|
|
, "middleware" .= sfconfigMiddleware
|
|
]
|
|
|
|
data RedirectConfig = RedirectConfig
|
|
{ redirconfigHosts :: !(Set Host)
|
|
, redirconfigStatus :: !Int
|
|
, redirconfigActions :: !(Vector RedirectAction)
|
|
}
|
|
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
|
|
}
|
|
|
|
instance ParseYamlFile RedirectConfig where
|
|
parseYamlFile _ = withObject "RedirectConfig" $ \o -> RedirectConfig
|
|
<$> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host")))))
|
|
<*> o .:? "status" .!= 303
|
|
<*> o .: "actions"
|
|
|
|
instance ToJSON RedirectConfig where
|
|
toJSON RedirectConfig {..} = object
|
|
[ "hosts" .= Set.map CI.original redirconfigHosts
|
|
, "status" .= redirconfigStatus
|
|
, "actions" .= redirconfigActions
|
|
]
|
|
|
|
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 $ HashMap.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 :: !Bool
|
|
, waconfigPort :: !port
|
|
, waconfigForwardEnv :: !(Set Text)
|
|
}
|
|
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 = ssl
|
|
, waconfigPort = ()
|
|
, waconfigForwardEnv = Set.empty
|
|
}
|
|
|
|
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" .!= False
|
|
<*> return ()
|
|
<*> o .:? "forward-env" .!= Set.empty
|
|
|
|
instance ToJSON (WebAppConfig ()) where
|
|
toJSON WebAppConfig {..} = object
|
|
[ "exec" .= F.encodeString waconfigExec
|
|
, "args" .= waconfigArgs
|
|
, "env" .= waconfigEnvironment
|
|
, "hosts" .= map CI.original (waconfigApprootHost : Set.toList waconfigHosts)
|
|
, "ssl" .= waconfigSsl
|
|
, "forward-env" .= waconfigForwardEnv
|
|
]
|
|
|
|
data AppInput = AIBundle !FilePath !EpochTime
|
|
| AIData !BundleConfig
|
|
|
|
data BackgroundConfig = BackgroundConfig
|
|
{ bgconfigExec :: !F.FilePath
|
|
, bgconfigArgs :: !(Vector Text)
|
|
, bgconfigEnvironment :: !(Map Text Text)
|
|
, bgconfigRestartCount :: !RestartCount
|
|
, bgconfigRestartDelaySeconds :: !Word
|
|
}
|
|
deriving Show
|
|
|
|
data RestartCount = UnlimitedRestarts | LimitedRestarts !Word
|
|
deriving Show
|
|
|
|
instance FromJSON RestartCount where
|
|
parseJSON (String "unlimited") = return UnlimitedRestarts
|
|
parseJSON v = fmap 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
|
|
|
|
instance ToJSON BackgroundConfig where
|
|
toJSON BackgroundConfig {..} = object $ catMaybes
|
|
[ Just $ "exec" .= F.encodeString bgconfigExec
|
|
, Just $ "args" .= bgconfigArgs
|
|
, Just $ "env" .= bgconfigEnvironment
|
|
, case bgconfigRestartCount of
|
|
UnlimitedRestarts -> Nothing
|
|
LimitedRestarts count -> Just $ "restart-count" .= count
|
|
, Just $ "restart-delay-seconds" .= bgconfigRestartDelaySeconds
|
|
]
|