snap-server-1.1.2.1: src/Snap/Http/Server.hs
{-# 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 = S.pack $! showVersion V.version
------------------------------------------------------------------------------
rawHttpServe :: ServerHandler s -- ^ server handler
-> ServerConfig s -- ^ server config
-> [AcceptFunc] -- ^ listening server backends
-> IO ()
rawHttpServe h cfg loops = do
mvars <- mapM (const newEmptyMVar) loops
mask $ \restore -> bracket (mapM runLoop $ mvars `zip` loops)
(\mvTids -> do
mapM_ (killThread . snd) mvTids
mapM_ (readMVar . fst) mvTids)
(const $ restore $ mapM_ readMVar mvars)
where
-- parents and children have a mutual suicide pact
runLoop (mvar, loop) = do
tid <- forkIOLabeledWithUnmaskBs
"snap-server http master thread" $
\r -> (r $ httpAcceptLoop h cfg loop) `finally` putMVar 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 config handler = do
conf <- completeConfig config
let output = when (fromJust $ getVerbose conf) . hPutStrLn 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 act =
let r0 = return $! ()
in (act >> r0) `catch` \(_::SomeException) -> r0
--------------------------------------------------------------------------
-- FIXME: this logging code *sucks*
--------------------------------------------------------------------------
debugE :: (MonadIO m) => ByteString -> m ()
debugE s = debug $ "Error: " ++ S.unpack s
--------------------------------------------------------------------------
logE :: Maybe (ByteString -> IO ()) -> Builder -> IO ()
logE elog b = let x = S.concat $ L.toChunks $ toLazyByteString b
in (maybe debugE (\l s -> debugE s >> logE' l s) elog) x
--------------------------------------------------------------------------
logE' :: (ByteString -> IO ()) -> ByteString -> IO ()
logE' logger s = (timestampedLogEntry s) >>= logger
--------------------------------------------------------------------------
logA :: Maybe (ByteString -> IO ())
-> Request
-> Response
-> Word64
-> IO ()
logA alog = maybe (\_ _ _ -> return $! ()) logA' alog
--------------------------------------------------------------------------
logA' logger req rsp cl = do
let hdrs = rqHeaders req
let host = rqClientAddr req
let user = Nothing -- TODO we don't do authentication yet
let (v, v') = rqVersion req
let ver = S.concat [ "HTTP/", bshow v, ".", bshow v' ]
let method = bshow (rqMethod req)
let reql = S.intercalate " " [ method, rqURI req, ver ]
let status = rspStatus rsp
let referer = H.lookup "referer" hdrs
let userAgent = fromMaybe "-" $ H.lookup "user-agent" hdrs
msg <- combinedLogEntry host user reql status cl referer userAgent
logger msg
--------------------------------------------------------------------------
go conf sockets afuncs = do
let tout = fromMaybe 60 $ getDefaultTimeout conf
let shandler = snapToServerHandler handler
setUnicodeLocale $ fromJust $ getLocale conf
withLoggers (fromJust $ getAccessLog conf)
(fromJust $ getErrorLog conf) $ \(alog, elog) -> do
let scfg = Ty.setDefaultTimeout tout .
Ty.setLocalHostname (fromJust $ getHostname conf) .
Ty.setLogAccess (logA alog) .
Ty.setLogError (logE elog) $
Ty.emptyServerConfig
maybe (return $! ())
($ mkStartupInfo sockets conf)
(getStartupHook conf)
rawHttpServe shandler scfg afuncs
--------------------------------------------------------------------------
mkStartupInfo sockets conf =
setStartupSockets sockets $
setStartupConfig conf emptyStartupInfo
--------------------------------------------------------------------------
maybeSpawnLogger f (ConfigFileLog fp) =
liftM Just $ newLoggerWithCustomErrorFunction f fp
maybeSpawnLogger _ _ = return Nothing
--------------------------------------------------------------------------
maybeIoLog (ConfigIoLog a) = Just a
maybeIoLog _ = Nothing
--------------------------------------------------------------------------
withLoggers afp efp act =
bracket (do mvar <- newMVar ()
let f s = withMVar mvar
(const $ S.hPutStr stderr s >> hFlush stderr)
alog <- maybeSpawnLogger f afp
elog <- maybeSpawnLogger f efp
return (alog, elog))
(\(alog, elog) -> do
maybe (return ()) stopLogger alog
maybe (return ()) stopLogger elog)
(\(alog, elog) -> act ( liftM logMsg alog <|> maybeIoLog afp
, liftM logMsg elog <|> maybeIoLog efp))
{-# INLINE simpleHttpServe #-}
------------------------------------------------------------------------------
listeners :: Config m a -> IO [(ByteString, Socket, AcceptFunc)]
listeners conf = TLS.withTLS $ do
let fs = catMaybes [httpListener, httpsListener, unixListener]
mapM (\(str, mkAfunc) -> do (sock, afunc) <- mkAfunc
return $! (str, sock, afunc)) fs
where
httpsListener = do
b <- getSSLBind 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 = do
p <- getPort 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 = do
path <- getUnixSocket conf
let accessMode = getUnixSocketAccessMode 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 config handler0 = do
conf <- completeConfig config
let !handler = chooseProxy conf
let serve = compress conf . catch500 conf $ handler
simpleHttpServe conf serve
where
chooseProxy conf = maybe handler0
(\ptype -> pickProxy ptype handler0)
(getProxyType conf)
pickProxy NoProxy = id
pickProxy HaProxy = id -- we handle this case elsewhere
pickProxy X_Forwarded_For = behindProxy Proxy.X_Forwarded_For
------------------------------------------------------------------------------
catch500 :: MonadSnap m => Config m a -> m () -> m ()
catch500 conf = flip L.catch $ fromJust $ getErrorHandler conf
------------------------------------------------------------------------------
compress :: MonadSnap m => Config m a -> m () -> m ()
compress conf = if fromJust $ getCompression conf then withCompression else 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 handler = do
conf <- commandLineConfig 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 lang = mapM_ (\k -> setEnv k (lang ++ ".UTF-8") True)
[ "LANG"
, "LC_CTYPE"
, "LC_NUMERIC"
, "LC_TIME"
, "LC_COLLATE"
, "LC_MONETARY"
, "LC_MESSAGES"
, "LC_PAPER"
, "LC_NAME"
, "LC_ADDRESS"
, "LC_TELEPHONE"
, "LC_MEASUREMENT"
, "LC_IDENTIFICATION"
, "LC_ALL" ]
#else
setUnicodeLocale = const $ return ()
#endif
------------------------------------------------------------------------------
bshow :: (Show a) => a -> ByteString
bshow = S.pack . show