{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Snap.Snaplet.Config where
import Data.Function (on)
import Data.Maybe (fromMaybe)
import Data.Monoid (Last(..), getLast)
#if MIN_VERSION_base(4,10,0)
import Data.Typeable (Typeable)
#elif MIN_VERSION_base(4,7,0)
import Data.Typeable.Internal (Typeable)
#else
import Data.Typeable (Typeable, TyCon, mkTyCon,
mkTyConApp, typeOf)
#endif
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid, mappend, mempty)
#endif
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup(..))
#endif
import System.Console.GetOpt (OptDescr(Option), ArgDescr(ReqArg))
import Snap.Core
import Snap.Http.Server.Config (Config, fmapOpt, setOther, getOther, optDescrs
,extendedCommandLineConfig)
newtype AppConfig = AppConfig { AppConfig -> Maybe String
appEnvironment :: Maybe String }
#if MIN_VERSION_base(4,7,0)
deriving Typeable
#else
appConfigTyCon :: TyCon
appConfigTyCon = mkTyCon "Snap.Snaplet.Config.AppConfig"
{-# NOINLINE appConfigTyCon #-}
instance Typeable AppConfig where
typeOf _ = mkTyConApp appConfigTyCon []
#endif
instance Semigroup AppConfig where
a :: AppConfig
a <> :: AppConfig -> AppConfig -> AppConfig
<> b :: AppConfig
b = AppConfig :: Maybe String -> AppConfig
AppConfig
{ appEnvironment :: Maybe String
appEnvironment = (AppConfig -> Maybe String)
-> AppConfig -> AppConfig -> Maybe String
forall a a. (a -> Maybe a) -> a -> a -> Maybe a
ov AppConfig -> Maybe String
appEnvironment AppConfig
a AppConfig
b
}
where
ov :: (a -> Maybe a) -> a -> a -> Maybe a
ov f :: a -> Maybe a
f x :: a
x y :: a
y = Last a -> Maybe a
forall a. Last a -> Maybe a
getLast (Last a -> Maybe a) -> Last a -> Maybe a
forall a b. (a -> b) -> a -> b
$! (Last a -> Last a -> Last a
forall a. Semigroup a => a -> a -> a
(<>) (Last a -> Last a -> Last a) -> (a -> Last a) -> a -> a -> Last a
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Maybe a -> Last a
forall a. Maybe a -> Last a
Last (Maybe a -> Last a) -> (a -> Maybe a) -> a -> Last a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
f)) a
x a
y
instance Monoid AppConfig where
mempty :: AppConfig
mempty = Maybe String -> AppConfig
AppConfig Maybe String
forall a. Maybe a
Nothing
#if !MIN_VERSION_base(4,11,0)
mappend = (<>)
#endif
appOpts :: AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
appOpts :: AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
appOpts defaults :: AppConfig
defaults = (OptDescr (Maybe AppConfig)
-> OptDescr (Maybe (Config m AppConfig)))
-> [OptDescr (Maybe AppConfig)]
-> [OptDescr (Maybe (Config m AppConfig))]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe AppConfig -> Maybe (Config m AppConfig))
-> OptDescr (Maybe AppConfig)
-> OptDescr (Maybe (Config m AppConfig))
forall a b. (a -> b) -> OptDescr a -> OptDescr b
fmapOpt ((Maybe AppConfig -> Maybe (Config m AppConfig))
-> OptDescr (Maybe AppConfig)
-> OptDescr (Maybe (Config m AppConfig)))
-> (Maybe AppConfig -> Maybe (Config m AppConfig))
-> OptDescr (Maybe AppConfig)
-> OptDescr (Maybe (Config m AppConfig))
forall a b. (a -> b) -> a -> b
$ (AppConfig -> Config m AppConfig)
-> Maybe AppConfig -> Maybe (Config m AppConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AppConfig -> Config m AppConfig -> Config m AppConfig)
-> Config m AppConfig -> AppConfig -> Config m AppConfig
forall a b c. (a -> b -> c) -> b -> a -> c
flip AppConfig -> Config m AppConfig -> Config m AppConfig
forall a (m :: * -> *). a -> Config m a -> Config m a
setOther Config m AppConfig
forall a. Monoid a => a
mempty))
[ String
-> [String]
-> ArgDescr (Maybe AppConfig)
-> String
-> OptDescr (Maybe AppConfig)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option ['e'] ["environment"]
((String -> Maybe AppConfig) -> String -> ArgDescr (Maybe AppConfig)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Maybe AppConfig
setter "ENVIRONMENT")
(String -> OptDescr (Maybe AppConfig))
-> String -> OptDescr (Maybe AppConfig)
forall a b. (a -> b) -> a -> b
$ "runtime environment to use" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (AppConfig -> Maybe String) -> String
defaultC AppConfig -> Maybe String
appEnvironment
]
where
setter :: String -> Maybe AppConfig
setter s :: String
s = AppConfig -> Maybe AppConfig
forall a. a -> Maybe a
Just (AppConfig -> Maybe AppConfig) -> AppConfig -> Maybe AppConfig
forall a b. (a -> b) -> a -> b
$ AppConfig
forall a. Monoid a => a
mempty { appEnvironment :: Maybe String
appEnvironment = String -> Maybe String
forall a. a -> Maybe a
Just String
s}
defaultC :: (AppConfig -> Maybe String) -> String
defaultC f :: AppConfig -> Maybe String
f = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ((", default " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ AppConfig -> Maybe String
f AppConfig
defaults
commandLineAppConfig :: MonadSnap m
=> Config m AppConfig
-> IO (Config m AppConfig)
commandLineAppConfig :: Config m AppConfig -> IO (Config m AppConfig)
commandLineAppConfig defaults :: Config m AppConfig
defaults =
[OptDescr (Maybe (Config m AppConfig))]
-> (AppConfig -> AppConfig -> AppConfig)
-> Config m AppConfig
-> IO (Config m AppConfig)
forall (m :: * -> *) a.
MonadSnap m =>
[OptDescr (Maybe (Config m a))]
-> (a -> a -> a) -> Config m a -> IO (Config m a)
extendedCommandLineConfig (AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
forall (m :: * -> *).
AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
appOpts AppConfig
appDefaults [OptDescr (Maybe (Config m AppConfig))]
-> [OptDescr (Maybe (Config m AppConfig))]
-> [OptDescr (Maybe (Config m AppConfig))]
forall a. [a] -> [a] -> [a]
++ Config m AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> [OptDescr (Maybe (Config m a))]
optDescrs Config m AppConfig
defaults)
AppConfig -> AppConfig -> AppConfig
forall a. Monoid a => a -> a -> a
mappend Config m AppConfig
defaults
where
appDefaults :: AppConfig
appDefaults = AppConfig -> Maybe AppConfig -> AppConfig
forall a. a -> Maybe a -> a
fromMaybe AppConfig
forall a. Monoid a => a
mempty (Maybe AppConfig -> AppConfig) -> Maybe AppConfig -> AppConfig
forall a b. (a -> b) -> a -> b
$ Config m AppConfig -> Maybe AppConfig
forall (m :: * -> *) a. Config m a -> Maybe a
getOther Config m AppConfig
defaults