{-# 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 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
    [MVar ()]
mvars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const forall a. IO (MVar a)
newEmptyMVar) [AcceptFunc]
loops
    forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MVar (), AcceptFunc) -> IO (MVar (), ThreadId)
runLoop forall a b. (a -> b) -> a -> b
$ [MVar ()]
mvars forall a b. [a] -> [b] -> [(a, b)]
`zip` [AcceptFunc]
loops)
                               (\[(MVar (), ThreadId)]
mvTids -> do
                                   forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ThreadId -> IO ()
killThread forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(MVar (), ThreadId)]
mvTids
                                   forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. MVar a -> IO a
readMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(MVar (), ThreadId)]
mvTids)
                               (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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
        ThreadId
tid <- ByteString -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOLabeledWithUnmaskBs
               ByteString
"snap-server http master thread" forall a b. (a -> b) -> a -> b
$
               \forall a. IO a -> IO a
r -> (forall a. IO a -> IO a
r forall a b. (a -> b) -> a -> b
$ forall hookState.
ServerHandler hookState
-> ServerConfig hookState -> AcceptFunc -> IO ()
httpAcceptLoop ServerHandler s
h ServerConfig s
cfg AcceptFunc
loop) forall a b. IO a -> IO b -> IO a
`finally` forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
        forall (m :: * -> *) a. Monad m => a -> m a
return (MVar ()
mvar, ThreadId
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
    Config m a
conf <- forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig Config m a
config
    let output :: [Char] -> IO ()
output = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe Bool
getVerbose Config m a
conf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr
    ([ByteString]
descrs, [Socket]
sockets, [AcceptFunc]
afuncs) <- forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Config m a -> IO [(ByteString, Socket, AcceptFunc)]
listeners Config m a
conf
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
output forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Listening on " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
S.unpack) [ByteString]
descrs

    forall {m :: * -> *} {a}.
Config m a -> [Socket] -> [AcceptFunc] -> IO ()
go Config m a
conf [Socket]
sockets [AcceptFunc]
afuncs forall a b. IO a -> IO b -> IO a
`finally` (forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
        [Char] -> IO ()
output [Char]
"\nShutting down.."
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. IO a -> IO ()
eatException forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO ()
close) [Socket]
sockets)

  where
    eatException :: IO a -> IO ()
    eatException :: forall a. IO a -> IO ()
eatException IO a
act =
        let r0 :: IO ()
r0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()
        in (IO a
act forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
r0) 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 = forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Error: " 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 forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
b
                  in (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugE (\ByteString -> IO ()
l ByteString
s -> forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugE ByteString
s 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) 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (\Request
_ Response
_ Word64
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()) 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      = 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/", forall a. Show a => a -> ByteString
bshow Int
v, ByteString
".", forall a. Show a => a -> ByteString
bshow Int
v' ]
        let method :: ByteString
method    = 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 = forall a. a -> Maybe a -> a
fromMaybe ByteString
"-" forall a b. (a -> b) -> a -> b
$ CI ByteString -> Headers -> Maybe ByteString
H.lookup CI ByteString
"user-agent" Headers
hdrs

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

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

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

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

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

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

    --------------------------------------------------------------------------
    maybeIoLog :: ConfigLog -> Maybe (ByteString -> IO ())
maybeIoLog (ConfigIoLog ByteString -> IO ()
a) = forall a. a -> Maybe a
Just ByteString -> IO ()
a
    maybeIoLog ConfigLog
_               = 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 =
        forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (do MVar ()
mvar <- forall a. a -> IO (MVar a)
newMVar ()
                    let f :: ByteString -> IO ()
f ByteString
s = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
mvar
                                (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
S.hPutStr Handle
stderr ByteString
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stderr)
                    Maybe Logger
alog <- (ByteString -> IO ()) -> ConfigLog -> IO (Maybe Logger)
maybeSpawnLogger ByteString -> IO ()
f ConfigLog
afp
                    Maybe Logger
elog <- (ByteString -> IO ()) -> ConfigLog -> IO (Maybe Logger)
maybeSpawnLogger ByteString -> IO ()
f ConfigLog
efp
                    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Logger
alog, Maybe Logger
elog))
                (\(Maybe Logger
alog, Maybe Logger
elog) -> do
                    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Logger -> IO ()
stopLogger Maybe Logger
alog
                    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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 ( forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Logger -> ByteString -> IO ()
logMsg Maybe Logger
alog forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ConfigLog -> Maybe (ByteString -> IO ())
maybeIoLog ConfigLog
afp
                                      , forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Logger -> ByteString -> IO ()
logMsg Maybe Logger
elog 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 = forall a. IO a -> IO a
TLS.withTLS forall a b. (a -> b) -> a -> b
$ do
  let fs :: [(ByteString, IO (Socket, AcceptFunc))]
fs = forall a. [Maybe a] -> [a]
catMaybes [Maybe (ByteString, IO (Socket, AcceptFunc))
httpListener, Maybe (ByteString, IO (Socket, AcceptFunc))
httpsListener, Maybe (ByteString, IO (Socket, AcceptFunc))
unixListener]
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(ByteString
str, IO (Socket, AcceptFunc)
mkAfunc) -> do (Socket
sock, AcceptFunc
afunc) <- IO (Socket, AcceptFunc)
mkAfunc
                              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (ByteString
str, Socket
sock, AcceptFunc
afunc)) [(ByteString, IO (Socket, AcceptFunc))]
fs
  where
    httpsListener :: Maybe (ByteString, IO (Socket, AcceptFunc))
httpsListener = do
        ByteString
b    <- forall (m :: * -> *) a. Config m a -> Maybe ByteString
getSSLBind Config m a
conf
        Int
p    <- forall (m :: * -> *) a. Config m a -> Maybe Int
getSSLPort Config m a
conf
        [Char]
cert <- forall (m :: * -> *) a. Config m a -> Maybe [Char]
getSSLCert Config m a
conf
        Bool
chainCert <- forall (m :: * -> *) a. Config m a -> Maybe Bool
getSSLChainCert Config m a
conf
        [Char]
key  <- forall (m :: * -> *) a. Config m a -> Maybe [Char]
getSSLKey Config m a
conf
        forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
S.concat [ ByteString
"https://"
                         , ByteString
b
                         , ByteString
":"
                         , forall a. Show a => a -> ByteString
bshow Int
p ],
                do (Socket
sock, ()
ctx) <- ByteString -> Int -> [Char] -> Bool -> [Char] -> IO (Socket, ())
TLS.bindHttps ByteString
b Int
p [Char]
cert Bool
chainCert [Char]
key
                   forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> () -> AcceptFunc
TLS.httpsAcceptFunc Socket
sock ()
ctx)
                )
    httpListener :: Maybe (ByteString, IO (Socket, AcceptFunc))
httpListener = do
        Int
p <- forall (m :: * -> *) a. Config m a -> Maybe Int
getPort Config m a
conf
        ByteString
b <- forall (m :: * -> *) a. Config m a -> Maybe ByteString
getBind Config m a
conf
        forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
S.concat [ ByteString
"http://"
                         , ByteString
b
                         , ByteString
":"
                         , forall a. Show a => a -> ByteString
bshow Int
p ],
                do Socket
sock <- ByteString -> Int -> IO Socket
Sock.bindSocket ByteString
b Int
p
                   if forall (m :: * -> *) a. Config m a -> Maybe ProxyType
getProxyType Config m a
conf forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ProxyType
HaProxy
                     then forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> AcceptFunc
Sock.haProxyAcceptFunc Socket
sock)
                     else forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> AcceptFunc
Sock.httpAcceptFunc Socket
sock))
    unixListener :: Maybe (ByteString, IO (Socket, AcceptFunc))
unixListener = do
        [Char]
path <- forall (m :: * -> *) a. Config m a -> Maybe [Char]
getUnixSocket Config m a
conf
        let accessMode :: Maybe Int
accessMode = forall (m :: * -> *) a. Config m a -> Maybe Int
getUnixSocketAccessMode Config m a
conf
        forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack  forall a b. (a -> b) -> a -> b
$ [Char]
"unix:" forall a. [a] -> [a] -> [a]
++ [Char]
path,
                 do Socket
sock <- Maybe Int -> [Char] -> IO Socket
Sock.bindUnixSocket Maybe Int
accessMode [Char]
path
                    forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> AcceptFunc
Sock.httpAcceptFunc Socket
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
    Config Snap a
conf <- forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig Config Snap a
config
    let !handler :: Snap ()
handler = forall {m :: * -> *} {a}. Config m a -> Snap ()
chooseProxy Config Snap a
conf
    let serve :: Snap ()
serve    = forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
compress Config Snap a
conf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
catch500 Config Snap a
conf forall a b. (a -> b) -> a -> b
$ Snap ()
handler
    forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> Snap () -> IO ()
simpleHttpServe Config Snap a
conf Snap ()
serve

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

    pickProxy :: ProxyType -> m a -> m a
pickProxy ProxyType
NoProxy         = forall a. a -> a
id
    pickProxy ProxyType
HaProxy         = forall a. a -> a
id  -- we handle this case elsewhere
    pickProxy ProxyType
X_Forwarded_For = 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
L.catch forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ 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 forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe Bool
getCompression Config m a
conf then forall (m :: * -> *) a. MonadSnap m => m a -> m ()
withCompression else 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
    Config Snap Any
conf <- forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
commandLineConfig forall (m :: * -> *) a. MonadSnap m => Config m a
defaultConfig
    forall a. Config Snap a -> Snap () -> IO ()
httpServe Config Snap Any
conf Snap ()
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 = 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show