happstack-server 7.0.3 → 7.0.4
raw patch · 15 files changed
+94/−321 lines, 15 filesdep +happstack-serverdep ~base
Dependencies added: happstack-server
Dependency ranges changed: base
Files
- happstack-server.cabal +23/−31
- src/Happstack/Server/Error.hs +4/−4
- src/Happstack/Server/Internal/Clock.hs +2/−1
- src/Happstack/Server/Internal/Cookie.hs +4/−3
- src/Happstack/Server/Internal/Listen.hs +4/−4
- src/Happstack/Server/Internal/MessageWrap.hs +7/−7
- src/Happstack/Server/Internal/Monads.hs +2/−2
- src/Happstack/Server/Internal/Multipart.hs +5/−5
- src/Happstack/Server/Internal/RFC822Headers.hs +23/−22
- src/Happstack/Server/Internal/Types.hs +1/−1
- src/Happstack/Server/RqData.hs +10/−10
- src/Happstack/Server/SimpleHTTP.hs +3/−3
- src/Happstack/Server/Validation.hs +5/−4
- tests/Happstack/Server/Tests.hs +0/−223
- tests/Test.hs +1/−1
happstack-server.cabal view
@@ -1,5 +1,5 @@ Name: happstack-server-Version: 7.0.3+Version: 7.0.4 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@@ -9,24 +9,17 @@ homepage: http://happstack.com Category: Web, Happstack Build-Type: Simple-Cabal-Version: >= 1.6+Cabal-Version: >= 1.8 source-repository head type: darcs subdir: happstack-server location: http://patch-tag.com/r/mae/happstack -Flag base4- Description: Choose the even newer, even smaller, split-up base package.- Flag network_2_2_3 Description: Choose newer network library with merged in network-bytestring. Default: True -Flag tests- Description: Build the testsuite, and include the tests in the library- Default: False- Flag template_haskell Description: Template Haskell is available on this system Default: True@@ -65,9 +58,6 @@ Happstack.Server.SimpleHTTP Happstack.Server.Types Happstack.Server.Validation- if flag(tests)- Exposed-modules:- Happstack.Server.Tests Other-modules: Happstack.Server.Internal.Clock Happstack.Server.Internal.LazyLiner@@ -77,7 +67,7 @@ Happstack.Server.SURI.ParseURI Paths_happstack_server - Build-Depends: base,+ Build-Depends: base >= 4 && < 5, base64-bytestring == 0.1.*, blaze-html == 0.5.*, bytestring,@@ -95,6 +85,7 @@ process, sendfile >= 0.7.1 && < 0.8, system-filepath >= 0.3.1,+ syb, text >= 0.10 && < 0.12, time, transformers >= 0.1.3 && < 0.4,@@ -113,35 +104,36 @@ cpp-options: -DTEMPLATE_HASKELL hs-source-dirs: src- if flag(tests)- hs-source-dirs: tests if !os(windows) Build-Depends: unix cpp-options: -DUNIX- if flag(base4)- Build-Depends: base >= 4 && < 5, syb - if flag(tests)- Build-Depends: HUnit- Extensions: TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, OverlappingInstances, FlexibleInstances, UndecidableInstances, ScopedTypeVariables, TypeSynonymInstances, PatternGuards CPP, ForeignFunctionInterface- if impl(ghc >= 6.12)- ghc-options: -Wall -fno-warn-unused-do-bind- else- ghc-options: -Wall+ ghc-options: -Wall -fwarn-tabs GHC-Prof-Options: -auto-all+ -- The policy is to support GHC versions no older than the GHC stable+ -- branch that was used by the latest Haskell Platform release+ -- available 18 months ago. In order to avoid people spending time+ -- keeping the build working for older versions, we tell Cabal that+ -- it shouldn't allow builds with them.+ if impl(ghc < 7.0)+ buildable: False -Executable happstack-server-tests+Test-Suite happstack-server-tests+ Type: exitcode-stdio-1.0 Main-Is: Test.hs GHC-Options: -threaded- hs-source-dirs: tests, src- if flag(tests)- Buildable: True- Build-depends: HUnit, parsec < 4- else- Buildable: False+ hs-source-dirs: tests+ Build-depends: HUnit,+ base,+ bytestring,+ containers,+ happstack-server,+ parsec < 4,+ zlib+
src/Happstack/Server/Error.hs view
@@ -50,8 +50,8 @@ -- DEPRECATED: use 'spUnwrapErrorT' instead. errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> ServerPartT (ErrorT e m) a -> ServerPartT m a errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do- eer <- runErrorT $ ununWebT $ runServerPartT sps req- case eer of- Left err -> ununWebT (handler req err)- Right res -> return res+ eer <- runErrorT $ ununWebT $ runServerPartT sps req+ case eer of+ Left err -> ununWebT (handler req err)+ Right res -> return res {-# DEPRECATED errorHandlerSP "Use spUnwrapErrorT" #-}
src/Happstack/Server/Internal/Clock.hs view
@@ -8,6 +8,7 @@ import Control.Applicative ((<$>)) import Control.Concurrent+import Control.Monad import Data.IORef import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)@@ -38,7 +39,7 @@ nowRef <- newIORef now httpDateRef <- newIORef httpDate let dateCache = (DateCache nowRef httpDateRef)- forkIO $ updater dateCache+ void $ forkIO $ updater dateCache return dateCache updater :: DateCache -> IO ()
src/Happstack/Server/Internal/Cookie.hs view
@@ -16,6 +16,7 @@ ) where +import Control.Monad import qualified Data.ByteString.Char8 as C import Data.Char (chr, toLower) import Data.Data (Data, Typeable)@@ -132,7 +133,7 @@ cookie_path = cookie_special "$Path" cookie_domain = cookie_special "$Domain" cookie_special s = do- string s+ void $ string s cookieEq value cookieSep = ws >> oneOf ",;" >> ws@@ -143,9 +144,9 @@ -- Parsers based on RFC 2068 quoted_string = do- char '"'+ void $ char '"' r <-many ((try quotedPair) <|> (oneOf qdtext))- char '"'+ void $ char '"' return r -- Custom parsers, incompatible with RFC 2068, but more forgiving ;)
src/Happstack/Server/Internal/Listen.hs view
@@ -8,7 +8,7 @@ import Happstack.Server.Internal.TimeoutSocket as TS import Control.Exception.Extensible as E import Control.Concurrent (forkIO, killThread, myThreadId)-import Control.Monad (forever, when)+import Control.Monad import Network.BSD (getProtocolNumber) import Network (sClose, Socket) import Network.Socket as Socket (SocketOption(KeepAlive), setSocketOption,@@ -79,7 +79,7 @@ {- #ifndef mingw32_HOST_OS -}- installHandler openEndedPipe Ignore Nothing+ void $ installHandler openEndedPipe Ignore Nothing {- #endif -}@@ -99,6 +99,7 @@ loop = forever $ do w <- acceptLite s forkIO $ work w pe e = log' ERROR ("ERROR in http accept thread: " ++ show e)+ infi :: IO () infi = loop `catchSome` pe >> infi infi `finally` (sClose s)@@ -106,8 +107,7 @@ {-- #ifndef mingw32_HOST_OS -}- installHandler openEndedPipe Ignore Nothing- return ()+ void $ installHandler openEndedPipe Ignore Nothing {- #endif -}
src/Happstack/Server/Internal/MessageWrap.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} module Happstack.Server.Internal.MessageWrap (- module Happstack.Server.Internal.MessageWrap- ,defaultInputIter+ module Happstack.Server.Internal.MessageWrap+ ,defaultInputIter ) where import Control.Concurrent.MVar (tryTakeMVar, tryPutMVar, putMVar)@@ -119,18 +119,18 @@ splitList :: Eq a => a -> [a] -> [[a]] splitList _ [] = [] splitList sep list = h:splitList sep t- where (h,t)=split (==sep) list+ where (h,t)=split (==sep) list -- | Repeatedly splits a list and collects the results splitListBy :: (a -> Bool) -> [a] -> [[a]] splitListBy _ [] = [] splitListBy f list = h:splitListBy f t- where (h,t)=split f list+ where (h,t)=split f list -- | Split is like break, but the matching element is dropped. split :: (a -> Bool) -> [a] -> ([a], [a]) split f s = (left,right)- where- (left,right')=break f s- right = if null right' then [] else tail right'+ where+ (left,right')=break f s+ right = if null right' then [] else tail right'
src/Happstack/Server/Internal/Monads.hs view
@@ -485,8 +485,8 @@ put = lift . put instance MonadError e m => MonadError e (WebT m) where- throwError err = lift $ throwError err- catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler)+ throwError err = lift $ throwError err+ catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler) instance MonadWriter w m => MonadWriter w (WebT m) where tell = lift . tell
src/Happstack/Server/Internal/Multipart.hs view
@@ -66,11 +66,11 @@ | BodyResult (String, Input) InputWorker | HeaderResult [Header] InputWorker -type FileSaver = FilePath -- ^ tempdir- -> Int64 -- ^ quota- -> FilePath -- ^ filename of field- -> L.ByteString -- ^ content to save- -> IO (Bool, Int64 , FilePath) -- ^ truncated?, saved bytes, saved filename+type FileSaver = FilePath -- ^ tempdir+ -> Int64 -- ^ quota+ -> FilePath -- ^ filename of field+ -> L.ByteString -- ^ content to save+ -> IO (Bool, Int64 , FilePath) -- ^ truncated?, saved bytes, saved filename defaultFileSaver :: FilePath -> Int64 -> FilePath -> ByteString -> IO (Bool, Int64, FilePath) defaultFileSaver tmpDir diskQuota filename b =
src/Happstack/Server/Internal/RFC822Headers.hs view
@@ -43,6 +43,7 @@ parseM ) where +import Control.Monad import Data.Char import Data.List import Text.ParserCombinators.Parsec@@ -58,10 +59,10 @@ pHeader :: Parser Header pHeader = do name <- many1 headerNameChar- char ':'- many ws1+ void $ char ':'+ void $ many ws1 line <- lineString- crLf+ void crLf extraLines <- many extraFieldLine return (map toLower name, concat (line:extraLines)) @@ -69,7 +70,7 @@ extraFieldLine = do sp <- ws1 line <- lineString- crLf+ void $ crLf return (sp:line) --@@ -86,9 +87,9 @@ p_parameter :: Parser (String,String) p_parameter =- do lexeme $ char ';'+ do void $ lexeme $ char ';' p_name <- lexeme $ p_token- lexeme $ char '='+ void $ lexeme $ char '=' -- Workaround for seemingly standardized web browser bug -- where nothing is escaped in the filename parameter -- of the content-disposition header in multipart/form-data@@ -110,7 +111,7 @@ -- See <http://www.ietf.org/rfc/rfc2046.txt> for more -- information about MIME media types. data ContentType =- ContentType {+ ContentType { -- | The top-level media type, the general type -- of the data. Common examples are -- \"text\", \"image\", \"audio\", \"video\",@@ -134,9 +135,9 @@ pContentType :: Parser ContentType pContentType =- do many ws1+ do void $ many ws1 c_type <- p_token- lexeme $ char '/'+ void $ lexeme $ char '/' c_subtype <- lexeme $ p_token c_parameters <- many p_parameter return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters@@ -155,12 +156,12 @@ -- data ContentTransferEncoding =- ContentTransferEncoding String+ ContentTransferEncoding String deriving (Show, Read, Eq, Ord) pContentTransferEncoding :: Parser ContentTransferEncoding pContentTransferEncoding =- do many ws1+ do void $ many ws1 c_cte <- p_token return $ ContentTransferEncoding (map toLower c_cte) @@ -177,12 +178,12 @@ -- data ContentDisposition =- ContentDisposition String [(String, String)]+ ContentDisposition String [(String, String)] deriving (Show, Read, Eq, Ord) pContentDisposition :: Parser ContentDisposition pContentDisposition =- do many ws1+ do void $ many ws1 c_cd <- p_token c_parameters <- many p_parameter return $ ContentDisposition (map toLower c_cd) c_parameters@@ -216,7 +217,7 @@ ws1 = oneOf " \t" lexeme :: Parser a -> Parser a-lexeme p = do x <- p; many ws1; return x+lexeme p = do x <- p; void $ many ws1; return x -- | RFC 822 CRLF (but more permissive) crLf :: Parser String@@ -227,10 +228,10 @@ lineString = many (noneOf "\n\r") literalString :: Parser String-literalString = do char '\"'- str <- many (noneOf "\"\\" <|> quoted_pair)- char '\"'- return str+literalString = do void $ char '\"'+ str <- many (noneOf "\"\\" <|> quoted_pair)+ void $ char '\"'+ return str -- No web browsers seem to implement RFC 2046 correctly, -- since they do not escape double quotes and backslashes@@ -239,10 +240,10 @@ -- Note that this eats everything until the last double quote on the line. buggyLiteralString :: Parser String buggyLiteralString =- do char '\"'+ do void $ char '\"' str <- manyTill anyChar (try lastQuote) return str- where lastQuote = do char '\"'+ where lastQuote = do void $ char '\"' notFollowedBy (try (many (noneOf "\"") >> char '\"')) headerNameChar :: Parser Char@@ -262,5 +263,5 @@ p_text = oneOf text_chars quoted_pair :: Parser Char-quoted_pair = do char '\\'- p_text+quoted_pair = do void $ char '\\'+ p_text
src/Happstack/Server/Internal/Types.hs view
@@ -487,5 +487,5 @@ "0" -> Just False "false" -> Just False "1" -> Just True- "True" -> Just True+ "true" -> Just True _ -> Nothing
src/Happstack/Server/RqData.hs view
@@ -58,27 +58,27 @@ , HasRqData(askRqEnv, localRqEnv,rqDataError) ) where -import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad), (<$>))+import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad), (<$>)) import Control.Concurrent.MVar (newMVar)-import Control.Monad (MonadPlus(mzero))-import Control.Monad.Reader (ReaderT(ReaderT, runReaderT), MonadReader(ask, local), mapReaderT)-import Control.Monad.State (StateT, mapStateT)-import Control.Monad.Writer (WriterT, mapWriterT)-import Control.Monad.RWS (RWST, mapRWST)-import Control.Monad.Error (Error(noMsg, strMsg))+import Control.Monad (MonadPlus(mzero))+import Control.Monad.Reader (ReaderT(ReaderT, runReaderT), MonadReader(ask, local), mapReaderT)+import Control.Monad.State (StateT, mapStateT)+import Control.Monad.Writer (WriterT, mapWriterT)+import Control.Monad.RWS (RWST, mapRWST)+import Control.Monad.Error (Error(noMsg, strMsg)) import Control.Monad.Trans (MonadIO(..), lift) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU-import Data.Char (toLower)+import Data.Char (toLower) import Data.Either (partitionEithers) import Data.Generics (Data, Typeable) import Data.Maybe (fromMaybe, fromJust)-import Data.Monoid (Monoid(mempty, mappend, mconcat))+import Data.Monoid (Monoid(mempty, mappend, mconcat)) import Data.Text (Text) import qualified Data.Text.Lazy as LazyText import qualified Data.Text.Lazy.Encoding as LazyText-import Happstack.Server.Cookie (Cookie (cookieValue))+import Happstack.Server.Cookie (Cookie (cookieValue)) import Happstack.Server.Internal.Monads (ServerMonad(askRq, localRq), FilterMonad, WebMonad, ServerPartT, escape) import Happstack.Server.Internal.RFC822Headers (parseContentType) import Happstack.Server.Types (ContentType(..), FromReqURI(..), Input(inputValue, inputFilename, inputContentType), Response, Request(rqInputsQuery, rqInputsBody, rqCookies, rqMethod), Method(POST,PUT), getHeader, readInputsBody)
src/Happstack/Server/SimpleHTTP.hs view
@@ -83,6 +83,7 @@ import Happstack.Server.Validation +import Control.Monad import Data.Maybe (fromMaybe) import qualified Data.Version as DV import Happstack.Server.Internal.Monads (FilterFun, WebT(..), unFilterFun, runServerPartT, ununWebT)@@ -225,10 +226,9 @@ #ifdef UNIX istty <- queryTerminal stdInput mv <- newEmptyMVar- installHandler softwareTermination (CatchOnce (putMVar mv ())) Nothing+ void $ installHandler softwareTermination (CatchOnce (putMVar mv ())) Nothing case istty of- True -> do installHandler keyboardSignal (CatchOnce (putMVar mv ())) Nothing- return ()+ True -> void $ installHandler keyboardSignal (CatchOnce (putMVar mv ())) Nothing False -> return () takeMVar mv #else
src/Happstack/Server/Validation.hs view
@@ -3,6 +3,7 @@ import Control.Concurrent (forkIO) import Control.Exception (evaluate)+import Control.Monad import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L@@ -111,10 +112,10 @@ do (inh, outh, errh, ph) <- runInteractiveProcess exec args wd env out <- hGetContents outh err <- hGetContents errh- forkIO $ do L.hPut inh (rsBody response)- hClose inh- forkIO $ evaluate (length out) >> return ()- forkIO $ evaluate (length err) >> return ()+ void $ forkIO $ do L.hPut inh (rsBody response)+ hClose inh+ void $ forkIO $ evaluate (length out) >> return ()+ void $ forkIO $ evaluate (length err) >> return () ec <- waitForProcess ph case ec of ExitSuccess -> return response
− tests/Happstack/Server/Tests.hs
@@ -1,223 +0,0 @@--- |HUnit tests and QuickQuick properties for Happstack.Server.*-module Happstack.Server.Tests (allTests) where--import qualified Codec.Compression.GZip as GZ-import qualified Codec.Compression.Zlib as Z-import Control.Arrow ((&&&))-import Control.Applicative ((<$>))-import Control.Concurrent.MVar-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.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, matchMethod)-import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse)-import Happstack.Server.Cookie-import Happstack.Server.Internal.Compression-import Happstack.Server.Internal.Cookie-import Happstack.Server.Internal.Multipart-import Happstack.Server.Internal.MessageWrap-import Happstack.Server.SURI(ToSURI(..), SURI(..),path,query)-import Test.HUnit as HU (Test(..),(~:),(~?),(@?=),(@=?), assertEqual, assertFailure)-import Text.ParserCombinators.Parsec---- |All of the tests for happstack-util should be listed here.-allTests :: Test-allTests =- "happstack-server tests" ~: [ cookieParserTest- , acceptEncodingParserTest- , multipart- , compressFilterResponseTest- , matchMethodTest- ]--cookieParserTest :: Test-cookieParserTest =- "cookieParserTest" ~:- [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2"- @?= (Right [- Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False- , Cookie "1" "" "" "cookie2" "value2" False False- ])- ,parseCookies " \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/ "- @?= (Right [- Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False- ])- ,parseCookies " cookie1 = value1 "- @?= (Right [- Cookie "" "" "" "cookie1" "value1" False False- ])- ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe "- @?= (Right [- Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False- ])- , parseCookies "foo=\"\\\"bar\\\"\""- @?= (Right [- Cookie "" "" "" "foo" "\"bar\"" False False- ])- ]--acceptEncodingParserTest :: Test-acceptEncodingParserTest =- "acceptEncodingParserTest" ~:- map (\(string, result) -> either (Left . show) Right (parse encodings "" string) @?= (Right result)) acceptEncodings- where- acceptEncodings =- [ (" gzip;q=1,*, compress ; q = 0.5 ", [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)])- , (" compress , gzip", [ ("compress", Nothing), ("gzip", Nothing)])- , (" ", [])- , (" *", [("*", Nothing)])- , (" compress;q=0.5, gzip;q=1.0", [("compress", Just 0.5), ("gzip", Just 1.0)])- , (" gzip;q=1.0, identity; q=0.5, *;q=0", [("gzip", Just 1.0), ("identity",Just 0.5), ("*", Just 0)])- , (" x-gzip",[("x-gzip", Nothing)])- ]--multipart :: Test-multipart =- "split multipart" ~:- [ ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=?- parseMultipartBody (pack "boundary")- (pack "--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend")-- , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=?- parseMultipartBody (pack "boundary.with.dot")- (pack "--boundary.with.dot\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary.with.dot--\r\nend")-- , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=?- parseMultipartBody (pack "boundary")- (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend")-- , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n")], Nothing) @=?- parseMultipartBody (pack "boundary")- (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\n--boundary--\r\nend")-- , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\r\n")], Nothing) @=?- parseMultipartBody (pack "boundary")- (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n\r\n--boundary--\r\nend")- , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n\r")], Nothing) @=?- parseMultipartBody (pack "boundary")- (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\r\n--boundary--\r\nend")-- , ([BodyPart (pack "content-type: text/plain\r\n") (pack "\r\n1\n\r")], Nothing) @=?- parseMultipartBody (pack "boundary")- (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n\r\n1\n\r\r\n--boundary--\r\nend")- ]--compressFilterResponseTest :: Test-compressFilterResponseTest =- "compressFilterResponseTest" ~:- [ uncompressedResponse- , uncompressedSendFile- , compressedResponseGZ- , compressedResponseZ- , compressedSendFile- , compressedSendFileNoIdentity- ]--mkRequest :: Method -> String -> [(String, Cookie)] -> Headers -> L.ByteString -> IO Request-mkRequest method uri cookies headers body =- do let u = toSURI uri- ib <- newEmptyMVar- b <- newMVar (Body body)- return $ Request { rqMethod = method- , rqPaths = (pathEls (path u))- , rqUri = (path u)- , rqQuery = (query u)- , rqInputsQuery = (queryInput u)- , rqInputsBody = ib- , rqCookies = cookies- , rqVersion = HttpVersion 1 1- , rqHeaders = headers- , rqBody = b- , rqPeer = ("",0)- , rqSecure = False- }--compressPart :: ServerPart Response-compressPart =- do compressedResponseFilter- composeFilter noContentLength- msum [ dir "response" $ ok (toResponse "compress Response")- , dir "sendfile" $ ok (sendFileResponse "text/plain" "/dev/null" Nothing 0 100)- ]--uncompressedResponse :: Test-uncompressedResponse =- "uncompressedResponse" ~:- do req <- mkRequest GET "/response" [] Map.empty L.empty- res <- simpleHTTP'' compressPart req- assertEqual "respone code" (rsCode res) 200- assertEqual "body" (unpack (rsBody res)) "compress Response"- assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing--uncompressedSendFile :: Test-uncompressedSendFile =- "uncompressedSendFile" ~:- do req <- mkRequest GET "/sendfile" [] Map.empty L.empty- res <- simpleHTTP'' compressPart req- assertEqual "respone code" (rsCode res) 200- assertEqual "filepath" (sfFilePath res) "/dev/null"- assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing--compressedResponseGZ :: Test-compressedResponseGZ =- "compressedResponseGZ" ~:- do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty- res <- simpleHTTP'' compressPart req- assertEqual "respone code" (rsCode res) 200- assertEqual "body" (unpack (GZ.decompress (rsBody res))) ("compress Response")- assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "gzip"]))--compressedResponseZ :: Test-compressedResponseZ =- "compressedResponseZ" ~:- do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " deflate;q=1"])) L.empty- res <- simpleHTTP'' compressPart req- assertEqual "respone code" (rsCode res) 200- assertEqual "body" (unpack (Z.decompress (rsBody res))) ("compress Response")- assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "deflate"]))--compressedSendFile :: Test-compressedSendFile =- "compressedSendfile" ~:- do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty- res <- simpleHTTP'' compressPart req- assertEqual "respone code" (rsCode res) 200- assertEqual "filepath" (sfFilePath res) "/dev/null"- assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing--compressedSendFileNoIdentity :: Test-compressedSendFileNoIdentity =- "compressedSendFileNoIdentity" ~:- do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1, identity: q=0.0"])) L.empty- res <- simpleHTTP'' compressPart req- 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]
tests/Test.hs view
@@ -16,4 +16,4 @@ return c case (failures c) + (errors c) of 0 -> return ()- n -> exitFailure+ _ -> exitFailure