{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
------------------------------------------------------------------------------
-- | This module exports the 'Config' datatype, which you can use to configure
-- the Snap HTTP server.
--
module Snap.Internal.Http.Server.Config
  -- NOTE: also edit Snap.Http.Server.Config if you change these
  ( ConfigLog(..)
  , Config(..)
  , ProxyType(..)

  , emptyConfig
  , defaultConfig

  , commandLineConfig
  , extendedCommandLineConfig
  , completeConfig

  , optDescrs
  , fmapOpt

  , getAccessLog
  , getBind
  , getCompression
  , getDefaultTimeout
  , getErrorHandler
  , getErrorLog
  , getHostname
  , getLocale
  , getOther
  , getPort
  , getProxyType
  , getSSLBind
  , getSSLCert
  , getSSLChainCert
  , getSSLKey
  , getSSLPort
  , getVerbose
  , getStartupHook
  , getUnixSocket
  , getUnixSocketAccessMode

  , setAccessLog
  , setBind
  , setCompression
  , setDefaultTimeout
  , setErrorHandler
  , setErrorLog
  , setHostname
  , setLocale
  , setOther
  , setPort
  , setProxyType
  , setSSLBind
  , setSSLCert
  , setSSLChainCert
  , setSSLKey
  , setSSLPort
  , setVerbose
  , setUnixSocket
  , setUnixSocketAccessMode

  , setStartupHook

  , StartupInfo(..)
  , getStartupSockets
  , getStartupConfig

  -- * Private
  , emptyStartupInfo
  , setStartupSockets
  , setStartupConfig
  ) where

------------------------------------------------------------------------------
import           Control.Exception          (SomeException)
import           Control.Monad              (when)
import           Data.Bits                  ((.&.))
import           Data.ByteString            (ByteString)
import qualified Data.ByteString.Char8      as S
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.CaseInsensitive       as CI
import           Data.Function              (on)
import           Data.List                  (foldl')
import qualified Data.Map                   as Map
import           Data.Maybe                 (isJust, isNothing)
#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid                (Monoid (..))
#endif
import           Data.Monoid                (Last (Last, getLast))
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup             (Semigroup (..))
#endif
import qualified Data.Text                  as T
import qualified Data.Text.Encoding         as T
#if MIN_VERSION_base(4,7,0)
import           Data.Typeable              (Typeable)
#else
import           Data.Typeable              (TyCon, Typeable, Typeable1 (..), mkTyCon3, mkTyConApp)
#endif
import           Network.Socket             (Socket)
import           Numeric                    (readOct, showOct)
#if !MIN_VERSION_base(4,6,0)
import           Prelude                    hiding (catch)
#endif
import           System.Console.GetOpt      (ArgDescr (..), ArgOrder (Permute), OptDescr (..), getOpt, usageInfo)
import           System.Environment         hiding (getEnv)
#ifndef PORTABLE
import           Data.Char                  (isAlpha)
import           System.Posix.Env           (getEnv)
#endif
import           System.Exit                (exitFailure)
import           System.IO                  (hPutStrLn, stderr)
------------------------------------------------------------------------------
import           Data.ByteString.Builder    (Builder, byteString, stringUtf8, toLazyByteString)
import qualified System.IO.Streams          as Streams
------------------------------------------------------------------------------
import           Snap.Core                  (MonadSnap, Request (rqClientAddr, rqClientPort, rqParams, rqPostParams), emptyResponse, finishWith, getsRequest, logError, setContentLength, setContentType, setResponseBody, setResponseStatus)
import           Snap.Internal.Debug        (debug)


------------------------------------------------------------------------------
-- | FIXME
--
-- Note: this type changed in snap-server 1.0.0.0.
data ProxyType = NoProxy
               | HaProxy
               | X_Forwarded_For
  deriving (Int -> ProxyType -> ShowS
[ProxyType] -> ShowS
ProxyType -> String
(Int -> ProxyType -> ShowS)
-> (ProxyType -> String)
-> ([ProxyType] -> ShowS)
-> Show ProxyType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProxyType] -> ShowS
$cshowList :: [ProxyType] -> ShowS
show :: ProxyType -> String
$cshow :: ProxyType -> String
showsPrec :: Int -> ProxyType -> ShowS
$cshowsPrec :: Int -> ProxyType -> ShowS
Show, ProxyType -> ProxyType -> Bool
(ProxyType -> ProxyType -> Bool)
-> (ProxyType -> ProxyType -> Bool) -> Eq ProxyType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProxyType -> ProxyType -> Bool
$c/= :: ProxyType -> ProxyType -> Bool
== :: ProxyType -> ProxyType -> Bool
$c== :: ProxyType -> ProxyType -> Bool
Eq, Typeable)

------------------------------------------------------------------------------
-- | Data type representing the configuration of a logging target
data ConfigLog = ConfigNoLog                        -- ^ no logging
               | ConfigFileLog FilePath             -- ^ log to text file
               | ConfigIoLog (ByteString -> IO ())  -- ^ log custom IO handler

instance Show ConfigLog where
    show :: ConfigLog -> String
show ConfigLog
ConfigNoLog       = String
"no log"
    show (ConfigFileLog String
f) = String
"log to file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
f
    show (ConfigIoLog ByteString -> IO ()
_)   = String
"custom logging handler"


------------------------------------------------------------------------------
-- We should be using ServerConfig here. There needs to be a clearer
-- separation between:
--
--   * what the underlying code needs to configure itself
--
--   * what the command-line processing does.
--
-- The latter will provide "library" helper functions that operate on
-- ServerConfig/etc in order to allow users to configure their own environment.
--
--
-- Todo:
--
--  * need a function ::
--      CommandLineConfig -> IO [(ServerConfig hookState, AcceptFunc)]
--
--       this will prep for another function that will spawn all of the
--       accept loops with httpAcceptLoop.
--
--  * all backends provide "Some -> Foo -> Config -> IO AcceptFunc"
--
--  * add support for socket activation to command line, or delegate to
--    different library? It's linux-only anyways, need to ifdef. It would be
--    silly to depend on the socket-activation library for that one little
--    function.
--
--  * break config into multiple modules:
--
--     * everything that modifies the snap handler (compression, proxy
--       settings, error handler)
--
--     * everything that directly modifies server settings (hostname /
--       defaultTimeout / hooks / etc)
--
--     * everything that configures backends (port/bind/ssl*)
--
--     * everything that handles command line stuff
--
--     * utility stuff
--
-- Cruft that definitely must be removed:
--
--  * ConfigLog -- this becomes a binary option on the command-line side (no
--    logging or yes, to this file), but the ConfigIoLog gets zapped
--    altogether.

------------------------------------------------------------------------------
-- | A record type which represents partial configurations (for 'httpServe')
-- by wrapping all of its fields in a 'Maybe'. Values of this type are usually
-- constructed via its 'Monoid' instance by doing something like:
--
-- > setPort 1234 mempty
--
-- Any fields which are unspecified in the 'Config' passed to 'httpServe' (and
-- this is the norm) are filled in with default values from 'defaultConfig'.
data Config m a = Config
    { Config m a -> Maybe ByteString
hostname       :: Maybe ByteString
    , Config m a -> Maybe ConfigLog
accessLog      :: Maybe ConfigLog
    , Config m a -> Maybe ConfigLog
errorLog       :: Maybe ConfigLog
    , Config m a -> Maybe String
locale         :: Maybe String
    , Config m a -> Maybe Int
port           :: Maybe Int
    , Config m a -> Maybe ByteString
bind           :: Maybe ByteString
    , Config m a -> Maybe Int
sslport        :: Maybe Int
    , Config m a -> Maybe ByteString
sslbind        :: Maybe ByteString
    , Config m a -> Maybe String
sslcert        :: Maybe FilePath
    , Config m a -> Maybe Bool
sslchaincert   :: Maybe Bool
    , Config m a -> Maybe String
sslkey         :: Maybe FilePath
    , Config m a -> Maybe String
unixsocket     :: Maybe FilePath
    , Config m a -> Maybe Int
unixaccessmode :: Maybe Int
    , Config m a -> Maybe Bool
compression    :: Maybe Bool
    , Config m a -> Maybe Bool
verbose        :: Maybe Bool
    , Config m a -> Maybe (SomeException -> m ())
errorHandler   :: Maybe (SomeException -> m ())
    , Config m a -> Maybe Int
defaultTimeout :: Maybe Int
    , Config m a -> Maybe a
other          :: Maybe a
    , Config m a -> Maybe ProxyType
proxyType      :: Maybe ProxyType
    , Config m a -> Maybe (StartupInfo m a -> IO ())
startupHook    :: Maybe (StartupInfo m a -> IO ())
    }
#if MIN_VERSION_base(4,7,0)
  deriving Typeable
#else

------------------------------------------------------------------------------
-- | The 'Typeable1' instance is here so 'Config' values can be
-- dynamically loaded with Hint.
configTyCon :: TyCon
configTyCon = mkTyCon3 "snap-server" "Snap.Http.Server.Config" "Config"
{-# NOINLINE configTyCon #-}

instance (Typeable1 m) => Typeable1 (Config m) where
    typeOf1 _ = mkTyConApp configTyCon [typeOf1 (undefined :: m ())]
#endif


instance Show (Config m a) where
    show :: Config m a -> String
show Config m a
c = [String] -> String
unlines [ String
"Config:"
                     , String
"hostname: "       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_hostname
                     , String
"accessLog: "      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_accessLog
                     , String
"errorLog: "       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_errorLog
                     , String
"locale: "         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_locale
                     , String
"port: "           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_port
                     , String
"bind: "           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_bind
                     , String
"sslport: "        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_sslport
                     , String
"sslbind: "        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_sslbind
                     , String
"sslcert: "        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_sslcert
                     , String
"sslchaincert: "   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_sslchaincert
                     , String
"sslkey: "         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_sslkey
                     , String
"unixsocket: "     String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_unixsocket
                     , String
"unixaccessmode: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_unixaccessmode
                     , String
"compression: "    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_compression
                     , String
"verbose: "        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_verbose
                     , String
"defaultTimeout: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_defaultTimeout
                     , String
"proxyType: "      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_proxyType
                     ]

      where
        _hostname :: String
_hostname       = Maybe ByteString -> String
forall a. Show a => a -> String
show (Maybe ByteString -> String) -> Maybe ByteString -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
hostname       Config m a
c
        _accessLog :: String
_accessLog      = Maybe ConfigLog -> String
forall a. Show a => a -> String
show (Maybe ConfigLog -> String) -> Maybe ConfigLog -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
accessLog      Config m a
c
        _errorLog :: String
_errorLog       = Maybe ConfigLog -> String
forall a. Show a => a -> String
show (Maybe ConfigLog -> String) -> Maybe ConfigLog -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
errorLog       Config m a
c
        _locale :: String
_locale         = Maybe String -> String
forall a. Show a => a -> String
show (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
locale         Config m a
c
        _port :: String
_port           = Maybe Int -> String
forall a. Show a => a -> String
show (Maybe Int -> String) -> Maybe Int -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
port           Config m a
c
        _bind :: String
_bind           = Maybe ByteString -> String
forall a. Show a => a -> String
show (Maybe ByteString -> String) -> Maybe ByteString -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
bind           Config m a
c
        _sslport :: String
_sslport        = Maybe Int -> String
forall a. Show a => a -> String
show (Maybe Int -> String) -> Maybe Int -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
sslport        Config m a
c
        _sslbind :: String
_sslbind        = Maybe ByteString -> String
forall a. Show a => a -> String
show (Maybe ByteString -> String) -> Maybe ByteString -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
sslbind        Config m a
c
        _sslcert :: String
_sslcert        = Maybe String -> String
forall a. Show a => a -> String
show (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
sslcert        Config m a
c
        _sslchaincert :: String
_sslchaincert   = Maybe Bool -> String
forall a. Show a => a -> String
show (Maybe Bool -> String) -> Maybe Bool -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
sslchaincert   Config m a
c
        _sslkey :: String
_sslkey         = Maybe String -> String
forall a. Show a => a -> String
show (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
sslkey         Config m a
c
        _compression :: String
_compression    = Maybe Bool -> String
forall a. Show a => a -> String
show (Maybe Bool -> String) -> Maybe Bool -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
compression    Config m a
c
        _verbose :: String
_verbose        = Maybe Bool -> String
forall a. Show a => a -> String
show (Maybe Bool -> String) -> Maybe Bool -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
verbose        Config m a
c
        _defaultTimeout :: String
_defaultTimeout = Maybe Int -> String
forall a. Show a => a -> String
show (Maybe Int -> String) -> Maybe Int -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
defaultTimeout Config m a
c
        _proxyType :: String
_proxyType      = Maybe ProxyType -> String
forall a. Show a => a -> String
show (Maybe ProxyType -> String) -> Maybe ProxyType -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe ProxyType
forall (m :: * -> *) a. Config m a -> Maybe ProxyType
proxyType      Config m a
c
        _unixsocket :: String
_unixsocket     = Maybe String -> String
forall a. Show a => a -> String
show (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
unixsocket     Config m a
c
        _unixaccessmode :: String
_unixaccessmode = case Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
unixaccessmode Config m a
c of
                               Maybe Int
Nothing -> String
"Nothing"
                               Just Int
s -> (String
"Just 0" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showOct Int
s ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ []


------------------------------------------------------------------------------
-- | Returns a completely empty 'Config'. Equivalent to 'mempty' from
-- 'Config''s 'Monoid' instance.
emptyConfig :: Config m a
emptyConfig :: Config m a
emptyConfig = Config m a
forall a. Monoid a => a
mempty


------------------------------------------------------------------------------
instance Semigroup (Config m a) where
    Config m a
a <> :: Config m a -> Config m a -> Config m a
<> Config m a
b = Config :: forall (m :: * -> *) a.
Maybe ByteString
-> Maybe ConfigLog
-> Maybe ConfigLog
-> Maybe String
-> Maybe Int
-> Maybe ByteString
-> Maybe Int
-> Maybe ByteString
-> Maybe String
-> Maybe Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> Maybe Bool
-> Maybe Bool
-> Maybe (SomeException -> m ())
-> Maybe Int
-> Maybe a
-> Maybe ProxyType
-> Maybe (StartupInfo m a -> IO ())
-> Config m a
Config
        { hostname :: Maybe ByteString
hostname       = (Config m a -> Maybe ByteString) -> Maybe ByteString
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
hostname
        , accessLog :: Maybe ConfigLog
accessLog      = (Config m a -> Maybe ConfigLog) -> Maybe ConfigLog
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
accessLog
        , errorLog :: Maybe ConfigLog
errorLog       = (Config m a -> Maybe ConfigLog) -> Maybe ConfigLog
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
errorLog
        , locale :: Maybe String
locale         = (Config m a -> Maybe String) -> Maybe String
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
locale
        , port :: Maybe Int
port           = (Config m a -> Maybe Int) -> Maybe Int
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
port
        , bind :: Maybe ByteString
bind           = (Config m a -> Maybe ByteString) -> Maybe ByteString
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
bind
        , sslport :: Maybe Int
sslport        = (Config m a -> Maybe Int) -> Maybe Int
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
sslport
        , sslbind :: Maybe ByteString
sslbind        = (Config m a -> Maybe ByteString) -> Maybe ByteString
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
sslbind
        , sslcert :: Maybe String
sslcert        = (Config m a -> Maybe String) -> Maybe String
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
sslcert
        , sslchaincert :: Maybe Bool
sslchaincert   = (Config m a -> Maybe Bool) -> Maybe Bool
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
sslchaincert
        , sslkey :: Maybe String
sslkey         = (Config m a -> Maybe String) -> Maybe String
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
sslkey
        , unixsocket :: Maybe String
unixsocket     = (Config m a -> Maybe String) -> Maybe String
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
unixsocket
        , unixaccessmode :: Maybe Int
unixaccessmode = (Config m a -> Maybe Int) -> Maybe Int
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
unixaccessmode
        , compression :: Maybe Bool
compression    = (Config m a -> Maybe Bool) -> Maybe Bool
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
compression
        , verbose :: Maybe Bool
verbose        = (Config m a -> Maybe Bool) -> Maybe Bool
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
verbose
        , errorHandler :: Maybe (SomeException -> m ())
errorHandler   = (Config m a -> Maybe (SomeException -> m ()))
-> Maybe (SomeException -> m ())
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe (SomeException -> m ())
forall (m :: * -> *) a. Config m a -> Maybe (SomeException -> m ())
errorHandler
        , defaultTimeout :: Maybe Int
defaultTimeout = (Config m a -> Maybe Int) -> Maybe Int
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
defaultTimeout
        , other :: Maybe a
other          = (Config m a -> Maybe a) -> Maybe a
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe a
forall (m :: * -> *) a. Config m a -> Maybe a
other
        , proxyType :: Maybe ProxyType
proxyType      = (Config m a -> Maybe ProxyType) -> Maybe ProxyType
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe ProxyType
forall (m :: * -> *) a. Config m a -> Maybe ProxyType
proxyType
        , startupHook :: Maybe (StartupInfo m a -> IO ())
startupHook    = (Config m a -> Maybe (StartupInfo m a -> IO ()))
-> Maybe (StartupInfo m a -> IO ())
forall b. (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe (StartupInfo m a -> IO ())
forall (m :: * -> *) a.
Config m a -> Maybe (StartupInfo m a -> IO ())
startupHook
        }
      where
        ov :: (Config m a -> Maybe b) -> Maybe b
        ov :: (Config m a -> Maybe b) -> Maybe b
ov Config m a -> Maybe b
f = Last b -> Maybe b
forall a. Last a -> Maybe a
getLast (Last b -> Maybe b) -> Last b -> Maybe b
forall a b. (a -> b) -> a -> b
$! (Last b -> Last b -> Last b
forall a. Monoid a => a -> a -> a
mappend (Last b -> Last b -> Last b)
-> (Config m a -> Last b) -> Config m a -> Config m a -> Last b
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Maybe b -> Last b
forall a. Maybe a -> Last a
Last (Maybe b -> Last b)
-> (Config m a -> Maybe b) -> Config m a -> Last b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config m a -> Maybe b
f)) Config m a
a Config m a
b


instance Monoid (Config m a) where
    mempty :: Config m a
mempty = Config :: forall (m :: * -> *) a.
Maybe ByteString
-> Maybe ConfigLog
-> Maybe ConfigLog
-> Maybe String
-> Maybe Int
-> Maybe ByteString
-> Maybe Int
-> Maybe ByteString
-> Maybe String
-> Maybe Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> Maybe Bool
-> Maybe Bool
-> Maybe (SomeException -> m ())
-> Maybe Int
-> Maybe a
-> Maybe ProxyType
-> Maybe (StartupInfo m a -> IO ())
-> Config m a
Config
        { hostname :: Maybe ByteString
hostname       = Maybe ByteString
forall a. Maybe a
Nothing
        , accessLog :: Maybe ConfigLog
accessLog      = Maybe ConfigLog
forall a. Maybe a
Nothing
        , errorLog :: Maybe ConfigLog
errorLog       = Maybe ConfigLog
forall a. Maybe a
Nothing
        , locale :: Maybe String
locale         = Maybe String
forall a. Maybe a
Nothing
        , port :: Maybe Int
port           = Maybe Int
forall a. Maybe a
Nothing
        , bind :: Maybe ByteString
bind           = Maybe ByteString
forall a. Maybe a
Nothing
        , sslport :: Maybe Int
sslport        = Maybe Int
forall a. Maybe a
Nothing
        , sslbind :: Maybe ByteString
sslbind        = Maybe ByteString
forall a. Maybe a
Nothing
        , sslcert :: Maybe String
sslcert        = Maybe String
forall a. Maybe a
Nothing
        , sslchaincert :: Maybe Bool
sslchaincert   = Maybe Bool
forall a. Maybe a
Nothing
        , sslkey :: Maybe String
sslkey         = Maybe String
forall a. Maybe a
Nothing
        , unixsocket :: Maybe String
unixsocket     = Maybe String
forall a. Maybe a
Nothing
        , unixaccessmode :: Maybe Int
unixaccessmode = Maybe Int
forall a. Maybe a
Nothing
        , compression :: Maybe Bool
compression    = Maybe Bool
forall a. Maybe a
Nothing
        , verbose :: Maybe Bool
verbose        = Maybe Bool
forall a. Maybe a
Nothing
        , errorHandler :: Maybe (SomeException -> m ())
errorHandler   = Maybe (SomeException -> m ())
forall a. Maybe a
Nothing
        , defaultTimeout :: Maybe Int
defaultTimeout = Maybe Int
forall a. Maybe a
Nothing
        , other :: Maybe a
other          = Maybe a
forall a. Maybe a
Nothing
        , proxyType :: Maybe ProxyType
proxyType      = Maybe ProxyType
forall a. Maybe a
Nothing
        , startupHook :: Maybe (StartupInfo m a -> IO ())
startupHook    = Maybe (StartupInfo m a -> IO ())
forall a. Maybe a
Nothing
        }

#if !MIN_VERSION_base(4,11,0)
    mappend = (<>)
#endif


------------------------------------------------------------------------------
-- | These are the default values for the options
defaultConfig :: MonadSnap m => Config m a
defaultConfig :: Config m a
defaultConfig = Config m a
forall a. Monoid a => a
mempty
    { hostname :: Maybe ByteString
hostname       = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"localhost"
    , accessLog :: Maybe ConfigLog
accessLog      = ConfigLog -> Maybe ConfigLog
forall a. a -> Maybe a
Just (ConfigLog -> Maybe ConfigLog) -> ConfigLog -> Maybe ConfigLog
forall a b. (a -> b) -> a -> b
$ String -> ConfigLog
ConfigFileLog String
"log/access.log"
    , errorLog :: Maybe ConfigLog
errorLog       = ConfigLog -> Maybe ConfigLog
forall a. a -> Maybe a
Just (ConfigLog -> Maybe ConfigLog) -> ConfigLog -> Maybe ConfigLog
forall a b. (a -> b) -> a -> b
$ String -> ConfigLog
ConfigFileLog String
"log/error.log"
    , locale :: Maybe String
locale         = String -> Maybe String
forall a. a -> Maybe a
Just String
"en_US"
    , compression :: Maybe Bool
compression    = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    , verbose :: Maybe Bool
verbose        = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    , errorHandler :: Maybe (SomeException -> m ())
errorHandler   = (SomeException -> m ()) -> Maybe (SomeException -> m ())
forall a. a -> Maybe a
Just SomeException -> m ()
forall (m :: * -> *). MonadSnap m => SomeException -> m ()
defaultErrorHandler
    , bind :: Maybe ByteString
bind           = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"0.0.0.0"
    , sslbind :: Maybe ByteString
sslbind        = Maybe ByteString
forall a. Maybe a
Nothing
    , sslcert :: Maybe String
sslcert        = Maybe String
forall a. Maybe a
Nothing
    , sslkey :: Maybe String
sslkey         = Maybe String
forall a. Maybe a
Nothing
    , sslchaincert :: Maybe Bool
sslchaincert   = Maybe Bool
forall a. Maybe a
Nothing
    , defaultTimeout :: Maybe Int
defaultTimeout = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
60
    }


------------------------------------------------------------------------------
-- | The hostname of the HTTP server. This field has the same format as an HTTP
-- @Host@ header; if a @Host@ header came in with the request, we use that,
-- otherwise we default to this value specified in the configuration.
getHostname       :: Config m a -> Maybe ByteString
getHostname :: Config m a -> Maybe ByteString
getHostname = Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
hostname

-- | Path to the access log
getAccessLog      :: Config m a -> Maybe ConfigLog
getAccessLog :: Config m a -> Maybe ConfigLog
getAccessLog = Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
accessLog

-- | Path to the error log
getErrorLog       :: Config m a -> Maybe ConfigLog
getErrorLog :: Config m a -> Maybe ConfigLog
getErrorLog = Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
errorLog

-- | Gets the locale to use. Locales are used on Unix only, to set the
-- @LANG@\/@LC_ALL@\/etc. environment variable. For instance if you set the
-- locale to \"@en_US@\", we'll set the relevant environment variables to
-- \"@en_US.UTF-8@\".
getLocale         :: Config m a -> Maybe String
getLocale :: Config m a -> Maybe String
getLocale = Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
locale

-- | Returns the port to listen on (for http)
getPort           :: Config m a -> Maybe Int
getPort :: Config m a -> Maybe Int
getPort = Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
port

-- | Returns the address to bind to (for http)
getBind           :: Config m a -> Maybe ByteString
getBind :: Config m a -> Maybe ByteString
getBind = Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
bind

-- | Returns the port to listen on (for https)
getSSLPort        :: Config m a -> Maybe Int
getSSLPort :: Config m a -> Maybe Int
getSSLPort = Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
sslport

-- | Returns the address to bind to (for https)
getSSLBind        :: Config m a -> Maybe ByteString
getSSLBind :: Config m a -> Maybe ByteString
getSSLBind = Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
sslbind

-- | Path to the SSL certificate file
getSSLCert        :: Config m a -> Maybe FilePath
getSSLCert :: Config m a -> Maybe String
getSSLCert = Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
sslcert

-- | Path to the SSL certificate file
getSSLChainCert   :: Config m a -> Maybe Bool
getSSLChainCert :: Config m a -> Maybe Bool
getSSLChainCert = Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
sslchaincert

-- | Path to the SSL key file
getSSLKey         :: Config m a -> Maybe FilePath
getSSLKey :: Config m a -> Maybe String
getSSLKey = Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
sslkey

-- | File path to unix socket. Must be absolute path, but allows for symbolic
-- links.
getUnixSocket     :: Config m a -> Maybe FilePath
getUnixSocket :: Config m a -> Maybe String
getUnixSocket = Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
unixsocket

-- | Access mode for unix socket, by default is system specific.
-- This should only be used to grant additional permissions to created
-- socket file, and not to remove permissions set by default.
-- The only portable way to limit access to socket is creating it in a
-- directory with proper permissions set.
--
-- Most BSD systems ignore access permissions on unix sockets.
--
-- Note: This uses umask. There is a race condition if process creates other
-- files at the same time as opening a unix socket with this option set.
getUnixSocketAccessMode :: Config m a -> Maybe Int
getUnixSocketAccessMode :: Config m a -> Maybe Int
getUnixSocketAccessMode = Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
unixaccessmode

-- | If set and set to True, compression is turned on when applicable
getCompression    :: Config m a -> Maybe Bool
getCompression :: Config m a -> Maybe Bool
getCompression = Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
compression

-- | Whether to write server status updates to stderr
getVerbose        :: Config m a -> Maybe Bool
getVerbose :: Config m a -> Maybe Bool
getVerbose = Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
verbose

-- | A MonadSnap action to handle 500 errors
getErrorHandler   :: Config m a -> Maybe (SomeException -> m ())
getErrorHandler :: Config m a -> Maybe (SomeException -> m ())
getErrorHandler = Config m a -> Maybe (SomeException -> m ())
forall (m :: * -> *) a. Config m a -> Maybe (SomeException -> m ())
errorHandler

getDefaultTimeout :: Config m a -> Maybe Int
getDefaultTimeout :: Config m a -> Maybe Int
getDefaultTimeout = Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
defaultTimeout

getOther :: Config m a -> Maybe a
getOther :: Config m a -> Maybe a
getOther = Config m a -> Maybe a
forall (m :: * -> *) a. Config m a -> Maybe a
other

getProxyType :: Config m a -> Maybe ProxyType
getProxyType :: Config m a -> Maybe ProxyType
getProxyType = Config m a -> Maybe ProxyType
forall (m :: * -> *) a. Config m a -> Maybe ProxyType
proxyType

-- | A startup hook is run after the server initializes but before user request
-- processing begins. The server passes, through a 'StartupInfo' object, the
-- startup hook a list of the sockets it is listening on and the final 'Config'
-- object completed after command-line processing.
getStartupHook :: Config m a -> Maybe (StartupInfo m a -> IO ())
getStartupHook :: Config m a -> Maybe (StartupInfo m a -> IO ())
getStartupHook = Config m a -> Maybe (StartupInfo m a -> IO ())
forall (m :: * -> *) a.
Config m a -> Maybe (StartupInfo m a -> IO ())
startupHook


------------------------------------------------------------------------------
setHostname       :: ByteString              -> Config m a -> Config m a
setHostname :: ByteString -> Config m a -> Config m a
setHostname ByteString
x Config m a
c = Config m a
c { hostname :: Maybe ByteString
hostname = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x }

setAccessLog      :: ConfigLog               -> Config m a -> Config m a
setAccessLog :: ConfigLog -> Config m a -> Config m a
setAccessLog ConfigLog
x Config m a
c = Config m a
c { accessLog :: Maybe ConfigLog
accessLog = ConfigLog -> Maybe ConfigLog
forall a. a -> Maybe a
Just ConfigLog
x }

setErrorLog       :: ConfigLog               -> Config m a -> Config m a
setErrorLog :: ConfigLog -> Config m a -> Config m a
setErrorLog ConfigLog
x Config m a
c = Config m a
c { errorLog :: Maybe ConfigLog
errorLog = ConfigLog -> Maybe ConfigLog
forall a. a -> Maybe a
Just ConfigLog
x }

setLocale         :: String                  -> Config m a -> Config m a
setLocale :: String -> Config m a -> Config m a
setLocale String
x Config m a
c = Config m a
c { locale :: Maybe String
locale = String -> Maybe String
forall a. a -> Maybe a
Just String
x }

setPort           :: Int                     -> Config m a -> Config m a
setPort :: Int -> Config m a -> Config m a
setPort Int
x Config m a
c = Config m a
c { port :: Maybe Int
port = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x }

setBind           :: ByteString              -> Config m a -> Config m a
setBind :: ByteString -> Config m a -> Config m a
setBind ByteString
x Config m a
c = Config m a
c { bind :: Maybe ByteString
bind = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x }

setSSLPort        :: Int                     -> Config m a -> Config m a
setSSLPort :: Int -> Config m a -> Config m a
setSSLPort Int
x Config m a
c = Config m a
c { sslport :: Maybe Int
sslport = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x }

setSSLBind        :: ByteString              -> Config m a -> Config m a
setSSLBind :: ByteString -> Config m a -> Config m a
setSSLBind ByteString
x Config m a
c = Config m a
c { sslbind :: Maybe ByteString
sslbind = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x }

setSSLCert        :: FilePath                -> Config m a -> Config m a
setSSLCert :: String -> Config m a -> Config m a
setSSLCert String
x Config m a
c = Config m a
c { sslcert :: Maybe String
sslcert = String -> Maybe String
forall a. a -> Maybe a
Just String
x }

setSSLChainCert   :: Bool                    -> Config m a -> Config m a
setSSLChainCert :: Bool -> Config m a -> Config m a
setSSLChainCert Bool
x Config m a
c = Config m a
c { sslchaincert :: Maybe Bool
sslchaincert = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x }

setSSLKey         :: FilePath                -> Config m a -> Config m a
setSSLKey :: String -> Config m a -> Config m a
setSSLKey String
x Config m a
c = Config m a
c { sslkey :: Maybe String
sslkey = String -> Maybe String
forall a. a -> Maybe a
Just String
x }

setUnixSocket     :: FilePath                -> Config m a -> Config m a
setUnixSocket :: String -> Config m a -> Config m a
setUnixSocket String
x Config m a
c = Config m a
c { unixsocket :: Maybe String
unixsocket = String -> Maybe String
forall a. a -> Maybe a
Just String
x }

setUnixSocketAccessMode :: Int               -> Config m a -> Config m a
setUnixSocketAccessMode :: Int -> Config m a -> Config m a
setUnixSocketAccessMode Int
p Config m a
c = Config m a
c { unixaccessmode :: Maybe Int
unixaccessmode = Int -> Maybe Int
forall a. a -> Maybe a
Just ( Int
p Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0o777) }

setCompression    :: Bool                    -> Config m a -> Config m a
setCompression :: Bool -> Config m a -> Config m a
setCompression Bool
x Config m a
c = Config m a
c { compression :: Maybe Bool
compression = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x }

setVerbose        :: Bool                    -> Config m a -> Config m a
setVerbose :: Bool -> Config m a -> Config m a
setVerbose Bool
x Config m a
c = Config m a
c { verbose :: Maybe Bool
verbose = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x }

setErrorHandler   :: (SomeException -> m ()) -> Config m a -> Config m a
setErrorHandler :: (SomeException -> m ()) -> Config m a -> Config m a
setErrorHandler SomeException -> m ()
x Config m a
c = Config m a
c { errorHandler :: Maybe (SomeException -> m ())
errorHandler = (SomeException -> m ()) -> Maybe (SomeException -> m ())
forall a. a -> Maybe a
Just SomeException -> m ()
x }

setDefaultTimeout :: Int                     -> Config m a -> Config m a
setDefaultTimeout :: Int -> Config m a -> Config m a
setDefaultTimeout Int
x Config m a
c = Config m a
c { defaultTimeout :: Maybe Int
defaultTimeout = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x }

setOther          :: a                       -> Config m a -> Config m a
setOther :: a -> Config m a -> Config m a
setOther a
x Config m a
c = Config m a
c { other :: Maybe a
other = a -> Maybe a
forall a. a -> Maybe a
Just a
x }

setProxyType      :: ProxyType               -> Config m a -> Config m a
setProxyType :: ProxyType -> Config m a -> Config m a
setProxyType ProxyType
x Config m a
c = Config m a
c { proxyType :: Maybe ProxyType
proxyType = ProxyType -> Maybe ProxyType
forall a. a -> Maybe a
Just ProxyType
x }

setStartupHook    :: (StartupInfo m a -> IO ()) -> Config m a -> Config m a
setStartupHook :: (StartupInfo m a -> IO ()) -> Config m a -> Config m a
setStartupHook StartupInfo m a -> IO ()
x Config m a
c = Config m a
c { startupHook :: Maybe (StartupInfo m a -> IO ())
startupHook = (StartupInfo m a -> IO ()) -> Maybe (StartupInfo m a -> IO ())
forall a. a -> Maybe a
Just StartupInfo m a -> IO ()
x }


------------------------------------------------------------------------------

-- | Arguments passed to 'setStartupHook'.
data StartupInfo m a = StartupInfo
    { StartupInfo m a -> Config m a
startupHookConfig  :: Config m a
    , StartupInfo m a -> [Socket]
startupHookSockets :: [Socket]
    }

emptyStartupInfo :: StartupInfo m a
emptyStartupInfo :: StartupInfo m a
emptyStartupInfo = Config m a -> [Socket] -> StartupInfo m a
forall (m :: * -> *) a. Config m a -> [Socket] -> StartupInfo m a
StartupInfo Config m a
forall (m :: * -> *) a. Config m a
emptyConfig []

-- | The 'Socket's opened by the server. There will be two 'Socket's for SSL
-- connections, and one otherwise.
getStartupSockets :: StartupInfo m a -> [Socket]
getStartupSockets :: StartupInfo m a -> [Socket]
getStartupSockets = StartupInfo m a -> [Socket]
forall (m :: * -> *) a. StartupInfo m a -> [Socket]
startupHookSockets

-- The 'Config', after any command line parsing has been performed.
getStartupConfig :: StartupInfo m a -> Config m a
getStartupConfig :: StartupInfo m a -> Config m a
getStartupConfig = StartupInfo m a -> Config m a
forall (m :: * -> *) a. StartupInfo m a -> Config m a
startupHookConfig

setStartupSockets :: [Socket] -> StartupInfo m a -> StartupInfo m a
setStartupSockets :: [Socket] -> StartupInfo m a -> StartupInfo m a
setStartupSockets [Socket]
x StartupInfo m a
c = StartupInfo m a
c { startupHookSockets :: [Socket]
startupHookSockets = [Socket]
x }

setStartupConfig :: Config m a -> StartupInfo m a -> StartupInfo m a
setStartupConfig :: Config m a -> StartupInfo m a -> StartupInfo m a
setStartupConfig Config m a
x StartupInfo m a
c = StartupInfo m a
c { startupHookConfig :: Config m a
startupHookConfig = Config m a
x }


------------------------------------------------------------------------------
completeConfig :: (MonadSnap m) => Config m a -> IO (Config m a)
completeConfig :: Config m a -> IO (Config m a)
completeConfig Config m a
config = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noPort (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr
        String
"no port specified, defaulting to port 8000"

    Config m a -> IO (Config m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Config m a -> IO (Config m a)) -> Config m a -> IO (Config m a)
forall a b. (a -> b) -> a -> b
$! Config m a
cfg Config m a -> Config m a -> Config m a
forall a. Monoid a => a -> a -> a
`mappend` Config m a
forall (m :: * -> *) a. Config m a
cfg'

  where
    cfg :: Config m a
cfg = Config m a
forall (m :: * -> *) a. MonadSnap m => Config m a
defaultConfig Config m a -> Config m a -> Config m a
forall a. Monoid a => a -> a -> a
`mappend` Config m a
config

    sslVals :: [Bool]
sslVals = ((Config m a -> Bool) -> Bool) -> [Config m a -> Bool] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((Config m a -> Bool) -> Config m a -> Bool
forall a b. (a -> b) -> a -> b
$ Config m a
cfg) [ Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool)
-> (Config m a -> Maybe Int) -> Config m a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
getSSLPort
                          , Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool)
-> (Config m a -> Maybe ByteString) -> Config m a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
getSSLBind
                          , Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool)
-> (Config m a -> Maybe String) -> Config m a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
getSSLKey
                          , Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool)
-> (Config m a -> Maybe String) -> Config m a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
getSSLCert ]

    sslValid :: Bool
sslValid   = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
sslVals
    unixValid :: Bool
unixValid  = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
unixsocket Config m a
cfg
    noPort :: Bool
noPort = Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
getPort Config m a
cfg) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
sslValid Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
unixValid

    cfg' :: Config m a
cfg' = Config m a
forall (m :: * -> *) a. Config m a
emptyConfig { port :: Maybe Int
port = if Bool
noPort then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8000 else Maybe Int
forall a. Maybe a
Nothing }


------------------------------------------------------------------------------
bsFromString :: String -> ByteString
bsFromString :: String -> ByteString
bsFromString = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack


------------------------------------------------------------------------------
toString :: ByteString -> String
toString :: ByteString -> String
toString = Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8


------------------------------------------------------------------------------
-- | Returns a description of the snap command line options suitable for use
-- with "System.Console.GetOpt".
optDescrs :: forall m a . MonadSnap m =>
             Config m a         -- ^ the configuration defaults.
          -> [OptDescr (Maybe (Config m a))]
optDescrs :: Config m a -> [OptDescr (Maybe (Config m a))]
optDescrs Config m a
defaults =
    [ String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"hostname"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> (String -> Config m a) -> String -> Maybe (Config m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Config m a -> Config m a)
-> ByteString -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig ByteString -> Config m a -> Config m a
forall (m :: * -> *) a. ByteString -> Config m a -> Config m a
setHostname (ByteString -> Config m a)
-> (String -> ByteString) -> String -> Config m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
bsFromString) String
"NAME")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"local hostname" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe ByteString) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultC Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
getHostname
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"b" [String
"address"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s -> Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ Config m a
forall a. Monoid a => a
mempty { bind :: Maybe ByteString
bind = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
bsFromString String
s })
                     String
"ADDRESS")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"address to bind to" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe ByteString) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultO Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
bind
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"p" [String
"port"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s -> Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ Config m a
forall a. Monoid a => a
mempty { port :: Maybe Int
port = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
s}) String
"PORT")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"port to listen on" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe Int) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultO Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
port
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"ssl-address"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s -> Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ Config m a
forall a. Monoid a => a
mempty { sslbind :: Maybe ByteString
sslbind = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
bsFromString String
s })
                     String
"ADDRESS")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"ssl address to bind to" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe ByteString) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultO Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
sslbind
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"ssl-port"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s -> Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ Config m a
forall a. Monoid a => a
mempty { sslport :: Maybe Int
sslport = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
s}) String
"PORT")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"ssl port to listen on" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe Int) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultO Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
sslport
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"ssl-cert"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s -> Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ Config m a
forall a. Monoid a => a
mempty { sslcert :: Maybe String
sslcert = String -> Maybe String
forall a. a -> Maybe a
Just String
s}) String
"PATH")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"path to ssl certificate in PEM format" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe String) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultO Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
sslcert
   , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"ssl-chain-cert"]
             (Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a. a -> ArgDescr a
NoArg (Maybe (Config m a) -> ArgDescr (Maybe (Config m a)))
-> Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ (Bool -> Config m a -> Config m a) -> Bool -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig Bool -> Config m a -> Config m a
forall (m :: * -> *) a. Bool -> Config m a -> Config m a
setSSLChainCert Bool
True)
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"certificate file contains complete certificate chain" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe Bool) -> String -> ShowS
defaultB Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
sslchaincert String
"site certificate only" String
"complete certificate chain"
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"no-ssl-chain-cert"]
             (Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a. a -> ArgDescr a
NoArg (Maybe (Config m a) -> ArgDescr (Maybe (Config m a)))
-> Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ (Bool -> Config m a -> Config m a) -> Bool -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig Bool -> Config m a -> Config m a
forall (m :: * -> *) a. Bool -> Config m a -> Config m a
setSSLChainCert Bool
False)
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"certificate file contains only the site certificate" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe Bool) -> String -> ShowS
defaultB Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
sslchaincert String
"site certificate only" String
"complete certificate chain"
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"ssl-key"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s -> Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ Config m a
forall a. Monoid a => a
mempty { sslkey :: Maybe String
sslkey = String -> Maybe String
forall a. a -> Maybe a
Just String
s}) String
"PATH")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"path to ssl private key in PEM format" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe String) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultO Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
sslkey
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"access-log"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> (String -> Config m a) -> String -> Maybe (Config m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfigLog -> Config m a -> Config m a) -> ConfigLog -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig ConfigLog -> Config m a -> Config m a
forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
setAccessLog (ConfigLog -> Config m a)
-> (String -> ConfigLog) -> String -> Config m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ConfigLog
ConfigFileLog) String
"PATH")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"access log" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe ConfigLog) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultC Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
getAccessLog
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"error-log"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> (String -> Config m a) -> String -> Maybe (Config m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfigLog -> Config m a -> Config m a) -> ConfigLog -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig ConfigLog -> Config m a -> Config m a
forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
setErrorLog (ConfigLog -> Config m a)
-> (String -> ConfigLog) -> String -> Config m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ConfigLog
ConfigFileLog) String
"PATH")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"error log" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe ConfigLog) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultC Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
getErrorLog
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"no-access-log"]
             (Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a. a -> ArgDescr a
NoArg (Maybe (Config m a) -> ArgDescr (Maybe (Config m a)))
-> Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ (ConfigLog -> Config m a -> Config m a) -> ConfigLog -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig ConfigLog -> Config m a -> Config m a
forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
setAccessLog ConfigLog
ConfigNoLog)
             String
"don't have an access log"
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"no-error-log"]
             (Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a. a -> ArgDescr a
NoArg (Maybe (Config m a) -> ArgDescr (Maybe (Config m a)))
-> Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ (ConfigLog -> Config m a -> Config m a) -> ConfigLog -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig ConfigLog -> Config m a -> Config m a
forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
setErrorLog ConfigLog
ConfigNoLog)
             String
"don't have an error log"
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"c" [String
"compression"]
             (Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a. a -> ArgDescr a
NoArg (Maybe (Config m a) -> ArgDescr (Maybe (Config m a)))
-> Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ (Bool -> Config m a -> Config m a) -> Bool -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig Bool -> Config m a -> Config m a
forall (m :: * -> *) a. Bool -> Config m a -> Config m a
setCompression Bool
True)
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"use gzip compression on responses" String -> ShowS
forall a. [a] -> [a] -> [a]
++
               (Config m a -> Maybe Bool) -> String -> ShowS
defaultB Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
getCompression String
"compressed" String
"uncompressed"
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"t" [String
"timeout"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
t -> Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ Config m a
forall a. Monoid a => a
mempty {
                              defaultTimeout :: Maybe Int
defaultTimeout = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
t
                            }) String
"SECS")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"set default timeout in seconds" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Config m a -> Maybe Int) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultC Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
defaultTimeout
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"no-compression"]
             (Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a. a -> ArgDescr a
NoArg (Maybe (Config m a) -> ArgDescr (Maybe (Config m a)))
-> Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ (Bool -> Config m a -> Config m a) -> Bool -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig Bool -> Config m a -> Config m a
forall (m :: * -> *) a. Bool -> Config m a -> Config m a
setCompression Bool
False)
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"serve responses uncompressed" String -> ShowS
forall a. [a] -> [a] -> [a]
++
               (Config m a -> Maybe Bool) -> String -> ShowS
defaultB Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
compression String
"compressed" String
"uncompressed"
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"v" [String
"verbose"]
             (Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a. a -> ArgDescr a
NoArg (Maybe (Config m a) -> ArgDescr (Maybe (Config m a)))
-> Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ (Bool -> Config m a -> Config m a) -> Bool -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig Bool -> Config m a -> Config m a
forall (m :: * -> *) a. Bool -> Config m a -> Config m a
setVerbose Bool
True)
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"print server status updates to stderr" String -> ShowS
forall a. [a] -> [a] -> [a]
++
               (Config m a -> Maybe Bool) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultC Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
getVerbose
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"q" [String
"quiet"]
             (Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a. a -> ArgDescr a
NoArg (Maybe (Config m a) -> ArgDescr (Maybe (Config m a)))
-> Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> Config m a -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$ (Bool -> Config m a -> Config m a) -> Bool -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig Bool -> Config m a -> Config m a
forall (m :: * -> *) a. Bool -> Config m a -> Config m a
setVerbose Bool
False)
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ String
"do not print anything to stderr" String -> ShowS
forall a. [a] -> [a] -> [a]
++
               (Config m a -> Maybe Bool) -> String -> ShowS
defaultB Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
getVerbose String
"verbose" String
"quiet"
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"proxy"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> (String -> Config m a) -> String -> Maybe (Config m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProxyType -> Config m a -> Config m a) -> ProxyType -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig ProxyType -> Config m a -> Config m a
forall (m :: * -> *) a. ProxyType -> Config m a -> Config m a
setProxyType (ProxyType -> Config m a)
-> (String -> ProxyType) -> String -> Config m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI String -> ProxyType
parseProxy (CI String -> ProxyType)
-> (String -> CI String) -> String -> ProxyType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CI String
forall s. FoldCase s => s -> CI s
CI.mk)
                     String
"X_Forwarded_For")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Set --proxy=X_Forwarded_For if your snap application \n"
                      , String
"is behind an HTTP reverse proxy to ensure that \n"
                      , String
"rqClientAddr is set properly.\n"
                      , String
"Set --proxy=haproxy to use the haproxy protocol\n("
                      , String
"http://haproxy.1wt.eu/download/1.5/doc/proxy-protocol.txt)"
                      , (Config m a -> Maybe ProxyType) -> String
forall b. Show b => (Config m a -> Maybe b) -> String
defaultC Config m a -> Maybe ProxyType
forall (m :: * -> *) a. Config m a -> Maybe ProxyType
getProxyType ]
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"unix-socket"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> (String -> Config m a) -> String -> Maybe (Config m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Config m a -> Config m a) -> String -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig String -> Config m a -> Config m a
forall (m :: * -> *) a. String -> Config m a -> Config m a
setUnixSocket) String
"PATH")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"Absolute path to unix socket file. "
                      , String
"File will be removed if already exists"]
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
"unix-socket-mode"]
             ((String -> Maybe (Config m a))
-> String -> ArgDescr (Maybe (Config m a))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (Config m a -> Maybe (Config m a)
forall a. a -> Maybe a
Just (Config m a -> Maybe (Config m a))
-> (String -> Config m a) -> String -> Maybe (Config m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Config m a -> Config m a) -> Int -> Config m a
forall t t t. Monoid t => (t -> t -> t) -> t -> t
setConfig Int -> Config m a -> Config m a
forall (m :: * -> *) a. Int -> Config m a -> Config m a
setUnixSocketAccessMode (Int -> Config m a) -> (String -> Int) -> String -> Config m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall p. (Num p, Ord p) => String -> p
parseOctal)
                     String
"MODE")
             (String -> OptDescr (Maybe (Config m a)))
-> String -> OptDescr (Maybe (Config m a))
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"Access mode for unix socket in octal, for example 0760.\n"
                      ,String
" Default is system specific."]
    , String
-> [String]
-> ArgDescr (Maybe (Config m a))
-> String
-> OptDescr (Maybe (Config m a))
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"h" [String
"help"]
             (Maybe (Config m a) -> ArgDescr (Maybe (Config m a))
forall a. a -> ArgDescr a
NoArg Maybe (Config m a)
forall a. Maybe a
Nothing)
             String
"display this help and exit"
    ]

  where
    parseProxy :: CI String -> ProxyType
parseProxy CI String
s | CI String
s CI String -> CI String -> Bool
forall a. Eq a => a -> a -> Bool
== CI String
"NoProxy"         = ProxyType
NoProxy
                 | CI String
s CI String -> CI String -> Bool
forall a. Eq a => a -> a -> Bool
== CI String
"X_Forwarded_For" = ProxyType
X_Forwarded_For
                 | CI String
s CI String -> CI String -> Bool
forall a. Eq a => a -> a -> Bool
== CI String
"haproxy"         = ProxyType
HaProxy
                 | Bool
otherwise = String -> ProxyType
forall a. HasCallStack => String -> a
error (String -> ProxyType) -> String -> ProxyType
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                         String
"Error (--proxy): expected one of 'NoProxy', "
                       , String
"'X_Forwarded_For', or 'haproxy'. Got '"
                       , CI String -> String
forall s. CI s -> s
CI.original CI String
s
                       , String
"'"
                       ]
    parseOctal :: String -> p
parseOctal String
s = case ReadS p
forall a. (Eq a, Num a) => ReadS a
readOct String
s of
          ((p
v, String
_):[(p, String)]
_) | p
v p -> p -> Bool
forall a. Ord a => a -> a -> Bool
>= p
0 Bool -> Bool -> Bool
&& p
v p -> p -> Bool
forall a. Ord a => a -> a -> Bool
<= p
0o777 -> p
v
          [(p, String)]
_ -> String -> p
forall a. HasCallStack => String -> a
error (String -> p) -> String -> p
forall a b. (a -> b) -> a -> b
$ String
"Error (--unix-socket-mode): expected octal access mode"

    setConfig :: (t -> t -> t) -> t -> t
setConfig t -> t -> t
f t
c  = t -> t -> t
f t
c t
forall a. Monoid a => a
mempty
    conf :: Config m a
conf           = Config m a
forall (m :: * -> *) a. MonadSnap m => Config m a
defaultConfig Config m a -> Config m a -> Config m a
forall a. Monoid a => a -> a -> a
`mappend` Config m a
defaults

    defaultB :: (Config m a -> Maybe Bool) -> String -> String -> String
    defaultB :: (Config m a -> Maybe Bool) -> String -> ShowS
defaultB Config m a -> Maybe Bool
f String
y String
n = (String -> (Bool -> String) -> Maybe Bool -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Bool
b -> String
", default " String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Bool
b
                                                        then String
y
                                                        else String
n) (Maybe Bool -> String) -> Maybe Bool -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Bool
f Config m a
conf) :: String

    defaultC :: (Show b) => (Config m a -> Maybe b) -> String
    defaultC :: (Config m a -> Maybe b) -> String
defaultC Config m a -> Maybe b
f     = String -> (b -> String) -> Maybe b -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((String
", default " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (b -> String) -> b -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> String
forall a. Show a => a -> String
show) (Maybe b -> String) -> Maybe b -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe b
f Config m a
conf

    defaultO :: (Show b) => (Config m a -> Maybe b) -> String
    defaultO :: (Config m a -> Maybe b) -> String
defaultO Config m a -> Maybe b
f     = String -> (b -> String) -> Maybe b -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
", default off" ((String
", default " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (b -> String) -> b -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> String
forall a. Show a => a -> String
show) (Maybe b -> String) -> Maybe b -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe b
f Config m a
conf


------------------------------------------------------------------------------
defaultErrorHandler :: MonadSnap m => SomeException -> m ()
defaultErrorHandler :: SomeException -> m ()
defaultErrorHandler SomeException
e = do
    String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Snap.Http.Server.Config errorHandler:"
    Request
req <- (Request -> Request) -> m Request
forall (m :: * -> *) a. MonadSnap m => (Request -> a) -> m a
getsRequest Request -> Request
blindParams
    let sm :: ByteString
sm = Request -> ByteString
smsg Request
req
    String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
toString ByteString
sm
    ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
logError ByteString
sm

    Response -> m ()
forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith (Response -> m ()) -> Response -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Response -> Response
setContentType ByteString
"text/plain; charset=utf-8"
               (Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Response -> Response
setContentLength (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
msg)
               (Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> Response -> Response
setResponseStatus Int
500 ByteString
"Internal Server Error"
               (Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
setResponseBody OutputStream Builder -> IO (OutputStream Builder)
errBody
               (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ Response
emptyResponse

  where
    blindParams :: Request -> Request
blindParams Request
r = Request
r { rqPostParams :: Params
rqPostParams = Params -> Params
forall k b. Map k b -> Map k [ByteString]
rmValues (Params -> Params) -> Params -> Params
forall a b. (a -> b) -> a -> b
$ Request -> Params
rqPostParams Request
r
                      , rqParams :: Params
rqParams     = Params -> Params
forall k b. Map k b -> Map k [ByteString]
rmValues (Params -> Params) -> Params -> Params
forall a b. (a -> b) -> a -> b
$ Request -> Params
rqParams Request
r }
    rmValues :: Map k b -> Map k [ByteString]
rmValues = (b -> [ByteString]) -> Map k b -> Map k [ByteString]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([ByteString] -> b -> [ByteString]
forall a b. a -> b -> a
const [ByteString
"..."])

    errBody :: OutputStream Builder -> IO (OutputStream Builder)
errBody OutputStream Builder
os = Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
msgB) OutputStream Builder
os IO () -> IO (OutputStream Builder) -> IO (OutputStream Builder)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
os

    toByteString :: Builder -> ByteString
toByteString = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (Builder -> [ByteString]) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString])
-> (Builder -> ByteString) -> Builder -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString
    smsg :: Request -> ByteString
smsg Request
req = Builder -> ByteString
toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> SomeException -> Builder
requestErrorMessage Request
req SomeException
e

    msg :: ByteString
msg  = Builder -> ByteString
toByteString Builder
msgB
    msgB :: Builder
msgB = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
             ByteString -> Builder
byteString ByteString
"A web handler threw an exception. Details:\n"
           , String -> Builder
stringUtf8 (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
           ]


------------------------------------------------------------------------------
-- | Returns a 'Config' obtained from parsing command-line options, using the
-- default Snap 'OptDescr' set.
--
-- On Unix systems, the locale is read from the @LANG@ environment variable.
commandLineConfig :: MonadSnap m
                  => Config m a
                      -- ^ default configuration. This is combined with
                      -- 'defaultConfig' to obtain default values to use if the
                      -- given parameter is specified on the command line.
                      -- Usually it is fine to use 'emptyConfig' here.
                  -> IO (Config m a)
commandLineConfig :: Config m a -> IO (Config m a)
commandLineConfig Config m a
defaults = [OptDescr (Maybe (Config m a))]
-> (a -> a -> a) -> Config m a -> IO (Config m a)
forall (m :: * -> *) a.
MonadSnap m =>
[OptDescr (Maybe (Config m a))]
-> (a -> a -> a) -> Config m a -> IO (Config m a)
extendedCommandLineConfig (Config m a -> [OptDescr (Maybe (Config m a))]
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> [OptDescr (Maybe (Config m a))]
optDescrs Config m a
defaults) a -> a -> a
forall a. a
f Config m a
defaults
  where
    -- Here getOpt can ever change the "other" field, because we only use the
    -- Snap OptDescr list. The combining function will never be invoked.
    f :: a
f = a
forall a. HasCallStack => a
undefined


------------------------------------------------------------------------------
-- | Returns a 'Config' obtained from parsing command-line options, using the
-- default Snap 'OptDescr' set as well as a list of user OptDescrs. User
-- OptDescrs use the \"other\" field (accessible using 'getOther' and
-- 'setOther') to store additional command-line option state. These are
-- combined using a user-defined combining function.
--
-- On Unix systems, the locale is read from the @LANG@ environment variable.

extendedCommandLineConfig :: MonadSnap m
                          => [OptDescr (Maybe (Config m a))]
                             -- ^ Full list of command line options (combine
                             -- yours with 'optDescrs' to extend Snap's default
                             -- set of options)
                          -> (a -> a -> a)
                             -- ^ State for multiple invoked user command-line
                             -- options will be combined using this function.
                          -> Config m a
                             -- ^ default configuration. This is combined with
                             -- Snap's 'defaultConfig' to obtain default values
                             -- to use if the given parameter is specified on
                             -- the command line. Usually it is fine to use
                             -- 'emptyConfig' here.
                          -> IO (Config m a)
extendedCommandLineConfig :: [OptDescr (Maybe (Config m a))]
-> (a -> a -> a) -> Config m a -> IO (Config m a)
extendedCommandLineConfig [OptDescr (Maybe (Config m a))]
opts a -> a -> a
combiningFunction Config m a
defaults = do
    [String]
args <- IO [String]
getArgs
    String
prog <- IO String
getProgName

    Config m a
result <- ([String] -> IO (Config m a))
-> (Config m a -> IO (Config m a))
-> Either [String] (Config m a)
-> IO (Config m a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> [String] -> IO (Config m a)
forall (t :: * -> *) b. Foldable t => String -> t String -> IO b
usage String
prog)
                     Config m a -> IO (Config m a)
forall (m :: * -> *) a. Monad m => a -> m a
return
                     (case ArgOrder (Maybe (Config m a))
-> [OptDescr (Maybe (Config m a))]
-> [String]
-> ([Maybe (Config m a)], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder (Maybe (Config m a))
forall a. ArgOrder a
Permute [OptDescr (Maybe (Config m a))]
opts [String]
args of
                        ([Maybe (Config m a)]
f, [String]
_, []  ) -> Either [String] (Config m a)
-> (Config m a -> Either [String] (Config m a))
-> Maybe (Config m a)
-> Either [String] (Config m a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([String] -> Either [String] (Config m a)
forall a b. a -> Either a b
Left []) Config m a -> Either [String] (Config m a)
forall a b. b -> Either a b
Right (Maybe (Config m a) -> Either [String] (Config m a))
-> Maybe (Config m a) -> Either [String] (Config m a)
forall a b. (a -> b) -> a -> b
$
                                        ([Config m a] -> Config m a)
-> Maybe [Config m a] -> Maybe (Config m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Config m a -> Config m a -> Config m a)
-> Config m a -> [Config m a] -> Config m a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Config m a -> Config m a -> Config m a
forall (m :: * -> *). Config m a -> Config m a -> Config m a
combine Config m a
forall a. Monoid a => a
mempty) (Maybe [Config m a] -> Maybe (Config m a))
-> Maybe [Config m a] -> Maybe (Config m a)
forall a b. (a -> b) -> a -> b
$
                                        [Maybe (Config m a)] -> Maybe [Config m a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe (Config m a)]
f
                        ([Maybe (Config m a)]
_, [String]
_, [String]
errs) -> [String] -> Either [String] (Config m a)
forall a b. a -> Either a b
Left [String]
errs)

#ifndef PORTABLE
    Maybe String
lang <- String -> IO (Maybe String)
getEnv String
"LANG"
    Config m a -> IO (Config m a)
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig (Config m a -> IO (Config m a)) -> Config m a -> IO (Config m a)
forall a b. (a -> b) -> a -> b
$ [Config m a] -> Config m a
forall a. Monoid a => [a] -> a
mconcat [Config m a
defaults,
                              Config m a
forall a. Monoid a => a
mempty {locale :: Maybe String
locale = ShowS -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
upToUtf8 Maybe String
lang},
                              Config m a
result]
#else
    completeConfig $ mconcat [defaults, result]
#endif

  where
    usage :: String -> t String -> IO b
usage String
prog t String
errs = do
        let hdr :: String
hdr = String
"Usage:\n  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
prog String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" [OPTION...]\n\nOptions:"
        let msg :: String
msg = t String -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t String
errs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [OptDescr (Maybe (Config m a))] -> String
forall a. String -> [OptDescr a] -> String
usageInfo String
hdr [OptDescr (Maybe (Config m a))]
opts
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
        IO b
forall a. IO a
exitFailure
#ifndef PORTABLE
    upToUtf8 :: ShowS
upToUtf8 = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Char -> Bool) -> ShowS) -> (Char -> Bool) -> ShowS
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
'_' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c
#endif

    combine :: Config m a -> Config m a -> Config m a
combine !Config m a
a !Config m a
b = Config m a
a Config m a -> Config m a -> Config m a
forall a. Monoid a => a -> a -> a
`mappend` Config m a
b Config m a -> Config m a -> Config m a
forall a. Monoid a => a -> a -> a
`mappend` Config m a
forall (m :: * -> *). Config m a
newOther
      where
        -- combined is only a Just if both a and b have other fields, and then
        -- we use the combining function. Config's mappend picks the last
        -- "Just" in the other list.
        combined :: Maybe a
combined = do
            a
x <- Config m a -> Maybe a
forall (m :: * -> *) a. Config m a -> Maybe a
getOther Config m a
a
            a
y <- Config m a -> Maybe a
forall (m :: * -> *) a. Config m a -> Maybe a
getOther Config m a
b
            a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$! a -> a -> a
combiningFunction a
x a
y

        newOther :: Config m a
newOther = Config m a
forall a. Monoid a => a
mempty { other :: Maybe a
other = Maybe a
combined }

fmapArg :: (a -> b) -> ArgDescr a -> ArgDescr b
fmapArg :: (a -> b) -> ArgDescr a -> ArgDescr b
fmapArg a -> b
f (NoArg a
a) = b -> ArgDescr b
forall a. a -> ArgDescr a
NoArg (a -> b
f a
a)
fmapArg a -> b
f (ReqArg String -> a
g String
s) = (String -> b) -> String -> ArgDescr b
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (a -> b
f (a -> b) -> (String -> a) -> String -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
g) String
s
fmapArg a -> b
f (OptArg Maybe String -> a
g String
s) = (Maybe String -> b) -> String -> ArgDescr b
forall a. (Maybe String -> a) -> String -> ArgDescr a
OptArg (a -> b
f (a -> b) -> (Maybe String -> a) -> Maybe String -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> a
g) String
s

fmapOpt :: (a -> b) -> OptDescr a -> OptDescr b
fmapOpt :: (a -> b) -> OptDescr a -> OptDescr b
fmapOpt a -> b
f (Option String
s [String]
l ArgDescr a
d String
e) = String -> [String] -> ArgDescr b -> String -> OptDescr b
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
s [String]
l ((a -> b) -> ArgDescr a -> ArgDescr b
forall a b. (a -> b) -> ArgDescr a -> ArgDescr b
fmapArg a -> b
f ArgDescr a
d) String
e


------------------------------------------------------------------------------
requestErrorMessage :: Request -> SomeException -> Builder
requestErrorMessage :: Request -> SomeException -> Builder
requestErrorMessage Request
req SomeException
e =
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"During processing of request from "
            , ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqClientAddr Request
req
            , ByteString -> Builder
byteString ByteString
":"
            , Int -> Builder
forall a. Show a => a -> Builder
fromShow (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> Int
rqClientPort Request
req
            , ByteString -> Builder
byteString ByteString
"\nrequest:\n"
            , String -> Builder
forall a. Show a => a -> Builder
fromShow (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ Request -> String
forall a. Show a => a -> String
show Request
req
            , ByteString -> Builder
byteString ByteString
"\n"
            , Builder
msgB
            ]
  where
    msgB :: Builder
msgB = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
             ByteString -> Builder
byteString ByteString
"A web handler threw an exception. Details:\n"
           , SomeException -> Builder
forall a. Show a => a -> Builder
fromShow SomeException
e
           ]

------------------------------------------------------------------------------
fromShow :: Show a => a -> Builder
fromShow :: a -> Builder
fromShow = String -> Builder
stringUtf8 (String -> Builder) -> (a -> String) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show