diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/Wai/Handler/CGI.hs b/Network/Wai/Handler/CGI.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/CGI.hs @@ -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? diff --git a/Network/Wai/Handler/Helper.hs b/Network/Wai/Handler/Helper.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Helper.hs @@ -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) diff --git a/Network/Wai/Handler/SimpleServer.hs b/Network/Wai/Handler/SimpleServer.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/SimpleServer.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +--------------------------------------------------------- +-- | +-- Module : Network.Wai.Handler.SimpleServer +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- 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) diff --git a/Network/Wai/Middleware/CleanPath.hs b/Network/Wai/Middleware/CleanPath.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/CleanPath.hs @@ -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 diff --git a/Network/Wai/Middleware/ClientSession.hs b/Network/Wai/Middleware/ClientSession.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/ClientSession.hs @@ -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 diff --git a/Network/Wai/Middleware/Gzip.hs b/Network/Wai/Middleware/Gzip.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/Gzip.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +--------------------------------------------------------- +-- | +-- Module : Network.Wai.Middleware.Gzip +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- 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 diff --git a/Network/Wai/Middleware/Jsonp.hs b/Network/Wai/Middleware/Jsonp.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/Jsonp.hs @@ -0,0 +1,71 @@ +--------------------------------------------------------- +-- | +-- Module : Network.Wai.Middleware.Jsonp +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- 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 diff --git a/Network/Wai/Middleware/MethodOverride.hs b/Network/Wai/Middleware/MethodOverride.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/MethodOverride.hs @@ -0,0 +1,38 @@ +--------------------------------------------------------- +-- | +-- Module : Network.Wai.Middleware.MethodOverride +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- 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 } diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/wai-extra.cabal b/wai-extra.cabal new file mode 100644 --- /dev/null +++ b/wai-extra.cabal @@ -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