[Snap Framework] snap-server branch, enumerator, updated. d7e7d6de01aaf1ad67e06433b67301d58535a991

noreply at snapframework.com noreply at snapframework.com
Sat Dec 4 05:39:23 CST 2010


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-server".

The branch, enumerator has been updated
       via  d7e7d6de01aaf1ad67e06433b67301d58535a991 (commit)
       via  01fa6a78a121eba44303e4afb04f08699243b75f (commit)
      from  ffb7f661a99e5b490e8f53697cb3ebe021aa6121 (commit)


Summary of changes:
 src/Snap/Internal/Http/Server.hs |   13 +++++++++----
 test/suite/Test/Blackbox.hs      |   20 ++++++++++++--------
 2 files changed, 21 insertions(+), 12 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 d7e7d6de01aaf1ad67e06433b67301d58535a991
Merge: 01fa6a7 ffb7f66
Author: Gregory Collins <greg at gregorycollins.net>
Date:   Sat Dec 4 12:39:08 2010 +0100

    Merge branch 'enumerator' of git.snapframework.com:snap-server into enumerator

commit 01fa6a78a121eba44303e4afb04f08699243b75f
Author: Gregory Collins <greg at gregorycollins.net>
Date:   Sat Dec 4 12:38:28 2010 +0100

    Fix a couple of enumerator bugs

diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 176a966..81db8fd 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -421,7 +421,7 @@ receiveRequest = do
               let e = joinI . readChunkedTransferEncoding
               liftIO $ writeIORef (rqBody req)
                                   (SomeEnumerator e)
-          else maybe noContentLength hasContentLength mbCL
+          else maybe (noContentLength req) hasContentLength mbCL
 
       where
         isChunked = maybe False
@@ -444,11 +444,16 @@ receiveRequest = do
 
                 joinI $ takeExactly len st'
 
-        noContentLength :: ServerMonad ()
-        noContentLength = liftIO $ do
+        noContentLength :: Request -> ServerMonad ()
+        noContentLength req = liftIO $ do
             debug ("receiveRequest/setEnumerator: " ++
                    "request did NOT have content-length")
-            writeIORef (rqBody req) (SomeEnumerator returnI)
+            let enum = SomeEnumerator $
+                       if rqMethod req == POST || rqMethod req == PUT
+                         then returnI
+                         else iterateeDebugWrapper "noContentLength" .
+                              joinI . I.take 0
+            writeIORef (rqBody req) enum
             debug "receiveRequest/setEnumerator: body enumerator set"
 
 
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index 43eab3f..5d7d8bd 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -68,16 +68,18 @@ startTestServer :: Int
                 -> ConfigBackend
                 -> IO (ThreadId, MVar ())
 startTestServer port sslport backend = do
-    let cfg = setAccessLog (Just $ "ts-access.log." ++ show backend)  .
-              setErrorLog  (Just $ "ts-error.log." ++ show backend)   . 
-              addListen    (ListenHttp "*" port)                      .
-              setBackend   backend                                    .
-              setVerbose   False                                      $
+    let cfg = setAccessLog (Just $ "ts-access." ++ show backend ++ ".log") .
+              setErrorLog  (Just $ "ts-error." ++ show backend ++ ".log")  . 
+              addListen    (ListenHttp "*" port)                           .
+              setBackend   backend                                         .
+              setVerbose   False                                           $
               defaultConfig
 
     let cfg' = case sslport of
                 Nothing    -> cfg
-                Just (p,_) -> addListen (ListenHttps "*" p "cert.pem" "key.pem") cfg
+                Just (p,_) -> addListen
+                              (ListenHttps "*" p "cert.pem" "key.pem")
+                              cfg
 
     mvar <- newEmptyMVar
     tid  <- forkIO $
@@ -162,7 +164,8 @@ testEcho port name = testProperty (name ++ "/blackbox/echo") $
         let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString
         let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req'
 
-        rsp <- QC.run $ HTTP.simpleHTTP $ req { HTTP.rqBody = (txt::S.ByteString) }
+        rsp <- QC.run $ HTTP.simpleHTTP
+                      $ req { HTTP.rqBody = (txt::S.ByteString) }
         doc <- QC.run $ HTTP.getResponseBody rsp
 
         QC.assert $ txt == doc
@@ -183,7 +186,8 @@ testRot13 port name = testProperty (name ++ "/blackbox/rot13") $
         let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString
         let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req'
 
-        rsp <- QC.run $ HTTP.simpleHTTP $ req { HTTP.rqBody = (txt::S.ByteString) }
+        rsp <- QC.run $ HTTP.simpleHTTP
+                      $ req { HTTP.rqBody = (txt::S.ByteString) }
         doc <- QC.run $ HTTP.getResponseBody rsp
 
         QC.assert $ txt == rot13 doc
-----------------------------------------------------------------------


hooks/post-receive
-- 
snap-server


More information about the Snap mailing list