content: {-# 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
  