{-# 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 = String -> ByteString
S.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$! Version -> String
showVersion Version
V.version


------------------------------------------------------------------------------
rawHttpServe :: ServerHandler s  -- ^ server handler
             -> ServerConfig s   -- ^ server config
             -> [AcceptFunc]     -- ^ listening server backends
             -> IO ()
rawHttpServe :: ServerHandler s -> ServerConfig s -> [AcceptFunc] -> IO ()
rawHttpServe ServerHandler s
h ServerConfig s
cfg [AcceptFunc]
loops = do
    [MVar ()]
mvars <- (AcceptFunc -> IO (MVar ())) -> [AcceptFunc] -> IO [MVar ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO (MVar ()) -> AcceptFunc -> IO (MVar ())
forall a b. a -> b -> a
const IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar) [AcceptFunc]
loops
    ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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)
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
        ThreadId
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 ()
        (MVar (), ThreadId) -> IO (MVar (), ThreadId)
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 :: Config m a -> Snap () -> IO ()
simpleHttpServe Config m a
config Snap ()
handler = do
    Config m a
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 :: String -> IO ()
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 ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr
    ([ByteString]
descrs, [Socket]
sockets, [AcceptFunc]
afuncs) <- [(ByteString, Socket, AcceptFunc)]
-> ([ByteString], [Socket], [AcceptFunc])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(ByteString, Socket, AcceptFunc)]
 -> ([ByteString], [Socket], [AcceptFunc]))
-> IO [(ByteString, Socket, AcceptFunc)]
-> IO ([ByteString], [Socket], [AcceptFunc])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config m a -> IO [(ByteString, Socket, AcceptFunc)]
forall (m :: * -> *) a.
Config m a -> IO [(ByteString, Socket, AcceptFunc)]
listeners Config m a
conf
    (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
output (String -> IO ()) -> (ByteString -> String) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Listening on " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S.unpack) [ByteString]
descrs

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

  where
    eatException :: IO a -> IO ()
    eatException :: IO a -> IO ()
eatException IO a
act =
        let r0 :: IO ()
r0 = () -> IO ()
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 (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 :: ByteString -> m ()
debugE ByteString
s = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
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
$ ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
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 (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 (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 (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

        ByteString
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
        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 = 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

        String -> IO ()
setUnicodeLocale (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (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
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 (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 Any -> ServerConfig Any -> [AcceptFunc] -> IO ()
forall s.
ServerHandler s -> ServerConfig s -> [AcceptFunc] -> IO ()
rawHttpServe ServerHandler Any
forall hookState. ServerHandler hookState
shandler ServerConfig Any
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 String
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 ()) -> String -> IO Logger
newLoggerWithCustomErrorFunction ByteString -> IO ()
f String
fp
    maybeSpawnLogger ByteString -> IO ()
_ ConfigLog
_                  = Maybe Logger -> IO (Maybe Logger)
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 ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
                    let f :: ByteString -> IO ()
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 (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
                    (Maybe Logger, Maybe Logger) -> IO (Maybe Logger, Maybe Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Logger
alog, Maybe Logger
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 (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 (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 (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 (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 :: 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)
mapM (\(ByteString
str, IO (Socket, AcceptFunc)
mkAfunc) -> do (Socket
sock, AcceptFunc
afunc) <- IO (Socket, AcceptFunc)
mkAfunc
                              (ByteString, Socket, AcceptFunc)
-> IO (ByteString, Socket, AcceptFunc)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, Socket, AcceptFunc)
 -> IO (ByteString, Socket, AcceptFunc))
-> (ByteString, Socket, AcceptFunc)
-> IO (ByteString, Socket, AcceptFunc)
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    <- Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
getSSLBind Config m a
conf
        Int
p    <- Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
getSSLPort Config m a
conf
        String
cert <- Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
getSSLCert Config m a
conf
        Bool
chainCert <- Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
getSSLChainCert Config m a
conf
        String
key  <- Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
getSSLKey Config m a
conf
        (ByteString, IO (Socket, AcceptFunc))
-> Maybe (ByteString, IO (Socket, AcceptFunc))
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
S.concat [ ByteString
"https://"
                         , ByteString
b
                         , ByteString
":"
                         , Int -> ByteString
forall a. Show a => a -> ByteString
bshow Int
p ],
                do (Socket
sock, ()
ctx) <- ByteString -> Int -> String -> Bool -> String -> IO (Socket, ())
TLS.bindHttps ByteString
b Int
p String
cert Bool
chainCert String
key
                   (Socket, AcceptFunc) -> IO (Socket, AcceptFunc)
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 <- Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
getPort Config m a
conf
        ByteString
b <- Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
getBind Config m a
conf
        (ByteString, IO (Socket, AcceptFunc))
-> Maybe (ByteString, IO (Socket, AcceptFunc))
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
S.concat [ ByteString
"http://"
                         , ByteString
b
                         , ByteString
":"
                         , Int -> ByteString
forall a. Show a => a -> ByteString
bshow Int
p ],
                do Socket
sock <- ByteString -> Int -> IO Socket
Sock.bindSocket ByteString
b Int
p
                   if Config m a -> Maybe ProxyType
forall (m :: * -> *) a. Config m a -> Maybe ProxyType
getProxyType Config m a
conf Maybe ProxyType -> Maybe ProxyType -> Bool
forall a. Eq a => a -> a -> Bool
== ProxyType -> Maybe ProxyType
forall a. a -> Maybe a
Just ProxyType
HaProxy
                     then (Socket, AcceptFunc) -> IO (Socket, AcceptFunc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> AcceptFunc
Sock.haProxyAcceptFunc Socket
sock)
                     else (Socket, AcceptFunc) -> IO (Socket, AcceptFunc)
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
        String
path <- Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
getUnixSocket Config m a
conf
        let accessMode :: Maybe Int
accessMode = Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
getUnixSocketAccessMode Config m a
conf
        (ByteString, IO (Socket, AcceptFunc))
-> Maybe (ByteString, IO (Socket, AcceptFunc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack  (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"unix:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path,
                 do Socket
sock <- Maybe Int -> String -> IO Socket
Sock.bindUnixSocket Maybe Int
accessMode String
path
                    (Socket, AcceptFunc) -> IO (Socket, AcceptFunc)
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 :: Config Snap a -> Snap () -> IO ()
httpServe Config Snap a
config Snap ()
handler0 = do
    Config Snap a
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 :: Snap ()
handler = Config Snap a -> Snap ()
forall (m :: * -> *) a. Config m a -> Snap ()
chooseProxy Config Snap a
conf
    let serve :: Snap ()
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
    Config Snap a -> Snap () -> IO ()
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 = 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 :: 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 :: 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
    Config Snap Any
conf <- Config Snap Any -> IO (Config Snap Any)
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
commandLineConfig Config Snap Any
forall (m :: * -> *) a. MonadSnap m => Config m a
defaultConfig
    Config Snap Any -> Snap () -> IO ()
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 :: String -> IO ()
setUnicodeLocale String
lang = (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
k -> String -> String -> Bool -> IO ()
setEnv String
k (String
lang String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".UTF-8") Bool
True)
                            [ String
"LANG"
                            , String
"LC_CTYPE"
                            , String
"LC_NUMERIC"
                            , String
"LC_TIME"
                            , String
"LC_COLLATE"
                            , String
"LC_MONETARY"
                            , String
"LC_MESSAGES"
                            , String
"LC_PAPER"
                            , String
"LC_NAME"
                            , String
"LC_ADDRESS"
                            , String
"LC_TELEPHONE"
                            , String
"LC_MEASUREMENT"
                            , String
"LC_IDENTIFICATION"
                            , String
"LC_ALL" ]
#else
setUnicodeLocale = const $ return ()
#endif

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