{-# 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)


------------------------------------------------------------------------------
-- | AppConfig contains the config options for command line arguments in
-- snaplet-based apps.
newtype AppConfig = AppConfig { AppConfig -> Maybe String
appEnvironment :: Maybe String }
#if MIN_VERSION_base(4,7,0)
  deriving Typeable
#else

------------------------------------------------------------------------------
-- | AppConfig has a manual instance of Typeable due to limitations in the
-- tools available before GHC 7.4, and the need to make dynamic loading
-- tractable.  When support for earlier versions of GHC is dropped, the
-- dynamic loader package can be updated so that manual Typeable instances
-- are no longer needed.
appConfigTyCon :: TyCon
appConfigTyCon = mkTyCon "Snap.Snaplet.Config.AppConfig"
{-# NOINLINE appConfigTyCon #-}

instance Typeable AppConfig where
    typeOf _ = mkTyConApp appConfigTyCon []
#endif

instance Semigroup AppConfig where
    AppConfig
a <> :: AppConfig -> AppConfig -> AppConfig
<> AppConfig
b = 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 a -> Maybe a
f a
x 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


------------------------------------------------------------------------------
-- | Command line options for snaplet applications.
appOpts :: AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
appOpts :: forall (m :: * -> *).
AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
appOpts 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 a b. (a -> b) -> Maybe a -> Maybe b
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 [Char
'e'] [String
"environment"]
             ((String -> Maybe AppConfig) -> String -> ArgDescr (Maybe AppConfig)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Maybe AppConfig
setter String
"ENVIRONMENT")
             (String -> OptDescr (Maybe AppConfig))
-> String -> OptDescr (Maybe AppConfig)
forall a b. (a -> b) -> a -> b
$ String
"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 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 AppConfig -> Maybe String
f = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((String
", 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


------------------------------------------------------------------------------
-- | Calls snap-server's extendedCommandLineConfig to add snaplet options to
-- the built-in server command line options.
commandLineAppConfig :: MonadSnap m
                     => Config m AppConfig
                     -> IO (Config m AppConfig)
commandLineAppConfig :: forall (m :: * -> *).
MonadSnap m =>
Config m AppConfig -> IO (Config m AppConfig)
commandLineAppConfig 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