16914df · typeable/wai

git.iko.soy/typeable/wai

Provide more information to file upload sinks (yesodweb/yesod#262)

commit16914dfa9f5c9efa9c583ebb4c0cdedd2451ce8f authorMichael Snoyman <michael@snoyman.com> dateWed 11 Jul 2012, 15:57 (14 years ago) parent321d6d2

3 files changed+44−34

compare with master

unifiedsplit

wai-extra/Network/Wai/Middleware/RequestLogger.hs+2−2 wai-extra/Network/Wai/Parse.hs+32−22 wai-extra/test/WaiExtraTest.hs+10−10

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

@@ -25,7 +25,7 @@ import System.Log.FastLogger

2525import Network.HTTP.Types as H

2626import Data.Maybe (fromMaybe)

2727

28−import Network.Wai.Parse (sinkRequestBody, lbsSink, fileName, Param, File, getRequestBodyType)

28+import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)

2929import qualified Data.ByteString.Lazy as LBS

3030

3131import qualified Data.Conduit as C

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

223223 allPostParams body =

224224 case getRequestBodyType req of

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

226− Just rbt -> C.runResourceT $ CL.sourceList body C.$$ sinkRequestBody lbsSink rbt

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

227227

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

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

wai-extra/Network/Wai/Parse.hs+32−22

@@ -10,9 +10,10 @@ module Network.Wai.Parse

1010 , getRequestBodyType

1111 , sinkRequestBody

1212 , conduitRequestBody

13− , lbsSink

14− , tempFileSink

15− , tempFileSinkOpts

13+ , BackEnd

14+ , lbsBackEnd

15+ , tempFileBackEnd

16+ , tempFileBackEndOpts

1617 , Param

1718 , File

1819 , FileInfo (..)

@@ -72,19 +73,21 @@ parseHttpAccept = map fst

7273 trimWhite = S.dropWhile (== 32) -- space

7374

7475-- | Store uploaded files in memory

75−lbsSink :: Monad m => Sink S.ByteString m L.ByteString

76−lbsSink = fmap L.fromChunks CL.consume

76+lbsBackEnd :: Monad m => ignored1 -> ignored2 -> Sink S.ByteString m L.ByteString

77+lbsBackEnd _ _ = fmap L.fromChunks CL.consume

7778

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

79−tempFileSink :: MonadResource m => Sink S.ByteString m FilePath

80−tempFileSink = tempFileSinkOpts getTemporaryDirectory "webenc.buf"

80+tempFileBackEnd :: MonadResource m => ignored1 -> ignored2 -> Sink S.ByteString m FilePath

81+tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"

8182

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

83−tempFileSinkOpts :: MonadResource m

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

85− -> String -- ^ filename pattern

86− -> Sink S.ByteString m FilePath

87−tempFileSinkOpts getTmpDir pattern = do

84+tempFileBackEndOpts :: MonadResource m

85+ => IO FilePath -- ^ get temporary directory

86+ -> String -- ^ filename pattern

87+ -> ignored1

88+ -> ignored2

89+ -> Sink S.ByteString m FilePath

90+tempFileBackEndOpts getTmpDir pattern _ _ = do

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

8992 tempDir <- getTmpDir

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

@@ -104,6 +107,12 @@ data FileInfo c = FileInfo

104107type Param = (S.ByteString, S.ByteString)

105108type File y = (S.ByteString, FileInfo y)

106109

110+-- | A file uploading backend. Takes the parameter name, file name, and content

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

112+type BackEnd a = S.ByteString -- ^ parameter name

113+ -> FileInfo ()

114+ -> Sink S.ByteString (ResourceT IO) a

115+

107116data RequestBodyType = UrlEncoded | Multipart S.ByteString

108117

109118getRequestBodyType :: Request -> Maybe RequestBodyType

@@ -127,7 +136,7 @@ getRequestBodyType req = do

127136 else Nothing

128137 else Nothing

129138

130−parseRequestBody :: Sink S.ByteString (ResourceT IO) y

139+parseRequestBody :: BackEnd y

131140 -> Request

132141 -> ResourceT IO ([Param], [File y])

133142parseRequestBody s r =

@@ -135,12 +144,12 @@ parseRequestBody s r =

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

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

137146

138−sinkRequestBody :: Sink S.ByteString (ResourceT IO) y

147+sinkRequestBody :: BackEnd y

139148 -> RequestBodyType

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

141150sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume

142151

143−conduitRequestBody :: Sink S.ByteString (ResourceT IO) y

152+conduitRequestBody :: BackEnd y

144153 -> RequestBodyType

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

146155conduitRequestBody _ UrlEncoded = do

@@ -178,7 +187,7 @@ takeLines = do

178187 ls <- takeLines

179188 return $ l : ls

180189

181−parsePieces :: Sink S.ByteString (ResourceT IO) y

190+parsePieces :: BackEnd y

182191 -> S.ByteString

183192 -> Pipe S.ByteString S.ByteString (Either Param (File y)) u (ResourceT IO) ()

184193parsePieces sink bound =

@@ -198,10 +207,9 @@ parsePieces sink bound =

198207 case x of

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

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

201− (wasFound, y) <- sinkTillBound' bound sink

202− let fi = FileInfo filename ct y

203− let y' = (name, fi)

204− yield $ Right y'

210+ fi0 = FileInfo filename ct ()

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

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

205213 when wasFound loop

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

207215 let seed = id

@@ -253,9 +261,11 @@ findBound b bs = handleBreak $ Search.breakOn b bs

253261 | otherwise = True

254262

255263sinkTillBound' :: S.ByteString

256− -> Sink S.ByteString (ResourceT IO) y

264+ -> S.ByteString

265+ -> FileInfo ()

266+ -> BackEnd y

257267 -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, y)

258−sinkTillBound' bound sink = conduitTillBound bound >+> withUpstream (sinkToPipe sink)

268+sinkTillBound' bound name fi sink = conduitTillBound bound >+> withUpstream (sinkToPipe $ sink name fi)

259269

260270conduitTillBound :: Monad m

261271 => S.ByteString -- bound

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

@@ -102,7 +102,7 @@ caseParseHttpAccept = do

102102 expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]

103103 expected @=? parseHttpAccept input

104104

105−parseRequestBody' :: C.Sink S.ByteString (C.ResourceT IO) L.ByteString

105+parseRequestBody' :: BackEnd L.ByteString

106106 -> SRequest

107107 -> C.ResourceT IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])

108108parseRequestBody' sink (SRequest req bod) =

@@ -134,13 +134,13 @@ caseParseRequestBody =

134134 t = do

135135 let content1 = "foo=bar&baz=bin"

136136 let ctype1 = "application/x-www-form-urlencoded"

137− result1 <- parseRequestBody' lbsSink $ toRequest ctype1 content1

137+ result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1

138138 liftIO $ assertEqual "parsing post x-www-form-urlencoded"

139139 (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], [])

140140 result1

141141

142142 let ctype2 = "multipart/form-data; boundary=AaB03x"

143− result2 <- parseRequestBody' lbsSink $ toRequest ctype2 content2

143+ result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2

144144 let expectedsmap2 =

145145 [ ("title", "A File")

146146 , ("summary", "This is my file\nfile test")

@@ -155,7 +155,7 @@ caseParseRequestBody =

155155 result2

156156

157157 let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"

158− result3 <- parseRequestBody' lbsSink $ toRequest ctype3 content3

158+ result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3

159159 let expectedsmap3 = []

160160 let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $

161161 L8.pack "Photo blog using Hack.\n")]

@@ -164,19 +164,19 @@ caseParseRequestBody =

164164 expected3

165165 result3

166166

167− result2' <- parseRequestBody' lbsSink $ toRequest' ctype2 content2

167+ result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2

168168 liftIO $ assertEqual "parsing post multipart/form-data 2"

169169 expected2

170170 result2'

171171

172− result3' <- parseRequestBody' lbsSink $ toRequest' ctype3 content3

172+ result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3

173173 liftIO $ assertEqual "parsing actual post multipart/form-data 2"

174174 expected3

175175 result3'

176176

177177caseMultipartPlus :: Assertion

178178caseMultipartPlus = do

179− result <- C.runResourceT $ parseRequestBody' lbsSink $ toRequest ctype content

179+ result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content

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

181181 where

182182 content = S8.pack $

@@ -189,7 +189,7 @@ caseMultipartPlus = do

189189

190190caseUrlEncPlus :: Assertion

191191caseUrlEncPlus = do

192− result <- C.runResourceT $ parseRequestBody' lbsSink $ toRequest ctype content

192+ result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content

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

194194 where

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

@@ -458,7 +458,7 @@ caseDalvikMultipart = do

458458 case getRequestBodyType request' of

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

460460 Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request"

461− C.$$ sinkRequestBody lbsSink rbt

461+ C.$$ sinkRequestBody lbsBackEnd rbt

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

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

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

@@ -484,7 +484,7 @@ caseDebugRequestBody = do

484484 params = [("foo", "bar"), ("baz", "bin")]

485485 -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)

486486 postOutput = T.pack $ "POST /\nAccept: \nStatus: 200 OK. /\n"

487− getOutput params = T.pack $ "GET /location\nAccept: \nGET " ++ show params ++ "\nStatus: 200 OK. /location\n"

487+ getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"

488488

489489 debugApp output' req = do

490490 iactual <- liftIO $ I.newIORef []