module Keter.Types.V10 where
import Control.Applicative ((<$>), (<*>), (<|>))
import Data.Aeson (Object, ToJSON (..))
import Data.Aeson (FromJSON (..),
Value (Object, String),
withObject, (.!=), (.:),
(.:?))
import Data.Aeson (Value (Bool), object, (.=))
import qualified Data.CaseInsensitive as CI
import Data.Conduit.Network (HostPreference)
import Data.Default
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe)
import qualified Data.Set as Set
import Data.String (fromString)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Word (Word)
import Data.Yaml.FilePath
import qualified System.FilePath as F
import Keter.Types.Common
import Keter.Types.Middleware
import qualified Keter.Types.V04 as V04
import Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WarpTLS as WarpTLS
import System.Posix.Types (EpochTime)
data BundleConfig = BundleConfig
{ bconfigStanzas :: !(Vector (Stanza ()))
, bconfigPlugins :: !Object
}
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 ->
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 !(V.Vector 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
chainCerts <- o .:? "chain-certificates"
>>= maybe (return V.empty) (parseYamlFile basedir)
return $ LPSecure host port cert chainCerts 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
, kconfigExternalHttpsPort :: !Int
, kconfigEnvironment :: !(Map Text Text)
, kconfigConnectionTimeBound :: !Int
}
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
}
where
getSSL Nothing = V.empty
getSSL (Just (V04.TLSConfig s ts)) = V.singleton $ LPSecure
(Warp.getHost s)
(Warp.getPort s)
(WarpTLS.certFile ts)
V.empty
(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
, kconfigConnectionTimeBound = V04.fiveMinutes
}
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
<*> o .:? "connection-time-bound" .!= V04.fiveMinutes
type RequiresSecure = Bool
data Stanza port = Stanza (StanzaRaw port) RequiresSecure
data StanzaRaw port
= StanzaStaticFiles !StaticFilesConfig
| StanzaRedirect !RedirectConfig
| StanzaWebApp !(WebAppConfig port)
| StanzaReverseProxy !ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)
| StanzaBackground !BackgroundConfig
deriving Show
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 $ 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
, sfconfigMiddleware :: ![ MiddlewareConfig ]
, sfconfigTimeout :: !(Maybe Int)
}
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
}
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"
instance ToJSON StaticFilesConfig where
toJSON StaticFilesConfig {..} = object
[ "root" .= sfconfigRoot
, "hosts" .= Set.map CI.original sfconfigHosts
, "directory-listing" .= sfconfigListings
, "middleware" .= sfconfigMiddleware
, "connection-time-bound" .= sfconfigTimeout
]
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
, waconfigHosts :: !(Set Host)
, waconfigSsl :: !Bool
, waconfigPort :: !port
, waconfigForwardEnv :: !(Set Text)
, waconfigTimeout :: !(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 = ssl
, waconfigPort = ()
, waconfigForwardEnv = Set.empty
, waconfigTimeout = 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" .!= False
<*> return ()
<*> o .:? "forward-env" .!= Set.empty
<*> o .:? "connection-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
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
]