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
#ifndef PORTABLE
import System.Posix.Env
#endif
import System.IO
import System.FastLogger
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
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))
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