wai-extra (empty) → 0.0.0
raw patch · 11 files changed
+725/−0 lines, 11 filesdep +basedep +bytestringdep +clientsessionsetup-changed
Dependencies added: base, bytestring, clientsession, failure, network, old-locale, predicates, safe, sendfile, split, time, wai, web-encodings, zlib
Files
- LICENSE +25/−0
- Network/Wai/Handler/CGI.hs +102/−0
- Network/Wai/Handler/Helper.hs +15/−0
- Network/Wai/Handler/SimpleServer.hs +175/−0
- Network/Wai/Middleware/CleanPath.hs +65/−0
- Network/Wai/Middleware/ClientSession.hs +136/−0
- Network/Wai/Middleware/Gzip.hs +58/−0
- Network/Wai/Middleware/Jsonp.hs +71/−0
- Network/Wai/Middleware/MethodOverride.hs +38/−0
- Setup.hs +2/−0
- wai-extra.cabal +38/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/Wai/Handler/CGI.hs view
@@ -0,0 +1,102 @@+module Network.Wai.Handler.CGI+ ( run+ , run'+ ) where++import Network.Wai+import Network.Wai.Enumerator (fromEitherFile)+import Network.Wai.Handler.Helper+import System.Environment (getEnvironment)+import Data.Maybe (fromMaybe)+import qualified Data.ByteString.Char8 as B+import Control.Arrow ((***))+import Data.Char (toLower)+import qualified System.IO++safeRead :: Read a => a -> String -> a+safeRead d s =+ case reads s of+ ((x, _):_) -> x+ [] -> d++lookup' :: String -> [(String, String)] -> String+lookup' key pairs = fromMaybe "" $ lookup key pairs++run :: Application -> IO ()+run app = do+ vars <- getEnvironment+ run' vars System.IO.stdin System.IO.stdout app++run' :: [(String, String)] -- ^ all variables+ -> System.IO.Handle -- ^ responseBody of input+ -> System.IO.Handle -- ^ destination for output+ -> Application+ -> IO ()+run' vars inputH outputH app = do+ let rmethod = safeRead GET $ lookup' "REQUEST_METHOD" vars+ pinfo = lookup' "PATH_INFO" vars+ qstring = lookup' "QUERY_STRING" vars+ servername = lookup' "SERVER_NAME" vars+ serverport = safeRead 80 $ lookup' "SERVER_PORT" vars+ contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars+ remoteHost' =+ case lookup "REMOTE_HOST" vars of+ Just x -> x+ Nothing ->+ case lookup "REMOTE_ADDR" vars of+ Just x -> x+ Nothing -> ""+ urlScheme' =+ case map toLower $ lookup' "SERVER_PROTOCOL" vars of+ "https" -> HTTPS+ _ -> HTTP+ let env = Request+ { requestMethod = rmethod+ , pathInfo = B.pack pinfo+ , queryString = B.pack qstring+ , serverName = B.pack servername+ , serverPort = serverport+ , requestHeaders = map (cleanupVarName *** B.pack) vars+ , urlScheme = urlScheme'+ , requestBody = requestBodyHandle inputH contentLength+ , errorHandler = System.IO.hPutStr System.IO.stderr+ , remoteHost = B.pack remoteHost'+ , httpVersion = HttpVersion B.empty+ }+ res <- app env+ let h = responseHeaders res+ let h' = case lookup ContentType h of+ Nothing -> (ContentType, B.pack "text/html; charset=utf-8")+ : h+ Just _ -> h+ let hPut = B.hPut outputH+ hPut $ B.pack $ "Status: " ++ (show $ statusCode $ status res) ++ " "+ hPut $ statusMessage $ status res+ hPut $ B.singleton '\n'+ mapM_ (printHeader hPut) h'+ hPut $ B.singleton '\n'+ _ <- runEnumerator (fromEitherFile (responseBody res)) (myPut outputH) ()+ return ()++myPut :: System.IO.Handle -> () -> B.ByteString -> IO (Either () ())+myPut outputH _ bs = B.hPut outputH bs >> return (Right ())++printHeader :: (B.ByteString -> IO ())+ -> (ResponseHeader, B.ByteString)+ -> IO ()+printHeader f (x, y) = do+ f $ responseHeaderToBS 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+ 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" = RequestHeader $ B.pack "CGI-Script-Name"+cleanupVarName x = requestHeaderFromBS $ B.pack x -- FIXME remove?
+ Network/Wai/Handler/Helper.hs view
@@ -0,0 +1,15 @@+module Network.Wai.Handler.Helper+ ( requestBodyHandle+ ) where++import System.IO (Handle)+import qualified Data.ByteString as B+import Data.ByteString.Lazy.Internal (defaultChunkSize)+import Network.Wai (Source (..))++requestBodyHandle :: Handle -> Int -> Source+requestBodyHandle _ 0 = Source $ return Nothing+requestBodyHandle h len = Source $ do+ bs <- B.hGet h $ min len defaultChunkSize+ let newLen = len - B.length bs+ return $ Just (bs, requestBodyHandle h newLen)
+ Network/Wai/Handler/SimpleServer.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+---------------------------------------------------------+-- |+-- Module : Network.Wai.Handler.SimpleServer+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- A simplistic HTTP server handler for Wai.+--+---------------------------------------------------------+module Network.Wai.Handler.SimpleServer+ ( run+ ) where++import Network.Wai+import Network.Wai.Handler.Helper+import qualified System.IO++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Network+ ( listenOn, accept, sClose, PortID(PortNumber), Socket+ , withSocketsDo)+import Control.Exception (bracket, finally, Exception)+import System.IO (Handle, hClose)+import Control.Concurrent (forkIO)+import Control.Monad (unless)+import Data.Maybe (isJust, fromJust, fromMaybe)++import Control.Failure+import Data.Typeable (Typeable)++import qualified Web.Encodings.StringLike as SL++import qualified Safe+import Network.Socket.SendFile+import Control.Arrow (first)++run :: Port -> Application -> IO ()+run port = withSocketsDo .+ bracket+ (listenOn $ PortNumber $ fromIntegral port)+ sClose .+ serveConnections port+type Port = Int++serveConnections :: Port -> Application -> Socket -> IO ()+serveConnections port app socket = do+ (conn, remoteHost', _) <- accept socket+ _ <- forkIO $ serveConnection port app conn remoteHost'+ serveConnections port app socket++serveConnection :: Port -> Application -> Handle -> String -> IO ()+serveConnection port app conn remoteHost' =+ finally+ serveConnection'+ (hClose conn)+ where+ serveConnection' = do+ env <- hParseRequest port conn remoteHost'+ res <- app env+ sendResponse (httpVersion env) conn res++hParseRequest :: Port -> Handle -> String -> IO Request+hParseRequest port conn remoteHost' = do+ headers' <- takeUntilBlank conn id+ parseRequest port headers' conn remoteHost'++takeUntilBlank :: Handle+ -> ([ByteString] -> [ByteString])+ -> IO [ByteString]+takeUntilBlank h front = do+ l <- stripCR `fmap` B.hGetLine h+ if B.null l+ then return $ front []+ else takeUntilBlank h $ front . (:) l++stripCR :: ByteString -> ByteString+stripCR bs+ | B.null bs = bs+ | B.last bs == '\r' = B.init bs+ | otherwise = bs++data InvalidRequest =+ NotEnoughLines [String]+ | HostNotIncluded+ | BadFirstLine String+ | NonHttp+ deriving (Show, Typeable)+instance Exception InvalidRequest++-- | Parse a set of header lines and body into a 'Request'.+parseRequest :: Port+ -> [ByteString]+ -> Handle+ -> String+ -> IO Request+parseRequest port lines' handle remoteHost' = do+ case lines' of+ (_:_:_) -> return ()+ _ -> failure $ NotEnoughLines $ map B.unpack lines'+ (method', rpath', gets, httpversion) <- parseFirst $ head lines'+ let method = methodFromBS method'+ 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+ unless (isJust host') $ failure HostNotIncluded+ let host = fromJust host'+ let len = fromMaybe 0 $ do+ bs <- lookup ReqContentLength heads+ let str = B.unpack bs+ Safe.readMay str+ let (serverName', _) = B.break (== ':') host+ return $ Request+ { requestMethod = method+ , httpVersion = httpversion+ , pathInfo = B.pack rpath+ , queryString = gets+ , serverName = serverName'+ , serverPort = port+ , requestHeaders = heads+ , urlScheme = HTTP+ , requestBody = requestBodyHandle handle len+ , errorHandler = System.IO.hPutStr System.IO.stderr+ , remoteHost = B.pack remoteHost'+ }++parseFirst :: ByteString+ -> IO (ByteString, ByteString, ByteString, HttpVersion)+parseFirst s = do+ let pieces = SL.split ' ' s+ (method, query, http') <-+ case pieces of+ [x, y, z] -> return (x, y, z)+ _ -> failure $ BadFirstLine $ B.unpack s+ let (hfirst, hsecond) = B.splitAt 5 http'+ unless (hfirst == B.pack "HTTP/") $ failure NonHttp+ let (rpath, qstring) = B.break (== '?') query+ return (method, rpath, qstring, httpVersionFromBS 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 $ B.pack " "+ B.hPut h $ B.pack $ show $ statusCode $ status res+ B.hPut h $ statusMessage $ status res+ B.hPut h $ B.pack "\r\n"+ 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 ()+ where+ myPut _ bs = do+ B.hPut h bs+ return (Right h)+ putHeader (x, y) = do+ B.hPut h $ responseHeaderToBS x+ B.hPut h $ B.pack ": "+ B.hPut h y+ B.hPut h $ B.pack "\r\n"++parseHeaderNoAttr :: ByteString -> (ByteString, ByteString)+parseHeaderNoAttr s =+ let (k, rest) = B.span (/= ':') s+ in (k, SL.dropPrefix' (B.pack ": ") rest)
+ Network/Wai/Middleware/CleanPath.hs view
@@ -0,0 +1,65 @@+module Network.Wai.Middleware.CleanPath (cleanPath, splitPath) where++import Network.Wai+import Web.Encodings+import qualified Data.ByteString.Char8 as B++-- | Performs redirects as per 'splitPath'.+cleanPath :: ([B.ByteString] -> Request -> IO Response)+ -> Request+ -> IO Response+cleanPath app env =+ case splitPath $ pathInfo env of+ Left p -> do+ -- include the query string if present+ let suffix = case B.uncons $ queryString env of+ Nothing -> B.empty+ Just ('?', _) -> queryString env+ _ -> B.cons '?' $ queryString env+ return $ Response Status303 [(Location, B.append p suffix)]+ $ Right emptyEnum+ Right pieces -> app pieces env++emptyEnum :: Enumerator+emptyEnum = Enumerator $ \_ -> return . Right++-- | Given a certain requested path, return either a corrected path+-- to redirect to or the tokenized path.+--+-- This code corrects for the following issues:+--+-- * It is missing a trailing slash, and there is no period after the+-- last slash.+--+-- * There are any doubled slashes.+splitPath :: B.ByteString -> Either B.ByteString [B.ByteString]+splitPath s =+ let corrected = B.pack $ ats $ rds $ B.unpack s+ in if corrected == s+ then Right $ map decodeUrl+ $ filter (not . B.null)+ $ B.split '/' s+ else Left corrected++-- | Remove double slashes+rds :: String -> String+rds [] = []+rds [x] = [x]+rds (a:b:c)+ | a == '/' && b == '/' = rds (b:c)+ | otherwise = a : rds (b:c)++-- | Add a trailing slash if it is missing. Empty string is left alone.+ats :: String -> String+ats [] = []+ats s =+ if last s == '/' || dbs (reverse s)+ then s+ else s ++ "/"++-- | Is there a period before a slash here?+dbs :: String -> Bool+dbs ('/':_) = False+dbs ('.':_) = True+dbs (_:x) = dbs x+dbs [] = False
+ Network/Wai/Middleware/ClientSession.hs view
@@ -0,0 +1,136 @@+module Network.Wai.Middleware.ClientSession+ ( clientsession+ -- * Generating keys+ , Word256+ , defaultKeyFile+ , getKey+ , getDefaultKey+ ) where++import Prelude hiding (exp)+import Network.Wai+import Web.Encodings+import Data.List (partition)+import Data.Function.Predicate (is, isn't, equals)+import Data.Maybe (fromMaybe, mapMaybe)+import Web.ClientSession+import Data.Time.Clock (getCurrentTime, UTCTime, addUTCTime)+import Data.Time.LocalTime () -- Show instance of UTCTime+import Data.Time.Format (formatTime) -- Read instance of UTCTime+import System.Locale (defaultTimeLocale)+import Control.Monad (guard)+import qualified Data.ByteString.Char8 as B+import Control.Arrow (first)++-- | Automatic encrypting and decrypting of client session data.+--+-- Using the clientsession package, this middleware handles automatic+-- encryption, decryption, checking, expiration and renewal of whichever+-- cookies you ask it to. For example, if you tell it to deal with the+-- cookie \"IDENTIFIER\", it will do the following:+--+-- * When you specify an \"IDENTIFIER\" value in your 'Response', it will+-- encrypt the value, along with the session expiration date and the+-- REMOTE_HOST of the user. It will then be set as a cookie on the client.+--+-- * When there is an incoming \"IDENTIFIER\" cookie from the user, it will+-- decrypt it and check both the expiration date and the REMOTE_HOST. If+-- everything matches up, it will set the \"IDENTIFIER\" value in+-- 'hackHeaders'.+--+-- * If the client sent an \"IDENTIFIER\" and the application does not set+-- a new value, this will reset the cookie to a new expiration date. This+-- way, you do not have sessions timing out every 20 minutes.+--+-- As far as security: clientsesion itself handles hashing and encrypting+-- the data to make sure that the user can neither see not tamper with it.+clientsession :: [B.ByteString] -- ^ list of cookies to intercept+ -> Word256 -- ^ encryption key+ -> Int -- ^ minutes to live+ -> ([(B.ByteString, B.ByteString)] -> Application)+ -> Request+ -> IO Response+clientsession cnames key minutesToLive app env = do+ let hs = requestHeaders env+ initCookiesRaw :: B.ByteString+ initCookiesRaw = fromMaybe B.empty $ lookup Cookie hs+ nonCookies :: [(RequestHeader, B.ByteString)]+ nonCookies = filter (fst `isn't` (== Cookie)) hs+ initCookies :: [(B.ByteString, B.ByteString)]+ initCookies = parseCookies initCookiesRaw+ cookies, interceptCookies :: [(B.ByteString, B.ByteString)]+ (interceptCookies, cookies) = partition (fst `is` (`elem` cnames))+ initCookies+ cookiesRaw, remoteHost' :: B.ByteString+ cookiesRaw = B.concat $ combineCookies cookies+ remoteHost' = remoteHost env+ now <- getCurrentTime+ let convertedCookies :: [(B.ByteString, B.ByteString)]+ convertedCookies =+ mapMaybe (decodeCookie key now remoteHost') interceptCookies+ let env' = env { requestHeaders =+ (Cookie, cookiesRaw)+ -- FIXME not sure how I feel about the next line+ : filter (fst `equals` Cookie) (requestHeaders env)+ ++ nonCookies+ }+ res <- app convertedCookies env'+ let interceptHeaders, responseHeaders' :: [(ResponseHeader, B.ByteString)]+ (interceptHeaders, responseHeaders') =+ partition ((responseHeaderToBS . fst) `is` (`elem` cnames))+ $ responseHeaders res+ interceptHeaders' :: [(B.ByteString, B.ByteString)]+ interceptHeaders' = map (first responseHeaderToBS) interceptHeaders+ let timeToLive :: Int+ timeToLive = minutesToLive * 60+ let exp = fromIntegral timeToLive `addUTCTime` now+ let formattedExp = B.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp+ let oldCookies :: [(B.ByteString, B.ByteString)]+ oldCookies = filter+ (\(k, _) -> k `notElem` map fst interceptHeaders')+ convertedCookies+ let newCookies = map (setCookie key exp formattedExp remoteHost') $+ oldCookies ++ interceptHeaders'+ let res' = res { responseHeaders = newCookies ++ responseHeaders' }+ return res'++combineCookies :: [(B.ByteString, B.ByteString)] -> [B.ByteString]+combineCookies [] = []+combineCookies ((k, v):rest) = k : B.singleton '=' : v : B.pack "; "+ : combineCookies rest+setCookie :: Word256+ -> UTCTime -- ^ expiration time+ -> B.ByteString -- ^ formatted expiration time+ -> B.ByteString -- ^ remote host+ -> (B.ByteString, B.ByteString)+ -> (ResponseHeader, B.ByteString)+setCookie key exp fexp rhost (cname, cval) =+ (SetCookie, B.concat+ [ cname+ , B.singleton '='+ , B.pack $ encrypt key $ B.pack $ show $ ACookie exp rhost cval+ , B.pack "; path=/; expires="+ , fexp+ ])++data ACookie = ACookie UTCTime B.ByteString B.ByteString+ deriving (Show, Read)++decodeCookie :: Word256 -- ^ key+ -> UTCTime -- ^ current time+ -> B.ByteString -- ^ remote host field+ -> (B.ByteString, B.ByteString) -- ^ cookie pair+ -> Maybe (B.ByteString, B.ByteString)+decodeCookie key now rhost (cname, encrypted) = do+ decrypted <- decrypt key $ B.unpack encrypted+ (ACookie exp rhost' val) <- mread $ B.unpack decrypted+ guard $ exp > now+ guard $ rhost' == rhost+ guard $ not $ B.null val+ return (cname, val)++mread :: (Monad m, Read a) => String -> m a+mread s =+ case reads s of+ [] -> fail $ "Reading of " ++ s ++ " failed"+ ((x, _):_) -> return x
+ Network/Wai/Middleware/Gzip.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+---------------------------------------------------------+-- |+-- Module : Network.Wai.Middleware.Gzip+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Automatic gzip compression of responses.+--+---------------------------------------------------------+module Network.Wai.Middleware.Gzip (gzip) where++import Network.Wai+import Network.Wai.Enumerator (fromLBS', toLBS)+import Codec.Compression.GZip (compress)+import Data.Maybe (fromMaybe)+import Data.List.Split (splitOneOf)+import qualified Data.ByteString.Char8 as B++-- | Use gzip to compress the body of the response.+--+-- Analyzes the \"Accept-Encoding\" header from the client to determine+-- if gzip is supported.+--+-- Possible future enhancements:+--+-- * Only compress if the response is above a certain size.+--+-- * Add Content-Length.+--+-- * I read somewhere that \"the beast\" (MSIE) can\'t support compression+-- for Javascript files..+gzip :: Middleware+gzip app env = do+ res <- app env+ case responseBody res of+ Left _ -> return res+ Right _ -> do+ let enc = fromMaybe []+ $ (splitOneOf "," . B.unpack)+ `fmap` lookup AcceptEncoding+ (requestHeaders env)+ if "gzip" `elem` enc+ then return res+ { responseBody = compressE $ responseBody res+ , responseHeaders = (ContentEncoding, B.pack "gzip")+ : responseHeaders res+ }+ else return res++compressE :: Either FilePath Enumerator -> Either FilePath Enumerator+compressE (Left fp) = Left fp+compressE (Right e) = Right $ fromLBS' $ fmap compress $ toLBS e
+ Network/Wai/Middleware/Jsonp.hs view
@@ -0,0 +1,71 @@+---------------------------------------------------------+-- |+-- Module : Network.Wai.Middleware.Jsonp+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Automatic wrapping of JSON responses to convert into JSONP.+--+---------------------------------------------------------+module Network.Wai.Middleware.Jsonp (jsonp) where++import Network.Wai+import Network.Wai.Enumerator (fromEitherFile)+import Web.Encodings (decodeUrlPairs)+import qualified Data.ByteString.Char8 as B8+import Data.Maybe (fromMaybe)++-- | Wrap json responses in a jsonp callback.+--+-- Basically, if the user requested a \"text\/javascript\" and supplied a+-- \"callback\" GET parameter, ask the application for an+-- \"application/json\" response, then convern that into a JSONP response,+-- having a content type of \"text\/javascript\" and calling the specified+-- callback function.+jsonp :: Middleware+jsonp app env = do+ let accept = fromMaybe B8.empty $ lookup Accept $ requestHeaders env+ let gets = decodeUrlPairs $ queryString env+ let callback :: Maybe B8.ByteString+ callback =+ if B8.pack "text/javascript" `B8.isInfixOf` accept+ then lookup (B8.pack "callback") gets+ else Nothing+ let env' =+ case callback of+ Nothing -> env+ Just _ -> env+ { requestHeaders = changeVal Accept+ "application/json"+ $ requestHeaders env+ }+ res <- app env'+ case (fmap B8.unpack $ lookup ContentType $ 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+ }+ _ -> return res++addCallback :: B8.ByteString -> Enumerator -> Enumerator+addCallback cb (Enumerator e) = Enumerator $ \iter a -> do+ ea' <- iter a $ B8.snoc cb '('+ case ea' of+ Left a' -> return $ Left a'+ Right a' -> do+ ea'' <- e iter a'+ case ea'' of+ Left a'' -> return $ Left a''+ Right a'' -> iter a'' $ B8.singleton ')'++changeVal :: Eq a+ => a+ -> String+ -> [(a, B8.ByteString)]+ -> [(a, B8.ByteString)]+changeVal key val old = (key, B8.pack val)+ : filter (\(k, _) -> k /= key) old
+ Network/Wai/Middleware/MethodOverride.hs view
@@ -0,0 +1,38 @@+---------------------------------------------------------+-- |+-- Module : Network.Wai.Middleware.MethodOverride+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Override the HTTP method based on either:+-- The X-HTTP-Method-Override header.+-- The _method_override GET parameter.+--+---------------------------------------------------------+module Network.Wai.Middleware.MethodOverride (methodOverride) where++import Network.Wai+import Web.Encodings (decodeUrlPairs)+import Data.Monoid (mappend)+import Data.Char+import qualified Data.ByteString.Char8 as B8++moHeader :: RequestHeader+moHeader = requestHeaderFromBS $ B8.pack "X-HTTP-Method-Override"++moParam :: B8.ByteString+moParam = B8.pack "_method_override"++methodOverride :: Middleware+methodOverride app env = do+ let mo1 = lookup moHeader $ requestHeaders env+ gets = decodeUrlPairs $ queryString env+ mo2 = lookup moParam gets+ app $+ case mo1 `mappend` mo2 of+ Nothing -> env+ Just nm -> env { requestMethod = methodFromBS $ B8.map toUpper nm }
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ wai-extra.cabal view
@@ -0,0 +1,38 @@+Name: wai-extra+Version: 0.0.0+Synopsis: Provides some basic WAI handlers and middleware.+Description: The goal here is to provide common features without many dependencies.+License: BSD3+License-file: LICENSE+Author: Michael Snoyman+Maintainer: michael@snoyman.com+Homepage: http://github.com/snoyberg/wai-extra+Category: Web+Build-Type: Simple+Cabal-Version: >=1.2+Stability: Stable++Library+ Build-Depends: base >= 3 && < 5,+ bytestring >= 0.9 && < 0.10,+ wai >= 0.0.0 && < 0.1,+ split >= 0.1.2 && < 0.2,+ web-encodings >= 0.2.3 && < 0.5,+ old-locale >= 1.0 && < 1.1,+ time >= 1.1.4 && < 1.2,+ clientsession >= 0.2.0 && < 0.3,+ predicates >= 0.1 && < 0.2,+ zlib >= 0.5.2.0 && < 0.6,+ sendfile >= 0.6.1 && < 0.7,+ safe >= 0.2 && < 0.3,+ failure >= 0.0.0 && < 0.1,+ network >= 2.2.1.5 && < 2.3+ Exposed-modules: Network.Wai.Handler.CGI+ Network.Wai.Handler.SimpleServer+ Network.Wai.Middleware.CleanPath+ Network.Wai.Middleware.ClientSession+ Network.Wai.Middleware.Gzip+ Network.Wai.Middleware.Jsonp+ Network.Wai.Middleware.MethodOverride+ Other-modules: Network.Wai.Handler.Helper+ ghc-options: -Wall