module Keter.Types.V10 where
import Prelude hiding (FilePath)
import System.Posix.Types (EpochTime)
import Data.Aeson (Object, ToJSON (..))
import Keter.Types.Common
import qualified Keter.Types.V04 as V04
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
}
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 (StanzaWebApp . toCurrent) webapp
, V.fromList $ map (StanzaStaticFiles . toCurrent) $ Set.toList statics
, V.fromList $ map (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
}
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 StanzaReverseProxy $ Set.toList rproxy
, kconfigIpFromHeader = ipFromHeader
}
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
}
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
data Stanza port
= StanzaStaticFiles !StaticFilesConfig
| StanzaRedirect !RedirectConfig
| StanzaWebApp !(WebAppConfig port)
| StanzaReverseProxy !ReverseProxyConfig
| StanzaBackground !BackgroundConfig
deriving Show
data ProxyAction = PAPort Port
| PAStatic StaticFilesConfig
| PARedirect RedirectConfig
| PAReverseProxy ReverseProxyConfig
deriving Show
instance ParseYamlFile (Stanza ()) where
parseYamlFile basedir = withObject "Stanza" $ \o -> do
typ <- o .: "type"
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
instance ToJSON (Stanza ()) 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
}
deriving Show
instance ToCurrent StaticFilesConfig where
type Previous StaticFilesConfig = V04.StaticHost
toCurrent (V04.StaticHost host root) = StaticFilesConfig
{ sfconfigRoot = root
, sfconfigHosts = Set.singleton host
, sfconfigListings = True
}
instance ParseYamlFile StaticFilesConfig where
parseYamlFile basedir = withObject "StaticFilesConfig" $ \o -> StaticFilesConfig
<$> lookupBase basedir o "root"
<*> (o .: "hosts" <|> (Set.singleton <$> (o .: "host")))
<*> o .:? "directory-listing" .!= False
instance ToJSON StaticFilesConfig where
toJSON StaticFilesConfig {..} = object
[ "root" .= F.encodeString sfconfigRoot
, "hosts" .= sfconfigHosts
, "directory-listing" .= sfconfigListings
]
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 from
, redirconfigStatus = 301
, redirconfigActions = V.singleton $ RedirectAction SPAny
(RDPrefix False to Nothing) Nothing
}
instance ParseYamlFile RedirectConfig where
parseYamlFile _ = withObject "RedirectConfig" $ \o -> RedirectConfig
<$> (o .: "hosts" <|> (Set.singleton <$> (o .: "host")))
<*> o .:? "status" .!= 303
<*> o .: "actions"
instance ToJSON RedirectConfig where
toJSON RedirectConfig {..} = object
[ "hosts" .= redirconfigHosts
, "status" .= redirconfigStatus
, "actions" .= redirconfigActions
]
data RedirectAction = RedirectAction
{ raSourcePath :: !SourcePath
, raRedirectDest :: !RedirectDest
, raSourceSecure :: !(Maybe Bool)
}
deriving Show
instance FromJSON RedirectAction where
parseJSON = withObject "RedirectAction" $ \o -> RedirectAction
<$> (maybe SPAny SPSpecific <$> (o .:? "path"))
<*> parseJSON (Object o)
<*> o .:? "secure"
instance ToJSON RedirectAction where
toJSON (RedirectAction path dest sourceSecure) =
case toJSON dest of
Object o ->
case path of
SPAny -> Object $ addSecureSource o
SPSpecific x -> Object $ addSecureSource $ HashMap.insert "path" (String x) o
v -> v
where
addSecureSource =
case sourceSecure of
Nothing -> id
Just b -> HashMap.insert "secure" (Bool b)
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
<*> 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" .= 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 :: !Text
, waconfigHosts :: !(Set Text)
, waconfigSsl :: !Bool
, waconfigPort :: !port
}
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 = host
, waconfigHosts = hosts
, waconfigSsl = ssl
, waconfigPort = ()
}
instance ParseYamlFile (WebAppConfig ()) where
parseYamlFile basedir = withObject "WebAppConfig" $ \o -> do
(ahost, hosts) <-
(do
h <- o .: "host"
return (h, Set.empty)) <|>
(do
hs <- o .: "hosts"
case hs of
[] -> fail "Must provide at least one host"
h:hs' -> return (h, Set.fromList hs'))
WebAppConfig
<$> lookupBase basedir o "exec"
<*> o .:? "args" .!= V.empty
<*> o .:? "env" .!= Map.empty
<*> return ahost
<*> return hosts
<*> o .:? "ssl" .!= False
<*> return ()
instance ToJSON (WebAppConfig ()) where
toJSON WebAppConfig {..} = object
[ "exec" .= F.encodeString waconfigExec
, "args" .= waconfigArgs
, "env" .= waconfigEnvironment
, "hosts" .= (waconfigApprootHost : Set.toList waconfigHosts)
, "ssl" .= waconfigSsl
]
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
]