module Snap.Http.Server
( simpleHttpServe
, httpServe
, quickHttpServe
, snapServerVersion
, setUnicodeLocale
, module Snap.Http.Server.Config
) where
import Control.Monad
import Control.Monad.CatchIO
import Data.ByteString (ByteString)
import Data.Char
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.Types
import Snap.Util.GZip
#ifndef PORTABLE
import System.Posix.Env
#endif
import System.IO
snapServerVersion :: ByteString
snapServerVersion = Int.snapServerVersion
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
Int.httpServe tout
(listeners conf)
(fmap backendToInternal $ getBackend conf)
(fromJust $ getHostname conf)
(fromJust $ getAccessLog conf)
(fromJust $ getErrorLog conf)
(runSnap handler)
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
httpServe :: Config Snap a -> Snap () -> IO ()
httpServe config handler = do
conf <- completeConfig config
let serve = compress conf . catch500 conf $ handler
simpleHttpServe conf serve
catch500 :: MonadSnap m => Config m a -> m () -> m ()
catch500 conf = flip catch $ fromJust $ getErrorHandler conf
compress :: MonadSnap m => Config m a -> m () -> m ()
compress conf = if fromJust $ getCompression conf then withCompression else id
quickHttpServe :: Snap () -> IO ()
quickHttpServe m = commandLineConfig emptyConfig >>= \c -> httpServe c m
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