happstack-server 6.6.4 → 6.6.5
raw patch · 6 files changed
+92/−37 lines, 6 files
Files
- happstack-server.cabal +1/−1
- src/Happstack/Server/Internal/MessageWrap.hs +10/−9
- src/Happstack/Server/Internal/SocketTH.hs +14/−7
- src/Happstack/Server/Internal/Types.hs +1/−2
- src/Happstack/Server/Routing.hs +31/−8
- tests/Happstack/Server/Tests.hs +35/−10
happstack-server.cabal view
@@ -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 <http://happstack.com/docs/crashcourse/index.html> License: BSD3
src/Happstack/Server/Internal/MessageWrap.hs view
@@ -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'- +
src/Happstack/Server/Internal/SocketTH.hs view
@@ -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."+ )+
src/Happstack/Server/Internal/Types.hs view
@@ -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
src/Happstack/Server/Routing.hs view
@@ -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
tests/Happstack/Server/Tests.hs view
@@ -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]