{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Conferer.FromConfig.Snap where
import Conferer.FromConfig
import Data.Data (Typeable)
import Data.Dynamic (toDyn, Dynamic)
import Data.Text (unpack, toLower)
import qualified Snap.Core as Snap
import qualified Snap.Http.Server.Config as Snap
import qualified Snap.Internal.Http.Server.Config as Snap
instance FromConfig Snap.ConfigLog where
fetchFromConfig :: Key -> Config -> IO ConfigLog
fetchFromConfig =
(Text -> Maybe ConfigLog) -> Key -> Config -> IO ConfigLog
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith ((Text -> Maybe ConfigLog) -> Key -> Config -> IO ConfigLog)
-> (Text -> Maybe ConfigLog) -> Key -> Config -> IO ConfigLog
forall a b. (a -> b) -> a -> b
$
(\case
Text
"nolog" -> ConfigLog -> Maybe ConfigLog
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigLog
Snap.ConfigNoLog
Text
"none" -> ConfigLog -> Maybe ConfigLog
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigLog
Snap.ConfigNoLog
Text
"no" -> ConfigLog -> Maybe ConfigLog
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigLog
Snap.ConfigNoLog
Text
"false" -> ConfigLog -> Maybe ConfigLog
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigLog
Snap.ConfigNoLog
Text
t -> ConfigLog -> Maybe ConfigLog
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfigLog -> Maybe ConfigLog) -> ConfigLog -> Maybe ConfigLog
forall a b. (a -> b) -> a -> b
$ FilePath -> ConfigLog
Snap.ConfigFileLog (FilePath -> ConfigLog) -> FilePath -> ConfigLog
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
unpack Text
t
) (Text -> Maybe ConfigLog)
-> (Text -> Text) -> Text -> Maybe ConfigLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toLower
instance FromConfig Snap.ProxyType where
fetchFromConfig :: Key -> Config -> IO ProxyType
fetchFromConfig =
(Text -> Maybe ProxyType) -> Key -> Config -> IO ProxyType
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith ((Text -> Maybe ProxyType) -> Key -> Config -> IO ProxyType)
-> (Text -> Maybe ProxyType) -> Key -> Config -> IO ProxyType
forall a b. (a -> b) -> a -> b
$
(\case
Text
"noproxy" -> ProxyType -> Maybe ProxyType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyType
Snap.NoProxy
Text
"none" -> ProxyType -> Maybe ProxyType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyType
Snap.NoProxy
Text
"false" -> ProxyType -> Maybe ProxyType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyType
Snap.NoProxy
Text
"haproxy" -> ProxyType -> Maybe ProxyType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyType
Snap.HaProxy
Text
"ha" -> ProxyType -> Maybe ProxyType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyType
Snap.HaProxy
Text
"xforwardedfor" -> ProxyType -> Maybe ProxyType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyType
Snap.X_Forwarded_For
Text
"forwarded" -> ProxyType -> Maybe ProxyType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyType
Snap.X_Forwarded_For
Text
"x-forwarded-for" -> ProxyType -> Maybe ProxyType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyType
Snap.X_Forwarded_For
Text
"x_forwarded_for" -> ProxyType -> Maybe ProxyType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyType
Snap.X_Forwarded_For
Text
_ -> Maybe ProxyType
forall a. Maybe a
Nothing
) (Text -> Maybe ProxyType)
-> (Text -> Text) -> Text -> Maybe ProxyType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toLower
instance (Snap.MonadSnap m) => DefaultConfig (Snap.Config m a) where
configDef :: Config m a
configDef = Config m a
forall (m :: * -> *) a. MonadSnap m => Config m a
Snap.defaultConfig
desconstructSnapConfigToDefaults :: (Typeable a, Typeable m) => Snap.Config m a -> [(Key, Dynamic)]
desconstructSnapConfigToDefaults :: Config m a -> [(Key, Dynamic)]
desconstructSnapConfigToDefaults Snap.Config{Maybe a
Maybe Bool
Maybe Int
Maybe FilePath
Maybe ByteString
Maybe ProxyType
Maybe ConfigLog
Maybe (SomeException -> m ())
Maybe (StartupInfo m a -> IO ())
hostname :: forall (m :: * -> *) a. Config m a -> Maybe ByteString
accessLog :: forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
errorLog :: forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
locale :: forall (m :: * -> *) a. Config m a -> Maybe FilePath
port :: forall (m :: * -> *) a. Config m a -> Maybe Int
bind :: forall (m :: * -> *) a. Config m a -> Maybe ByteString
sslport :: forall (m :: * -> *) a. Config m a -> Maybe Int
sslbind :: forall (m :: * -> *) a. Config m a -> Maybe ByteString
sslcert :: forall (m :: * -> *) a. Config m a -> Maybe FilePath
sslchaincert :: forall (m :: * -> *) a. Config m a -> Maybe Bool
sslkey :: forall (m :: * -> *) a. Config m a -> Maybe FilePath
unixsocket :: forall (m :: * -> *) a. Config m a -> Maybe FilePath
unixaccessmode :: forall (m :: * -> *) a. Config m a -> Maybe Int
compression :: forall (m :: * -> *) a. Config m a -> Maybe Bool
verbose :: forall (m :: * -> *) a. Config m a -> Maybe Bool
errorHandler :: forall (m :: * -> *) a. Config m a -> Maybe (SomeException -> m ())
defaultTimeout :: forall (m :: * -> *) a. Config m a -> Maybe Int
other :: forall (m :: * -> *) a. Config m a -> Maybe a
proxyType :: forall (m :: * -> *) a. Config m a -> Maybe ProxyType
startupHook :: forall (m :: * -> *) a.
Config m a -> Maybe (StartupInfo m a -> IO ())
startupHook :: Maybe (StartupInfo m a -> IO ())
proxyType :: Maybe ProxyType
other :: Maybe a
defaultTimeout :: Maybe Int
errorHandler :: Maybe (SomeException -> m ())
verbose :: Maybe Bool
compression :: Maybe Bool
unixaccessmode :: Maybe Int
unixsocket :: Maybe FilePath
sslkey :: Maybe FilePath
sslchaincert :: Maybe Bool
sslcert :: Maybe FilePath
sslbind :: Maybe ByteString
sslport :: Maybe Int
bind :: Maybe ByteString
port :: Maybe Int
locale :: Maybe FilePath
errorLog :: Maybe ConfigLog
accessLog :: Maybe ConfigLog
hostname :: Maybe ByteString
..} =
[ (Key
"defaultTimeout", Maybe Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Int
defaultTimeout)
, (Key
"accessLog", Maybe ConfigLog -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ConfigLog
accessLog)
, (Key
"bind", Maybe ByteString -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ByteString
bind)
, (Key
"compression", Maybe Bool -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Bool
compression)
, (Key
"errorLog", Maybe ConfigLog -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ConfigLog
errorLog)
, (Key
"hostname", Maybe ByteString -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ByteString
hostname)
, (Key
"locale", Maybe FilePath -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe FilePath
locale)
, (Key
"port", Maybe Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Int
port)
, (Key
"proxyType", Maybe ProxyType -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ProxyType
proxyType)
, (Key
"sslBind", Maybe ByteString -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ByteString
sslbind)
, (Key
"sslCert", Maybe FilePath -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe FilePath
sslcert)
, (Key
"sslKey", Maybe FilePath -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe FilePath
sslkey)
, (Key
"sslChainCert", Maybe Bool -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Bool
sslchaincert)
, (Key
"sslPort", Maybe Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Int
sslport)
, (Key
"verbose", Maybe Bool -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Bool
verbose)
, (Key
"unixSocket", Maybe FilePath -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe FilePath
unixsocket)
, (Key
"unixSocketAccessMode", Maybe Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe Int
unixaccessmode)
, (Key
"errorHandler", Maybe (SomeException -> m ()) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe (SomeException -> m ())
errorHandler)
, (Key
"startupHook", Maybe (StartupInfo m a -> IO ()) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe (StartupInfo m a -> IO ())
startupHook)
, (Key
"other", Maybe a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe a
other)
]
instance forall a m. (FromConfig a, Typeable a, Snap.MonadSnap m, Typeable m) => FromConfig (Snap.Config m a) where
fetchFromConfig :: Key -> Config -> IO (Config m a)
fetchFromConfig Key
key Config
originalConfig = do
Config
config <- (Config m a -> [(Key, Dynamic)]) -> Key -> Config -> IO Config
forall a.
Typeable a =>
(a -> [(Key, Dynamic)]) -> Key -> Config -> IO Config
addDefaultsAfterDeconstructingToDefaults
(Config m a -> [(Key, Dynamic)]
forall a (m :: * -> *).
(Typeable a, Typeable m) =>
Config m a -> [(Key, Dynamic)]
desconstructSnapConfigToDefaults :: Snap.Config m a -> [(Key, Dynamic)])
Key
key Config
originalConfig
Maybe Int
defaultTimeout <- Key -> Config -> IO (Maybe Int)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"defaultTimeout") Config
config
Maybe ConfigLog
accessLog <- Key -> Config -> IO (Maybe ConfigLog)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"accessLog") Config
config
Maybe ByteString
bind <- Key -> Config -> IO (Maybe ByteString)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"bind") Config
config
Maybe Bool
compression <- Key -> Config -> IO (Maybe Bool)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"compression") Config
config
Maybe ConfigLog
errorLog <- Key -> Config -> IO (Maybe ConfigLog)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"errorLog") Config
config
Maybe ByteString
hostname <- Key -> Config -> IO (Maybe ByteString)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"hostname") Config
config
Maybe FilePath
locale <- Key -> Config -> IO (Maybe FilePath)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"locale") Config
config
Maybe Int
port <- Key -> Config -> IO (Maybe Int)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"port") Config
config
Maybe ProxyType
proxyType <- Key -> Config -> IO (Maybe ProxyType)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"proxyType") Config
config
Maybe ByteString
sslbind <- Key -> Config -> IO (Maybe ByteString)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"sslBind") Config
config
Maybe FilePath
sslcert <- Key -> Config -> IO (Maybe FilePath)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"sslCert") Config
config
Maybe FilePath
sslkey <- Key -> Config -> IO (Maybe FilePath)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"sslKey") Config
config
Maybe Bool
sslchaincert <- Key -> Config -> IO (Maybe Bool)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"sslChainCert") Config
config
Maybe Int
sslport <- Key -> Config -> IO (Maybe Int)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"sslPort") Config
config
Maybe Bool
verbose <- Key -> Config -> IO (Maybe Bool)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"verbose") Config
config
Maybe FilePath
unixsocket <- Key -> Config -> IO (Maybe FilePath)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"unixSocket") Config
config
Maybe Int
unixaccessmode <- Key -> Config -> IO (Maybe Int)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"unixSocketAccessMode") Config
config
Maybe (SomeException -> m ())
errorHandler <- Key -> Config -> IO (Maybe (SomeException -> m ()))
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"errorHandler") Config
config
Maybe (StartupInfo m a -> IO ())
startupHook <- Key -> Config -> IO (Maybe (StartupInfo m a -> IO ()))
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"startupHook") Config
config
Maybe a
other <- Key -> Config -> IO (Maybe a)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @(Maybe a) (Key
key Key -> Key -> Key
/. Key
"other") Config
config
Config m a -> IO (Config m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config :: forall (m :: * -> *) a.
Maybe ByteString
-> Maybe ConfigLog
-> Maybe ConfigLog
-> Maybe FilePath
-> Maybe Int
-> Maybe ByteString
-> Maybe Int
-> Maybe ByteString
-> Maybe FilePath
-> Maybe Bool
-> Maybe FilePath
-> Maybe FilePath
-> Maybe Int
-> Maybe Bool
-> Maybe Bool
-> Maybe (SomeException -> m ())
-> Maybe Int
-> Maybe a
-> Maybe ProxyType
-> Maybe (StartupInfo m a -> IO ())
-> Config m a
Snap.Config{Maybe a
Maybe Bool
Maybe Int
Maybe FilePath
Maybe ByteString
Maybe ProxyType
Maybe ConfigLog
Maybe (SomeException -> m ())
Maybe (StartupInfo m a -> IO ())
other :: Maybe a
startupHook :: Maybe (StartupInfo m a -> IO ())
errorHandler :: Maybe (SomeException -> m ())
unixaccessmode :: Maybe Int
unixsocket :: Maybe FilePath
verbose :: Maybe Bool
sslport :: Maybe Int
sslchaincert :: Maybe Bool
sslkey :: Maybe FilePath
sslcert :: Maybe FilePath
sslbind :: Maybe ByteString
proxyType :: Maybe ProxyType
port :: Maybe Int
locale :: Maybe FilePath
hostname :: Maybe ByteString
errorLog :: Maybe ConfigLog
compression :: Maybe Bool
bind :: Maybe ByteString
accessLog :: Maybe ConfigLog
defaultTimeout :: Maybe Int
hostname :: Maybe ByteString
accessLog :: Maybe ConfigLog
errorLog :: Maybe ConfigLog
locale :: Maybe FilePath
port :: Maybe Int
bind :: Maybe ByteString
sslport :: Maybe Int
sslbind :: Maybe ByteString
sslcert :: Maybe FilePath
sslchaincert :: Maybe Bool
sslkey :: Maybe FilePath
unixsocket :: Maybe FilePath
unixaccessmode :: Maybe Int
compression :: Maybe Bool
verbose :: Maybe Bool
errorHandler :: Maybe (SomeException -> m ())
defaultTimeout :: Maybe Int
other :: Maybe a
proxyType :: Maybe ProxyType
startupHook :: Maybe (StartupInfo m a -> IO ())
..}