wai-extra 0.1.3.1 → 0.2.0
raw patch · 7 files changed
+57/−51 lines, 7 filesdep ~timedep ~waiPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: time, wai
API changes (from Hackage documentation)
Files
- Network/Wai/Handler/CGI.hs +19/−16
- Network/Wai/Handler/SimpleServer.hs +13/−12
- Network/Wai/Middleware/CleanPath.hs +5/−6
- Network/Wai/Middleware/Gzip.hs +8/−7
- Network/Wai/Middleware/Jsonp.hs +7/−6
- Network/Wai/Parse.hs +2/−1
- wai-extra.cabal +3/−3
Network/Wai/Handler/CGI.hs view
@@ -1,10 +1,11 @@+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.CGI ( run , run' ) where import Network.Wai-import Network.Wai.Enumerator (fromEitherFile)+import Network.Wai.Enumerator (fromResponseBody) import Network.Wai.Handler.Helper import System.Environment (getEnvironment) import Data.Maybe (fromMaybe)@@ -12,6 +13,7 @@ import Control.Arrow ((***)) import Data.Char (toLower) import qualified System.IO+import Data.String (fromString) safeRead :: Read a => a -> String -> a safeRead d s =@@ -33,7 +35,7 @@ -> Application -> IO () run' vars inputH outputH app = do- let rmethod = safeRead GET $ lookup' "REQUEST_METHOD" vars+ let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars pinfo = lookup' "PATH_INFO" vars qstring = lookup' "QUERY_STRING" vars servername = lookup' "SERVER_NAME" vars@@ -46,10 +48,10 @@ case lookup "REMOTE_ADDR" vars of Just x -> x Nothing -> ""- urlScheme' =+ isSecure' = case map toLower $ lookup' "SERVER_PROTOCOL" vars of- "https" -> HTTPS- _ -> HTTP+ "https" -> True+ _ -> False let env = Request { requestMethod = rmethod , pathInfo = B.pack pinfo@@ -57,16 +59,16 @@ , serverName = B.pack servername , serverPort = serverport , requestHeaders = map (cleanupVarName *** B.pack) vars- , urlScheme = urlScheme'+ , isSecure = isSecure' , requestBody = requestBodyHandle inputH contentLength , errorHandler = System.IO.hPutStr System.IO.stderr , remoteHost = B.pack remoteHost'- , httpVersion = HttpVersion B.empty+ , httpVersion = "1.1" -- FIXME } res <- app env let h = responseHeaders res- let h' = case lookup ContentType h of- Nothing -> (ContentType, B.pack "text/html; charset=utf-8")+ let h' = case lookup "Content-Type" h of+ Nothing -> ("Content-Type", "text/html; charset=utf-8") : h Just _ -> h let hPut = B.hPut outputH@@ -75,7 +77,7 @@ hPut $ B.singleton '\n' mapM_ (printHeader hPut) h' hPut $ B.singleton '\n'- _ <- runEnumerator (fromEitherFile (responseBody res)) (myPut outputH) ()+ _ <- runEnumerator (fromResponseBody (responseBody res)) (myPut outputH) () return () myPut :: System.IO.Handle -> () -> B.ByteString -> IO (Either () ())@@ -85,18 +87,19 @@ -> (ResponseHeader, B.ByteString) -> IO () printHeader f (x, y) = do- f $ responseHeaderToBS x+ f $ ciOriginal x f $ B.pack ": " f y f $ B.singleton '\n' cleanupVarName :: String -> RequestHeader cleanupVarName ('H':'T':'T':'P':'_':a:as) =- requestHeaderFromBS $ B.pack $ a : helper' as where+ fromString $ a : helper' as+ where helper' ('_':x:rest) = '-' : x : helper' rest helper' (x:rest) = toLower x : helper' rest helper' [] = []-cleanupVarName "CONTENT_TYPE" = ReqContentType-cleanupVarName "CONTENT_LENGTH" = ReqContentLength-cleanupVarName "SCRIPT_NAME" = requestHeaderFromBS $ B.pack "CGI-Script-Name"-cleanupVarName x = requestHeaderFromBS $ B.pack x -- FIXME remove?+cleanupVarName "CONTENT_TYPE" = "Content-Type"+cleanupVarName "CONTENT_LENGTH" = "Content-Length"+cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"+cleanupVarName x = fromString x -- FIXME remove?
Network/Wai/Handler/SimpleServer.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Handler.SimpleServer@@ -23,6 +24,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as L import Network ( listenOn, accept, sClose, PortID(PortNumber), Socket , withSocketsDo)@@ -100,18 +102,16 @@ case lines' of (_:_:_) -> return () _ -> throwIO $ NotEnoughLines $ map B.unpack lines'- (method', rpath', gets, httpversion) <- parseFirst $ head lines'- let method = methodFromBS method'+ (method, rpath', gets, httpversion) <- parseFirst $ head lines' let rpath = '/' : case B.unpack rpath' of ('/':x) -> x _ -> B.unpack rpath'- let heads = map (first requestHeaderFromBS . parseHeaderNoAttr)- $ tail lines'- let host' = lookup Host heads+ let heads = map (first mkCIByteString . parseHeaderNoAttr) $ tail lines'+ let host' = lookup "Host" heads unless (isJust host') $ throwIO HostNotIncluded let host = fromJust host' let len = fromMaybe 0 $ do- bs <- lookup ReqContentLength heads+ bs <- lookup "Content-Length" heads let str = B.unpack bs case reads str of (x, _):_ -> Just x@@ -125,7 +125,7 @@ , serverName = serverName' , serverPort = port , requestHeaders = heads- , urlScheme = HTTP+ , isSecure = False , requestBody = requestBodyHandle handle len , errorHandler = System.IO.hPutStr System.IO.stderr , remoteHost = B.pack remoteHost'@@ -142,12 +142,12 @@ let (hfirst, hsecond) = B.splitAt 5 http' unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp let (rpath, qstring) = B.break (== '?') query- return (method, rpath, qstring, httpVersionFromBS hsecond)+ return (method, rpath, qstring, hsecond) sendResponse :: HttpVersion -> Handle -> Response -> IO () sendResponse httpversion h res = do B.hPut h $ B.pack "HTTP/"- B.hPut h $ httpVersionToBS httpversion+ B.hPut h $ httpversion B.hPut h $ B.pack " " B.hPut h $ B.pack $ show $ statusCode $ status res B.hPut h $ B.pack " "@@ -156,14 +156,15 @@ mapM_ putHeader $ responseHeaders res B.hPut h $ B.pack "\r\n" case responseBody res of- Left fp -> unsafeSendFile h fp- Right (Enumerator enum) -> enum myPut h >> return ()+ ResponseFile fp -> unsafeSendFile h fp+ ResponseEnumerator (Enumerator enum) -> enum myPut h >> return ()+ ResponseLBS lbs -> L.hPut h lbs where myPut _ bs = do B.hPut h bs return (Right h) putHeader (x, y) = do- B.hPut h $ responseHeaderToBS x+ B.hPut h $ ciOriginal x B.hPut h $ B.pack ": " B.hPut h y B.hPut h $ B.pack "\r\n"
Network/Wai/Middleware/CleanPath.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.CleanPath (cleanPath, cleanPathRel, splitPath) where import Network.Wai import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as L import Network.URI (unEscapeString) -- | Performs redirects as per 'splitPath'.@@ -10,9 +12,9 @@ case splitPath $ pathInfo env of Right pieces -> app pieces env Left p -> return- . Response Status301- [(Location, B.concat [prefix, p, suffix])]- $ Right emptyEnum+ . Response status301+ [("Location", B.concat [prefix, p, suffix])]+ $ ResponseLBS L.empty where -- include the query string if present suffix =@@ -23,9 +25,6 @@ cleanPath :: ([String] -> Request -> IO Response) -> Request -> IO Response cleanPath = cleanPathRel B.empty--emptyEnum :: Enumerator-emptyEnum = Enumerator $ \_ -> return . Right -- | Given a certain requested path, return either a corrected path -- to redirect to or the tokenized path.
Network/Wai/Middleware/Gzip.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Gzip@@ -16,6 +17,7 @@ module Network.Wai.Middleware.Gzip (gzip) where import Network.Wai+import Network.Wai.Enumerator (fromResponseBody) import Network.Wai.Zlib import Data.Maybe (fromMaybe) import qualified Data.ByteString.Char8 as B@@ -37,23 +39,22 @@ gzip app env = do res <- app env case responseBody res of- Left _ -> return res- Right _ -> do+ ResponseFile _ -> return res+ _ -> do let enc = fromMaybe [] $ (splitCommas . B.unpack)- `fmap` lookup AcceptEncoding+ `fmap` lookup "Accept-Encoding" (requestHeaders env) if "gzip" `elem` enc then return res { responseBody = compressE $ responseBody res- , responseHeaders = (ContentEncoding, B.pack "gzip")+ , responseHeaders = ("Content-Encoding", "gzip") : responseHeaders res } else return res -compressE :: Either FilePath Enumerator -> Either FilePath Enumerator-compressE (Left fp) = Left fp-compressE (Right e) = Right $ compress e+compressE :: ResponseBody -> ResponseBody+compressE = ResponseEnumerator . compress . fromResponseBody splitCommas :: String -> [String] splitCommas [] = []
Network/Wai/Middleware/Jsonp.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Jsonp@@ -14,7 +15,7 @@ module Network.Wai.Middleware.Jsonp (jsonp) where import Network.Wai-import Network.Wai.Enumerator (fromEitherFile)+import Network.Wai.Enumerator (fromResponseBody) import qualified Data.ByteString.Char8 as B8 import Data.Maybe (fromMaybe) @@ -42,7 +43,7 @@ -- callback function. jsonp :: Middleware jsonp app env = do- let accept = fromMaybe B8.empty $ lookup Accept $ requestHeaders env+ let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env let callback :: Maybe B8.ByteString callback = if B8.pack "text/javascript" `B8.isInfixOf` accept@@ -52,15 +53,15 @@ case callback of Nothing -> env Just _ -> env- { requestHeaders = changeVal Accept+ { requestHeaders = changeVal "Accept" "application/json" $ requestHeaders env } res <- app env'- case (fmap B8.unpack $ lookup ContentType $ responseHeaders res, callback) of+ case (fmap B8.unpack $ lookup "Content-Type" $ responseHeaders res, callback) of (Just "application/json", Just c) -> return $ res- { responseHeaders = changeVal ContentType "text/javascript" $ responseHeaders res- , responseBody = Right $ addCallback c $ fromEitherFile $ responseBody res+ { responseHeaders = changeVal "Content-Type" "text/javascript" $ responseHeaders res+ , responseBody = ResponseEnumerator $ addCallback c $ fromResponseBody $ responseBody res } _ -> return res
Network/Wai/Parse.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} -- | Some helpers for parsing data out of a raw WAI 'Request'. module Network.Wai.Parse@@ -164,7 +165,7 @@ -> IO ([Param], [File y]) parseRequestBody sink req = do let ctype = do- ctype' <- lookup ReqContentType $ requestHeaders req+ ctype' <- lookup "Content-Type" $ requestHeaders req if urlenc `S.isPrefixOf` ctype' then Just Nothing else if formBound `S.isPrefixOf` ctype'
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 0.1.3.1+Version: 0.2.0 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: BSD3@@ -18,9 +18,9 @@ Library Build-Depends: base >= 3 && < 5, bytestring >= 0.9 && < 0.10,- wai >= 0.0.0 && < 0.2,+ wai >= 0.2.0 && < 0.3, old-locale >= 1.0 && < 1.1,- time >= 1.1.4 && < 1.2,+ time >= 1.1.4 && < 1.3, sendfile >= 0.6.1 && < 0.7, network >= 2.2.1.5 && < 2.3, directory >= 1.0.1 && < 1.1