-- |
-- Copyright: (c) 2019 Lucas David Traverso
-- License: MPL-2.0
-- Maintainer: Lucas David Traverso <lucas6246@gmail.com>
-- Stability: stable
-- Portability: portable
--
-- FromConfig instance for warp
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
module Conferer.FromConfig.Warp where

import qualified Data.Text as Text
import Data.Dynamic

import Conferer.FromConfig

import Network.Wai.Handler.Warp
import Network.Wai.Handler.Warp.Internal

instance FromConfig HostPreference where
  fromConfig :: Key -> Config -> IO HostPreference
fromConfig = Key -> Config -> IO HostPreference
forall a. (Typeable a, IsString a) => Key -> Config -> IO a
fetchFromConfigByIsString

instance FromConfig ProxyProtocol where
  fromConfig :: Key -> Config -> IO ProxyProtocol
fromConfig = (Text -> Maybe ProxyProtocol) -> Key -> Config -> IO ProxyProtocol
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith ((Text -> Maybe ProxyProtocol)
 -> Key -> Config -> IO ProxyProtocol)
-> (Text -> Maybe ProxyProtocol)
-> Key
-> Config
-> IO ProxyProtocol
forall a b. (a -> b) -> a -> b
$
    (\case
      Text
"proxyprotocolnone" -> ProxyProtocol -> Maybe ProxyProtocol
forall a. a -> Maybe a
Just ProxyProtocol
ProxyProtocolNone
      Text
"none" -> ProxyProtocol -> Maybe ProxyProtocol
forall a. a -> Maybe a
Just ProxyProtocol
ProxyProtocolNone
      Text
"proxyprotocolrequired" -> ProxyProtocol -> Maybe ProxyProtocol
forall a. a -> Maybe a
Just ProxyProtocol
ProxyProtocolRequired
      Text
"required" -> ProxyProtocol -> Maybe ProxyProtocol
forall a. a -> Maybe a
Just ProxyProtocol
ProxyProtocolRequired
      Text
"proxyprotocoloptional" -> ProxyProtocol -> Maybe ProxyProtocol
forall a. a -> Maybe a
Just ProxyProtocol
ProxyProtocolOptional
      Text
"optional" -> ProxyProtocol -> Maybe ProxyProtocol
forall a. a -> Maybe a
Just ProxyProtocol
ProxyProtocolOptional
      Text
_ -> Maybe ProxyProtocol
forall a. Maybe a
Nothing
    ) (Text -> Maybe ProxyProtocol)
-> (Text -> Text) -> Text -> Maybe ProxyProtocol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toLower

instance DefaultConfig Settings where
  configDef :: Settings
configDef = Settings
defaultSettings

-- | Deconstruct a 'Settings' into a many key/dynamic pairs to
-- provide valid defaults for downstream 'fetchFromConfig'
deconstructSettingsToDefaults :: Settings -> [(Key, Dynamic)]
deconstructSettingsToDefaults :: Settings -> [(Key, Dynamic)]
deconstructSettingsToDefaults Settings{Bool
Int
Maybe Int
Maybe ByteString
Maybe Manager
IO ()
ByteString
HostPreference
ProxyProtocol
Maybe Request -> SomeException -> IO ()
IO () -> IO ()
SomeException -> Response
SockAddr -> IO Bool
SockAddr -> IO ()
Request -> ByteString -> Integer -> IO ()
Request -> Status -> Maybe Integer -> IO ()
((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsPort :: Settings -> Int
settingsHost :: Settings -> HostPreference
settingsOnException :: Settings -> Maybe Request -> SomeException -> IO ()
settingsOnExceptionResponse :: Settings -> SomeException -> Response
settingsOnOpen :: Settings -> SockAddr -> IO Bool
settingsOnClose :: Settings -> SockAddr -> IO ()
settingsTimeout :: Settings -> Int
settingsManager :: Settings -> Maybe Manager
settingsFdCacheDuration :: Settings -> Int
settingsFileInfoCacheDuration :: Settings -> Int
settingsBeforeMainLoop :: Settings -> IO ()
settingsFork :: Settings -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsNoParsePath :: Settings -> Bool
settingsInstallShutdownHandler :: Settings -> IO () -> IO ()
settingsServerName :: Settings -> ByteString
settingsMaximumBodyFlush :: Settings -> Maybe Int
settingsProxyProtocol :: Settings -> ProxyProtocol
settingsSlowlorisSize :: Settings -> Int
settingsHTTP2Enabled :: Settings -> Bool
settingsLogger :: Settings -> Request -> Status -> Maybe Integer -> IO ()
settingsServerPushLogger :: Settings -> Request -> ByteString -> Integer -> IO ()
settingsGracefulShutdownTimeout :: Settings -> Maybe Int
settingsGracefulCloseTimeout1 :: Settings -> Int
settingsGracefulCloseTimeout2 :: Settings -> Int
settingsMaxTotalHeaderLength :: Settings -> Int
settingsAltSvc :: Settings -> Maybe ByteString
settingsAltSvc :: Maybe ByteString
settingsMaxTotalHeaderLength :: Int
settingsGracefulCloseTimeout2 :: Int
settingsGracefulCloseTimeout1 :: Int
settingsGracefulShutdownTimeout :: Maybe Int
settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
settingsLogger :: Request -> Status -> Maybe Integer -> IO ()
settingsHTTP2Enabled :: Bool
settingsSlowlorisSize :: Int
settingsProxyProtocol :: ProxyProtocol
settingsMaximumBodyFlush :: Maybe Int
settingsServerName :: ByteString
settingsInstallShutdownHandler :: IO () -> IO ()
settingsNoParsePath :: Bool
settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsBeforeMainLoop :: IO ()
settingsFileInfoCacheDuration :: Int
settingsFdCacheDuration :: Int
settingsManager :: Maybe Manager
settingsTimeout :: Int
settingsOnClose :: SockAddr -> IO ()
settingsOnOpen :: SockAddr -> IO Bool
settingsOnExceptionResponse :: SomeException -> Response
settingsOnException :: Maybe Request -> SomeException -> IO ()
settingsHost :: HostPreference
settingsPort :: Int
..} =
  [ (Key
"port", Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
settingsPort)
  , (Key
"host", HostPreference -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn HostPreference
settingsHost)
  , (Key
"onException", (Maybe Request -> SomeException -> IO ()) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Request -> SomeException -> IO ()
settingsOnException)
  , (Key
"onExceptionResponse", (SomeException -> Response) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn SomeException -> Response
settingsOnExceptionResponse)
  , (Key
"onOpen", (SockAddr -> IO Bool) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn SockAddr -> IO Bool
settingsOnOpen)
  , (Key
"onClose", (SockAddr -> IO ()) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn SockAddr -> IO ()
settingsOnClose)
  , (Key
"timeout", Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
settingsTimeout)
  , (Key
"manager", Maybe Manager -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Manager
settingsManager)
  , (Key
"fdCacheDuration", Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
settingsFdCacheDuration)
  , (Key
"fileInfoCacheDuration", Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
settingsFileInfoCacheDuration)
  , (Key
"beforeMainLoop", IO () -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn IO ()
settingsBeforeMainLoop)
#if MIN_VERSION_warp(3,0,4)
  , (Key
"fork", ForkSettings -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (ForkSettings -> Dynamic) -> ForkSettings -> Dynamic
forall a b. (a -> b) -> a -> b
$ (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> ForkSettings
ForkSettings ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsFork)
#endif
#if MIN_VERSION_warp(2,0,3)
  , (Key
"noParsePath", Bool -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Bool
settingsNoParsePath)
#endif
#if MIN_VERSION_warp(3,0,1)
  , (Key
"installShutdownHandler", (IO () -> IO ()) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn IO () -> IO ()
settingsInstallShutdownHandler)
#endif
#if MIN_VERSION_warp(3,0,2)
  , (Key
"serverName", ByteString -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn ByteString
settingsServerName)
#endif
#if MIN_VERSION_warp(3,0,3)
  , (Key
"maximumBodyFlush", Maybe Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Int
settingsMaximumBodyFlush)
#endif
#if MIN_VERSION_warp(3,0,5)
  , (Key
"proxyProtocol", ProxyProtocol -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn ProxyProtocol
settingsProxyProtocol)
#endif
#if MIN_VERSION_warp(3,1,2)
  , (Key
"slowlorisSize", Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
settingsSlowlorisSize)
#endif
#if MIN_VERSION_warp(3,1,7)
  , (Key
"http2Enabled", Bool -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Bool
settingsHTTP2Enabled)
#endif
#if MIN_VERSION_warp(3,1,10)
  , (Key
"logger", (Request -> Status -> Maybe Integer -> IO ()) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Request -> Status -> Maybe Integer -> IO ()
settingsLogger)
#endif
#if MIN_VERSION_warp(3,2,7)
  , (Key
"serverPushLogger", (Request -> ByteString -> Integer -> IO ()) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Request -> ByteString -> Integer -> IO ()
settingsServerPushLogger)
#endif
#if MIN_VERSION_warp(3,2,8)
  , (Key
"gracefulShutdownTimeout", Maybe Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Int
settingsGracefulShutdownTimeout)
#endif
#if MIN_VERSION_warp(3,3,5)
  , (Key
"gracefulCloseTimeout1", Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
settingsGracefulCloseTimeout1)
  , (Key
"gracefulCloseTimeout2", Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
settingsGracefulCloseTimeout2)
#endif
#if MIN_VERSION_warp(3,3,8)
  , (Key
"maxTotalHeaderLength", Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
settingsMaxTotalHeaderLength)
#endif
#if MIN_VERSION_warp(3,3,11)
  , (Key
"altSvc", Maybe ByteString -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ByteString
settingsAltSvc)
#endif
  ]

-- | Newtype wrapper for the 'settingsFork' value that has too much polymorphism
-- to be typeable
newtype ForkSettings = ForkSettings (((forall a. IO a -> IO a) -> IO ()) -> IO ())

instance FromConfig Settings where
  fromConfig :: Key -> Config -> IO Settings
fromConfig Key
key Config
originalConfig = do
    Config
config <- (Settings -> [(Key, Dynamic)]) -> Key -> Config -> IO Config
forall a.
Typeable a =>
(a -> [(Key, Dynamic)]) -> Key -> Config -> IO Config
addDefaultsAfterDeconstructingToDefaults Settings -> [(Key, Dynamic)]
deconstructSettingsToDefaults Key
key Config
originalConfig
    Int
settingsPort <- Key -> Config -> IO Int
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"port") Config
config
    HostPreference
settingsHost <- Key -> Config -> IO HostPreference
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"host") Config
config
    Maybe Request -> SomeException -> IO ()
settingsOnException <- Key -> Config -> IO (Maybe Request -> SomeException -> IO ())
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"onException") Config
config
    SomeException -> Response
settingsOnExceptionResponse <- Key -> Config -> IO (SomeException -> Response)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"onExceptionResponse") Config
config
    SockAddr -> IO Bool
settingsOnOpen <- Key -> Config -> IO (SockAddr -> IO Bool)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"onOpen") Config
config
    SockAddr -> IO ()
settingsOnClose <- Key -> Config -> IO (SockAddr -> IO ())
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"onClose") Config
config
    Int
settingsTimeout <- Key -> Config -> IO Int
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"timeout") Config
config
    Maybe Manager
settingsManager <- Key -> Config -> IO (Maybe Manager)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"manager") Config
config
    Int
settingsFdCacheDuration <- Key -> Config -> IO Int
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"fdCacheDuration") Config
config
    Int
settingsFileInfoCacheDuration <- Key -> Config -> IO Int
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"fileInfoCacheDuration") Config
config
    IO ()
settingsBeforeMainLoop <- Key -> Config -> IO (IO ())
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"beforeMainLoop") Config
config
#if MIN_VERSION_warp(3,0,4)
    (ForkSettings ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsFork) <- Key -> Config -> IO ForkSettings
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"fork") Config
config
#endif
#if MIN_VERSION_warp(2,0,3)
    Bool
settingsNoParsePath <- Key -> Config -> IO Bool
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"noParsePath") Config
config
#endif
#if MIN_VERSION_warp(3,0,1)
    IO () -> IO ()
settingsInstallShutdownHandler <- Key -> Config -> IO (IO () -> IO ())
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"installShutdownHandler") Config
config
#endif
#if MIN_VERSION_warp(3,0,2)
    ByteString
settingsServerName <- Key -> Config -> IO ByteString
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"serverName") Config
config
#endif
#if MIN_VERSION_warp(3,0,3)
    Maybe Int
settingsMaximumBodyFlush <- Key -> Config -> IO (Maybe Int)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"maximumBodyFlush") Config
config
#endif
#if MIN_VERSION_warp(3,0,5)
    ProxyProtocol
settingsProxyProtocol <- Key -> Config -> IO ProxyProtocol
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"proxyProtocol") Config
config
#endif
#if MIN_VERSION_warp(3,1,2)
    Int
settingsSlowlorisSize <- Key -> Config -> IO Int
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"slowlorisSize") Config
config
#endif
#if MIN_VERSION_warp(3,1,7)
    Bool
settingsHTTP2Enabled <- Key -> Config -> IO Bool
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"http2Enabled") Config
config
#endif
#if MIN_VERSION_warp(3,1,10)
    Request -> Status -> Maybe Integer -> IO ()
settingsLogger <- Key -> Config -> IO (Request -> Status -> Maybe Integer -> IO ())
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"logger") Config
config
#endif
#if MIN_VERSION_warp(3,2,7)
    Request -> ByteString -> Integer -> IO ()
settingsServerPushLogger <- Key -> Config -> IO (Request -> ByteString -> Integer -> IO ())
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"serverPushLogger") Config
config
#endif
#if MIN_VERSION_warp(3,2,8)
    Maybe Int
settingsGracefulShutdownTimeout <- Key -> Config -> IO (Maybe Int)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"gracefulShutdownTimeout") Config
config
#endif
#if MIN_VERSION_warp(3,3,5)
    Int
settingsGracefulCloseTimeout1 <- Key -> Config -> IO Int
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"gracefulCloseTimeout1") Config
config
    Int
settingsGracefulCloseTimeout2 <- Key -> Config -> IO Int
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"gracefulCloseTimeout2") Config
config
#endif
#if MIN_VERSION_warp(3,3,8)
    Int
settingsMaxTotalHeaderLength <- Key -> Config -> IO Int
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"maxTotalHeaderLength") Config
config
#endif
#if MIN_VERSION_warp(3,3,11)
    Maybe ByteString
settingsAltSvc <- Key -> Config -> IO (Maybe ByteString)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"altSvc") Config
config
#endif
    Settings -> IO Settings
forall (m :: * -> *) a. Monad m => a -> m a
return Settings :: Int
-> HostPreference
-> (Maybe Request -> SomeException -> IO ())
-> (SomeException -> Response)
-> (SockAddr -> IO Bool)
-> (SockAddr -> IO ())
-> Int
-> Maybe Manager
-> Int
-> Int
-> IO ()
-> (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> Bool
-> (IO () -> IO ())
-> ByteString
-> Maybe Int
-> ProxyProtocol
-> Int
-> Bool
-> (Request -> Status -> Maybe Integer -> IO ())
-> (Request -> ByteString -> Integer -> IO ())
-> Maybe Int
-> Int
-> Int
-> Int
-> Maybe ByteString
-> Settings
Settings{Bool
Int
Maybe Int
Maybe ByteString
Maybe Manager
IO ()
ByteString
HostPreference
ProxyProtocol
Maybe Request -> SomeException -> IO ()
IO () -> IO ()
SomeException -> Response
SockAddr -> IO Bool
SockAddr -> IO ()
Request -> ByteString -> Integer -> IO ()
Request -> Status -> Maybe Integer -> IO ()
((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsAltSvc :: Maybe ByteString
settingsMaxTotalHeaderLength :: Int
settingsGracefulCloseTimeout2 :: Int
settingsGracefulCloseTimeout1 :: Int
settingsGracefulShutdownTimeout :: Maybe Int
settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
settingsLogger :: Request -> Status -> Maybe Integer -> IO ()
settingsHTTP2Enabled :: Bool
settingsSlowlorisSize :: Int
settingsProxyProtocol :: ProxyProtocol
settingsMaximumBodyFlush :: Maybe Int
settingsServerName :: ByteString
settingsInstallShutdownHandler :: IO () -> IO ()
settingsNoParsePath :: Bool
settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsBeforeMainLoop :: IO ()
settingsFileInfoCacheDuration :: Int
settingsFdCacheDuration :: Int
settingsManager :: Maybe Manager
settingsTimeout :: Int
settingsOnClose :: SockAddr -> IO ()
settingsOnOpen :: SockAddr -> IO Bool
settingsOnExceptionResponse :: SomeException -> Response
settingsOnException :: Maybe Request -> SomeException -> IO ()
settingsHost :: HostPreference
settingsPort :: Int
settingsPort :: Int
settingsHost :: HostPreference
settingsOnException :: Maybe Request -> SomeException -> IO ()
settingsOnExceptionResponse :: SomeException -> Response
settingsOnOpen :: SockAddr -> IO Bool
settingsOnClose :: SockAddr -> IO ()
settingsTimeout :: Int
settingsManager :: Maybe Manager
settingsFdCacheDuration :: Int
settingsFileInfoCacheDuration :: Int
settingsBeforeMainLoop :: IO ()
settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsNoParsePath :: Bool
settingsInstallShutdownHandler :: IO () -> IO ()
settingsServerName :: ByteString
settingsMaximumBodyFlush :: Maybe Int
settingsProxyProtocol :: ProxyProtocol
settingsSlowlorisSize :: Int
settingsHTTP2Enabled :: Bool
settingsLogger :: Request -> Status -> Maybe Integer -> IO ()
settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
settingsGracefulShutdownTimeout :: Maybe Int
settingsGracefulCloseTimeout1 :: Int
settingsGracefulCloseTimeout2 :: Int
settingsMaxTotalHeaderLength :: Int
settingsAltSvc :: Maybe ByteString
..}