Skip to content

Commit 9d64c12

Browse files
author
Clifford Beshers
committed
Merge remote-tracking branch 'happstack/master'
2 parents 9a44ba3 + bdefeda commit 9d64c12

7 files changed

Lines changed: 74 additions & 15 deletions

File tree

‎default.nix‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
{ mkDerivation, base, base64-bytestring, blaze-html, bytestring
2-
, containers, directory, exceptions, extensible-exceptions
2+
, containers, directory, exceptions
33
, filepath, hslogger, html, HUnit, monad-control, mtl, network
44
, network-uri, old-locale, parsec, process, semigroups, sendfile
55
, stdenv, syb, system-filepath, template-haskell, text, threads
@@ -12,7 +12,7 @@ mkDerivation {
1212
src = ./.;
1313
libraryHaskellDepends = [
1414
base base64-bytestring blaze-html bytestring containers directory
15-
exceptions extensible-exceptions filepath hslogger html
15+
exceptions filepath hslogger html
1616
monad-control mtl network network-uri old-locale parsec process
1717
semigroups sendfile syb system-filepath template-haskell text
1818
threads time transformers transformers-base transformers-compat

‎happstack-server.cabal‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -89,7 +89,6 @@ Library
8989
containers,
9090
directory >=1.2,
9191
exceptions,
92-
extensible-exceptions,
9392
filepath,
9493
hslogger >= 1.0.2,
9594
html,

‎src/Happstack/Server/FileServe/BuildingBlocks.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,7 @@ module Happstack.Server.FileServe.BuildingBlocks
5454
isDot
5555
) where
5656

57-
import Control.Exception.Extensible as E (IOException, bracket, catch)
57+
import Control.Exception as E (IOException, bracket, catch)
5858
import Control.Monad (MonadPlus(mzero), msum)
5959
import Control.Monad.Trans (MonadIO(liftIO))
6060
import qualified Data.ByteString.Lazy.Char8 as L

‎src/Happstack/Server/Internal/Handler.hs‎

Lines changed: 18 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -4,13 +4,14 @@ module Happstack.Server.Internal.Handler
44
( request
55
, parseResponse
66
, putRequest
7+
, consumeChunks
78
) where
89

910
import qualified Paths_happstack_server as Paths
1011
import qualified Data.Version as DV
1112
import Control.Applicative (pure)
1213
import Control.Concurrent (newMVar, newEmptyMVar, tryTakeMVar)
13-
import Control.Exception.Extensible as E
14+
import Control.Exception as E
1415
import Control.Monad
1516
import Data.List(elemIndex)
1617
import Data.Char(toLower)
@@ -154,24 +155,32 @@ parseResponse inputStr =
154155
mbCL
155156
return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags ContentLength,rsValidator=Nothing}
156157

157-
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html
158-
-- note this does NOT handle extenions
159-
consumeChunks::L.ByteString->(L.ByteString,L.ByteString)
160-
consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest)
158+
-- | Decode an HTTP/1.1 Transfer-Encoding: chunked body.
159+
-- See http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html (chunk extensions are not handled).
160+
-- Returns @(decoded body, bytes following the chunked stream)@. The trailer (optional headers
161+
-- after the terminating 0-chunk, RFC 2616 §3.6.1) is dropped from the body — trailers are
162+
-- headers, not body content.
163+
consumeChunks :: L.ByteString -> (L.ByteString, L.ByteString)
164+
consumeChunks str = let (parts,_tr,rest) = consumeChunksImpl str in (L.concat . map snd $ parts, rest)
161165

166+
-- | Worker for 'consumeChunks'. Returns @(chunks, trailer, remainder)@, where each chunk is
167+
-- @(declared-length, body-bytes)@ and the terminating 0-chunk has empty body.
162168
consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)
163169
consumeChunksImpl str
164170
| L.null str = ([],L.empty,str)
165-
| chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str
171+
| chunkLen == 0 = let (_sizeLine,rest') = L.splitAt lenLine1 str
166172
(tr',rest'') = getTrailer rest'
167-
in ([(0,last)],tr',rest'')
168-
| otherwise = ((chunkLen,part):crest,tr,rest2)
173+
in ([(0,L.empty)],tr',rest'')
174+
| otherwise = ((chunkLen,body):crest,tr,rest2)
169175
where
170176
line1 = head $ lazylines str
171177
lenLine1 = (L.length line1) + 1 -- endchar
172178
chunkLen = (fst $ head $ readHex $ L.unpack line1)
173179
len = chunkLen + lenLine1 + 2
174-
(part,rest) = L.splitAt len str
180+
-- Each frame on the wire is "<hex-size>\r\n<body-bytes>\r\n". Skip the size-line and
181+
-- take exactly chunkLen bytes so the trailing CRLF stays out of the decoded body.
182+
(frame,rest) = L.splitAt len str
183+
body = L.take chunkLen . L.drop lenLine1 $ frame
175184
(crest,tr,rest2) = consumeChunksImpl rest
176185
getTrailer s = L.splitAt index s
177186
where index | crlfLC `L.isPrefixOf` s = 2

‎src/Happstack/Server/Internal/Listen.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ import Happstack.Server.Internal.Socket (acceptLite)
88
import Happstack.Server.Internal.TimeoutManager (cancel, initialize, register, forceTimeoutAll)
99
import Happstack.Server.Internal.TimeoutSocket as TS
1010
import qualified Control.Concurrent.Thread.Group as TG
11-
import Control.Exception.Extensible as E
11+
import Control.Exception as E
1212
import Control.Concurrent (forkIO, killThread, myThreadId)
1313
import Control.Monad
1414
import qualified Data.Maybe as Maybe

‎src/Happstack/Server/Internal/Monads.hs‎

Lines changed: 16 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ import Control.Exception (throwIO)
1111
import Control.Monad ( MonadPlus(mzero, mplus), ap, liftM, msum
1212
)
1313
import Control.Monad.Base ( MonadBase, liftBase )
14-
import Control.Monad.Catch ( MonadCatch(..), MonadThrow(..) )
14+
import Control.Monad.Catch ( MonadCatch(..), MonadMask(..), MonadThrow(..) )
1515
#if !MIN_VERSION_transformers(0,6,0)
1616
import Control.Monad.Trans.Error ( ErrorT, Error, mapErrorT )
1717
#endif
@@ -85,6 +85,11 @@ newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m
8585
instance MonadCatch m => MonadCatch (ServerPartT m) where
8686
catch action handle = ServerPartT $ catch (unServerPartT action) (unServerPartT . handle)
8787

88+
instance MonadMask m => MonadMask (ServerPartT m) where
89+
mask restore = ServerPartT $ mask $ \action -> unServerPartT $ restore (ServerPartT . action . unServerPartT)
90+
uninterruptibleMask restore = ServerPartT $ uninterruptibleMask $ \action -> unServerPartT $ restore (ServerPartT . action . unServerPartT)
91+
generalBracket acquire release use = ServerPartT $ generalBracket (unServerPartT acquire) (\resource result -> unServerPartT $ release resource result) (unServerPartT . use)
92+
8893
instance MonadThrow m => MonadThrow (ServerPartT m) where
8994
throwM = ServerPartT . throwM
9095

@@ -320,6 +325,11 @@ newtype FilterT a m b = FilterT { unFilterT :: Lazy.WriterT (FilterFun a) m b }
320325
instance MonadCatch m => MonadCatch (FilterT a m) where
321326
catch action handle = FilterT $ catch (unFilterT action) (unFilterT . handle)
322327

328+
instance MonadMask m => MonadMask (FilterT a m) where
329+
mask restore = FilterT $ mask $ \action -> unFilterT $ restore (FilterT . action . unFilterT)
330+
uninterruptibleMask restore = FilterT $ uninterruptibleMask $ \action -> unFilterT $ restore (FilterT . action . unFilterT)
331+
generalBracket acquire release use = FilterT $ generalBracket (unFilterT acquire) (\resource result -> unFilterT $ release resource result) (unFilterT . use)
332+
323333
instance MonadThrow m => MonadThrow (FilterT a m) where
324334
throwM = FilterT . throwM
325335

@@ -379,6 +389,11 @@ newtype WebT m a = WebT { unWebT :: ExceptT Response (FilterT (Response) (MaybeT
379389
instance MonadCatch m => MonadCatch (WebT m) where
380390
catch action handle = WebT $ catch (unWebT action) (unWebT . handle)
381391

392+
instance MonadMask m => MonadMask (WebT m) where
393+
mask restore = WebT $ mask $ \action -> unWebT $ restore (WebT . action . unWebT)
394+
uninterruptibleMask restore = WebT $ uninterruptibleMask $ \action -> unWebT $ restore (WebT . action . unWebT)
395+
generalBracket acquire release use = WebT $ generalBracket (unWebT acquire) (\resource result -> unWebT $ release resource result) (unWebT . use)
396+
382397
instance MonadThrow m => MonadThrow (WebT m) where
383398
throwM = WebT . throwM
384399

‎tests/Happstack/Server/Tests.hs‎

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse)
1919
import Happstack.Server.Cookie
2020
import Happstack.Server.Internal.Compression
2121
import Happstack.Server.Internal.Cookie
22+
import Happstack.Server.Internal.Handler (consumeChunks)
2223
import Happstack.Server.Internal.Multipart
2324
import Happstack.Server.Internal.MessageWrap
2425
import Happstack.Server.Internal.RFC822Headers (ContentDisposition(..), parseContentDisposition)
@@ -37,6 +38,7 @@ allTests =
3738
, cookieHeaderOrderTest
3839
, pContentDispositionFilename
3940
, applicativeTest
41+
, consumeChunksTest
4042
]
4143

4244
cookieParserTest :: Test
@@ -251,6 +253,40 @@ pContentDispositionFilename =
251253
c <- parseContentDisposition doesNotWorkWithOldParserButWithNew
252254
assertEqual "parseContentDisposition" c (ContentDisposition "form-data" [("filename","file.pdf"),("name","file")])
253255

256+
consumeChunksTest :: Test
257+
consumeChunksTest =
258+
"consumeChunks decodes Transfer-Encoding: chunked" ~:
259+
[ -- Single chunk
260+
consumeChunks (pack "5\r\nhello\r\n0\r\n\r\n") @?= (pack "hello", pack "")
261+
-- Multiple chunks concatenated
262+
, consumeChunks (pack "5\r\nhello\r\n5\r\nworld\r\n0\r\n\r\n")
263+
@?= (pack "helloworld", pack "")
264+
-- Empty body (only terminator)
265+
, consumeChunks (pack "0\r\n\r\n") @?= (pack "", pack "")
266+
-- Trailing bytes after final chunk are returned as remainder
267+
, consumeChunks (pack "5\r\nhello\r\n0\r\n\r\nNEXT")
268+
@?= (pack "hello", pack "NEXT")
269+
270+
-- Trailer header after the 0-chunk is dropped, not appended to the body
271+
, consumeChunks (pack "5\r\nhello\r\n0\r\nFoo: bar\r\n\r\n")
272+
@?= (pack "hello", pack "")
273+
-- Multiple trailer headers, followed by a pipelined request
274+
, consumeChunks (pack "5\r\nhello\r\n0\r\nA: 1\r\nB: 2\r\n\r\nNEXT")
275+
@?= (pack "hello", pack "NEXT")
276+
-- Chunk extensions are skipped along with the size line
277+
, consumeChunks (pack "5;name=val\r\nhello\r\n0;last\r\n\r\n")
278+
@?= (pack "hello", pack "")
279+
-- Hex sizes in upper and lower case
280+
, consumeChunks (pack "A\r\n0123456789\r\na\r\nabcdefghij\r\n0\r\n\r\n")
281+
@?= (pack "0123456789abcdefghij", pack "")
282+
-- CRLFs inside the payload are body data, not framing
283+
, consumeChunks (pack "6\r\nab\r\ncd\r\n0\r\n\r\n")
284+
@?= (pack "ab\r\ncd", pack "")
285+
-- Payload that looks like a terminating chunk is still body data
286+
, consumeChunks (pack "5\r\n0\r\n\r\n\r\n0\r\n\r\n")
287+
@?= (pack "0\r\n\r\n", pack "")
288+
]
289+
254290
applicativeTest :: Test
255291
applicativeTest =
256292
"applicativeTest" ~:

0 commit comments

Comments
 (0)