changed to an intermediate config datastructures

This commit is contained in:
Dennis Frieberg 2020-10-01 21:57:14 +02:00
parent f03f91f917
commit 0b1e9339e2

View file

@ -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