    {-# LANGUAGE BangPatterns        #-}
    {-# LANGUAGE CPP                 #-}
    {-# LANGUAGE OverloadedStrings   #-}
    {-# LANGUAGE ScopedTypeVariables #-}

    ------------------------------------------------------------------------------
    -- | The Snap HTTP server is a high performance web server library written in
    -- Haskell. Together with the @snap-core@ library upon which it depends, it
    -- provides a clean and efficient Haskell programming interface to the HTTP
    -- protocol.
    --
    module Snap.Http.Server
      ( simpleHttpServe
      , httpServe
      , quickHttpServe
      , snapServerVersion
      , setUnicodeLocale
      , rawHttpServe
      , module Snap.Http.Server.Config
      ) where

    ------------------------------------------------------------------------------
    import           Control.Applicative               ((<$>), (<|>))
    import           Control.Concurrent                (killThread, newEmptyMVar, newMVar, putMVar, readMVar, withMVar)
    import           Control.Concurrent.Extended       (forkIOLabeledWithUnmaskBs)
    import           Control.Exception                 (SomeException, bracket, catch, finally, mask, mask_)
    import qualified Control.Exception.Lifted          as L
    import           Control.Monad                     (liftM, when)
    import           Control.Monad.Trans               (MonadIO)
    import           Data.ByteString.Char8             (ByteString)
    import qualified Data.ByteString.Char8             as S
    import qualified Data.ByteString.Lazy.Char8        as L
    import           Data.Maybe                        (catMaybes, fromJust, fromMaybe)
    import qualified Data.Text                         as T
    import qualified Data.Text.Encoding                as T
    import           Data.Version                      (showVersion)
    import           Data.Word                         (Word64)
    import           Network.Socket                    (Socket, close)
    import           Prelude                           (Bool (..), Eq (..), IO, Maybe (..), Monad (..), Show (..), String, const, flip, fst, id, mapM, mapM_, maybe, snd, unzip3, zip, ($), ($!), (++), (.))
    import           System.IO                         (hFlush, hPutStrLn, stderr)
    #ifndef PORTABLE
    import           System.Posix.Env
    #endif
    ------------------------------------------------------------------------------
    import           Data.ByteString.Builder           (Builder, toLazyByteString)
    ------------------------------------------------------------------------------
    import qualified Paths_snap_server                 as V
    import           Snap.Core                         (MonadSnap (..), Request, Response, Snap, rqClientAddr, rqHeaders, rqMethod, rqURI, rqVersion, rspStatus)
    -- Don't use explicit imports for Snap.Http.Server.Config because we're
    -- re-exporting everything.
    import           Snap.Http.Server.Config
    import qualified Snap.Http.Server.Types            as Ty
    import           Snap.Internal.Debug               (debug)
    import           Snap.Internal.Http.Server.Config  (ProxyType (..), emptyStartupInfo, setStartupConfig, setStartupSockets)
    import           Snap.Internal.Http.Server.Session (httpAcceptLoop, snapToServerHandler)
    import qualified Snap.Internal.Http.Server.Socket  as Sock
    import qualified Snap.Internal.Http.Server.TLS     as TLS
    import           Snap.Internal.Http.Server.Types   (AcceptFunc, ServerConfig, ServerHandler)
    import qualified Snap.Types.Headers                as H
    import           Snap.Util.GZip                    (withCompression)
    import           Snap.Util.Proxy                   (behindProxy)
    import qualified Snap.Util.Proxy                   as Proxy
    import           System.FastLogger                 (combinedLogEntry, logMsg, newLoggerWithCustomErrorFunction, stopLogger, timestampedLogEntry)

    ------------------------------------------------------------------------------
    -- | A short string describing the Snap server version
    snapServerVersion :: ByteString
    snapServerVersion :: ByteString
    snapServerVersion = [Char] -> ByteString
    S.pack ([Char] -> ByteString) -> [Char] -> ByteString
    forall a b. (a -> b) -> a -> b
    $! Version -> [Char]
    showVersion Version
    V.version

    ------------------------------------------------------------------------------
    rawHttpServe :: ServerHandler s  -- ^ server handler
                 -> ServerConfig s   -- ^ server config
                 -> [AcceptFunc]     -- ^ listening server backends
                 -> IO ()
    rawHttpServe :: forall s.
    ServerHandler s -> ServerConfig s -> [AcceptFunc] -> IO ()
    rawHttpServe ServerHandler s
    h ServerConfig s
    cfg [AcceptFunc]
    loops = do
        mvars <- (AcceptFunc -> IO (MVar ())) -> [AcceptFunc] -> IO [MVar ()]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (IO (MVar ()) -> AcceptFunc -> IO (MVar ())
    forall a b. a -> b -> a
    const IO (MVar ())
    forall a. IO (MVar a)
    newEmptyMVar) [AcceptFunc]
    loops
        mask $ \forall a. IO a -> IO a
    restore -> IO [(MVar (), ThreadId)]
    -> ([(MVar (), ThreadId)] -> IO ())
    -> ([(MVar (), ThreadId)] -> IO ())
    -> IO ()
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket (((MVar (), AcceptFunc) -> IO (MVar (), ThreadId))
    -> [(MVar (), AcceptFunc)] -> IO [(MVar (), ThreadId)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (MVar (), AcceptFunc) -> IO (MVar (), ThreadId)
    runLoop ([(MVar (), AcceptFunc)] -> IO [(MVar (), ThreadId)])
    -> [(MVar (), AcceptFunc)] -> IO [(MVar (), ThreadId)]
    forall a b. (a -> b) -> a -> b
    $ [MVar ()]
    mvars [MVar ()] -> [AcceptFunc] -> [(MVar (), AcceptFunc)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [AcceptFunc]
    loops)
                                   (\[(MVar (), ThreadId)]
    mvTids -> do
                                       ((MVar (), ThreadId) -> IO ()) -> [(MVar (), ThreadId)] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (ThreadId -> IO ()
    killThread (ThreadId -> IO ())
    -> ((MVar (), ThreadId) -> ThreadId)
    -> (MVar (), ThreadId)
    -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (MVar (), ThreadId) -> ThreadId
    forall a b. (a, b) -> b
    snd) [(MVar (), ThreadId)]
    mvTids
                                       ((MVar (), ThreadId) -> IO ()) -> [(MVar (), ThreadId)] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (MVar () -> IO ()
    forall a. MVar a -> IO a
    readMVar (MVar () -> IO ())
    -> ((MVar (), ThreadId) -> MVar ()) -> (MVar (), ThreadId) -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (MVar (), ThreadId) -> MVar ()
    forall a b. (a, b) -> a
    fst) [(MVar (), ThreadId)]
    mvTids)
                                   (IO () -> [(MVar (), ThreadId)] -> IO ()
    forall a b. a -> b -> a
    const (IO () -> [(MVar (), ThreadId)] -> IO ())
    -> IO () -> [(MVar (), ThreadId)] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ IO () -> IO ()
    forall a. IO a -> IO a
    restore (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (MVar () -> IO ()) -> [MVar ()] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ MVar () -> IO ()
    forall a. MVar a -> IO a
    readMVar [MVar ()]
    mvars)
      where
        -- parents and children have a mutual suicide pact
        runLoop :: (MVar (), AcceptFunc) -> IO (MVar (), ThreadId)
    runLoop (MVar ()
    mvar, AcceptFunc
    loop) = do
            tid <- ByteString -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
    forkIOLabeledWithUnmaskBs
                   ByteString
    "snap-server http master thread" (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
    -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
    forall a b. (a -> b) -> a -> b
    $
                   \forall a. IO a -> IO a
    r -> (IO () -> IO ()
    forall a. IO a -> IO a
    r (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ServerHandler s -> ServerConfig s -> AcceptFunc -> IO ()
    forall hookState.
    ServerHandler hookState
    -> ServerConfig hookState -> AcceptFunc -> IO ()
    httpAcceptLoop ServerHandler s
    h ServerConfig s
    cfg AcceptFunc
    loop) IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO a
    `finally` MVar () -> () -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar ()
    mvar ()
            return (mvar, tid)

    ------------------------------------------------------------------------------
    -- | Starts serving HTTP requests using the given handler. This function never
    -- returns; to shut down the HTTP server, kill the controlling thread.
    --
    -- This function is like 'httpServe' except it doesn't setup compression,
    -- reverse proxy address translation (via 'Snap.Util.Proxy.behindProxy'), or
    -- the error handler; this allows it to be used from 'MonadSnap'.
    simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()
    simpleHttpServe :: forall (m :: * -> *) a.
    MonadSnap m =>
    Config m a -> Snap () -> IO ()
    simpleHttpServe Config m a
    config Snap ()
    handler = do
        conf <- Config m a -> IO (Config m a)
    forall (m :: * -> *) a.
    MonadSnap m =>
    Config m a -> IO (Config m a)
    completeConfig Config m a
    config
        let output = Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Maybe Bool -> Bool
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe Bool -> Bool) -> Maybe Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ Config m a -> Maybe Bool
    forall (m :: * -> *) a. Config m a -> Maybe Bool
    getVerbose Config m a
    conf) (IO () -> IO ()) -> ([Char] -> IO ()) -> [Char] -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Handle -> [Char] -> IO ()
    hPutStrLn Handle
    stderr
        (descrs, sockets, afuncs) <- unzip3 <$> listeners conf
        mapM_ (output . ("Listening on " ++) . S.unpack) descrs

        go conf sockets afuncs `finally` (mask_ $ do
            output "\nShutting down.."
            mapM_ (eatException . close) sockets)

      where
        eatException :: IO a -> IO ()
        eatException :: forall a. IO a -> IO ()
    eatException IO a
    act =
            let r0 :: IO ()
    r0 = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (() -> IO ()) -> () -> IO ()
    forall a b. (a -> b) -> a -> b
    $! ()
            in (IO a
    act IO a -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO ()
    r0) IO () -> (SomeException -> IO ()) -> IO ()
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `catch` \(SomeException
    _::SomeException) -> IO ()
    r0

        --------------------------------------------------------------------------
        -- FIXME: this logging code *sucks*
        --------------------------------------------------------------------------
        debugE :: (MonadIO m) => ByteString -> m ()
        debugE :: forall (m :: * -> *). MonadIO m => ByteString -> m ()
    debugE ByteString
    s = [Char] -> m ()
    forall (m :: * -> *). MonadIO m => [Char] -> m ()
    debug ([Char] -> m ()) -> [Char] -> m ()
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Error: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ByteString -> [Char]
    S.unpack ByteString
    s

        --------------------------------------------------------------------------
        logE :: Maybe (ByteString -> IO ()) -> Builder -> IO ()
        logE :: Maybe (ByteString -> IO ()) -> Builder -> IO ()
    logE Maybe (ByteString -> IO ())
    elog Builder
    b = let x :: ByteString
    x = [ByteString] -> ByteString
    S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
    forall a b. (a -> b) -> a -> b
    $ LazyByteString -> [ByteString]
    L.toChunks (LazyByteString -> [ByteString]) -> LazyByteString -> [ByteString]
    forall a b. (a -> b) -> a -> b
    $ Builder -> LazyByteString
    toLazyByteString Builder
    b
                      in ((ByteString -> IO ())
    -> ((ByteString -> IO ()) -> ByteString -> IO ())
    -> Maybe (ByteString -> IO ())
    -> ByteString
    -> IO ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe ByteString -> IO ()
    forall (m :: * -> *). MonadIO m => ByteString -> m ()
    debugE (\ByteString -> IO ()
    l ByteString
    s -> ByteString -> IO ()
    forall (m :: * -> *). MonadIO m => ByteString -> m ()
    debugE ByteString
    s IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> (ByteString -> IO ()) -> ByteString -> IO ()
    logE' ByteString -> IO ()
    l ByteString
    s) Maybe (ByteString -> IO ())
    elog) ByteString
    x

        --------------------------------------------------------------------------
        logE' :: (ByteString -> IO ()) -> ByteString -> IO ()
        logE' :: (ByteString -> IO ()) -> ByteString -> IO ()
    logE' ByteString -> IO ()
    logger ByteString
    s = (ByteString -> IO ByteString
    timestampedLogEntry ByteString
    s) IO ByteString -> (ByteString -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= ByteString -> IO ()
    logger

        --------------------------------------------------------------------------
        logA :: Maybe (ByteString -> IO ())
             -> Request
             -> Response
             -> Word64
             -> IO ()
        logA :: Maybe (ByteString -> IO ())
    -> Request -> Response -> Word64 -> IO ()
    logA Maybe (ByteString -> IO ())
    alog = (Request -> Response -> Word64 -> IO ())
    -> ((ByteString -> IO ())
        -> Request -> Response -> Word64 -> IO ())
    -> Maybe (ByteString -> IO ())
    -> Request
    -> Response
    -> Word64
    -> IO ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (\Request
    _ Response
    _ Word64
    _ -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (() -> IO ()) -> () -> IO ()
    forall a b. (a -> b) -> a -> b
    $! ()) (ByteString -> IO ()) -> Request -> Response -> Word64 -> IO ()
    forall {b}.
    (ByteString -> IO b) -> Request -> Response -> Word64 -> IO b
    logA' Maybe (ByteString -> IO ())
    alog

        --------------------------------------------------------------------------
        logA' :: (ByteString -> IO b) -> Request -> Response -> Word64 -> IO b
    logA' ByteString -> IO b
    logger Request
    req Response
    rsp Word64
    cl = do
            let hdrs :: Headers
    hdrs      = Request -> Headers
    rqHeaders Request
    req
            let host :: ByteString
    host      = Request -> ByteString
    rqClientAddr Request
    req
            let user :: Maybe a
    user      = Maybe a
    forall a. Maybe a
    Nothing -- TODO we don't do authentication yet
            let (Int
    v, Int
    v')   = Request -> (Int, Int)
    rqVersion Request
    req
            let ver :: ByteString
    ver       = [ByteString] -> ByteString
    S.concat [ ByteString
    "HTTP/", Int -> ByteString
    forall a. Show a => a -> ByteString
    bshow Int
    v, ByteString
    ".", Int -> ByteString
    forall a. Show a => a -> ByteString
    bshow Int
    v' ]
            let method :: ByteString
    method    = Method -> ByteString
    forall a. Show a => a -> ByteString
    bshow (Request -> Method
    rqMethod Request
    req)
            let reql :: ByteString
    reql      = ByteString -> [ByteString] -> ByteString
    S.intercalate ByteString
    " " [ ByteString
    method, Request -> ByteString
    rqURI Request
    req, ByteString
    ver ]
            let status :: Int
    status    = Response -> Int
    rspStatus Response
    rsp
            let referer :: Maybe ByteString
    referer   = CI ByteString -> Headers -> Maybe ByteString
    H.lookup CI ByteString
    "referer" Headers
    hdrs
            let userAgent :: ByteString
    userAgent = ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe ByteString
    "-" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ CI ByteString -> Headers -> Maybe ByteString
    H.lookup CI ByteString
    "user-agent" Headers
    hdrs

            msg <- ByteString
    -> Maybe ByteString
    -> ByteString
    -> Int
    -> Word64
    -> Maybe ByteString
    -> ByteString
    -> IO ByteString
    combinedLogEntry ByteString
    host Maybe ByteString
    forall a. Maybe a
    user ByteString
    reql Int
    status Word64
    cl Maybe ByteString
    referer ByteString
    userAgent
            logger msg

        --------------------------------------------------------------------------
        go :: Config m a -> [Socket] -> [AcceptFunc] -> IO ()
    go Config m a
    conf [Socket]
    sockets [AcceptFunc]
    afuncs = do
            let tout :: Int
    tout = Int -> Maybe Int -> Int
    forall a. a -> Maybe a -> a
    fromMaybe Int
    60 (Maybe Int -> Int) -> Maybe Int -> Int
    forall a b. (a -> b) -> a -> b
    $ Config m a -> Maybe Int
    forall (m :: * -> *) a. Config m a -> Maybe Int
    getDefaultTimeout Config m a
    conf
            let shandler :: ServerHandler hookState
    shandler = Snap () -> ServerHandler hookState
    forall a hookState. Snap a -> ServerHandler hookState
    snapToServerHandler Snap ()
    handler

            [Char] -> IO ()
    setUnicodeLocale ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Maybe [Char] -> [Char]
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
    forall a b. (a -> b) -> a -> b
    $ Config m a -> Maybe [Char]
    forall (m :: * -> *) a. Config m a -> Maybe [Char]
    getLocale Config m a
    conf

            ConfigLog
    -> ConfigLog
    -> ((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
        -> IO ())
    -> IO ()
    forall {c}.
    ConfigLog
    -> ConfigLog
    -> ((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
        -> IO c)
    -> IO c
    withLoggers (Maybe ConfigLog -> ConfigLog
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe ConfigLog -> ConfigLog) -> Maybe ConfigLog -> ConfigLog
    forall a b. (a -> b) -> a -> b
    $ Config m a -> Maybe ConfigLog
    forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
    getAccessLog Config m a
    conf)
                        (Maybe ConfigLog -> ConfigLog
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe ConfigLog -> ConfigLog) -> Maybe ConfigLog -> ConfigLog
    forall a b. (a -> b) -> a -> b
    $ Config m a -> Maybe ConfigLog
    forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
    getErrorLog Config m a
    conf) (((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
      -> IO ())
     -> IO ())
    -> ((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
        -> IO ())
    -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \(Maybe (ByteString -> IO ())
    alog, Maybe (ByteString -> IO ())
    elog) -> do
                let scfg :: ServerConfig hookState
    scfg = Int -> ServerConfig hookState -> ServerConfig hookState
    forall hookState.
    Int -> ServerConfig hookState -> ServerConfig hookState
    Ty.setDefaultTimeout Int
    tout (ServerConfig hookState -> ServerConfig hookState)
    -> (ServerConfig hookState -> ServerConfig hookState)
    -> ServerConfig hookState
    -> ServerConfig hookState
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                           ByteString -> ServerConfig hookState -> ServerConfig hookState
    forall hookState.
    ByteString -> ServerConfig hookState -> ServerConfig hookState
    Ty.setLocalHostname (Maybe ByteString -> ByteString
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Config m a -> Maybe ByteString
    forall (m :: * -> *) a. Config m a -> Maybe ByteString
    getHostname Config m a
    conf) (ServerConfig hookState -> ServerConfig hookState)
    -> (ServerConfig hookState -> ServerConfig hookState)
    -> ServerConfig hookState
    -> ServerConfig hookState
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                           (Request -> Response -> Word64 -> IO ())
    -> ServerConfig hookState -> ServerConfig hookState
    forall hookState.
    (Request -> Response -> Word64 -> IO ())
    -> ServerConfig hookState -> ServerConfig hookState
    Ty.setLogAccess (Maybe (ByteString -> IO ())
    -> Request -> Response -> Word64 -> IO ()
    logA Maybe (ByteString -> IO ())
    alog) (ServerConfig hookState -> ServerConfig hookState)
    -> (ServerConfig hookState -> ServerConfig hookState)
    -> ServerConfig hookState
    -> ServerConfig hookState
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                           (Builder -> IO ())
    -> ServerConfig hookState -> ServerConfig hookState
    forall hookState.
    (Builder -> IO ())
    -> ServerConfig hookState -> ServerConfig hookState
    Ty.setLogError (Maybe (ByteString -> IO ()) -> Builder -> IO ()
    logE Maybe (ByteString -> IO ())
    elog) (ServerConfig hookState -> ServerConfig hookState)
    -> ServerConfig hookState -> ServerConfig hookState
    forall a b. (a -> b) -> a -> b
    $
                           ServerConfig hookState
    forall a. ServerConfig a
    Ty.emptyServerConfig
                IO ()
    -> ((StartupInfo m a -> IO ()) -> IO ())
    -> Maybe (StartupInfo m a -> IO ())
    -> IO ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (() -> IO ()) -> () -> IO ()
    forall a b. (a -> b) -> a -> b
    $! ())
                      ((StartupInfo m a -> IO ()) -> StartupInfo m a -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Socket] -> Config m a -> StartupInfo m a
    forall {m :: * -> *} {a}. [Socket] -> Config m a -> StartupInfo m a
    mkStartupInfo [Socket]
    sockets Config m a
    conf)
                      (Config m a -> Maybe (StartupInfo m a -> IO ())
    forall (m :: * -> *) a.
    Config m a -> Maybe (StartupInfo m a -> IO ())
    getStartupHook Config m a
    conf)
                ServerHandler (ZonkAny 0)
    -> ServerConfig (ZonkAny 0) -> [AcceptFunc] -> IO ()
    forall s.
    ServerHandler s -> ServerConfig s -> [AcceptFunc] -> IO ()
    rawHttpServe ServerHandler (ZonkAny 0)
    forall {hookState}. ServerHandler hookState
    shandler ServerConfig (ZonkAny 0)
    forall a. ServerConfig a
    scfg [AcceptFunc]
    afuncs

        --------------------------------------------------------------------------
        mkStartupInfo :: [Socket] -> Config m a -> StartupInfo m a
    mkStartupInfo [Socket]
    sockets Config m a
    conf =
            [Socket] -> StartupInfo m a -> StartupInfo m a
    forall (m :: * -> *) a.
    [Socket] -> StartupInfo m a -> StartupInfo m a
    setStartupSockets [Socket]
    sockets (StartupInfo m a -> StartupInfo m a)
    -> StartupInfo m a -> StartupInfo m a
    forall a b. (a -> b) -> a -> b
    $
            Config m a -> StartupInfo m a -> StartupInfo m a
    forall (m :: * -> *) a.
    Config m a -> StartupInfo m a -> StartupInfo m a
    setStartupConfig Config m a
    conf StartupInfo m a
    forall (m :: * -> *) a. StartupInfo m a
    emptyStartupInfo

        --------------------------------------------------------------------------
        maybeSpawnLogger :: (ByteString -> IO ()) -> ConfigLog -> IO (Maybe Logger)
    maybeSpawnLogger ByteString -> IO ()
    f (ConfigFileLog [Char]
    fp) =
            (Logger -> Maybe Logger) -> IO Logger -> IO (Maybe Logger)
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM Logger -> Maybe Logger
    forall a. a -> Maybe a
    Just (IO Logger -> IO (Maybe Logger)) -> IO Logger -> IO (Maybe Logger)
    forall a b. (a -> b) -> a -> b
    $ (ByteString -> IO ()) -> [Char] -> IO Logger
    newLoggerWithCustomErrorFunction ByteString -> IO ()
    f [Char]
    fp
        maybeSpawnLogger ByteString -> IO ()
    _ ConfigLog
    _                  = Maybe Logger -> IO (Maybe Logger)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Logger
    forall a. Maybe a
    Nothing

        --------------------------------------------------------------------------
        maybeIoLog :: ConfigLog -> Maybe (ByteString -> IO ())
    maybeIoLog (ConfigIoLog ByteString -> IO ()
    a) = (ByteString -> IO ()) -> Maybe (ByteString -> IO ())
    forall a. a -> Maybe a
    Just ByteString -> IO ()
    a
        maybeIoLog ConfigLog
    _               = Maybe (ByteString -> IO ())
    forall a. Maybe a
    Nothing

        --------------------------------------------------------------------------
        withLoggers :: ConfigLog
    -> ConfigLog
    -> ((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
        -> IO c)
    -> IO c
    withLoggers ConfigLog
    afp ConfigLog
    efp (Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ())) -> IO c
    act =
            IO (Maybe Logger, Maybe Logger)
    -> ((Maybe Logger, Maybe Logger) -> IO ())
    -> ((Maybe Logger, Maybe Logger) -> IO c)
    -> IO c
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket (do mvar <- () -> IO (MVar ())
    forall a. a -> IO (MVar a)
    newMVar ()
                        let f ByteString
    s = MVar () -> (() -> IO ()) -> IO ()
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar MVar ()
    mvar
                                    (IO () -> () -> IO ()
    forall a b. a -> b -> a
    const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> ByteString -> IO ()
    S.hPutStr Handle
    stderr ByteString
    s IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Handle -> IO ()
    hFlush Handle
    stderr)
                        alog <- maybeSpawnLogger f afp
                        elog <- maybeSpawnLogger f efp
                        return (alog, elog))
                    (\(Maybe Logger
    alog, Maybe Logger
    elog) -> do
                        IO () -> (Logger -> IO ()) -> Maybe Logger -> IO ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()) Logger -> IO ()
    stopLogger Maybe Logger
    alog
                        IO () -> (Logger -> IO ()) -> Maybe Logger -> IO ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()) Logger -> IO ()
    stopLogger Maybe Logger
    elog)
                    (\(Maybe Logger
    alog, Maybe Logger
    elog) -> (Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ())) -> IO c
    act ( (Logger -> ByteString -> IO ())
    -> Maybe Logger -> Maybe (ByteString -> IO ())
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM Logger -> ByteString -> IO ()
    logMsg Maybe Logger
    alog Maybe (ByteString -> IO ())
    -> Maybe (ByteString -> IO ()) -> Maybe (ByteString -> IO ())
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> ConfigLog -> Maybe (ByteString -> IO ())
    maybeIoLog ConfigLog
    afp
                                          , (Logger -> ByteString -> IO ())
    -> Maybe Logger -> Maybe (ByteString -> IO ())
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM Logger -> ByteString -> IO ()
    logMsg Maybe Logger
    elog Maybe (ByteString -> IO ())
    -> Maybe (ByteString -> IO ()) -> Maybe (ByteString -> IO ())
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> ConfigLog -> Maybe (ByteString -> IO ())
    maybeIoLog ConfigLog
    efp))
    {-# INLINE simpleHttpServe #-}

    ------------------------------------------------------------------------------
    listeners :: Config m a -> IO [(ByteString, Socket, AcceptFunc)]
    listeners :: forall (m :: * -> *) a.
    Config m a -> IO [(ByteString, Socket, AcceptFunc)]
    listeners Config m a
    conf = IO [(ByteString, Socket, AcceptFunc)]
    -> IO [(ByteString, Socket, AcceptFunc)]
    forall a. IO a -> IO a
    TLS.withTLS (IO [(ByteString, Socket, AcceptFunc)]
     -> IO [(ByteString, Socket, AcceptFunc)])
    -> IO [(ByteString, Socket, AcceptFunc)]
    -> IO [(ByteString, Socket, AcceptFunc)]
    forall a b. (a -> b) -> a -> b
    $ do
      let fs :: [(ByteString, IO (Socket, AcceptFunc))]
    fs = [Maybe (ByteString, IO (Socket, AcceptFunc))]
    -> [(ByteString, IO (Socket, AcceptFunc))]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe (ByteString, IO (Socket, AcceptFunc))
    httpListener, Maybe (ByteString, IO (Socket, AcceptFunc))
    httpsListener, Maybe (ByteString, IO (Socket, AcceptFunc))
    unixListener]
      ((ByteString, IO (Socket, AcceptFunc))
     -> IO (ByteString, Socket, AcceptFunc))
    -> [(ByteString, IO (Socket, AcceptFunc))]
    -> IO [(ByteString, Socket, AcceptFunc)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (\(ByteString
    str, IO (Socket, AcceptFunc)
    mkAfunc) -> do (sock, afunc) <- IO (Socket, AcceptFunc)
    mkAfunc
                                  return $! (str, sock, afunc)) [(ByteString, IO (Socket, AcceptFunc))]
    fs
      where
        httpsListener :: Maybe (ByteString, IO (Socket, AcceptFunc))
    httpsListener = do
            b    <- Config m a -> Maybe ByteString
    forall (m :: * -> *) a. Config m a -> Maybe ByteString
    getSSLBind Config m a
    conf
            p    <- getSSLPort conf
            cert <- getSSLCert conf
            chainCert <- getSSLChainCert conf
            key  <- getSSLKey conf
            return (S.concat [ "https://"
                             , b
                             , ":"
                             , bshow p ],
                    do (sock, ctx) <- TLS.bindHttps b p cert chainCert key
                       return (sock, TLS.httpsAcceptFunc sock ctx)
                    )
        httpListener :: Maybe (ByteString, IO (Socket, AcceptFunc))
    httpListener = do
            p <- Config m a -> Maybe Int
    forall (m :: * -> *) a. Config m a -> Maybe Int
    getPort Config m a
    conf
            b <- getBind conf
            return (S.concat [ "http://"
                             , b
                             , ":"
                             , bshow p ],
                    do sock <- Sock.bindSocket b p
                       if getProxyType conf == Just HaProxy
                         then return (sock, Sock.haProxyAcceptFunc sock)
                         else return (sock, Sock.httpAcceptFunc sock))
        unixListener :: Maybe (ByteString, IO (Socket, AcceptFunc))
    unixListener = do
            path <- Config m a -> Maybe [Char]
    forall (m :: * -> *) a. Config m a -> Maybe [Char]
    getUnixSocket Config m a
    conf
            let accessMode = Config m a -> Maybe Int
    forall (m :: * -> *) a. Config m a -> Maybe Int
    getUnixSocketAccessMode Config m a
    conf
            return (T.encodeUtf8 . T.pack  $ "unix:" ++ path,
                     do sock <- Sock.bindUnixSocket accessMode path
                        return (sock, Sock.httpAcceptFunc sock))

    ------------------------------------------------------------------------------
    -- | Starts serving HTTP requests using the given handler, with settings from
    -- the 'Config' passed in. This function never returns; to shut down the HTTP
    -- server, kill the controlling thread.
    httpServe :: Config Snap a -> Snap () -> IO ()
    httpServe :: forall a. Config Snap a -> Snap () -> IO ()
    httpServe Config Snap a
    config Snap ()
    handler0 = do
        conf <- Config Snap a -> IO (Config Snap a)
    forall (m :: * -> *) a.
    MonadSnap m =>
    Config m a -> IO (Config m a)
    completeConfig Config Snap a
    config
        let !handler = Config Snap a -> Snap ()
    forall {m :: * -> *} {a}. Config m a -> Snap ()
    chooseProxy Config Snap a
    conf
        let serve    = Config Snap a -> Snap () -> Snap ()
    forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
    compress Config Snap a
    conf (Snap () -> Snap ()) -> (Snap () -> Snap ()) -> Snap () -> Snap ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Config Snap a -> Snap () -> Snap ()
    forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
    catch500 Config Snap a
    conf (Snap () -> Snap ()) -> Snap () -> Snap ()
    forall a b. (a -> b) -> a -> b
    $ Snap ()
    handler
        simpleHttpServe conf serve

      where
        chooseProxy :: Config m a -> Snap ()
    chooseProxy Config m a
    conf = Snap () -> (ProxyType -> Snap ()) -> Maybe ProxyType -> Snap ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Snap ()
    handler0
                                 (\ProxyType
    ptype -> ProxyType -> Snap () -> Snap ()
    forall {m :: * -> *} {a}. MonadSnap m => ProxyType -> m a -> m a
    pickProxy ProxyType
    ptype Snap ()
    handler0)
                                 (Config m a -> Maybe ProxyType
    forall (m :: * -> *) a. Config m a -> Maybe ProxyType
    getProxyType Config m a
    conf)

        pickProxy :: ProxyType -> m a -> m a
    pickProxy ProxyType
    NoProxy         = m a -> m a
    forall a. a -> a
    id
        pickProxy ProxyType
    HaProxy         = m a -> m a
    forall a. a -> a
    id  -- we handle this case elsewhere
        pickProxy ProxyType
    X_Forwarded_For = ProxyType -> m a -> m a
    forall (m :: * -> *) a. MonadSnap m => ProxyType -> m a -> m a
    behindProxy ProxyType
    Proxy.X_Forwarded_For

    ------------------------------------------------------------------------------
    catch500 :: MonadSnap m => Config m a -> m () -> m ()
    catch500 :: forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
    catch500 Config m a
    conf = (m () -> (SomeException -> m ()) -> m ())
    -> (SomeException -> m ()) -> m () -> m ()
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip m () -> (SomeException -> m ()) -> m ()
    forall (m :: * -> *) e a.
    (MonadBaseControl IO m, Exception e) =>
    m a -> (e -> m a) -> m a
    L.catch ((SomeException -> m ()) -> m () -> m ())
    -> (SomeException -> m ()) -> m () -> m ()
    forall a b. (a -> b) -> a -> b
    $ Maybe (SomeException -> m ()) -> SomeException -> m ()
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe (SomeException -> m ()) -> SomeException -> m ())
    -> Maybe (SomeException -> m ()) -> SomeException -> m ()
    forall a b. (a -> b) -> a -> b
    $ Config m a -> Maybe (SomeException -> m ())
    forall (m :: * -> *) a. Config m a -> Maybe (SomeException -> m ())
    getErrorHandler Config m a
    conf

    ------------------------------------------------------------------------------
    compress :: MonadSnap m => Config m a -> m () -> m ()
    compress :: forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
    compress Config m a
    conf = if Maybe Bool -> Bool
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe Bool -> Bool) -> Maybe Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ Config m a -> Maybe Bool
    forall (m :: * -> *) a. Config m a -> Maybe Bool
    getCompression Config m a
    conf then m () -> m ()
    forall (m :: * -> *) a. MonadSnap m => m a -> m ()
    withCompression else m () -> m ()
    forall a. a -> a
    id

    ------------------------------------------------------------------------------
    -- | Starts serving HTTP using the given handler. The configuration is read
    -- from the options given on the command-line, as returned by
    -- 'commandLineConfig'. This function never returns; to shut down the HTTP
    -- server, kill the controlling thread.
    quickHttpServe :: Snap () -> IO ()
    quickHttpServe :: Snap () -> IO ()
    quickHttpServe Snap ()
    handler = do
        conf <- Config Snap (ZonkAny 1) -> IO (Config Snap (ZonkAny 1))
    forall (m :: * -> *) a.
    MonadSnap m =>
    Config m a -> IO (Config m a)
    commandLineConfig Config Snap (ZonkAny 1)
    forall (m :: * -> *) a. MonadSnap m => Config m a
    defaultConfig
        httpServe conf handler

    ------------------------------------------------------------------------------
    -- | Given a string like \"en_US\", this sets the locale to \"en_US.UTF-8\".
    -- This doesn't work on Windows.
    setUnicodeLocale :: String -> IO ()
    #ifndef PORTABLE
    setUnicodeLocale :: [Char] -> IO ()
    setUnicodeLocale [Char]
    lang = ([Char] -> IO ()) -> [[Char]] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (\[Char]
    k -> [Char] -> [Char] -> Bool -> IO ()
    setEnv [Char]
    k ([Char]
    lang [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    ".UTF-8") Bool
    True)
                                [ [Char]
    "LANG"
                                , [Char]
    "LC_CTYPE"
                                , [Char]
    "LC_NUMERIC"
                                , [Char]
    "LC_TIME"
                                , [Char]
    "LC_COLLATE"
                                , [Char]
    "LC_MONETARY"
                                , [Char]
    "LC_MESSAGES"
                                , [Char]
    "LC_PAPER"
                                , [Char]
    "LC_NAME"
                                , [Char]
    "LC_ADDRESS"
                                , [Char]
    "LC_TELEPHONE"
                                , [Char]
    "LC_MEASUREMENT"
                                , [Char]
    "LC_IDENTIFICATION"
                                , [Char]
    "LC_ALL" ]
    #else
    setUnicodeLocale = const $ return ()
    #endif

    ------------------------------------------------------------------------------
    bshow :: (Show a) => a -> ByteString
    bshow :: forall a. Show a => a -> ByteString
    bshow = [Char] -> ByteString
    S.pack ([Char] -> ByteString) -> (a -> [Char]) -> a -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> [Char]
    forall a. Show a => a -> [Char]
    show