Skip to content

Commit 899127c

Browse files
fluffynukeitfluffynukeit
committed
Add multipartI modifier.
1 parent 33f4990 commit 899127c

File tree

3 files changed

+48
-36
lines changed

3 files changed

+48
-36
lines changed

‎rest-core/src/Rest/Dictionary/Combinators.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Rest.Dictionary.Combinators
1212
, xmlI
1313
, rawXmlI
1414
, jsonI
15+
, multipartI
1516

1617
-- ** Output dictionaries
1718

@@ -103,6 +104,11 @@ xmlTextI = L.set inputs (Dicts [XmlTextI])
103104
fileI :: Dict h p i o e -> Dict h p ByteString o e
104105
fileI = L.set inputs (Dicts [FileI])
105106

107+
-- | Allow generic mixed input, represented as [BodyPart].
108+
109+
multipartI :: Dict h p i o e -> Dict h p [BodyPart] o e
110+
multipartI = L.set inputs (Dicts [MultipartI])
111+
106112
-- | The input can be read into some instance of `Read`. For inspection reasons
107113
-- the type must also be an instance of both `Info` and `Show`.
108114

‎rest-core/src/Rest/Dictionary/Types.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -65,9 +65,9 @@ data Format
6565
| JsonFormat
6666
| StringFormat
6767
| FileFormat
68-
| MultipartFormat
68+
| MultipartFormat String
6969
| NoFormat
70-
deriving (Eq, Ord, Enum, Bounded, Show)
70+
deriving (Eq, Ord, Show)
7171

7272
-- | The explicit dictionary `Ident` describes how to translate a resource
7373
-- identifier (originating from a request URI) to a Haskell value. We allow
@@ -132,6 +132,7 @@ data Input i where
132132
ReadI :: (Info i, Read i, Show i) => Input i
133133
StringI :: Input String
134134
FileI :: Input ByteString
135+
MultipartI :: Input [BodyPart]
135136
XmlI :: (Typeable i, XmlPickler i) => Input i
136137
XmlTextI :: Input Text
137138
RawXmlI :: Input ByteString

‎rest-core/src/Rest/Driver/Perform.hs‎

Lines changed: 39 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ import Data.List.Split
2323
import Data.Maybe
2424
import Data.Text.Lazy.Encoding (decodeUtf8)
2525
import Data.UUID (UUID)
26-
import Network.Multipart (BodyPart (..), MultiPart (..), showMultipartBody)
26+
import Network.Multipart (BodyPart (..), MultiPart (..), showMultipartBody, parseMultipartBody)
2727
import Safe
2828
import System.IO.Unsafe
2929
import System.Random (randomIO)
@@ -159,30 +159,33 @@ fetchInputs dict =
159159
None -> return ()
160160
_ ->
161161
case ct of
162-
Just XmlFormat -> parser XmlFormat inputs bs
163-
Just JsonFormat -> parser JsonFormat inputs bs
164-
Just StringFormat -> parser StringFormat inputs bs
165-
Just FileFormat -> parser FileFormat inputs bs
166-
Just x -> throwError (UnsupportedFormat (show x))
167-
Nothing | B.null bs -> parser NoFormat inputs bs
168-
Nothing -> throwError (UnsupportedFormat "unknown")
162+
Just XmlFormat -> parser XmlFormat inputs bs
163+
Just JsonFormat -> parser JsonFormat inputs bs
164+
Just StringFormat -> parser StringFormat inputs bs
165+
Just FileFormat -> parser FileFormat inputs bs
166+
Just (MultipartFormat k)-> parser (MultipartFormat k) inputs bs
167+
Just x -> throwError (UnsupportedFormat (show x))
168+
Nothing | B.null bs -> parser NoFormat inputs bs
169+
Nothing -> throwError (UnsupportedFormat "unknown")
169170
return (Env h p j)
170171

171172
parseContentType :: Rest m => m (Maybe Format)
172173
parseContentType =
173174
do ct <- fromMaybe "" <$> getHeader "Content-Type"
174-
let segs = concat (take 1 . splitOn ";" <$> splitOn "," ct)
175-
types = flip concatMap segs $ \ty ->
176-
case splitOn "/" ty of
177-
["application", "xml"] -> [XmlFormat]
178-
["application", "json"] -> [JsonFormat]
179-
["text", "xml"] -> [XmlFormat]
180-
["text", "json"] -> [JsonFormat]
181-
["text", "plain"] -> [StringFormat]
182-
["application", "octet-stream"] -> [FileFormat]
183-
["application", _ ] -> [FileFormat]
184-
["image", _ ] -> [FileFormat]
185-
_ -> []
175+
let hdrGrp :: [[String]]
176+
hdrGrp = filter (not . null) . splitOneOf ";= " <$> splitOn "," ct
177+
types = flip concatMap hdrGrp $ \ty ->
178+
case (ty :: [String]) of
179+
"application/xml":_ -> [XmlFormat]
180+
"application/json":_ -> [JsonFormat]
181+
"text/xml":_ -> [XmlFormat]
182+
"text/json":_ -> [JsonFormat]
183+
"text/plain":_ -> [StringFormat]
184+
"application/octet-stream":_ -> [FileFormat]
185+
"application": _ -> [FileFormat]
186+
"image":_ -> [FileFormat]
187+
"multipart/mixed":"boundary":bnd:_ -> [MultipartFormat bnd]
188+
_ -> []
186189
return (headMay types)
187190

188191
headers :: Rest m => Header h -> ErrorT DataError m h
@@ -211,6 +214,7 @@ parser f (Dicts ds) v = parserD f ds
211214
Left e -> throwError (ParseError e)
212215
parserD StringFormat (StringI : _ ) = return (UTF8.toString v)
213216
parserD FileFormat (FileI : _ ) = return v
217+
parserD (MultipartFormat bnd) (MultipartI:_) = return (flip ($) (parseMultipartBody bnd v) $ \(MultiPart bps) -> bps)
214218
parserD XmlFormat (RawXmlI : _ ) = return v
215219
parserD t [] = throwError (UnsupportedFormat (show t))
216220
parserD t (_ : xs) = parserD t xs
@@ -254,7 +258,7 @@ failureWriter es err =
254258
JsonFormat -> "json"
255259
StringFormat -> "text/plain"
256260
FileFormat -> "application/octet-stream"
257-
MultipartFormat -> "multipart/mixed"
261+
(MultipartFormat _) -> "multipart/mixed"
258262
NoFormat -> "any"
259263

260264
fromMaybeT def = runMaybeT >=> maybe def return
@@ -275,11 +279,11 @@ validator outputs = lift accept >>= \formats -> OutputError `mapE`
275279

276280
where
277281
try :: Outputs v -> Format -> ErrorT DataError m ()
278-
try None NoFormat = return ()
279-
try None XmlFormat = return ()
280-
try None JsonFormat = return ()
281-
try None StringFormat = return ()
282-
try None MultipartFormat = return ()
282+
try None NoFormat = return ()
283+
try None XmlFormat = return ()
284+
try None JsonFormat = return ()
285+
try None StringFormat = return ()
286+
try None (MultipartFormat _ ) = return ()
283287
try None FileFormat = throwError (UnsupportedFormat (show FileFormat))
284288
try (Dicts ds) f = tryD ds f
285289
where
@@ -303,14 +307,14 @@ outputWriter outputs v = lift accept >>= \formats -> OutputError `mapE`
303307
try None JsonFormat = contentType NoFormat >> ok "{}"
304308
try None StringFormat = contentType NoFormat >> ok "done"
305309
try None FileFormat = throwError (UnsupportedFormat (show FileFormat))
306-
try None MultipartFormat = contentType NoFormat >> ok ""
310+
try None (MultipartFormat _) = contentType NoFormat >> ok ""
307311
try (Dicts ds) f = tryD ds f
308312
where
309313
tryD (XmlO : _ ) XmlFormat = contentType XmlFormat >> ok (UTF8.fromString (toXML v))
310314
tryD (RawXmlO : _ ) XmlFormat = contentType XmlFormat >> ok v
311315
tryD (JsonO : _ ) JsonFormat = contentType JsonFormat >> ok (encode v)
312316
tryD (StringO : _ ) StringFormat = contentType StringFormat >> ok (UTF8.fromString v)
313-
tryD (MultipartO : _ ) _ = outputMultipart v
317+
tryD (MultipartO : _ ) (MultipartFormat bnd) = outputMultipart bnd v
314318
tryD (FileO : _ ) FileFormat =
315319
do let ext = (reverse . takeWhile (/='.') . reverse) $ snd v
316320
mime <- fromMaybe "application/octet-stream" <$> lookupMimeType (map toLower ext)
@@ -324,11 +328,10 @@ outputWriter outputs v = lift accept >>= \formats -> OutputError `mapE`
324328
escapeQuotes :: String -> String
325329
escapeQuotes = intercalate "\\\"" . splitOn "\""
326330

327-
outputMultipart :: Rest m => [BodyPart] -> m UTF8.ByteString
328-
outputMultipart vs =
329-
do let boundary = show $ unsafePerformIO (randomIO :: IO UUID)
330-
setHeader "Content-Type" ("multipart/mixed; boundary=" ++ boundary)
331-
return $ showMultipartBody boundary (MultiPart vs)
331+
outputMultipart :: Rest m => String -> [BodyPart] -> m UTF8.ByteString
332+
outputMultipart bnd vs =
333+
do setHeader "Content-Type" ("multipart/mixed; boundary=" ++ bnd)
334+
return $ showMultipartBody bnd (MultiPart vs)
332335

333336
accept :: Rest m => m [Format]
334337
accept =
@@ -344,7 +347,9 @@ accept =
344347
return (fromQuery ++ fromAccept)
345348

346349
where
347-
allFormats ct = (maybe id (:) ct) [minBound .. maxBound]
350+
bnd = show $ unsafePerformIO (randomIO :: IO UUID)
351+
formatList = [XmlFormat,JsonFormat,StringFormat,MultipartFormat bnd, NoFormat]
352+
allFormats ct = (maybe id (:) ct) formatList
348353
splitter ct hdr = nub (match ct =<< takeWhile (/= ';') . trim <$> splitOn "," hdr)
349354

350355
match ct ty =

0 commit comments

Comments
 (0)