packages feed

snap-core 0.2.7 → 0.2.7.1

raw patch · 2 files changed

+113/−2 lines, 2 files

Files

+ project_template/default/src/Server.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+module Server+    ( ServerConfig(..)+    , emptyServerConfig+    , commandLineConfig+    , server+    , quickServer+    ) where+import qualified Data.ByteString.Char8 as B+import           Data.ByteString.Char8 (ByteString)+import           Data.Char+import           Control.Concurrent+import           Control.Exception (SomeException)+import           Control.Monad.CatchIO+import qualified Data.Text as T+import           Prelude hiding (catch)+import           Snap.Http.Server+import           Snap.Types+import           Snap.Util.GZip+import           System hiding (getEnv)+import           System.Posix.Env+import qualified Text.XHtmlCombinators.Escape as XH+++data ServerConfig = ServerConfig+    { locale          :: String+    , interface       :: ByteString+    , port            :: Int+    , hostname        :: ByteString+    , accessLog       :: Maybe FilePath+    , errorLog        :: Maybe FilePath+    , compression     :: Bool+    , error500Handler :: SomeException -> Snap ()+    }+++emptyServerConfig :: ServerConfig+emptyServerConfig = ServerConfig+    { locale          = "en_US"+    , interface       = "0.0.0.0"+    , port            = 8000+    , hostname        = "myserver"+    , accessLog       = Just "access.log"+    , errorLog        = Just "error.log"+    , compression     = True+    , error500Handler = \e -> do+        let t = T.pack $ show e+            r = setContentType "text/html; charset=utf-8" $+                setResponseStatus 500 "Internal Server Error" emptyResponse+        putResponse r+        writeBS "<html><head><title>Internal Server Error</title></head>"+        writeBS "<body><h1>Internal Server Error</h1>"+        writeBS "<p>A web handler threw an exception. Details:</p>"+        writeBS "<pre>\n"+        writeText $ XH.escape t+        writeBS "\n</pre></body></html>"+    }+++commandLineConfig :: IO ServerConfig+commandLineConfig = do+    args <- getArgs+    let conf = case args of+         []        -> emptyServerConfig+         (port':_) -> emptyServerConfig { port = read port' }+    locale' <- getEnv "LANG"+    return $ case locale' of+        Nothing -> conf+        Just l  -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}++server :: ServerConfig -> Snap () -> IO ()+server config handler = do+    putStrLn $ "Listening on " ++ (B.unpack $ interface config)+             ++ ":" ++ show (port config)+    setUTF8Locale (locale config)+    try $ httpServe+             (interface config)+             (port      config)+             (hostname  config)+             (accessLog config)+             (errorLog  config)+             (catch500 $ compress $ handler)+             :: IO (Either SomeException ())+    threadDelay 1000000+    putStrLn "Shutting down"+  where+    catch500 = (`catch` (error500Handler config))+    compress = if compression config then withCompression else id+++quickServer :: Snap () -> IO ()+quickServer = (commandLineConfig >>=) . flip server+++setUTF8Locale :: String -> IO ()+setUTF8Locale locale' = do+    mapM_ (\k -> setEnv k (locale' ++ ".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" ]
snap-core.cabal view
@@ -1,5 +1,5 @@ name:           snap-core-version:        0.2.7+version:        0.2.7.1 synopsis:       Snap: A Haskell Web Framework (Core)  description:@@ -79,7 +79,7 @@   project_template/default/foo.cabal,   project_template/default/src/Glue.hs,   project_template/default/src/Main.hs,-  project_template/barebones/src/Server.hs,+  project_template/default/src/Server.hs,   README.md,   README.SNAP.md,   Setup.hs,