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 edfad488ed50d8906d1fc1cf04b7cab5826e8a29 (commit)
from 274b9bab8eb54ac9e2aca465a4b79fa07f2144b6 (commit)
Summary of changes:
project_template/hint/foo.cabal | 11 +---
project_template/hint/src/Main.hs | 17 +++++-
project_template/hint/src/Server.hs | 111 -----------------------------------
snap.cabal | 1 -
4 files changed, 16 insertions(+), 124 deletions(-)
delete mode 100644 project_template/hint/src/Server.hs
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 edfad488ed50d8906d1fc1cf04b7cab5826e8a29
Author: Carl Howells <[email protected]>
Date: Mon Jun 28 22:59:42 2010 -0700
Move the functionality from Server.hs into snap-server
diff --git a/project_template/hint/foo.cabal b/project_template/hint/foo.cabal
index e5a94f7..315be9d 100644
--- a/project_template/hint/foo.cabal
+++ b/project_template/hint/foo.cabal
@@ -24,22 +24,13 @@ Executable projname
Build-depends:
base >= 4 && < 5,
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,
snap-server >= 0.3 && < 0.4,
heist >= 0.2.1 && < 0.3,
hint >= 0.3.2 && < 0.4,
- template-haskell >= 2.3 && < 2.5,
- text >= 0.7 && < 0.8,
- time >= 1.0 && < 1.3,
- unix >= 2.0 && < 2.5,
- xhtml-combinators >= 0.2.1 && < 0.3
-
+ time >= 1.0 && < 1.3
if impl(ghc >= 6.12.0)
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 d955129..da0c02b 100644
--- a/project_template/hint/src/Main.hs
+++ b/project_template/hint/src/Main.hs
@@ -1,9 +1,13 @@
{-# LANGUAGE CPP, TemplateHaskell #-}
module Main where
+import Data.Monoid (mappend, mconcat)
+
import Config (getConfig, cleanupConfig)
import Site (site)
-import Server (quickServer)
+
+import Snap.Http.Server
+import Snap.Http.Server.Config
#ifdef PRODUCTION
import Snap.Loader.Static (loadSnapTH)
@@ -14,5 +18,14 @@ import Snap.Loader.Hint (loadSnapTH)
main :: IO ()
main = do
(cleanup, snap) <- $(loadSnapTH 'getConfig 'cleanupConfig 'site)
- quickServer snap
+
+ let defaultFlags = mconcat [ flagV -- verbose
+ , flagAL "log/access.log"
+ , flagEL "log/error.log"
+ ]
+
+ cmdLineFlags <- readFlagsFromCmdLineArgs
+ let conf = flagsToConfig $ defaultFlags `mappend` cmdLineFlags
+
+ httpServeConfig conf snap
cleanup
diff --git a/project_template/hint/src/Server.hs
b/project_template/hint/src/Server.hs
deleted file mode 100644
index 0971b1d..0000000
--- a/project_template/hint/src/Server.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Server
- ( ServerConfig(..)
- , emptyServerConfig
- , commandLineConfig
- , server
- , quickServer
- ) where
-import qualified Data.ByteString.Char8 as S
-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 " ++ (S.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 ())
- putStrLn " Shutting down..."
- threadDelay 1000000
- 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 3a092e5..68715d7 100644
--- a/snap.cabal
+++ b/snap.cabal
@@ -37,7 +37,6 @@ extra-source-files:
project_template/hint/resources/templates/index.tpl,
project_template/hint/src/Config.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
