This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, master has been updated
via 7ae3621c9fe7e26df8daebc1bb343eaa49288233 (commit)
from 7a604e0335c6dbb50f5b4d905577d1b8409f2814 (commit)
Summary of changes:
snap-core.cabal | 2 +-
src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs | 37 +++++++++-------
src/Snap/Iteratee.hs | 51 +++++++++++-----------
src/Snap/Util/FileUploads.hs | 41 ++++++++---------
4 files changed, 67 insertions(+), 64 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 7ae3621c9fe7e26df8daebc1bb343eaa49288233
Author: Gregory Collins <[email protected]>
Date: Wed Feb 16 09:27:05 2011 -0800
Kill one of the space leaks in file upload
diff --git a/snap-core.cabal b/snap-core.cabal
index db0b9c2..05015b8 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -1,5 +1,5 @@
name: snap-core
-version: 0.4.0.2
+version: 0.4.0.3
synopsis: Snap: A Haskell Web Framework (Core)
description:
diff --git a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
index dbe8975..f915d0b 100644
--- a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
+++ b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
@@ -91,20 +91,25 @@ bmhEnumeratee :: (MonadIO m) =>
-> Iteratee ByteString m (Step MatchInfo m a)
bmhEnumeratee needle _step = do
debug $ "boyermoore: needle=" ++ show needle
- checkDone iter _step
+ cDone _step iter
where
+ {-# INLINE cDone #-}
+ cDone (Continue k) f = f k
+ cDone step _ = yield step (Chunks [])
+
+
iter !k = {-# SCC "bmh/iter" #-} do
lookahead nlen >>= either (finishAndEOF k . (:[]))
(startSearch k)
- finishAndEOF k xs = do
+ finishAndEOF k xs = {-# SCC "finishAndEOF" #-} do
debug $ "finishAndEOF, returning NoMatch for " ++ show xs
step <- lift $ runIteratee $ k $
Chunks (map NoMatch $ filter (not . S.null) xs)
- checkDone (\k' -> lift $ runIteratee $ k' EOF) step
+ cDone step (\k' -> lift $ runIteratee $ k' EOF)
- startSearch !k !haystack = do
+ startSearch !k !haystack = {-# SCC "startSearch" #-} do
debug $ "startsearch: " ++ show haystack
if S.null haystack
then lookahead nlen >>=
@@ -116,12 +121,12 @@ bmhEnumeratee needle _step = do
go !hidx
| hend >= hlen = crossBound hidx
- | otherwise = do
+ | otherwise = {-# SCC "go" #-} do
let match = matches needle 0 last haystack hidx hend
debug $ "go " ++ show hidx ++ ", hend=" ++ show hend
++ ", match was " ++ show match
if match
- then do
+ then {-# SCC "go/match" #-} do
let !nomatch = S.take hidx haystack
let !aftermatch = S.drop (hend+1) haystack
@@ -129,10 +134,10 @@ bmhEnumeratee needle _step = do
then lift $ runIteratee $ k $ Chunks [NoMatch
nomatch]
else return $ Continue k
- flip checkDone step $ \k' -> do
+ cDone step $ \k' -> do
step' <- lift $ runIteratee $ k' $ Chunks [Match needle]
- flip checkDone step' $ \k'' -> startSearch k'' aftermatch
- else do
+ cDone step' $ \k'' -> startSearch k'' aftermatch
+ else {-# SCC "go/nomatch" #-} do
-- skip ahead
let c = S.index haystack hend
let !skip = V.unsafeIndex table $ fromEnum c
@@ -140,7 +145,7 @@ bmhEnumeratee needle _step = do
where
!hend = hidx + nlen - 1
- crossBound !hidx = do
+ crossBound !hidx = {-# SCC "crossBound" #-} do
let !leftLen = hlen - hidx
let !needMore = nlen - leftLen
debug $ "crossbound " ++ show hidx ++ ", leftlen=" ++ show leftLen
@@ -158,7 +163,7 @@ bmhEnumeratee needle _step = do
++ " match2=" ++ show match2
if match1 && match2
- then do
+ then {-# SCC "crossBound/match" #-} do
let !nomatch = S.take hidx haystack
let !aftermatch = S.drop needMore nextHaystack
@@ -169,13 +174,13 @@ bmhEnumeratee needle _step = do
else return $ Continue k
debug $ "matching"
- flip checkDone step $ \k' -> do
+ cDone step $ \k' -> do
step' <- lift $ runIteratee $ k' $
Chunks [Match needle]
- flip checkDone step' $ \k'' ->
+ cDone step' $ \k'' ->
startSearch k'' aftermatch
- else do
+ else {-# SCC "crossBound/nomatch" #-} do
let c = S.index nextHaystack $ needMore-1
let p = V.unsafeIndex table (fromEnum c)
@@ -189,7 +194,7 @@ bmhEnumeratee needle _step = do
Chunks $ map NoMatch $
filter (not . S.null) [nomatch]
- flip checkDone step $ flip startSearch rest
+ cDone step $ flip startSearch rest
else do
let sidx = p - leftLen
@@ -198,7 +203,7 @@ bmhEnumeratee needle _step = do
Chunks $ map NoMatch $
filter (not . S.null) [haystack, crumb]
- flip checkDone step $ flip startSearch rest
+ cDone step $ flip startSearch rest
)
diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs
index 0db8b3a..0dceeb6 100644
--- a/src/Snap/Iteratee.hs
+++ b/src/Snap/Iteratee.hs
@@ -484,7 +484,7 @@ takeExactly 0 s = do
takeExactly !n y@(Yield _ _ ) = drop' n >> return y
takeExactly _ (Error e ) = throwError e
-takeExactly !n st@(Continue k) = do
+takeExactly !n st@(Continue !k) = do
if n == 0
then lift $ runIteratee $ k EOF
else do
@@ -494,22 +494,22 @@ takeExactly !n st@(Continue k) = do
mbX
where
- check x | S.null x = takeExactly n st
- | strlen < n = do
- newStep <- lift $ runIteratee $ k $ Chunks [x]
- takeExactly (n-strlen) newStep
- | otherwise = do
- step1 <- lift $ runIteratee $ k $ Chunks [s1]
- step2 <- lift $ runIteratee $ enumEOF step1
-
- case step2 of
- (Continue _) -> error "divergent iteratee"
- (Error e) -> throwError e
- (Yield v _) -> yield (Yield v EOF) (Chunks [s2])
+ check !x | S.null x = takeExactly n st
+ | strlen < n = do
+ newStep <- lift $ runIteratee $ k $ Chunks [x]
+ takeExactly (n-strlen) newStep
+ | otherwise = do
+ let (s1,s2) = S.splitAt (fromEnum n) x
+ !step1 <- lift $ runIteratee $ k $ Chunks [s1]
+ !step2 <- lift $ runIteratee $ enumEOF step1
+
+ case step2 of
+ (Continue _) -> error "divergent iteratee"
+ (Error e) -> throwError e
+ (Yield v _) -> yield (Yield v EOF) (Chunks [s2])
where
- strlen = toEnum $ S.length x
- (s1,s2) = S.splitAt (fromEnum n) x
+ !strlen = toEnum $ S.length x
------------------------------------------------------------------------------
@@ -704,7 +704,7 @@ killIfTooSlow :: (MonadIO m) =>
-- the iteratee run for
-> Iteratee ByteString m a -- ^ iteratee consumer to wrap
-> Iteratee ByteString m a
-killIfTooSlow bump minRate minSeconds' inputIter = do
+killIfTooSlow !bump !minRate !minSeconds' !inputIter = do
!_ <- lift bump
startTime <- liftIO getTime
step <- lift $ runIteratee inputIter
@@ -712,24 +712,25 @@ killIfTooSlow bump minRate minSeconds' inputIter = do
where
minSeconds = fromIntegral minSeconds'
- wrap startTime nBytesRead = step
+
+ wrap !startTime = proc
where
- step (Continue k) = continue $ cont k
- step z = returnI z
+ proc !nb (Continue !k) = continue $ cont nb k
+ proc _ !z = returnI z
- cont k EOF = k EOF
- cont k stream = do
- let slen = toEnum $ streamLength stream
+ cont !nBytesRead !k EOF = k EOF
+ cont !nBytesRead !k !stream = do
+ let !slen = toEnum $ streamLength stream
now <- liftIO getTime
- let delta = now - startTime
- let newBytes = nBytesRead + slen
+ let !delta = now - startTime
+ let !newBytes = nBytesRead + slen
when (delta > minSeconds+1 &&
fromIntegral newBytes / (delta-minSeconds) < minRate) $
throw RateTooSlowException
-- otherwise bump the timeout and continue running the iteratee
!_ <- lift bump
- lift (runIteratee $ k stream) >>= wrap startTime newBytes
+ lift (runIteratee $! k stream) >>= proc newBytes
------------------------------------------------------------------------------
diff --git a/src/Snap/Util/FileUploads.hs b/src/Snap/Util/FileUploads.hs
index 72f5f4b..6199144 100644
--- a/src/Snap/Util/FileUploads.hs
+++ b/src/Snap/Util/FileUploads.hs
@@ -711,33 +711,29 @@ findParam p = fmap snd . find ((== p) . fst)
-- up until the next boundary and send all of the chunks into the wrapped
-- iteratee
processPart :: (Monad m) => Enumeratee MatchInfo ByteString m a
-processPart _st = {-# SCC "pPart/outer" #-} cDone go _st
+processPart st = {-# SCC "pPart/outer" #-}
+ case st of
+ (Continue k) -> go k
+ _ -> yield st (Chunks [])
where
- cDone !f (Continue !k) = {-# SCC "cDone/cont" #-} f k
- cDone _ step = {-# SCC "cDone/yield" #-}
- yield step (Chunks [])
-
go :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
-> Iteratee MatchInfo m (Step ByteString m a)
go !k = {-# SCC "pPart/go" #-}
- I.head >>= maybe (finish k) (process k)
-
- -- called when outer stream is EOF
- finish :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
- -> Iteratee MatchInfo m (Step ByteString m a)
- finish !k = {-# SCC "pPart/finish" #-}
- lift $ runIteratee $ k EOF
+ I.head >>= maybe finish process
+ where
+ -- called when outer stream is EOF
+ finish = {-# SCC "pPart/finish" #-}
+ lift $ runIteratee $ k EOF
- -- no match ==> pass the stream chunk along
- process :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
- -> MatchInfo
- -> Iteratee MatchInfo m (Step ByteString m a)
- process !k (NoMatch !s) = {-# SCC "pPart/noMatch" #-} do
- step <- lift $ runIteratee $ k $ Chunks [s]
- cDone go step
+ -- no match ==> pass the stream chunk along
+ process (NoMatch !s) = {-# SCC "pPart/noMatch" #-} do
+ !step <- lift $ runIteratee $ k $ Chunks [s]
+ case step of
+ (Continue k') -> go k'
+ _ -> yield step (Chunks [])
- process !k (Match _) = {-# SCC "pPart/match" #-}
- lift $ runIteratee $ k EOF
+ process (Match _) = {-# SCC "pPart/match" #-}
+ lift $ runIteratee $ k EOF
------------------------------------------------------------------------------
@@ -866,7 +862,8 @@ openFileForUpload ufs@(UploadedFiles stateRef) tmpdir =
liftIO $ do
cleanupUploadedFiles ufs
throw $ GenericFileUploadException alreadyOpenMsg
- fph <- openTempFile tmpdir "snap-"
+ fph@(_,h) <- openBinaryTempFile tmpdir "snap-"
+ hSetBuffering h NoBuffering
writeIORef stateRef $ state { _currentFile = Just fph }
return fph
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
