diff --git a/Network/Wai/Handler/SimpleServer.hs b/Network/Wai/Handler/SimpleServer.hs --- a/Network/Wai/Handler/SimpleServer.hs +++ b/Network/Wai/Handler/SimpleServer.hs @@ -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') diff --git a/Network/Wai/Middleware/CleanPath.hs b/Network/Wai/Middleware/CleanPath.hs --- a/Network/Wai/Middleware/CleanPath.hs +++ b/Network/Wai/Middleware/CleanPath.hs @@ -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 diff --git a/Network/Wai/Middleware/ClientSession.hs b/Network/Wai/Middleware/ClientSession.hs deleted file mode 100644 --- a/Network/Wai/Middleware/ClientSession.hs +++ /dev/null @@ -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 diff --git a/Network/Wai/Middleware/Gzip.hs b/Network/Wai/Middleware/Gzip.hs --- a/Network/Wai/Middleware/Gzip.hs +++ b/Network/Wai/Middleware/Gzip.hs @@ -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) diff --git a/Network/Wai/Middleware/Jsonp.hs b/Network/Wai/Middleware/Jsonp.hs --- a/Network/Wai/Middleware/Jsonp.hs +++ b/Network/Wai/Middleware/Jsonp.hs @@ -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 diff --git a/Network/Wai/Middleware/MethodOverride.hs b/Network/Wai/Middleware/MethodOverride.hs deleted file mode 100644 --- a/Network/Wai/Middleware/MethodOverride.hs +++ /dev/null @@ -1,38 +0,0 @@ ---------------------------------------------------------- --- | --- 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/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -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