diff --git a/app/Config.hs b/app/Config.hs index 8d7a73a..6b7daf0 100644 --- a/app/Config.hs +++ b/app/Config.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -module Config(Configuration(..),defaultConfiguration,configurationCodec) where +module Config(Configuration(..),defaultConfiguration,HttpConfiguration (..)) where import Toml (TomlCodec, (.=)) import qualified Toml import System.IO +import qualified Data.Text as T -- this module should handle everything connected to our TOML config #if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) @@ -15,13 +16,13 @@ import qualified Network.Wai.Handler.Warp as HTTP import qualified Network.Wai.Handler.WarpTLS as HTTPS #endif -data Configuration = Configuration { - cppDummy :: () -- this is a hack to get around the , rules of haskell records and the preprocessor +data Configuration = Configuration + { cppDummy :: () -- this is a hack to get around the , rules of haskell records and the preprocessor #ifdef HTTP_SUPPORT - , httpConf :: [HTTP.Settings] + , httpConf :: [HttpConfiguration] #endif #ifdef HTTPS_SUPPORT - , httpsConf :: [(HTTP.Settings,HTTPS.TLSSettings)] + , httpsConf :: [(HttpConfiguration,HttpsConfiguration)] #endif #ifdef FASTCGI_SUPPORT , fastCgiConf :: [FastCgiConfiguration] @@ -31,6 +32,36 @@ data Configuration = Configuration { #endif } +#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) +-- We leave it as a Text here and defer the conversion to the warp type to the last possible moment. +-- At least we can touch and print a String. Excepet that we don't use it so we don't need it in another +-- form +type BindPreference = String + +_BindPreference :: Toml.TomlBiMap BindPreference Toml.AnyValue +_BindPreference = Toml._String + +bindPreference :: Toml.Key -> TomlCodec BindPreference +bindPreference = Toml.match _BindPreference + +data HttpConfiguration = HttpConfiguration + { port :: Int + , bindPref :: BindPreference + } +httpDefaultSettings :: HttpConfiguration +httpDefaultSettings = HttpConfiguration 80 "*" +#endif + +#ifdef HTTPS_SUPPORT +data HttpsConfiguration = HttpsConfiguration + { certFile :: FilePath + , certChain :: [FilePath] + , keyFile :: FilePath + } +httpsDefaultSettings :: HttpsConfiguration +httpsDefaultSettings = HttpsConfiguration "certificate.pem" [] "key.pem" +#endif + #ifdef FASTCGI_SUPPORT data FastCgiConfiguration = FastCgiConfiguration #endif @@ -42,10 +73,10 @@ data CgiConfiguration = CgiConfiguration defaultConfiguration :: Configuration defaultConfiguration = Configuration () #ifdef HTTP_SUPPORT - [HTTP.defaultSettings] + [httpDefaultSettings] #endif #ifdef HTTPS_SUPPORT - [(HTTP.defaultSettings,HTTPS.defaultTlsSettings)] + [(httpDefaultSettings,httpsDefaultSettings)] #endif #ifdef FASTCGI_SUPPORT [FastCgiConfiguration] @@ -55,40 +86,28 @@ defaultConfiguration = Configuration () #endif #if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) --- this should not need to exist!!! It is realy ugly crap, but the only we to construct and deconstruct --- this datatype is via fromString, read, show. And as we want the fromString syntax we want an inverse --- of it too, but we don't get something nice exposed. Also we don't get the constructors exposed so we --- pattern match on Strings, this is a hack!!! -httpShowHostPreference :: HTTP.HostPreference -> String -httpShowHostPreference pref = case show pref of - "HostAny" -> "*" - "HostIPv4" -> "*4" - "HostIPv4Only" -> "!4" - "HostIPv6" -> "*6" - "HostIPv6Only" -> "!6" - x -> drop 6 $ init x -- why a String? Why is the only way to generate a HostPreference by its IsString instance? -- why does warp not expose its constructors?? httpConfigConstructor :: Int -> String -> HTTP.Settings httpConfigConstructor port bind = HTTP.setPort port $ HTTP.setHost (fromString bind) HTTP.defaultSettings -httpConfigCodec :: TomlCodec HTTP.Settings -httpConfigCodec = httpConfigConstructor - <$> Toml.int "Port" .= HTTP.getPort - <*> Toml.string "Bind" .= (httpShowHostPreference . HTTP.getHost) +httpConfigCodec :: TomlCodec HttpConfiguration +httpConfigCodec = HttpConfiguration + <$> Toml.int "Port" .= port + <*> bindPreference "Bind" .= bindPref #endif #ifdef HTTPS_SUPPORT -httpsConfigCodec :: TomlCodec (HTTP.Settings,HTTPS.TLSSettings) +httpsConfigCodec :: TomlCodec (HttpConfiguration,HttpsConfiguration) httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' -httpsConfigCodec' :: TomlCodec (HTTPS.TLSSettings) -httpsConfigCodec' = HTTPS.tlsSettingsChain +httpsConfigCodec' :: TomlCodec HttpsConfiguration +httpsConfigCodec' = HttpsConfiguration -- the hardcoded strings are a bloody hack, but we can't extract the values back out of a config (they are there -- warp just doesn't export the neccesarry types). So we hardcode default values, which is kind of realy bad, but -- we don't need it in our usecase - <$> Toml.string "Certificate" .= (const "certificate.pem") - <*> Toml.arrayOf Toml._String "CertChain" .= (const []) - <*> Toml.string "KeyFile" .= (const "key.pem") + <$> Toml.string "Certificate" .= certFile + <*> Toml.arrayOf Toml._String "CertChain" .= certChain + <*> Toml.string "KeyFile" .= keyFile #endif #ifdef FASTCGI_SUPPORT