From c425181638c7c4d3e91a209fe1653d310a755fa4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 14 Aug 2013 11:55:58 +0300 Subject: [PATCH] Added ToJSON instances --- Keter/Types/V10.hs | 82 ++++++++++++++++++++++++++-- Network/HTTP/ReverseProxy/Rewrite.hs | 19 +++++++ 2 files changed, 96 insertions(+), 5 deletions(-) diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs index 80b29d9..a44ecc5 100644 --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -2,11 +2,12 @@ {-# 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) +import Data.Aeson (Object, ToJSON (..)) import Keter.Types.Common import qualified Keter.Types.V04 as V04 import Data.Yaml.FilePath @@ -21,7 +22,7 @@ import Data.Vector (Vector) import qualified Data.Vector as V import Data.Monoid (mempty) import Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig) -import Data.Maybe (fromMaybe) +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 @@ -49,14 +50,20 @@ instance ToCurrent BundleConfig where } instance ParseYamlFile BundleConfig where - parseYamlFile basedir = withObject "Config" $ \o -> do + 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" - <*> pure o + <*> 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 @@ -158,6 +165,18 @@ instance ParseYamlFile (Stanza ()) where "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 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) @@ -180,6 +199,13 @@ instance ParseYamlFile StaticFilesConfig where <*> (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 @@ -202,6 +228,13 @@ instance ParseYamlFile RedirectConfig where <*> o .:? "status" .!= 303 <*> o .: "actions" +instance ToJSON RedirectConfig where + toJSON RedirectConfig {..} = object + [ "hosts" .= redirconfigHosts + , "status" .= redirconfigStatus + , "actions" .= redirconfigActions + ] + data RedirectAction = RedirectAction !SourcePath !RedirectDest deriving Show @@ -210,6 +243,15 @@ instance FromJSON RedirectAction where <$> (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 @@ -226,7 +268,17 @@ instance FromJSON RedirectDest where prefix o = RDPrefix <$> o .:? "secure" .!= False <*> o .: "host" - <*> o .: "port" + <*> 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 @@ -273,6 +325,15 @@ instance ParseYamlFile (WebAppConfig ()) where <*> 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 @@ -299,3 +360,14 @@ instance ParseYamlFile BackgroundConfig where <*> 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 + ] diff --git a/Network/HTTP/ReverseProxy/Rewrite.hs b/Network/HTTP/ReverseProxy/Rewrite.hs index 107653a..0e15504 100644 --- a/Network/HTTP/ReverseProxy/Rewrite.hs +++ b/Network/HTTP/ReverseProxy/Rewrite.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Network.HTTP.ReverseProxy.Rewrite ( ReverseProxyConfig (..) , RewriteRule (..) @@ -164,6 +165,17 @@ instance FromJSON ReverseProxyConfig where <*> o .:? "rewrite-request" .!= Set.empty parseJSON _ = fail "Wanted an object" +instance ToJSON ReverseProxyConfig where + toJSON ReverseProxyConfig {..} = object + [ "reversed-host" .= reversedHost + , "reversed-port" .= reversedPort + , "reversing-host" .= reversingHost + , "ssl" .= reverseUseSSL + , "timeout" .= reverseTimeout + , "rewrite-response" .= rewriteResponseRules + , "rewrite-request" .= rewriteRequestRules + ] + instance Default ReverseProxyConfig where def = ReverseProxyConfig { reversedHost = "" @@ -187,3 +199,10 @@ instance FromJSON RewriteRule where <*> o .: "from" <*> o .: "to" parseJSON _ = fail "Wanted an object" + +instance ToJSON RewriteRule where + toJSON RewriteRule {..} = object + [ "header" .= ruleHeader + , "from" .= ruleRegex + , "to" .= ruleReplacement + ]