wai-extra 0.0.0.2 → 0.1.0
raw patch · 7 files changed
+40/−205 lines, 7 filesdep −clientsessiondep −failuredep −predicatesdep ~wai
Dependencies removed: clientsession, failure, predicates, safe, split, web-encodings
Dependency ranges changed: wai
Files
- Network/Wai/Handler/SimpleServer.hs +16/−12
- Network/Wai/Middleware/CleanPath.hs +4/−4
- Network/Wai/Middleware/ClientSession.hs +0/−136
- Network/Wai/Middleware/Gzip.hs +7/−2
- Network/Wai/Middleware/Jsonp.hs +11/−3
- Network/Wai/Middleware/MethodOverride.hs +0/−38
- wai-extra.cabal +2/−10
Network/Wai/Handler/SimpleServer.hs view
@@ -26,18 +26,14 @@ import Network ( listenOn, accept, sClose, PortID(PortNumber), Socket , withSocketsDo)-import Control.Exception (bracket, finally, Exception)+import Control.Exception (bracket, finally, Exception, throwIO) 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) @@ -103,7 +99,7 @@ parseRequest port lines' handle remoteHost' = do case lines' of (_:_:_) -> return ()- _ -> failure $ NotEnoughLines $ map B.unpack lines'+ _ -> throwIO $ NotEnoughLines $ map B.unpack lines' (method', rpath', gets, httpversion) <- parseFirst $ head lines' let method = methodFromBS method' let rpath = '/' : case B.unpack rpath' of@@ -112,12 +108,14 @@ let heads = map (first requestHeaderFromBS . parseHeaderNoAttr) $ tail lines' let host' = lookup Host heads- unless (isJust host') $ failure HostNotIncluded+ unless (isJust host') $ throwIO HostNotIncluded let host = fromJust host' let len = fromMaybe 0 $ do bs <- lookup ReqContentLength heads let str = B.unpack bs- Safe.readMay str+ case reads str of+ (x, _):_ -> Just x+ _ -> Nothing let (serverName', _) = B.break (== ':') host return $ Request { requestMethod = method@@ -136,13 +134,13 @@ parseFirst :: ByteString -> IO (ByteString, ByteString, ByteString, HttpVersion) parseFirst s = do- let pieces = SL.split ' ' s+ let pieces = B.words s (method, query, http') <- case pieces of [x, y, z] -> return (x, y, z)- _ -> failure $ BadFirstLine $ B.unpack s+ _ -> throwIO $ BadFirstLine $ B.unpack s let (hfirst, hsecond) = B.splitAt 5 http'- unless (hfirst == B.pack "HTTP/") $ failure NonHttp+ unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp let (rpath, qstring) = B.break (== '?') query return (method, rpath, qstring, httpVersionFromBS hsecond) @@ -173,4 +171,10 @@ parseHeaderNoAttr :: ByteString -> (ByteString, ByteString) parseHeaderNoAttr s = let (k, rest) = B.span (/= ':') s- in (k, SL.dropPrefix' (B.pack ": ") rest)+ rest' = if not (B.null rest) &&+ B.head rest == ':' &&+ not (B.null $ B.tail rest) &&+ B.head (B.tail rest) == ' '+ then B.drop 2 rest+ else rest+ in (k, rest')
Network/Wai/Middleware/CleanPath.hs view
@@ -1,11 +1,11 @@ module Network.Wai.Middleware.CleanPath (cleanPath, splitPath) where import Network.Wai-import Web.Encodings import qualified Data.ByteString.Char8 as B+import Network.URI (unEscapeString) -- | Performs redirects as per 'splitPath'.-cleanPath :: ([B.ByteString] -> Request -> IO Response)+cleanPath :: ([String] -> Request -> IO Response) -> Request -> IO Response cleanPath app env =@@ -32,11 +32,11 @@ -- last slash. -- -- * There are any doubled slashes.-splitPath :: B.ByteString -> Either B.ByteString [B.ByteString]+splitPath :: B.ByteString -> Either B.ByteString [String] splitPath s = let corrected = B.pack $ ats $ rds $ B.unpack s in if corrected == s- then Right $ map decodeUrl+ then Right $ map (unEscapeString . B.unpack) $ filter (not . B.null) $ B.split '/' s else Left corrected
− Network/Wai/Middleware/ClientSession.hs
@@ -1,136 +0,0 @@-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
@@ -19,7 +19,6 @@ 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.@@ -42,7 +41,7 @@ Left _ -> return res Right _ -> do let enc = fromMaybe []- $ (splitOneOf "," . B.unpack)+ $ (splitCommas . B.unpack) `fmap` lookup AcceptEncoding (requestHeaders env) if "gzip" `elem` enc@@ -56,3 +55,9 @@ compressE :: Either FilePath Enumerator -> Either FilePath Enumerator compressE (Left fp) = Left fp compressE (Right e) = Right $ fromLBS' $ fmap compress $ toLBS e++splitCommas :: String -> [String]+splitCommas [] = []+splitCommas x =+ let (y, z) = break (== ',') x+ in y : splitCommas (drop 1 z)
Network/Wai/Middleware/Jsonp.hs view
@@ -15,10 +15,19 @@ import Network.Wai import Network.Wai.Enumerator (fromEitherFile)-import Web.Encodings (decodeUrlPairs) import qualified Data.ByteString.Char8 as B8 import Data.Maybe (fromMaybe) +takeCallback :: B8.ByteString -> Maybe B8.ByteString+takeCallback bs | B8.null bs = Nothing+takeCallback bs =+ let (x, y) = B8.break (== '=') bs+ (y', z) = B8.break (== '&') $ B8.drop 1 y+ in if x == B8.pack "callback"+ then Just y'+ else takeCallback $ B8.drop 1 z++ -- | Wrap json responses in a jsonp callback. -- -- Basically, if the user requested a \"text\/javascript\" and supplied a@@ -29,11 +38,10 @@ 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+ then takeCallback $ queryString env else Nothing let env' = case callback of
− Network/Wai/Middleware/MethodOverride.hs
@@ -1,38 +0,0 @@------------------------------------------------------------- |--- 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 }
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 0.0.0.2+Version: 0.1.0 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: BSD3@@ -15,24 +15,16 @@ Library Build-Depends: base >= 3 && < 5, bytestring >= 0.9 && < 0.10,- wai >= 0.0.0 && < 0.3,- split >= 0.1.2 && < 0.2,- web-encodings >= 0.2.3 && < 0.3,+ wai >= 0.0.0 && < 0.1, 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