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
        let verify = fromMaybe False (getSSLClientVerify conf)
        let verify_once = fromMaybe False (getSSLClientVerifyOnce conf)
        let ca_cert = fromMaybe "" (getSSLCACert conf)
        return (S.concat [ "https://"
                         , b
                         , ":"
                         , bshow p ],
                do (sock, ctx) <- TLS.bindHttps b p cert chainCert key verify verify_once ca_cert
                   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