Https backend done

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(MVar)
-import Control.Concurrent.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

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

hie.yaml

@@ -0,0 +1,6 @@
+cradle:
+  stack:
+    - path: "./app/"
+      component: "tickLeisteServer:exe:tickLeisteServer"
+    - path: "./test/"
+      component: "tickLeisteServer:test:tickLeisteServer-test"