diff --git a/app/Backend/Http.hs b/app/Backend/Http.hs index 824d055..52a58bb 100644 --- a/app/Backend/Http.hs +++ b/app/Backend/Http.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +-- we export a bit more than we have to, because the https module can reuse these things. module Backend.Http ( HttpConfiguration (..), httpDefaultSettings, @@ -7,12 +8,12 @@ module Backend.Http forkHttpBackend, httpConfigCodec, httpConfigsCodec, + httpToWarpConfig, ) where import Config -import Control.Concurrent -import Control.Concurrent.MVar +import Control.Concurrent.MVar(MVar) import Data.String import qualified Data.Text as T import qualified Network.Wai as Wai @@ -20,13 +21,6 @@ import Network.Wai.Handler.Warp as HTTP import Toml (TomlCodec, (.=)) import qualified Toml --- 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 - --- even though this is just a String alias, we leave the infrastructure in place. Maybe we want to change that --- type at some point. Then we can redifne the stuff to work with our new type. --- One can think about this as being accidantally a String, and not by design. type BindPreference = String _BindPreference :: Toml.TomlBiMap BindPreference Toml.AnyValue @@ -47,11 +41,6 @@ httpDefaultSetting = HttpConfiguration "http" 80 "*" httpDefaultSettings :: [HttpConfiguration] httpDefaultSettings = [httpDefaultSetting] --- 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 HttpConfiguration httpConfigCodec = HttpConfiguration diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs index d7f796a..4832649 100644 --- a/app/Backend/Https.hs +++ b/app/Backend/Https.hs @@ -1,14 +1,21 @@ -module Backend.Https where +{-# LANGUAGE OverloadedStrings #-} + +module Backend.Https (forkHttpsBackend, httpsDefaultSettings) where import Backend.Http -import qualified Data.Text as T +import Config +import Control.Concurrent.MVar (MVar) +import Data.Text () -- we only need the isString instance to generate literals +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as HTTP +import qualified Network.Wai.Handler.WarpTLS as HTTPS import Toml (TomlCodec, (.=)) import qualified Toml type HttpsConfiguration = (HttpConfiguration, TLSConfiguration) data TLSConfiguration = TLSConfiguration - { cerfFile :: FilePath, + { certFile :: FilePath, certChain :: [FilePath], keyFile :: FilePath } @@ -18,3 +25,31 @@ tlsDefaultSetting = TLSConfiguration "certificate.pem" [] "key.pem" httpsDefaultSetting :: HttpsConfiguration httpsDefaultSetting = (httpDefaultSetting, tlsDefaultSetting) + +httpsDefaultSettings :: [HttpsConfiguration] +httpsDefaultSettings = [httpsDefaultSetting] + +httpsConfigCodec' :: TomlCodec TLSConfiguration +httpsConfigCodec' = + TLSConfiguration + <$> Toml.string "Certificate" .= certFile + <*> Toml.arrayOf Toml._String "CertChain" .= certChain + <*> Toml.string "KeyFile" .= keyFile + +httpsConfigCodec :: TomlCodec HttpsConfiguration +httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' + +httpsConfigsCodec :: TomlCodec [HttpsConfiguration] +httpsConfigsCodec = Toml.list httpsConfigCodec "https" + +forkHttpsBackend :: Wai.Application -> FilePath -> IO [MVar ()] +forkHttpsBackend app configFile = forkWithConfigs (backend app) httpsConfigsCodec configFile + +httpsToWarpTLSConfig :: HttpsConfiguration -> HTTPS.TLSSettings +httpsToWarpTLSConfig (_, tlsConfig) = HTTPS.tlsSettingsChain (certFile tlsConfig) (certChain tlsConfig) (keyFile tlsConfig) + +httpsToWarpConfig :: HttpsConfiguration -> HTTP.Settings +httpsToWarpConfig = httpToWarpConfig . fst + +backend :: Wai.Application -> HttpsConfiguration -> IO () +backend app conf = HTTPS.runTLS (httpsToWarpTLSConfig conf) (httpsToWarpConfig conf) app diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..89544a0 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,6 @@ +cradle: + stack: + - path: "./app/" + component: "tickLeisteServer:exe:tickLeisteServer" + - path: "./test/" + component: "tickLeisteServer:test:tickLeisteServer-test"