@@ -4,15 +4,24 @@ module Network.Wai.Parse
44 ( parseQueryString
55 , parseCookies
66 , parseHttpAccept
7+ , parseRequestBody
8+ , Sink (..)
9+ , lbsSink
10+ , tempFileSink
11+ , FileInfo (..)
712 ) where
813
914import qualified Data.ByteString as S
15+import qualified Data.ByteString.Lazy as L
1016import qualified Data.ByteString.Char8 as S8
1117import Data.Word (Word8)
1218import Data.Bits
1319import Data.Maybe (fromMaybe)
1420import Data.List (sortBy)
1521import Data.Function (on)
22+import System.Directory (removeFile, getTemporaryDirectory)
23+import System.IO (hClose, openBinaryTempFile, Handle)
24+import Network.Wai
1625
1726uncons :: S.ByteString -> Maybe (Word8, S.ByteString)
1827uncons s
@@ -84,7 +93,7 @@ parseHttpAccept :: S.ByteString -> [S.ByteString]
8493parseHttpAccept = map fst
8594 . sortBy (rcompare `on` snd)
8695 . map grabQ
87− . split
96+ . S.split 44 -- comma
8897 where
8998 rcompare x y = compare y x
9099 grabQ s =
@@ -95,7 +104,153 @@ parseHttpAccept = map fst
95104 (x, _):_ -> x
96105 _ -> 1.0
97106 trimWhite = S.dropWhile (== 32) -- space
98− split s
99− | S.null s = []
100− | otherwise = let (x, y) = breakDiscard 44 s -- comma
101− in x : split y
107+
108+-- | A destination for data, the opposite of a 'Source'.
109+data Sink x y = Sink
110+ { sinkInit :: IO x
111+ , sinkAppend :: x -> S.ByteString -> IO x
112+ , sinkClose :: x -> IO y
113+ , sinkFinalize :: y -> IO ()
114+ }
115+
116+lbsSink :: Sink ([S.ByteString] -> [S.ByteString]) L.ByteString
117+lbsSink = Sink
118+ { sinkInit = return id
119+ , sinkAppend = \front bs -> return $ front . (:) bs
120+ , sinkClose = \front -> return $ L.fromChunks $ front []
121+ , sinkFinalize = \_ -> return ()
122+ }
123+
124+tempFileSink :: Sink (FilePath, Handle) FilePath
125+tempFileSink = Sink
126+ { sinkInit = do
127+ tempDir <- getTemporaryDirectory
128+ openBinaryTempFile tempDir "webenc.buf"
129+ , sinkAppend = \(fp, h) bs -> S.hPut h bs >> return (fp, h)
130+ , sinkClose = \(fp, h) -> do
131+ hClose h
132+ return fp
133+ , sinkFinalize = \fp -> removeFile fp
134+ }
135+
136+-- | Information on an uploaded file.
137+data FileInfo c = FileInfo
138+ { fileName :: S.ByteString
139+ , fileContentType :: S.ByteString
140+ , fileContent :: c
141+ }
142+ deriving (Eq, Show)
143+
144+type Param = (S.ByteString, S.ByteString)
145+type File y = (S.ByteString, FileInfo y)
146+
147+parseRequestBody :: Sink x y
148+ -> Request
149+ -> IO ([Param], [File y])
150+parseRequestBody sink req = do
151+ let ctype = do
152+ ctype' <- lookup ReqContentType $ requestHeaders req
153+ if urlenc `S.isPrefixOf` ctype'
154+ then Just Nothing
155+ else if formBound `S.isPrefixOf` ctype'
156+ then Just $ Just $ S.drop (S.length formBound) ctype'
157+ else Nothing
158+ case ctype of
159+ Nothing -> return ([], [])
160+ Just Nothing -> do -- url-encoded
161+ -- NOTE: in general, url-encoded data will be in a single chunk.
162+ -- Therefore, I'm optimizing for the usual case by sticking with
163+ -- strict byte strings here.
164+ bs <- sourceToBs $ requestBody req
165+ return (parseQueryString bs, [])
166+ Just (Just bound) -> -- multi-part
167+ parsePieces sink bound (S.empty, Just $ requestBody req) True
168+ where
169+ urlenc = S8.pack "application/x-www-form-urlencoded"
170+ formBound = S8.pack "multipart/form-data; boundary="
171+
172+sourceToBs :: Source -> IO S.ByteString
173+sourceToBs = fmap S.concat . go id
174+ where
175+ go front (Source src) = do
176+ res <- src
177+ case res of
178+ Nothing -> return $ front []
179+ Just (bs, src') -> go (front . (:) bs) src'
180+
181+type Source' = (S.ByteString, Maybe Source)
182+
183+takeLine :: Source' -> IO (Maybe (S.ByteString, Source'))
184+takeLine (s, msrc)
185+ | S.null s = case msrc of
186+ Nothing -> return Nothing
187+ Just (Source src) -> do
188+ res <- src
189+ case res of
190+ Nothing -> return Nothing
191+ Just (x, y) -> takeLine (x, Just y)
192+takeLine (s, msrc) =
193+ let (x, y) = S.break (== 10) s -- newline
194+ in if S.null y
195+ then do
196+ case msrc of
197+ Nothing -> return $ Just (x, (y, msrc))
198+ Just (Source src) -> do
199+ res <- src
200+ case res of
201+ Nothing -> return $ Just (x, (y, Nothing))
202+ Just (s', src') ->
203+ takeLine (s `S.append` s', Just src')
204+ else return $ Just (killCarriage x, (S.drop 1 y, msrc))
205+ where
206+ killCarriage bs
207+ | S.null bs = bs
208+ | S.last bs == 13 = S.init bs -- carriage return
209+ | otherwise = bs
210+
211+takeLines :: Source' -> IO (Maybe ([S.ByteString], Source'))
212+takeLines src = do
213+ res <- takeLine src
214+ case res of
215+ Nothing -> return Nothing
216+ Just (l, src') ->
217+ if S.null l
218+ then return $ Just ([], src')
219+ else do
220+ res' <- takeLines src'
221+ case res' of
222+ Nothing -> return $ Just ([l], src')
223+ Just (ls, src'') -> return $ Just (l : ls, src'')
224+
225+parsePieces :: Sink x y -> S.ByteString -> Source' -> Bool
226+ -> IO ([Param], [File y])
227+parsePieces sink bound src isFirst = do
228+ print ("bound", bound)
229+ src' <- if isFirst
230+ then do
231+ res <- takeLine src -- first line should be bound
232+ case res of
233+ Nothing -> return (S.empty, Nothing)
234+ Just (_, x) -> return x
235+ else return src
236+ res <- takeLines src'
237+ case res of
238+ Nothing -> return ([], [])
239+ Just (ls, src'') -> do
240+ let ls' = map parsePair ls
241+ case (lookup contDisp ls', lookup contType ls') of
242+ (Just cd, Just ct) -> do
243+ return ([], []) -- FIXME
244+ _ -> do
245+ (isEnd, src''') <- dropTillBound bound src''
246+ if isEnd
247+ then return ([], [])
248+ else parsePieces sink bound src''' False
249+ where
250+ contDisp = S8.pack "Content-Disposition"
251+ contType = S8.pack "Content-Type"
252+ parsePair s =
253+ let (x, y) = breakDiscard 58 s -- colon
254+ in (x, S.dropWhile (== 32) y) -- space
255+
256+dropTillBound bound (bs, msrc) = error "FIXME dropTillBound"