{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}

------------------------------------------------------------------------------
-- | The Snap HTTP server is a high performance, epoll-enabled, iteratee-based
-- 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
  , module Snap.Http.Server.Config
  ) where

------------------------------------------------------------------------------
import           Control.Applicative
import           Control.Concurrent (newMVar, withMVar)
import           Control.Monad
import           Control.Monad.CatchIO
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import           Data.List
import           Data.Maybe
import           Prelude hiding (catch)
import           Snap.Http.Server.Config
import qualified Snap.Internal.Http.Server as Int
import           Snap.Core
import           Snap.Util.GZip
import           Snap.Util.Proxy
#ifndef PORTABLE
import           System.Posix.Env
#endif
import           System.IO
import           System.FastLogger


------------------------------------------------------------------------------
-- | A short string describing the Snap server version
snapServerVersion :: ByteString
snapServerVersion = Int.snapServerVersion


------------------------------------------------------------------------------
-- | 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
    mapM_ (output . ("Listening on "++) . show) $ listeners conf

    go conf `finally` output "\nShutting down..."

  where
    go conf = do
        let tout = fromMaybe 60 $ getDefaultTimeout conf

        setUnicodeLocale $ fromJust $ getLocale conf
        withLoggers (fromJust $ getAccessLog conf)
                    (fromJust $ getErrorLog conf) $
            \(alog, elog) -> Int.httpServe tout
                             (listeners conf)
                             (fmap backendToInternal $ getBackend conf)
                             (fromJust $ getHostname  conf)
                             alog
                             elog
                             (runSnap handler)

    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 $ BS.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 -> [Int.ListenPort]
listeners conf = catMaybes [ httpListener, httpsListener ]
  where
    httpsListener = do
        b    <- getSSLBind conf
        p    <- getSSLPort conf
        cert <- getSSLCert conf
        key  <- getSSLKey conf
        return $! Int.HttpsPort b p cert key

    httpListener = do
        p <- getPort conf
        b <- getBind conf
        return $! Int.HttpPort b p


------------------------------------------------------------------------------
-- | 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 -> behindProxy ptype handler0)
                             (getProxyType conf)
{-# INLINE httpServe #-}


------------------------------------------------------------------------------
catch500 :: MonadSnap m => Config m a -> m () -> m ()
catch500 conf = flip catch $ fromJust $ getErrorHandler conf
{-# INLINE catch500 #-}


------------------------------------------------------------------------------
compress :: MonadSnap m => Config m a -> m () -> m ()
compress conf = if fromJust $ getCompression conf then withCompression else id
{-# INLINE compress #-}


------------------------------------------------------------------------------
-- | 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 m = commandLineConfig emptyConfig >>= \c -> httpServe c m


------------------------------------------------------------------------------
-- | Given a string like \"en_US\", this sets the locale to \"en_US.UTF-8\".
-- This doesn't work on Windows.
setUnicodeLocale :: String -> IO ()
setUnicodeLocale =
#ifndef PORTABLE
    \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
    const $ return ()
#endif


------------------------------------------------------------------------------
backendToInternal :: ConfigBackend -> Int.EventLoopType
backendToInternal ConfigSimpleBackend = Int.EventLoopSimple
backendToInternal ConfigLibEvBackend  = Int.EventLoopLibEv