156 lines
4.7 KiB
Haskell
156 lines
4.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Config(Configuration(..),forkBackend,withConfigs,forkWithConfigs) where
|
|
|
|
import Toml (TomlCodec, (.=))
|
|
import qualified Toml
|
|
import System.IO
|
|
import qualified Data.Text as T
|
|
import Control.Concurrent.MVar
|
|
import Control.Concurrent
|
|
import WaiApp
|
|
|
|
-- this module should handle everything connected to our TOML config
|
|
#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT)
|
|
import Data.String
|
|
import qualified Network.Wai.Handler.Warp as HTTP
|
|
#endif
|
|
|
|
#ifdef HTTPS_SUPPORT
|
|
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
|
|
#ifdef HTTP_SUPPORT
|
|
, httpConf :: [HttpConfiguration]
|
|
#endif
|
|
#ifdef HTTPS_SUPPORT
|
|
, httpsConf :: [(HttpConfiguration,HttpsConfiguration)]
|
|
#endif
|
|
#ifdef FASTCGI_SUPPORT
|
|
, fastCgiConf :: [FastCgiConfiguration]
|
|
#endif
|
|
#ifdef CGI_SUPPORT
|
|
, cgiConf :: [CgiConfiguration]
|
|
#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
|
|
|
|
#ifdef CGI_SUPPORT
|
|
data CgiConfiguration = CgiConfiguration
|
|
#endif
|
|
|
|
defaultConfiguration :: Configuration
|
|
defaultConfiguration = Configuration ()
|
|
#ifdef HTTP_SUPPORT
|
|
[httpDefaultSettings]
|
|
#endif
|
|
#ifdef HTTPS_SUPPORT
|
|
[(httpDefaultSettings,httpsDefaultSettings)]
|
|
#endif
|
|
#ifdef FASTCGI_SUPPORT
|
|
[FastCgiConfiguration]
|
|
#endif
|
|
#ifdef CGI_SUPPORT
|
|
[CgiConfiguration]
|
|
#endif
|
|
|
|
#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT)
|
|
-- 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
|
|
<$> Toml.int "Port" .= port
|
|
<*> bindPreference "Bind" .= bindPref
|
|
#endif
|
|
|
|
#ifdef HTTPS_SUPPORT
|
|
httpsConfigCodec :: TomlCodec (HttpConfiguration,HttpsConfiguration)
|
|
httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec'
|
|
|
|
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" .= certFile
|
|
<*> Toml.arrayOf Toml._String "CertChain" .= certChain
|
|
<*> Toml.string "KeyFile" .= keyFile
|
|
#endif
|
|
|
|
#ifdef FASTCGI_SUPPORT
|
|
fastCgiConfigCodec :: TomlCodec FastCgiConfiguration
|
|
fastCgiConfigCodec = pure FastCgiConfiguration
|
|
#endif
|
|
|
|
#ifdef CGI_SUPPORT
|
|
cgiConfigCodec :: TomlCodec CgiConfiguration
|
|
cgiConfigCodec = pure CgiConfiguration
|
|
#endif
|
|
|
|
configurationCodec :: TomlCodec Configuration
|
|
configurationCodec = pure (Configuration ())
|
|
#ifdef HTTP_SUPPORT
|
|
<*> Toml.list httpConfigCodec "http" .= httpConf
|
|
#endif
|
|
#ifdef HTTPS_SUPPORT
|
|
<*> Toml.list httpsConfigCodec "https" .= httpsConf
|
|
#endif
|
|
#ifdef FASTCGI_SUPPORT
|
|
<*> Toml.list fastCgiConfigCodec "fast-cgi" .= fastCgiConf
|
|
#endif
|
|
#ifdef CGI_SUPPORT
|
|
<*> Toml.list cgiConfigCodec "cgi" .= cgiConf
|
|
#endif
|
|
|
|
forkWithConfigs :: (a -> IO ()) -> TomlCodec [a] -> FilePath -> IO [MVar ()]
|
|
forkWithConfigs f = withConfigs (\conf -> forkBackend $ f conf)
|
|
|
|
withConfigs :: (a -> IO (MVar ())) -> TomlCodec [a] -> FilePath -> IO [MVar ()]
|
|
withConfigs f codec configFile = do
|
|
parseResult <- Toml.decodeFileEither codec configFile
|
|
either
|
|
(error "Logging not implemented")
|
|
(mapM f)
|
|
parseResult
|
|
|
|
forkBackend :: IO () -> IO (MVar ())
|
|
forkBackend f = do
|
|
mVar <- newEmptyMVar
|
|
forkFinally f (const $ putMVar mVar ())
|
|
return mVar
|