/src/Snap/Http/Server.hs
Haskell | 312 lines | 219 code | 38 blank | 55 comment | 5 complexity | 38b62fef4faeed3c126f0682f2dcd411 MD5 | raw file
Possible License(s): BSD-3-Clause
- {-# 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