git.iko.soy/typeable/wai
on master help sign in
More thorough testing; unbump unix-compat
commita02f907be5fc80dae37218c46b3d0cb7860eaad3 authorMichael Snoyman <michael@snoyman.com> dateSun 28 Aug 2011, 01:38 (15 years ago) parentfc07184
13 files changed+89−52
compare with master
unifiedsplit
install-all.sh+4−2 wai-app-static/wai-app-static.cabal+1−1 wai-extra/Network/Wai/Handler/CGI.hs+7−6 wai-extra/Network/Wai/Middleware/Debug.hs+1−1 wai-extra/runtests.hs+39−29 wai-handler-fastcgi/wai-handler-fastcgi.cabal+1 wai-handler-launch/Network/Wai/Handler/Launch.hs+11−7 wai-handler-scgi/wai-handler-scgi.cabal+1 wai-test/Network/Wai/Test.hs+17−1 wai-test/wai-test.cabal+2−1 warp-static/warp-static.cabal+1 warp-static/warp.hs+2−3 warp/warp.cabal+2−1
install-all.sh+4−2
@@ -24,13 +24,15 @@ for pkg in "${pkgs[@]}"; do
2424 (
2525 cd "./$pkg"
2626
27− if ! $CABAL configure --enable-tests; then
27+ if ! $CABAL configure --enable-tests --ghc-options="-Wall -Werror" ; then
2828 $CABAL install --only-dependencies
29− $CABAL configure --enable-tests
29+ $CABAL configure --enable-tests --ghc-options="-Wall -Werror"
3030 fi
3131
3232 $CABAL build
3333 $CABAL test
34+ $CABAL check
35+ $CABAL haddock --executables
3436 ./Setup.lhs install
3537 )
3638done
wai-app-static/wai-app-static.cabal+1−1
@@ -23,7 +23,7 @@ library
2323 , bytestring >= 0.9.1.4 && < 0.10
2424 , http-types >= 0.6 && < 0.7
2525 , transformers >= 0.2.2 && < 0.3
26− , unix-compat >= 0.2 && < 0.4
26+ , unix-compat >= 0.2 && < 0.3
2727 , directory >= 1.0 && < 1.2
2828 , containers >= 0.2 && < 0.5
2929 , blaze-html >= 0.4 && < 0.5
wai-extra/Network/Wai/Handler/CGI.hs+7−6
@@ -147,16 +147,17 @@ runGeneric vars inputH outputH xsendfile app = do
147147 Just _ -> h
148148
149149cleanupVarName :: String -> CI.CI B.ByteString
150−cleanupVarName ('H':'T':'T':'P':'_':a:as) =
151− String.fromString $ a : helper' as
150+cleanupVarName "CONTENT_TYPE" = "Content-Type"
151+cleanupVarName "CONTENT_LENGTH" = "Content-Length"
152+cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
153+cleanupVarName s =
154+ case s of
155+ 'H':'T':'T':'P':'_':a:as -> String.fromString $ a : helper' as
156+ _ -> String.fromString s -- FIXME remove?
152157 where
153158 helper' ('_':x:rest) = '-' : x : helper' rest
154159 helper' (x:rest) = toLower x : helper' rest
155160 helper' [] = []
156−cleanupVarName "CONTENT_TYPE" = "Content-Type"
157−cleanupVarName "CONTENT_LENGTH" = "Content-Length"
158−cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
159−cleanupVarName x = String.fromString x -- FIXME remove?
160161
161162requestBodyHandle :: Handle -> Int -> Enumerator B.ByteString IO a
162163requestBodyHandle h =
wai-extra/Network/Wai/Middleware/Debug.hs+1−1
@@ -45,7 +45,7 @@ debugHandle cb app req = do
4545 where
4646 paramsToStr prefix params = if null params then "" else "\n" ++ prefix ++ (show params)
4747
48− allPostParams req body = run_ $ enumList 1 body $$ parseRequestBody lbsSink req
48+ allPostParams req' body = run_ $ enumList 1 body $$ parseRequestBody lbsSink req'
4949
5050 emptyGetParam :: (S.ByteString, Maybe S.ByteString) -> (S.ByteString, S.ByteString)
5151 emptyGetParam (k, Just v) = (k,v)
wai-extra/runtests.hs+39−29
@@ -1,6 +1,5 @@
11{-# LANGUAGE OverloadedStrings #-}
22import Test.Hspec
3−import Test.Hspec.QuickCheck
43import Test.Hspec.HUnit ()
54import Test.HUnit hiding (Test)
65
@@ -20,7 +19,7 @@ import Network.Wai.Middleware.Vhost
2019import Network.Wai.Middleware.Autohead
2120import Network.Wai.Middleware.MethodOverride
2221import Network.Wai.Middleware.AcceptOverride
23−import Network.Wai.Middleware.Debug (debug, debugHandle)
22+import Network.Wai.Middleware.Debug (debugHandle)
2423import Codec.Compression.GZip (decompress)
2524
2625import Data.Enumerator (run_, enumList, ($$), Iteratee)
@@ -162,18 +161,18 @@ caseParseRequestBody = run_ t where
162161 result3'
163162
164163toRequest :: S8.ByteString -> S8.ByteString -> SRequest
165−toRequest ctype content = SRequest (Request
164+toRequest ctype content = SRequest defaultRequest
166165 { requestHeaders = [("Content-Type", ctype)]
167166 , requestMethod = "POST"
168167 , rawPathInfo = ""
169168 , rawQueryString = ""
170169 , queryString = []
171− }) (L.fromChunks [content])
170+ } (L.fromChunks [content])
172171
173172toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
174−toRequest' ctype content = SRequest (Request
173+toRequest' ctype content = SRequest defaultRequest
175174 { requestHeaders = [("Content-Type", ctype)]
176− }) (L.fromChunks $ map S.singleton $ S.unpack content)
175+ } (L.fromChunks $ map S.singleton $ S.unpack content)
177176
178177{-
179178caseFindBound :: Assertion
@@ -226,6 +225,7 @@ caseTakeLine = do
226225 Just needle @=? x
227226-}
228227
228+jsonpApp :: Application
229229jsonpApp = jsonp $ const $ return $ responseLBS
230230 status200
231231 [("Content-Type", "application/json")]
@@ -233,38 +233,39 @@ jsonpApp = jsonp $ const $ return $ responseLBS
233233
234234caseJsonp :: Assertion
235235caseJsonp = flip runSession jsonpApp $ do
236− sres1 <- request Request
236+ sres1 <- request defaultRequest
237237 { queryString = [("callback", Just "test")]
238238 , requestHeaders = [("Accept", "text/javascript")]
239239 }
240240 assertContentType "text/javascript" sres1
241241 assertBody "test({\"foo\":\"bar\"})" sres1
242242
243− sres2 <- request Request
243+ sres2 <- request defaultRequest
244244 { queryString = [("call_back", Just "test")]
245245 , requestHeaders = [("Accept", "text/javascript")]
246246 }
247247 assertContentType "application/json" sres2
248248 assertBody "{\"foo\":\"bar\"}" sres2
249249
250− sres3 <- request Request
250+ sres3 <- request defaultRequest
251251 { queryString = [("callback", Just "test")]
252252 , requestHeaders = [("Accept", "text/html")]
253253 }
254254 assertContentType "application/json" sres3
255255 assertBody "{\"foo\":\"bar\"}" sres3
256256
257+gzipApp :: Application
257258gzipApp = gzip True $ const $ return $ responseLBS status200 [] "test"
258259
259260caseGzip :: Assertion
260261caseGzip = flip runSession gzipApp $ do
261− sres1 <- request Request
262+ sres1 <- request defaultRequest
262263 { requestHeaders = [("Accept-Encoding", "gzip")]
263264 }
264265 assertHeader "Content-Encoding" "gzip" sres1
265266 liftIO $ decompress (simpleBody sres1) @?= "test"
266267
267− sres2 <- request Request
268+ sres2 <- request defaultRequest
268269 { requestHeaders = []
269270 }
270271 assertNoHeader "Content-Encoding" sres2
@@ -272,7 +273,7 @@ caseGzip = flip runSession gzipApp $ do
272273
273274caseGzipMSIE :: Assertion
274275caseGzipMSIE = flip runSession gzipApp $ do
275− sres1 <- request Request
276+ sres1 <- request defaultRequest
276277 { requestHeaders =
277278 [ ("Accept-Encoding", "gzip")
278279 , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")
@@ -281,6 +282,7 @@ caseGzipMSIE = flip runSession gzipApp $ do
281282 assertNoHeader "Content-Encoding" sres1
282283 liftIO $ simpleBody sres1 @?= "test"
283284
285+vhostApp1, vhostApp2, vhostApp :: Application
284286vhostApp1 = const $ return $ responseLBS status200 [] "app1"
285287vhostApp2 = const $ return $ responseLBS status200 [] "app2"
286288vhostApp = vhost
@@ -288,77 +290,85 @@ vhostApp = vhost
288290 ]
289291 vhostApp2
290292
293+caseVhost :: Assertion
291294caseVhost = flip runSession vhostApp $ do
292− sres1 <- request Request
295+ sres1 <- request defaultRequest
293296 { serverName = "foo.com"
294297 }
295298 assertBody "app1" sres1
296299
297− sres2 <- request Request
300+ sres2 <- request defaultRequest
298301 { serverName = "bar.com"
299302 }
300303 assertBody "app2" sres2
301304
305+autoheadApp :: Application
302306autoheadApp = autohead $ const $ return $ responseLBS status200
303307 [("Foo", "Bar")] "body"
304308
309+caseAutohead :: Assertion
305310caseAutohead = flip runSession autoheadApp $ do
306− sres1 <- request Request
311+ sres1 <- request defaultRequest
307312 { requestMethod = "GET"
308313 }
309314 assertHeader "Foo" "Bar" sres1
310315 assertBody "body" sres1
311316
312− sres1 <- request Request
317+ sres2 <- request defaultRequest
313318 { requestMethod = "HEAD"
314319 }
315− assertHeader "Foo" "Bar" sres1
316− assertBody "" sres1
320+ assertHeader "Foo" "Bar" sres2
321+ assertBody "" sres2
317322
323+moApp :: Application
318324moApp = methodOverride $ \req -> return $ responseLBS status200
319325 [("Method", requestMethod req)] ""
320326
327+caseMethodOverride :: Assertion
321328caseMethodOverride = flip runSession moApp $ do
322− sres1 <- request Request
329+ sres1 <- request defaultRequest
323330 { requestMethod = "GET"
324331 , queryString = []
325332 }
326333 assertHeader "Method" "GET" sres1
327334
328− sres2 <- request Request
335+ sres2 <- request defaultRequest
329336 { requestMethod = "POST"
330337 , queryString = []
331338 }
332339 assertHeader "Method" "POST" sres2
333340
334− sres3 <- request Request
341+ sres3 <- request defaultRequest
335342 { requestMethod = "POST"
336343 , queryString = [("_method", Just "PUT")]
337344 }
338345 assertHeader "Method" "PUT" sres3
339346
347+aoApp :: Application
340348aoApp = acceptOverride $ \req -> return $ responseLBS status200
341349 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
342350
351+caseAcceptOverride :: Assertion
343352caseAcceptOverride = flip runSession aoApp $ do
344− sres1 <- request Request
353+ sres1 <- request defaultRequest
345354 { queryString = []
346355 , requestHeaders = [("Accept", "foo")]
347356 }
348357 assertHeader "Accept" "foo" sres1
349358
350− sres2 <- request Request
359+ sres2 <- request defaultRequest
351360 { queryString = []
352361 , requestHeaders = [("Accept", "bar")]
353362 }
354363 assertHeader "Accept" "bar" sres2
355364
356− sres3 <- request Request
365+ sres3 <- request defaultRequest
357366 { queryString = [("_accept", Just "baz")]
358367 , requestHeaders = [("Accept", "bar")]
359368 }
360369 assertHeader "Accept" "baz" sres3
361370
371+caseDalvikMultipart :: Assertion
362372caseDalvikMultipart = do
363373 let headers =
364374 [ ("content-length", "12098")
@@ -378,10 +388,10 @@ caseDalvikMultipart = do
378388 , ("HTTP_VERSION", "HTTP/1.1")
379389 , ("REQUEST_PATH", "/")
380390 ]
381− let request = Request
391+ let request' = defaultRequest
382392 { requestHeaders = headers
383393 }
384− (params, files) <- run_ $ enumFile "test/dalvik-request" $$ parseRequestBody lbsSink request
394+ (params, files) <- run_ $ enumFile "test/dalvik-request" $$ parseRequestBody lbsSink request'
385395 lookup "scannedTime" params @?= Just "1.298590056748E9"
386396 lookup "geoLong" params @?= Just "0"
387397 lookup "geoLat" params @?= Just "0"
@@ -396,7 +406,7 @@ caseDebugRequestBody = do
396406
397407 let qs = "?foo=bar&baz=bin"
398408 flip runSession (debugApp $ getOutput qs) $ do
399− assertStatus 200 =<< request Request
409+ assertStatus 200 =<< request defaultRequest
400410 { requestMethod = "GET"
401411 , queryString = map (\(k,v) -> (k, Just v)) params
402412 , rawQueryString = qs
@@ -406,9 +416,9 @@ caseDebugRequestBody = do
406416 where
407417 params = [("foo", "bar"), ("baz", "bin")]
408418 postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)
409− getOutput qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)
419+ getOutput _qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)
410420
411− debugApp output = debugHandle (\t -> liftIO $ assertEqual "debug" output t) $ \req -> do
421+ debugApp output = debugHandle (\t -> liftIO $ assertEqual "debug" output t) $ \_req -> do
412422 return $ responseLBS status200 [ ] ""
413423 {-debugApp = debug $ \req -> do-}
414424 {-return $ responseLBS status200 [ ] ""-}
wai-handler-fastcgi/wai-handler-fastcgi.cabal+1
@@ -11,6 +11,7 @@ cabal-version: >= 1.2
1111build-type: Configure
1212extra-source-files: configure fastcgi.buildinfo.in
1313homepage: http://www.yesodweb.com/book/wai
14+description: Calls out to the libfcgi C library.
1415
1516library
1617 build-depends: base >= 4 && < 5
wai-handler-launch/Network/Wai/Handler/Launch.hs+11−7
@@ -11,13 +11,14 @@ import Network.HTTP.Types
1111import qualified Network.Wai.Handler.Warp as Warp
1212import Data.IORef
1313import Control.Concurrent
14−import Foreign
15−import Foreign.C.String
1614import Control.Monad.IO.Class (liftIO)
1715import qualified Data.ByteString as S
18−import Data.Enumerator (($$), enumList, joinI, Enumeratee, Stream (..), Iteratee (..), Step (..))
16+import Data.Enumerator (($$), joinI, Enumeratee, Stream (..), Iteratee (..), Step (..))
1917import Blaze.ByteString.Builder (fromByteString)
20−#if !WINDOWS
18+#if WINDOWS
19+import Foreign
20+import Foreign.C.String
21+#else
2122import System.Cmd (rawSystem)
2223#endif
2324import Codec.Zlib.Enum (ungzip)
@@ -92,11 +93,11 @@ insideHead toInsert =
9293 Error e -> return $ Error e
9394
9495 --feedCont :: Monad m => S.ByteString -> S.ByteString -> Stream S.ByteString -> Iteratee S.ByteString m (Step S.ByteString m a)
95− feedCont held atFront stream = do
96+ feedCont held' atFront' stream = do
9697 case step of
9798 Continue k -> do
9899 step' <- lift $ runIteratee $ k stream
99− go held atFront step'
100+ go held' atFront' step'
100101 Yield b s -> return $ Yield b s
101102 Error e -> return $ Error e
102103
@@ -112,6 +113,9 @@ getOverlap whole x =
112113 in (piece, atFront, x')
113114 | otherwise = go $ S.init piece
114115
116+fixHeaders :: ([Header] -> [Header])
117+ -> [Header]
118+ -> (Bool, [Header])
115119fixHeaders front [] = (False, front [])
116120fixHeaders front (("content-encoding", "gzip"):rest) = (True, front rest)
117121fixHeaders front (x:xs) = fixHeaders (front . (:) x) xs
@@ -141,7 +145,7 @@ run = runUrl ""
141145runUrl :: String -> Application -> IO ()
142146runUrl url app = do
143147 x <- newIORef True
144− forkIO $ Warp.runSettings Warp.defaultSettings
148+ _ <- forkIO $ Warp.runSettings Warp.defaultSettings
145149 { Warp.settingsPort = 4587
146150 , Warp.settingsOnException = const $ return ()
147151 , Warp.settingsHost = "127.0.0.1"
wai-handler-scgi/wai-handler-scgi.cabal+1
@@ -10,6 +10,7 @@ stability: stable
1010cabal-version: >= 1.6
1111build-type: Simple
1212homepage: http://www.yesodweb.com/book/wai
13+description: Wai handler to SCGI
1314
1415library
1516 build-depends: base >= 4 && < 5
wai-test/Network/Wai/Test.hs+17−1
@@ -8,6 +8,7 @@ module Network.Wai.Test
88 , srequest
99 , SRequest (..)
1010 , SResponse (..)
11+ , defaultRequest
1112 -- * Assertions
1213 , assertStatus
1314 , assertContentType
@@ -35,7 +36,7 @@ import Data.CaseInsensitive (CI)
3536type Session = ReaderT Application (StateT ClientState IO)
3637
3738data ClientState = ClientState
38− { clientCookies :: Map ByteString ByteString
39+ { _clientCookies :: Map ByteString ByteString
3940 }
4041
4142initState :: ClientState
@@ -57,6 +58,21 @@ data SResponse = SResponse
5758request :: Request -> Session SResponse
5859request = srequest . flip SRequest L.empty
5960
61+defaultRequest :: Request
62+defaultRequest = Request
63+ { requestMethod = "GET"
64+ , httpVersion = H.http11
65+ , rawPathInfo = "/"
66+ , rawQueryString = ""
67+ , serverName = "localhost"
68+ , serverPort = 80
69+ , requestHeaders = []
70+ , isSecure = False
71+ , remoteHost = error "Network.Wai.Test.defaultRequest{remoteHost}"
72+ , pathInfo = []
73+ , queryString = []
74+ }
75+
6076srequest :: SRequest -> Session SResponse
6177srequest (SRequest req bod) = do
6278 app <- ask
wai-test/wai-test.cabal+2−1
@@ -1,5 +1,5 @@
11name: wai-test
2−version: 0.1.0.2
2+version: 0.1.1
33license: BSD3
44license-file: LICENSE
55author: Michael Snoyman <michael@snoyman.com>
@@ -10,6 +10,7 @@ stability: Stable
1010cabal-version: >= 1.6
1111build-type: Simple
1212homepage: http://www.yesodweb.com/book/wai
13+description: Unit test framework (built on HUnit) for WAI applications.
1314
1415library
1516 build-depends: base >= 4 && < 5
warp-static/warp-static.cabal+1
@@ -9,6 +9,7 @@ Maintainer: michael@snoyman.com
99Category: Web
1010Build-type: Simple
1111Cabal-version: >=1.2
12+Description: Static file server based on Warp and wai-app-static
1213
1314
1415Executable warp
warp-static/warp.hs+2−3
@@ -6,7 +6,6 @@ import Network.Wai.Application.Static
66 , fileName, toFilePath
77 )
88import Network.Wai.Handler.Warp (run)
9−import System.Environment (getArgs)
109import System.Console.CmdArgs
1110import Text.Printf (printf)
1211import System.Directory (canonicalizePath)
@@ -17,7 +16,7 @@ import Network.Wai.Middleware.Gzip
1716import qualified Data.Map as Map
1817import qualified Data.ByteString.Char8 as S8
1918import Control.Arrow ((***))
20−import Data.Text (pack, unpack)
19+import Data.Text (pack)
2120
2221data Args = Args
2322 { docroot :: FilePath
@@ -30,6 +29,7 @@ data Args = Args
3029 }
3130 deriving (Show, Data, Typeable)
3231
32+defaultArgs :: Args
3333defaultArgs = Args "." ["index.html", "index.htm"] 3000 False False False []
3434
3535main :: IO ()
@@ -38,7 +38,6 @@ main = do
3838 let mime' = map (toFilePath *** S8.pack) mime
3939 let mimeMap = Map.fromList mime' `Map.union` defaultMimeTypes
4040 docroot' <- canonicalizePath docroot
41− args <- getArgs
4241 unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)
4342 let middle = gzip False
4443 . (if verbose then debug else id)
warp/warp.cabal+2−1
@@ -10,6 +10,7 @@ Category: Web, Yesod
1010Build-Type: Simple
1111Cabal-Version: >=1.6
1212Stability: Stable
13+Description: The premier WAI handler. For more information, see <http://steve.vinoski.net/blog/2011/05/01/warp-a-haskell-web-server/>.
1314
1415flag network-bytestring
1516 Default: False
@@ -25,7 +26,7 @@ Library
2526 , simple-sendfile >= 0.1 && < 0.2
2627 , http-types >= 0.6 && < 0.7
2728 , case-insensitive >= 0.2 && < 0.4
28− , unix-compat >= 0.2 && < 0.4
29+ , unix-compat >= 0.2 && < 0.3
2930 if flag(network-bytestring)
3031 build-depends: network >= 2.2.1 && < 2.2.3
3132 , network-bytestring >= 0.1.3 && < 0.1.4