wai-extra 1.1.0.1 → 1.2.0

raw patch · 7 files changed

+74/−56 lines, 7 filesdep ~blaze-builder-conduitdep ~conduitdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: blaze-builder-conduit, conduit, transformers, wai, zlib-conduit

API changes (from Hackage documentation)

Files

• Network/Wai/Handler/CGI.hs +7/−7
• Network/Wai/Middleware/RequestLogger.hs +22/−12
• Network/Wai/Middleware/Rewrite.hs +15/−21
• Network/Wai/Middleware/Vhost.hs +15/−1
• Network/Wai/Parse.hs +7/−7
• test/WaiExtraTest.hs +2/−2
• wai-extra.cabal +6/−6

@@ -66,7 +66,7 @@ -- stick with 'run' or 'runSendfile'. runGeneric      :: [(String, String)] -- ^ all variables-     -> (Int -> C.Source IO B.ByteString) -- ^ responseBody of input+     -> (Int -> C.Source (C.ResourceT IO) B.ByteString) -- ^ responseBody of input      -> (B.ByteString -> IO ()) -- ^ destination for output      -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?      -> Application@@ -141,12 +141,12 @@         , fromByteString sf         , fromByteString " not supported"         ]-    bsSink = C.SinkData push (return ())-    push (C.Chunk bs) = do+    bsSink = C.NeedInput push (return ())+    push (C.Chunk bs) = C.PipeM (do         liftIO $ outputH bs-        return $ C.Processing push (return ())+        return bsSink) (return ())     -- FIXME actually flush?-    push C.Flush = return $ C.Processing push (return ())+    push C.Flush = bsSink     builderSink = builderToByteStringFlush C.=$ bsSink     fixHeaders h =         case lookup "content-type" h of@@ -166,12 +166,12 @@     helper' (x:rest) = toLower x : helper' rest     helper' [] = [] -requestBodyHandle :: Handle -> Int -> C.Source IO B.ByteString+requestBodyHandle :: Handle -> Int -> C.Source (C.ResourceT IO) B.ByteString requestBodyHandle h = requestBodyFunc $ \i -> do     bs <- B.hGet h i     return $ if B.null bs then Nothing else Just bs -requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> C.Source IO B.ByteString+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> C.Source (C.ResourceT IO) B.ByteString requestBodyFunc get count0 =     C.sourceState count0 pull   where

@@ -13,9 +13,10 @@ import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack, unpack) import Control.Monad.IO.Class (liftIO)-import Network.Wai (Request(..), Middleware, responseStatus)+import Network.Wai (Request(..), Middleware, responseStatus, Response) import System.Log.FastLogger import Network.HTTP.Types as H+import Data.Maybe (fromMaybe)  import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType) import qualified Data.ByteString.Lazy as LBS@@ -37,7 +38,7 @@ -- | Production request logger middleware. -- Implemented on top of "logCallback", but prints to 'stdout' logStdout :: Middleware-logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs]+logStdout = logCallback $ \bs -> hPutLogStr stdout [LB bs]  -- | Development request logger middleware. -- Implemented on top of "logCallbackDev", but prints to 'stdout'@@ -45,7 +46,7 @@ -- Flushes 'stdout' on each request, which would be inefficient in production use. -- Use "logStdout" in production. logStdoutDev :: Middleware-logStdoutDev = logHandleDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout+logStdoutDev = logCallbackDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout  -- | Prints a message using the given callback function for each request. -- Designed for fast production use at the expense of convenience.@@ -55,6 +56,7 @@ logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.             -> Middleware logCallback cb app req = do+    rsp <- app req     liftIO $ cb $ BS.concat         [ requestMethod req         , " "@@ -64,15 +66,19 @@         , "Accept: "         , maybe "" toBS $ lookup "Accept" $ requestHeaders req         , "\n"+        , "Status: "+        , statusBS rsp+        , " "+        , msgBS rsp         ]-    app req+    return rsp  toBS :: H.Ascii -> BS.ByteString toBS = id  -- no black or white which are expected to be existing terminal colors. colors :: IORef [Color]-colors = unsafePerformIO $ newIORef $ [+colors = unsafePerformIO $ newIORef [     Red    , Green    , Yellow @@ -124,7 +130,7 @@                  return (req', body)             _ -> return (req, []) -    postParams <- if any (requestMethod req ==) ["GET", "HEAD"]+    postParams <- if requestMethod req `elem` ["GET", "HEAD"]       then return []       else do postParams <- liftIO $ allPostParams body               return $ collectPostParams postParams@@ -139,7 +145,7 @@         , rawPathInfo req         , "\n"         , "Accept: "-        , maybe "" id $ lookup "Accept" $ requestHeaders req+        , fromMaybe "" $ lookup "Accept" $ requestHeaders req         , paramsToBS  "GET " getParams         , paramsToBS "POST " postParams         , "\n"@@ -151,9 +157,9 @@     -- this is color coordinated with the request logging     -- also includes the request path to connect it to the request     liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [-          sCode rsp+          statusBS rsp         , " "-        , msg rsp+        , msgBS rsp         , ". "         , rawPathInfo req -- if you need help matching the 2 logging statements         , "\n"@@ -165,8 +171,6 @@       , bs       , pack $ setSGRCode [Reset]       ]-    sCode = pack . show . statusCode . responseStatus-    msg = statusMessage . responseStatus      paramsToBS prefix params =       if null params then ""@@ -183,9 +187,15 @@      collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]     collectPostParams (postParams, files) = postParams ++-      (map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files)+      map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files      readInt bs =         case reads $ unpack bs of             (i, _):_ -> Just (i :: Int)             [] -> Nothing++statusBS :: Response -> BS.ByteString+statusBS = pack . show . statusCode . responseStatus++msgBS :: Response -> BS.ByteString+msgBS = statusMessage . responseStatus

@@ -1,39 +1,33 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.Rewrite-    ( rewrite, autoHtmlRewrite+    ( rewrite, rewritePure     ) where  import Network.Wai-import System.Directory (doesFileExist) import Control.Monad.IO.Class (liftIO)-import Data.Text (Text, unpack, pack)+import Data.Text (Text) import qualified Data.Text.Encoding as TE import qualified Data.Text as T import Network.HTTP.Types as H   -- | rewrite based on your own conversion rules--- Example usage: rewrite (autoHtmlRewrite "static") rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware rewrite convert app req = do   newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)   let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo   app req { pathInfo = newPathInfo, rawPathInfo =  rawPInfo } --- | example rewriter--- We don't recommend normally checking the file system on every request - this is just an example.--- Implements 2 rules for static html re-writes---   1) for a directory foo/, check for foo/index.html---   2) for a non-directory bar, check for bar.html--- Do the rewrite only if the html file exists.-autoHtmlRewrite :: String -> [Text] -> H.RequestHeaders -> IO [Text]-autoHtmlRewrite staticDir pieces' _ = do-    fe <- doesFileExist $ staticDir ++ "/" ++ reWritePath-    return $ if fe then map pack reWritePieces else pieces'-  where-    pieces = map unpack pieces'-    reWritePath = concat $ map ((:) '/') reWritePieces-    reWritePieces =-       if (null pieces) || (null $ last pieces)-          then pieces ++  ["index.html"]-          else (init pieces) ++ [(last pieces) ++ ".html"]+-- | rewrite based on your own conversion rules+-- Example convert function:++-- staticConvert :: [Text] -> H.RequestHeaders -> [Text]+-- staticConvert pieces _ = piecesConvert pieces+--   where+--    piecesConvert [] = ["static", "html", "pages.html"]+--    piecesConvert route@("pages":_) = "static":"html":route+rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware+rewritePure convert app req =+  let pInfo = convert (pathInfo req) (requestHeaders req)+      rawPInfo = TE.encodeUtf8 $ T.intercalate "/" pInfo+  in  app req { pathInfo = pInfo, rawPathInfo =  rawPInfo }

@@ -1,9 +1,23 @@-module Network.Wai.Middleware.Vhost (vhost) where+{-# LANGUAGE OverloadedStrings #-}+module Network.Wai.Middleware.Vhost (vhost, redirectWWW) where  import Network.Wai +import Network.HTTP.Types as H+import qualified Data.Text.Encoding as TE+import Data.Text (Text)+import qualified Data.ByteString as BS+ vhost :: [(Request -> Bool, Application)] -> Application -> Application vhost vhosts def req =     case filter (\(b, _) -> b req) vhosts of         [] -> def req         (_, app):_ -> app req++redirectWWW :: Text -> Application -> Application -- W.MiddleWare+redirectWWW home app req =+  if BS.isPrefixOf "www" $ serverName req+    then return $ responseLBS H.status301+          [ ("Content-Type", "text/plain") , ("Location", TE.encodeUtf8 home) ] "Redirect"+    else app req+

@@ -182,12 +182,12 @@  sinkRequestBody :: BackEnd y                 -> RequestBodyType-                -> C.Sink S.ByteString IO ([Param], [File y])+                -> C.Sink S.ByteString (C.ResourceT IO) ([Param], [File y]) sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r C.=$ CL.consume  conduitRequestBody :: BackEnd y                    -> RequestBodyType-                   -> C.Conduit S.ByteString IO (Either Param (File y))+                   -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y)) conduitRequestBody _ UrlEncoded = C.sequenceSink () $ \() -> do -- url-encoded     -- NOTE: in general, url-encoded data will be in a single chunk.     -- Therefore, I'm optimizing for the usual case by sticking with@@ -197,7 +197,7 @@ conduitRequestBody backend (Multipart bound) =     parsePieces backend $ S8.pack "--" `S.append` bound -takeLine :: C.Sink S.ByteString IO (Maybe S.ByteString)+takeLine :: C.Sink S.ByteString (C.ResourceT IO) (Maybe S.ByteString) takeLine =     C.sinkState id push close'   where@@ -210,7 +210,7 @@                     let lo = if S.length y > 1 then Just (S.drop 1 y) else Nothing                     return $ C.StateDone lo $ Just $ killCR x -takeLines :: C.Sink S.ByteString IO [S.ByteString]+takeLines :: C.Sink S.ByteString (C.ResourceT IO) [S.ByteString] takeLines = do     res <- takeLine     case res of@@ -222,12 +222,12 @@                 return $ l : ls  parsePieces :: BackEnd y -> S.ByteString-            -> C.Conduit S.ByteString IO (Either Param (File y))+            -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y)) parsePieces sink bound = C.sequenceSink True (parsePiecesSink sink bound)  parsePiecesSink :: BackEnd y                 -> S.ByteString-                -> C.SequencedSink Bool S.ByteString IO (Either Param (File y))+                -> C.SequencedSink Bool S.ByteString (C.ResourceT IO) (Either Param (File y)) parsePiecesSink _ _ False = return C.Stop parsePiecesSink BackEnd{initialize=initialize',append=append',close=close'}                 bound True = do@@ -299,7 +299,7 @@ sinkTillBound :: S.ByteString               -> (x -> S.ByteString -> IO x)               -> x-              -> C.Sink S.ByteString IO (x, Bool)+              -> C.Sink S.ByteString (C.ResourceT IO) (x, Bool) sinkTillBound bound iter seed0 = C.sinkState     (id, seed0)     push

@@ -430,9 +430,9 @@   where     params = [("foo", "bar"), ("baz", "bin")]     -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)-    postOutput = T.pack $ "POST / Accept: \n"+    postOutput = T.pack $ "POST / Accept: \nStatus: 200 OK"     -- FIXME getOutput _qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)-    getOutput _qs = T.pack $ "GET /location?foo=bar&baz=bin Accept: \n"+    getOutput _qs = T.pack $ "GET /location?foo=bar&baz=bin Accept: \nStatus: 200 OK"      debugApp output' = logCallback (\t -> liftIO $ assertEqual "debug" output t) $ \_req -> do         return $ responseLBS status200 [ ] ""

@@ -1,5 +1,5 @@ Name:                wai-extra-Version:             1.1.0.1+Version:             1.2.0 Synopsis:            Provides some basic WAI handlers and middleware. Description:         The goal here is to provide common features without many dependencies. License:             BSD3@@ -22,21 +22,21 @@ Library   Build-Depends:     base                      >= 4 && < 5                    , bytestring                >= 0.9.1.4  && < 0.10-                   , wai                       >= 1.1      && < 1.2+                   , wai                       >= 1.2      && < 1.3                    , old-locale                >= 1.0.0.2  && < 1.1                    , time                      >= 1.1.4                    , network                   >= 2.2.1.5  && < 2.4                    , directory                 >= 1.0.1    && < 1.2-                   , transformers              >= 0.2.2    && < 0.3+                   , transformers              >= 0.2.2    && < 0.4                    , blaze-builder             >= 0.2.1.4  && < 0.4                    , http-types                >= 0.6      && < 0.7                    , text                      >= 0.7      && < 0.12                    , case-insensitive          >= 0.2                    , data-default              >= 0.3      && < 0.4                    , fast-logger               >= 0.0.2-                   , conduit                   >= 0.2      && < 0.3-                   , zlib-conduit              >= 0.2      && < 0.3-                   , blaze-builder-conduit     >= 0.2      && < 0.3+                   , conduit                   >= 0.4      && < 0.5+                   , zlib-conduit              >= 0.4      && < 0.5+                   , blaze-builder-conduit     >= 0.4      && < 0.5                    , ansi-terminal    Exposed-modules:   Network.Wai.Handler.CGI