diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -1,5 +1,5 @@ Name: happstack-server -Version: 6.6.4 +Version: 6.6.5 Synopsis: Web related tools and services. Description: Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course License: BSD3 diff --git a/src/Happstack/Server/Internal/MessageWrap.hs b/src/Happstack/Server/Internal/MessageWrap.hs --- a/src/Happstack/Server/Internal/MessageWrap.hs +++ b/src/Happstack/Server/Internal/MessageWrap.hs @@ -9,6 +9,7 @@ import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.UTF8 as U (toString) import Data.Int (Int64) import Happstack.Server.Internal.Types as H import Happstack.Server.Internal.Multipart @@ -21,7 +22,7 @@ xs -> xs) -- | see 'defaultBodyPolicy' -data BodyPolicy +data BodyPolicy = BodyPolicy { inputWorker :: Int64 -> Int64 -> Int64 -> InputWorker , maxDisk :: Int64 -- ^ maximum bytes for files uploaded in this 'Request' , maxRAM :: Int64 -- ^ maximum bytes for all non-file values in the 'Request' body @@ -42,7 +43,7 @@ } bodyInput :: (MonadIO m) => BodyPolicy -> Request -> m ([(String, Input)], Maybe String) -bodyInput _ req | ((rqMethod req /= POST) && (rqMethod req /= PUT)) || (not (isDecodable ctype)) = +bodyInput _ req | ((rqMethod req /= POST) && (rqMethod req /= PUT)) || (not (isDecodable ctype)) = do _ <- liftIO $ tryPutMVar (rqInputsBody req) [] return ([], Nothing) where @@ -66,17 +67,17 @@ do rqbody <- takeRequestBody req case rqbody of Nothing -> return ([], Just $ "bodyInput: Request body was already consumed.") - (Just (Body bs)) -> + (Just (Body bs)) -> do r@(inputs, _err) <- decodeBody bodyPolicy ctype bs putMVar (rqInputsBody req) inputs return r --- | Decodes application\/x-www-form-urlencoded inputs. +-- | Decodes application\/x-www-form-urlencoded inputs. -- TODO: should any of the [] be error conditions? formDecode :: String -> [(String, Input)] formDecode [] = [] -formDecode qString = - if null pairString then rest else +formDecode qString = + if null pairString then rest else (SURI.unEscapeQS name,simpleInput $ SURI.unEscapeQS val):rest where (pairString,qString')= split (=='&') qString (name,val)=split (=='=') pairString @@ -94,7 +95,7 @@ return (formDecode (L.unpack (L.take (maxRAM bp) inp)), Nothing) Just (ContentType "multipart" "form-data" ps) -> multipartDecode ((inputWorker bp) (maxDisk bp) (maxRAM bp) (maxHeader bp)) ps inp - Just ct -> + Just ct -> return ([], Just $ "decodeBody: unsupported content-type: " ++ show ct) -- unknown content-type, the user will have to -- deal with it by looking at the raw content -- No content-type given, assume x-www-form-urlencoded @@ -112,7 +113,7 @@ -- | Get the path components from a String. pathEls :: String -> [String] -pathEls = (drop 1) . map SURI.unEscape . splitList '/' +pathEls = (drop 1) . map (U.toString . P.pack . SURI.unEscape) . splitList '/' -- | Repeadly splits a list by the provided separator and collects the results splitList :: Eq a => a -> [a] -> [[a]] @@ -132,4 +133,4 @@ where (left,right')=break f s right = if null right' then [] else tail right' - + diff --git a/src/Happstack/Server/Internal/SocketTH.hs b/src/Happstack/Server/Internal/SocketTH.hs --- a/src/Happstack/Server/Internal/SocketTH.hs +++ b/src/Happstack/Server/Internal/SocketTH.hs @@ -2,14 +2,21 @@ module Happstack.Server.Internal.SocketTH(supportsIPv6) where import Language.Haskell.TH -import Data.List -import Data.Maybe import Network.Socket(SockAddr(..)) -- find out at compile time if the SockAddr6 / HostAddress6 constructors are available supportsIPv6 :: Bool -supportsIPv6 = $(let c = ["Network.Socket.SockAddrInet6", "Network.Socket.Internal.SockAddrInet6"] ; d = ''SockAddr in - do TyConI (DataD _ _ _ cs _) <- reify d - if isJust (find (\(NormalC n _) -> show n `elem` c) cs) - then [| True |] - else [| False |] ) +supportsIPv6 = $(let c = ["Network.Socket.SockAddrInet6", "Network.Socket.Internal.SockAddrInet6"] ; d = ''SockAddr + isInet6 :: Con -> Bool + isInet6 (NormalC n _) = show n `elem` c + isInet6 _ = False + in + do info <- reify d + case info of + TyConI (DataD _ _ _ cs _) -> + if any isInet6 cs + then [| True |] + else [| False |] + _ -> error "supportsIPv6: SockAddr is no longer a TyConI ?!?! Giving up." + ) + diff --git a/src/Happstack/Server/Internal/Types.hs b/src/Happstack/Server/Internal/Types.hs --- a/src/Happstack/Server/Internal/Types.hs +++ b/src/Happstack/Server/Internal/Types.hs @@ -28,7 +28,6 @@ import Data.Time.Format (FormatTime(..)) import Data.Typeable(Typeable) import qualified Data.ByteString.Char8 as P -import qualified Data.ByteString.UTF8 as U (toString) import Data.ByteString.Char8 (ByteString,pack) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) @@ -464,7 +463,7 @@ class FromReqURI a where fromReqURI :: String -> Maybe a -instance FromReqURI String where fromReqURI = Just . U.toString . P.pack +instance FromReqURI String where fromReqURI = Just instance FromReqURI Text.Text where fromReqURI = fmap fromString . fromReqURI instance FromReqURI Lazy.Text where fromReqURI = fmap fromString . fromReqURI instance FromReqURI Char where fromReqURI s = case s of [c] -> Just c ; _ -> Nothing diff --git a/src/Happstack/Server/Routing.hs b/src/Happstack/Server/Routing.hs --- a/src/Happstack/Server/Routing.hs +++ b/src/Happstack/Server/Routing.hs @@ -33,17 +33,40 @@ -- | instances of this class provide a variety of ways to match on the 'Request' method. -- --- Examples +-- Examples: -- --- > method GET -- match GET --- > method [HEAD, GET] -- match HEAD or GET +-- > method GET -- match GET or HEAD +-- > method [GET, POST] -- match GET, HEAD or POST +-- > method HEAD -- match HEAD /but not/ GET +-- > method (== GET) -- match GET or HEAD -- > method (not . (==) DELETE) -- match any method except DELETE -- > method () -- match any method -class MatchMethod m where matchMethod :: m -> Method -> Bool -instance MatchMethod Method where matchMethod m = (== m) -instance MatchMethod [Method] where matchMethod methods = (`elem` methods) -instance MatchMethod (Method -> Bool) where matchMethod f = f -instance MatchMethod () where matchMethod () _ = True +-- +-- As you can see, GET implies that HEAD should match as well. This is to +-- make it harder to write an application that uses HTTP incorrectly. +-- Happstack handles HEAD requests automatically, but we still need to make +-- sure our handlers don't mismatch or a HEAD will result in a 404. +-- +-- If you must, you can still do something like this +-- to match GET without HEAD: +-- +-- > guardRq ((== GET) . rqMethod) + +class MatchMethod m where + matchMethod :: m -> Method -> Bool + +instance MatchMethod Method where + matchMethod m = matchMethod (== m) + +instance MatchMethod [Method] where + matchMethod ms m = any (`matchMethod` m) ms + +instance MatchMethod (Method -> Bool) where + matchMethod f HEAD = f HEAD || f GET + matchMethod f m = f m + +instance MatchMethod () where + matchMethod () _ = True ------------------------------------- -- guards diff --git a/tests/Happstack/Server/Tests.hs b/tests/Happstack/Server/Tests.hs --- a/tests/Happstack/Server/Tests.hs +++ b/tests/Happstack/Server/Tests.hs @@ -6,14 +6,14 @@ import Control.Arrow ((&&&)) import Control.Applicative ((<$>)) import Control.Concurrent.MVar -import Control.Monad (msum) +import Control.Monad (msum, forM_) import Control.Monad.Trans (liftIO) import Data.ByteString.Lazy.Char8 (pack, unpack) -import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import Happstack.Server ( Request(..), Method(..), Response(..), ServerPart(..), Headers(..), RqBody(Body), HttpVersion(..) - , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength) + , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod) import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse) import Happstack.Server.Cookie import Happstack.Server.Internal.Compression @@ -24,17 +24,18 @@ import Test.HUnit as HU (Test(..),(~:),(~?),(@?=),(@=?), assertEqual, assertFailure) import Text.ParserCombinators.Parsec --- |All of the tests for happstack-util should be listed here. +-- |All of the tests for happstack-util should be listed here. allTests :: Test -allTests = +allTests = "happstack-server tests" ~: [ cookieParserTest , acceptEncodingParserTest , multipart , compressFilterResponseTest + , matchMethodTest ] cookieParserTest :: Test -cookieParserTest = +cookieParserTest = "cookieParserTest" ~: [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2" @?= (Right [ @@ -107,8 +108,8 @@ compressFilterResponseTest :: Test compressFilterResponseTest = - "compressFilterResponseTest" ~: - [ uncompressedResponse + "compressFilterResponseTest" ~: + [ uncompressedResponse , uncompressedSendFile , compressedResponseGZ , compressedResponseZ @@ -117,9 +118,9 @@ ] mkRequest :: Method -> String -> [(String, Cookie)] -> Headers -> L.ByteString -> IO Request -mkRequest method uri cookies headers body = +mkRequest method uri cookies headers body = do let u = toSURI uri - ib <- newEmptyMVar + ib <- newEmptyMVar b <- newMVar (Body body) return $ Request { rqMethod = method , rqPaths = (pathEls (path u)) @@ -196,3 +197,27 @@ assertEqual "respone code" (rsCode res) 406 assertEqual "body" (unpack (rsBody res)) "" assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing + +matchMethodTest :: Test +matchMethodTest = + "matchMethodTest" ~: + do forM_ gethead $ \m -> matchMethod GET m @?= True + forM_ others $ \m -> matchMethod GET m @?= False + forM_ gethead $ \m -> matchMethod [GET] m @?= True + forM_ others $ \m -> matchMethod [GET] m @?= False + forM_ gethead $ \m -> matchMethod [GET, HEAD] m @?= True + forM_ others $ \m -> matchMethod [GET, HEAD] m @?= False + matchMethod POST GET @?= False + matchMethod POST HEAD @?= False + matchMethod POST TRACE @?= False + matchMethod POST POST @?= True + matchMethod [POST, PUT] GET @?= False + matchMethod [POST, PUT] HEAD @?= False + matchMethod [POST, PUT] TRACE @?= False + matchMethod [POST, PUT] POST @?= True + matchMethod [POST, PUT] PUT @?= True + forM_ (others) $ \m -> matchMethod (`notElem` gethead) m @?= True + forM_ (gethead ++ others) $ \m -> matchMethod () m @?= True + where + gethead = [GET, HEAD] + others = [POST, PUT, DELETE, TRACE, OPTIONS, CONNECT]