-- |
-- Copyright: (c) 2019 Lucas David Traverso
-- License: MPL-2.0
-- Maintainer: Lucas David Traverso <lucas6246@gmail.com>
-- Stability: stable
-- Portability: portable
--
-- FromConfig instance for snap
{-# 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

-- | Deconstruct a 'Snap.Config' into a many key/dynamic pairs to
-- provide valid defaults for downstream 'fetchFromConfig'
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 ())
..}