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, 0.5 has been updated
via 0f3d29bb2438fff4b6de2400846c8e8f1c6551ff (commit)
from 24636e7d1b00558c60aa82c1c7655dfcabe266e9 (commit)
Summary of changes:
src/Snap/Extension/Server.hs | 43 +++++++++++++----------------------------
test/snap-testsuite.cabal | 2 +-
2 files changed, 15 insertions(+), 30 deletions(-)
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 0f3d29bb2438fff4b6de2400846c8e8f1c6551ff
Author: Gregory Collins <[email protected]>
Date: Sat Jun 18 13:09:36 2011 -0400
Completely rework Snap.Http.Server.Config
diff --git a/src/Snap/Extension/Server.hs b/src/Snap/Extension/Server.hs
index 07898c4..ac06c3b 100644
--- a/src/Snap/Extension/Server.hs
+++ b/src/Snap/Extension/Server.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
{-|
@@ -31,7 +32,7 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Prelude hiding (catch)
import Snap.Extension
-import Snap.Http.Server (simpleHttpServe)
+import qualified Snap.Http.Server as SS
import qualified Snap.Http.Server.Config as C
import Snap.Http.Server.Config hiding ( defaultConfig
, completeConfig
@@ -89,11 +90,8 @@ defaultConfig = setReloadHandler handler C.defaultConfig
------------------------------------------------------------------------------
-- | Completes a partial 'Config' by filling in the unspecified values with
-- the default values from 'defaultConfig'.
-completeConfig :: ConfigExtend s -> ConfigExtend s
-completeConfig c = case getListen c' of
- [] -> addListen (ListenHttp "0.0.0.0" 8000) c'
- _ -> c'
- where c' = mappend defaultConfig c
+completeConfig :: ConfigExtend s -> IO (ConfigExtend s)
+completeConfig = C.completeConfig . (mappend defaultConfig)
------------------------------------------------------------------------------
@@ -108,33 +106,20 @@ httpServe :: ConfigExtend s
-- ^ The application to be served
-> IO ()
httpServe config initializer handler = do
- (snap, cleanup) <- runInitializerWithReloadAction
+ conf <- completeConfig config
+ let !verbose = fromJust $ getVerbose conf
+ let !reloader = fromJust $ getReloadHandler conf
+ let !compress = if fromJust $ getCompression conf then withCompression
else id
+ let !catch500 = flip catch $ fromJust $ getErrorHandler conf
+ let !serve = SS.simpleHttpServe config
+ (site, cleanup) <- runInitializerWithReloadAction
verbose
initializer
- (catch500 handler)
+ (catch500 $ compress handler)
reloader
- let site = compress $ snap
- mapM_ printListen $ C.getListen config
_ <- try $ serve $ site :: IO (Either SomeException ())
putStr "\n"
cleanup
- output "Shutting down..."
-
- where
- conf = completeConfig config
- verbose = fromJust $ getVerbose conf
- output = when verbose . hPutStrLn stderr
- reloader = fromJust $ getReloadHandler conf
- compress = if fromJust $ getCompression conf then withCompression else id
- catch500 = flip catch $ fromJust $ getErrorHandler conf
- serve = simpleHttpServe config
-
- listenToString (C.ListenHttp host port) =
- concat ["http://";, fromUTF8 host, ":", show port, "/"]
- listenToString (C.ListenHttps host port _ _) =
- concat ["https://";, fromUTF8 host, ":", show port, "/"]
-
- printListen l = output $ "Listening on " ++ listenToString l
------------------------------------------------------------------------------
diff --git a/test/snap-testsuite.cabal b/test/snap-testsuite.cabal
index 393712a..7e6c0c2 100644
--- a/test/snap-testsuite.cabal
+++ b/test/snap-testsuite.cabal
@@ -14,7 +14,7 @@ Executable testsuite
directory,
filepath,
HUnit >= 1.2 && < 2,
- http-enumerator >= 0.3 && <0.4,
+ http-enumerator >= 0.6.5.3 && <0.7,
process == 1.*,
test-framework >= 0.3.1 && <0.4,
test-framework-hunit >= 0.2.5 && < 0.3,
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
https://mailman-mail5.webfaction.com/listinfo/snap
