This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap".
The branch, master has been updated
via d7254afc3e5b6655e552a9d6bf4a07fbb46a68b6 (commit)
from c3e685c6a26015786308e188f645742cb9efbae5 (commit)
Summary of changes:
project_template/hint/foo.cabal | 14 ++++++++++++--
project_template/hint/src/Main.hs | 18 +++---------------
project_template/{barebones => hint}/src/Server.hs | 4 ++--
snap.cabal | 1 +
4 files changed, 18 insertions(+), 19 deletions(-)
copy project_template/{barebones => hint}/src/Server.hs (97%)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d7254afc3e5b6655e552a9d6bf4a07fbb46a68b6
Author: Carl Howells <[email protected]>
Date: Tue Jun 22 21:19:02 2010 -0700
Use Server.hs from the default template in the hint template
diff --git a/project_template/hint/foo.cabal b/project_template/hint/foo.cabal
index 57c9d70..e5a94f7 100644
--- a/project_template/hint/foo.cabal
+++ b/project_template/hint/foo.cabal
@@ -26,6 +26,8 @@ Executable projname
bytestring >= 0.9.1 && < 0.10,
directory >= 1.0.0.0 && < 1.1,
filepath >= 1.0 && < 1.2,
+ haskell98 >= 1.0 && < 1.1,
+ MonadCatchIO-transformers >= 0.2.0.0 && < 0.3,
monads-fd >= 0.1 && < 0.2,
snap >= 0.3 && < 0.4,
snap-core >= 0.3 && < 0.4,
@@ -33,6 +35,14 @@ Executable projname
heist >= 0.2.1 && < 0.3,
hint >= 0.3.2 && < 0.4,
template-haskell >= 2.3 && < 2.5,
- time >= 1.0 && < 1.3
+ text >= 0.7 && < 0.8,
+ time >= 1.0 && < 1.3,
+ unix >= 2.0 && < 2.5,
+ xhtml-combinators >= 0.2.1 && < 0.3
- ghc-options: -O2 -Wall -fwarn-tabs -threaded
+
+ if impl(ghc >= 6.12.0)
+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-unused-do-bind
+ else
+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
diff --git a/project_template/hint/src/Main.hs
b/project_template/hint/src/Main.hs
index 48f1680..ee1e15a 100644
--- a/project_template/hint/src/Main.hs
+++ b/project_template/hint/src/Main.hs
@@ -1,10 +1,9 @@
-{-# LANGUAGE OverloadedStrings, CPP, TemplateHaskell #-}
+{-# LANGUAGE CPP, TemplateHaskell #-}
module Main where
import Config (getConfig)
import Site (site)
-
-import Snap.Http.Server (httpServe)
+import Server (quickServer)
#ifdef PRODUCTION
import Snap.Loader.Static (loadSnapTH)
@@ -12,18 +11,7 @@ import Snap.Loader.Static (loadSnapTH)
import Snap.Loader.Hint (loadSnapTH)
#endif
-import System.Environment (getArgs)
-
-
main :: IO ()
main = do
- args <- getArgs
- let port = case args of
- [] -> 8000
- p:_ -> read p
- aLog = Just "log/access.log"
- eLog = Just "log/error.log"
-
snap <- $(loadSnapTH 'getConfig 'site)
-
- httpServe "*" port "localhost" aLog eLog snap
+ quickServer snap
diff --git a/project_template/hint/src/Server.hs
b/project_template/hint/src/Server.hs
new file mode 100644
index 0000000..fcad67b
--- /dev/null
+++ b/project_template/hint/src/Server.hs
@@ -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 "log/access.log"
+ , errorLog = Just "log/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" ]
diff --git a/snap.cabal b/snap.cabal
index 914873a..c7cd015 100644
--- a/snap.cabal
+++ b/snap.cabal
@@ -38,6 +38,7 @@ extra-source-files:
project_template/hint/src/Config.hs,
project_template/hint/src/Glue.hs,
project_template/hint/src/Main.hs,
+ project_template/hint/src/Server.hs,
project_template/hint/src/Site.hs
Library
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
