[Snap Framework] Patch: 50962af Fix broken testsuite

noreply at snapframework.com noreply at snapframework.com
Fri Apr 9 18:05:24 CDT 2010


refname: refs/heads/master
commit 50962af0b80681e1be3001d4144f707cf3688b62
Author: Gregory Collins <greg at gregorycollins.net>
Date:   Fri Apr 9 19:02:50 2010 -0400

    Fix broken testsuite
    
      * remove bogus hexpat dependency
    
      * turn off annoying -fwarn-unused-do-bind
    
      * change sendResponse type to return iteratee return value as well as count
        of bytes sent
    
      * fix testsuite to match recent type changes
---
 snap-server.cabal                             |    2 +-
 src/Snap/Internal/Http/Server.hs              |   22 +++++++++---------
 test/pongserver/Main.hs                       |    2 +-
 test/snap-server-testsuite.cabal              |    6 +++-
 test/suite/Snap/Internal/Http/Server/Tests.hs |   31 +++++++++++++-----------
 5 files changed, 34 insertions(+), 29 deletions(-)

diff --git a/snap-server.cabal b/snap-server.cabal
index 6474b82..526bce8 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -64,7 +64,7 @@ Library
     build-depends: network-bytestring >= 0.1.2 && < 0.2
     other-modules: Snap.Internal.Http.Server.SimpleBackend
 
-  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind
 
 
 source-repository head
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 9548002..6c7310a 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -257,7 +257,7 @@ httpSession writeEnd handler = do
           let ins = (Map.insert "Date" [date] . Map.insert "Server" sERVER_HEADER)
           let rsp' = updateHeaders ins rsp
           liftIO $ debug "Server.httpSession: request body skipped, sending response"
-          bytesSent <- sendResponse rsp' writeEnd
+          (bytesSent,_) <- sendResponse rsp' writeEnd
 
           maybe (logAccess req rsp')
                 (\_ -> logAccess req $ setContentLength bytesSent rsp')
@@ -402,8 +402,8 @@ receiveRequest = do
 
 
 sendResponse :: Response
-             -> Iteratee IO ()
-             -> ServerMonad Int
+             -> Iteratee IO a
+             -> ServerMonad (Int,a)
 sendResponse rsp writeEnd = do
     (hdrs, bodyEnum) <- maybe noCL hasCL (rspContentLength rsp)
 
@@ -417,18 +417,18 @@ sendResponse rsp writeEnd = do
                               , rspStatusReason rsp
                               , "
" ]
 
-    let enum = enumBS headerline >.
-               enumLBS (L.fromChunks $ fmtHdrs hdrs) >.
-               enumBS "
" >.
+    let headerString = L.fromChunks $ concat [ [headerline]
+                                             , fmtHdrs hdrs
+                                             , ["
"] ]
+
+    let enum = enumLBS headerString >.
                bodyEnum (rspBody rsp)
 
     -- send the data out. run throws an exception on error that we will catch
     -- in the toplevel handler.
-    (_, bs) <- liftIO $ enum (countBytes writeEnd) >>= run
-    let hdrsLength = S.length $ S.concat [ headerline
-                                         , S.concat $ fmtHdrs hdrs
-                                         , "
" ]
-    return $! bs - hdrsLength
+    (x, bs) <- liftIO $ enum (countBytes writeEnd) >>= run
+    let hdrsLength = fromEnum $ L.length headerString
+    return $! (bs - hdrsLength, x)
 
   where
     (major,minor) = rspHttpVersion rsp
diff --git a/test/pongserver/Main.hs b/test/pongserver/Main.hs
index 65d958f..9a80608 100644
--- a/test/pongserver/Main.hs
+++ b/test/pongserver/Main.hs
@@ -25,5 +25,5 @@ main = do
 
   where
     go m = do
-        httpServe "*" 8000 "localhost" pongServer 
+        httpServe "*" 8000 "localhost" Nothing Nothing pongServer 
         putMVar m ()
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index f332ab7..1ec003a 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -16,6 +16,7 @@ Executable testsuite
 
    build-depends:
      QuickCheck >= 2,
+     array >= 0.3 && <0.4,
      attoparsec >= 0.8 && < 0.9,
      attoparsec-iteratee >= 0.1 && <0.2,
      base >= 4 && < 5,
@@ -28,7 +29,6 @@ Executable testsuite
      dlist >= 0.5 && < 0.6,
      filepath,
      haskell98,
-     hexpat >= 0.11,
      HUnit >= 1.2 && < 2,
      monads-fd,
      network == 2.2.1.*,
@@ -52,6 +52,7 @@ Executable testsuite
      other-modules: Snap.Internal.Http.Server.SimpleBackend
 
    ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded
+                -fno-warn-unused-do-bind
 
 
 Executable pongserver
@@ -63,6 +64,7 @@ Executable pongserver
 
    build-depends:
      QuickCheck >= 2,
+     array >= 0.3 && <0.4,
      attoparsec >= 0.8 && < 0.9,
      attoparsec-iteratee >= 0.1 && <0.2,
      base >= 4 && < 5,
@@ -75,7 +77,6 @@ Executable pongserver
      dlist >= 0.5 && < 0.6,
      filepath,
      haskell98,
-     hexpat >= 0.11,
      HUnit >= 1.2 && < 2,
      monads-fd,
      old-locale,
@@ -99,4 +100,5 @@ Executable pongserver
      other-modules: Snap.Internal.Http.Server.SimpleBackend
 
    ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields -threaded
+                -fno-warn-unused-do-bind
    ghc-prof-options: -prof -auto-all
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs
index aff2a08..2eed62a 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -12,6 +12,7 @@ import           Data.ByteString (ByteString)
 import           Data.ByteString.Internal (c2w)
 import           Data.IORef
 import qualified Data.Map as Map
+import           Data.Maybe (fromJust)
 import           Data.Time.Calendar
 import           Data.Time.Clock
 import           Prelude hiding (take)
@@ -63,7 +64,7 @@ testHttpRequest1 =
     testCase "HttpRequest1" $ do
         iter <- enumBS sampleRequest $
                 do
-                    r <- rsm receiveRequest
+                    r <- liftM fromJust $ rsm receiveRequest
                     b <- liftM fromWrap $ joinIM $ rqBody r stream2stream
                     return (r,b)
 
@@ -104,9 +105,9 @@ testMultiRequest =
     testCase "MultiRequest" $ do
         iter <- (enumBS sampleRequest >. enumBS sampleRequest) $
                 do
-                    r1 <- rsm receiveRequest
+                    r1 <- liftM fromJust $ rsm receiveRequest
                     b1 <- liftM fromWrap $ joinIM $ rqBody r1 stream2stream
-                    r2 <- rsm receiveRequest
+                    r2 <- liftM fromJust $ rsm receiveRequest
                     b2 <- liftM fromWrap $ joinIM $ rqBody r2 stream2stream
                     return (r1,b1,r2,b2)
 
@@ -127,7 +128,7 @@ testMultiRequest =
 
 testOneMethod :: Method -> IO ()
 testOneMethod m = do
-    iter <- enumLBS txt $ rsm receiveRequest
+    iter <- enumLBS txt $ liftM fromJust $ rsm receiveRequest
     req <- run iter
 
     assertEqual "method" m $ rqMethod req
@@ -141,7 +142,7 @@ sampleShortRequest = "GET /fo"
 
 testPartialParse :: Test
 testPartialParse = testCase "Short" $ do
-    iter <- enumBS sampleShortRequest $ rsm receiveRequest
+    iter <- enumBS sampleShortRequest $ liftM fromJust $ rsm receiveRequest
 
     e <- (try $ run iter) :: IO (Either SomeException Request)
 
@@ -172,7 +173,7 @@ testHttpRequest2 =
     testCase "HttpRequest2" $ do
         iter <- enumBS sampleRequest2 $
                 do
-                    r <- rsm receiveRequest
+                    r <- liftM fromJust $ rsm receiveRequest
                     b <- liftM fromWrap $ joinIM $ rqBody r stream2stream
                     return (r,b)
 
@@ -186,7 +187,7 @@ testHttpRequest3 =
     testCase "HttpRequest3" $ do
         iter <- enumBS sampleRequest3 $
                 do
-                    r <- rsm receiveRequest
+                    r <- liftM fromJust $ rsm receiveRequest
                     b <- liftM fromWrap $ joinIM $ rqBody r stream2stream
                     return (r,b)
 
@@ -225,13 +226,15 @@ sampleRequest3 =
 
 
 rsm :: ServerMonad a -> Iteratee IO a
-rsm = runServerMonad "localhost" "127.0.0.1" 80 "127.0.0.1" 58382
-
+rsm = runServerMonad "localhost" "127.0.0.1" 80 "127.0.0.1" 58382 alog elog
+  where
+    alog = const . const . return $ ()
+    elog = const $ return ()
 
 testHttpResponse1 :: Test
 testHttpResponse1 = testCase "HttpResponse1" $ do
     b <- run $ rsm $
-         sendResponse rsp1 stream2stream >>= return . fromWrap
+         sendResponse rsp1 stream2stream >>= return . fromWrap . snd
 
     assertEqual "http response" b $ L.concat [
                       "HTTP/1.0 600 Test
"
@@ -241,7 +244,7 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
                     ]
 
     b2 <- run $ rsm $
-          sendResponse rsp2 stream2stream >>= return . fromWrap
+          sendResponse rsp2 stream2stream >>= return . fromWrap . snd
 
     assertEqual "http response" b2 $ L.concat [
                       "HTTP/1.0 600 Test
"
@@ -250,7 +253,7 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
                     ]
 
     b3 <- run $ rsm $
-          sendResponse rsp3 stream2stream >>= return . fromWrap
+          sendResponse rsp3 stream2stream >>= return . fromWrap . snd
 
     assertEqual "http response" b3 $ L.concat [
                       "HTTP/1.1 600 Test
"
@@ -308,7 +311,7 @@ testHttp1 = testCase "http session" $ do
     let iter = mkIter ref
 
     runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384
-            enumBody iter echoServer
+            Nothing Nothing enumBody iter echoServer
 
     s <- readIORef ref
 
@@ -362,7 +365,7 @@ testHttp2 = testCase "connection: close" $ do
     let iter = mkIter ref
 
     runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384
-            enumBody iter echoServer2
+            Nothing Nothing enumBody iter echoServer2
 
     s <- readIORef ref
 


More information about the Snap mailing list