bea0431 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Don't prematurely delete temp files yesodweb/yesod#630

bea0431Michael Snoyman13 years ago

wai-extra/Network/Wai/Middleware/RequestLogger.hs+1−2

compare with master

unifiedsplit

@@ -261,8 +261,7 @@ detailedMiddleware' cb getAddColor app req = do

261 allPostParams body =

262 case getRequestBodyType req of

263 Nothing -> return ([], [])

264− Just rbt -> C.runResourceT $ withInternalState $ \internalState ->

265− CL.sourceList body C.$$ sinkRequestBody internalState lbsBackEnd rbt

264+ Just rbt -> CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt

266

265

267 emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)

266 emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)

268 emptyGetParam (k, Just v) = (k,v)

267 emptyGetParam (k, Just v) = (k,v)

wai-extra/Network/Wai/Parse.hs+25−27

@@ -89,21 +89,24 @@ lbsBackEnd :: Monad m => ignored1 -> ignored2 -> Sink S.ByteString m L.ByteStrin

89lbsBackEnd _ _ = fmap L.fromChunks CL.consume

91-- | Save uploaded files on disk as temporary files

92+--

93+-- Note: starting with version 2.0, it is the responsibility of the caller to

94+-- remove any temp files created by using this backend.

92−tempFileBackEnd :: MonadResource m => ignored1 -> ignored2 -> Sink S.ByteString m FilePath

95+tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> Sink S.ByteString IO FilePath

93tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"

96tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"

95-- | Same as 'tempFileSink', but use configurable temp folders and patterns.

98-- | Same as 'tempFileSink', but use configurable temp folders and patterns.

96−tempFileBackEndOpts :: MonadResource m

97− => IO FilePath -- ^ get temporary directory

99+tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory

98 -> String -- ^ filename pattern

100 -> String -- ^ filename pattern

101+ -> InternalState

99 -> ignored1

102 -> ignored1

100 -> ignored2

103 -> ignored2

101− -> Sink S.ByteString m FilePath

104+ -> Sink S.ByteString IO FilePath

102−tempFileBackEndOpts getTmpDir pattern _ _ = do

105+tempFileBackEndOpts getTmpDir pattern internalState _ _ = do

103− (key, (fp, h)) <- lift $ allocate (do

106+ (key, (fp, h)) <- flip runInternalState internalState $ allocate (do

104 tempDir <- getTmpDir

107 tempDir <- getTmpDir

105 openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)

108 openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)

106− _ <- lift $ register $ removeFile fp

109+ _ <- runInternalState (register $ removeFile fp) internalState

107 CB.sinkHandle h

110 CB.sinkHandle h

108 lift $ release key

111 lift $ release key

109 return fp

112 return fp

@@ -126,7 +129,7 @@ type File y = (S.ByteString, FileInfo y)

126-- type, and returns a `Sink` for storing the contents.

129-- type, and returns a `Sink` for storing the contents.

127type BackEnd a = S.ByteString -- ^ parameter name

130type BackEnd a = S.ByteString -- ^ parameter name

128 -> FileInfo ()

131 -> FileInfo ()

129− -> Sink S.ByteString (ResourceT IO) a

132+ -> Sink S.ByteString IO a

130

133

131data RequestBodyType = UrlEncoded | Multipart S.ByteString

134data RequestBodyType = UrlEncoded | Multipart S.ByteString

132

135

@@ -169,27 +172,24 @@ parseRequestBody :: BackEnd y

169parseRequestBody s r =

172parseRequestBody s r =

170 case getRequestBodyType r of

173 case getRequestBodyType r of

171 Nothing -> return ([], [])

174 Nothing -> return ([], [])

172− Just rbt -> runResourceT $ withInternalState $ \internalState ->

173− fmap partitionEithers $ requestBody r $$ conduitRequestBody internalState s rbt =$ CL.consume

175+ Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume

174

176

175−sinkRequestBody :: InternalState

177+sinkRequestBody :: BackEnd y

176− -> BackEnd y

177 -> RequestBodyType

178 -> RequestBodyType

178 -> Sink S.ByteString IO ([Param], [File y])

179 -> Sink S.ByteString IO ([Param], [File y])

179−sinkRequestBody internalState s r = fmap partitionEithers $ conduitRequestBody internalState s r =$ CL.consume

180+sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume

180

181

181−conduitRequestBody :: InternalState

182+conduitRequestBody :: BackEnd y

182− -> BackEnd y

183 -> RequestBodyType

184 -> Conduit S.ByteString IO (Either Param (File y))

185−conduitRequestBody _ _ UrlEncoded = do

185+conduitRequestBody _ UrlEncoded = do

186 -- NOTE: in general, url-encoded data will be in a single chunk.

187 -- Therefore, I'm optimizing for the usual case by sticking with

188 -- strict byte strings here.

189 bs <- CL.consume

190 mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs

191−conduitRequestBody internalState backend (Multipart bound) =

191+conduitRequestBody backend (Multipart bound) =

192− parsePieces internalState backend $ S8.pack "--" `S.append` bound

192+ parsePieces backend $ S8.pack "--" `S.append` bound

193

194takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString)

195takeLine =

@@ -217,11 +217,10 @@ takeLines = do

217 ls <- takeLines

218 return $ l : ls

219

220−parsePieces :: InternalState

221− -> BackEnd y

220+parsePieces :: BackEnd y

222 -> S.ByteString

221 -> S.ByteString

223 -> ConduitM S.ByteString (Either Param (File y)) IO ()

222 -> ConduitM S.ByteString (Either Param (File y)) IO ()

224−parsePieces internalState sink bound =

223+parsePieces sink bound =

225 loop

224 loop

226 where

225 where

227 loop = do

226 loop = do

@@ -239,7 +238,7 @@ parsePieces internalState sink bound =

239 Just (mct, name, Just filename) -> do

238 Just (mct, name, Just filename) -> do

240 let ct = fromMaybe "application/octet-stream" mct

239 let ct = fromMaybe "application/octet-stream" mct

241 fi0 = FileInfo filename ct ()

240 fi0 = FileInfo filename ct ()

242− (wasFound, y) <- sinkTillBound' internalState bound name fi0 sink

241+ (wasFound, y) <- sinkTillBound' bound name fi0 sink

243 yield $ Right (name, fi0 { fileContent = y })

242 yield $ Right (name, fi0 { fileContent = y })

244 when wasFound loop

243 when wasFound loop

245 Just (_ct, name, Nothing) -> do

244 Just (_ct, name, Nothing) -> do

@@ -291,18 +290,17 @@ findBound b bs = handleBreak $ Search.breakOn b bs

291 | S.index b x == S.index bs y = mismatch xs ys

290 | S.index b x == S.index bs y = mismatch xs ys

292 | otherwise = True

291 | otherwise = True

293

292

294−sinkTillBound' :: InternalState

295− -> S.ByteString

293+sinkTillBound' :: S.ByteString

296 -> S.ByteString

294 -> S.ByteString

297 -> FileInfo ()

295 -> FileInfo ()

298 -> BackEnd y

296 -> BackEnd y

299 -> ConduitM S.ByteString o IO (Bool, y)

297 -> ConduitM S.ByteString o IO (Bool, y)

300−sinkTillBound' internalState bound name fi sink =

298+sinkTillBound' bound name fi sink =

301 ConduitM $ anyOutput $

299 ConduitM $ anyOutput $

302 conduitTillBound bound >+> withUpstream (fix $ sink name fi)

300 conduitTillBound bound >+> withUpstream (fix $ sink name fi)

303 where

301 where

304− fix :: Sink S8.ByteString (ResourceT IO) y -> Pipe Void S8.ByteString Void Bool IO y

302+ fix :: Sink S8.ByteString IO y -> Pipe Void S8.ByteString Void Bool IO y

305− fix p = ignoreTerm >+> injectLeftovers (unConduitM $ transPipe (flip runInternalState internalState) p)

303+ fix p = ignoreTerm >+> injectLeftovers (unConduitM p)

306 ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)

304 ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)

307 await' = NeedInput (return . Just) (const $ return Nothing)

305 await' = NeedInput (return . Just) (const $ return Nothing)

308 yield' = HaveOutput (return ()) (return ())

306 yield' = HaveOutput (return ()) (return ())

wai-extra/test/WaiExtraTest.hs+9−10

@@ -31,11 +31,12 @@ import Codec.Compression.GZip (decompress)

32import qualified Data.Conduit as C

33import qualified Data.Conduit.List as CL

34−import Data.Conduit.Binary (sourceFile)

34+import Data.Conduit.Binary (sourceHandle)

35import Control.Monad.IO.Class (liftIO)

36import Data.Maybe (fromMaybe)

37import Network.HTTP.Types (parseSimpleQuery, status200)

38import System.Log.FastLogger

39+import System.IO (withFile, IOMode (ReadMode))

40import qualified Data.IORef as I

41import qualified Data.IORef as I

@@ -117,14 +118,13 @@ caseParseHttpAccept = do

117 expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"]

118 expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"]

118 expected @=? parseHttpAccept input

119 expected @=? parseHttpAccept input

119

120

120−parseRequestBody' :: BackEnd L.ByteString

121+parseRequestBody' :: BackEnd file

121 -> SRequest

122 -> SRequest

122− -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])

123+ -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo file)])

123parseRequestBody' sink (SRequest req bod) =

124parseRequestBody' sink (SRequest req bod) =

124 case getRequestBodyType req of

125 case getRequestBodyType req of

125 Nothing -> return ([], [])

126 Nothing -> return ([], [])

126− Just rbt -> runResourceT $ withInternalState $ \is ->

127− CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody is sink rbt

127+ Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt

128

129caseParseRequestBody :: Assertion

130caseParseRequestBody =

@@ -218,7 +218,8 @@ caseMultipartAttrs = do

218

219caseUrlEncPlus :: Assertion

220caseUrlEncPlus = do

221+ result <- runResourceT $ withInternalState $ \state ->

221− result <- parseRequestBody' lbsBackEnd $ toRequest ctype content

222+ parseRequestBody' (tempFileBackEnd state) $ toRequest ctype content

222 liftIO $ result @?= ([("email", "has+plus")], [])

223 liftIO $ result @?= ([("email", "has+plus")], [])

223 where

224 where

224 content = S8.pack $ "email=has%2Bplus"

225 content = S8.pack $ "email=has%2Bplus"

@@ -514,10 +515,8 @@ dalvikHelper includeLength = do

514 (params, files) <-

515 (params, files) <-

515 case getRequestBodyType request' of

516 case getRequestBodyType request' of

516 Nothing -> return ([], [])

517 Nothing -> return ([], [])

517− Just rbt -> C.runResourceT $ do

518− internalState <- getInternalState

519− sourceFile "test/requests/dalvik-request"

518+ Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->

520− C.$$ C.transPipe liftIO (sinkRequestBody internalState lbsBackEnd rbt)

519+ sourceHandle h C.$$ sinkRequestBody lbsBackEnd rbt

521 lookup "scannedTime" params @?= Just "1.298590056748E9"

520 lookup "scannedTime" params @?= Just "1.298590056748E9"

522 lookup "geoLong" params @?= Just "0"

521 lookup "geoLong" params @?= Just "0"

523 lookup "geoLat" params @?= Just "0"

522 lookup "geoLat" params @?= Just "0"

wai-extra/wai-extra.cabal+1−1

@@ -1,5 +1,5 @@

1Name: wai-extra

2−Version: 2.0.0.1

2+Version: 2.0.1

3Synopsis: Provides some basic WAI handlers and middleware.

4Description: The goal here is to provide common features without many dependencies.

5License: MIT