Skip to content

Implement multipartI modifier #68

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
fluffynukeit wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Implement multipartI modifier #68

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
f1b1f43
Fix typos in haddock for Param dictionary
jcpetruzza Feb 9, 2015
e391b3d
Add multipartI modifier.
fluffynukeit Sep 21, 2014
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 6 additions & 0 deletions rest-core/src/Rest/Dictionary/Combinators.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ module Rest.Dictionary.Combinators
, xmlI
, rawXmlI
, jsonI
, multipartI

-- ** Output dictionaries

Expand Down Expand Up @@ -113,6 +114,11 @@ xmlTextI = L.set inputs (Dicts [XmlTextI])
fileI :: Dict h p Nothing o e -> Dict h p (Just ByteString) o e
fileI = L.set inputs (Dicts [FileI])

-- | Allow generic mixed input, represented as [BodyPart].

multipartI :: Dict h p i o e -> Dict h p [BodyPart] o e
multipartI = L.set inputs (Dicts [MultipartI])

-- | The input can be read into some instance of `Read`. For inspection reasons
-- the type must also be an instance of both `Info` and `Show`.

Expand Down
23 changes: 12 additions & 11 deletions rest-core/src/Rest/Dictionary/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -77,9 +77,9 @@ data Format
| JsonFormat
| StringFormat
| FileFormat
| MultipartFormat
| MultipartFormat String
| NoFormat
deriving (Eq, Ord, Enum, Bounded, Show)
deriving (Eq, Ord, Show)

-- | The explicit dictionary `Ident` describes how to translate a resource
-- identifier (originating from a request URI) to a Haskell value. We allow
Expand Down Expand Up @@ -112,8 +112,8 @@ instance Show (Header h) where
. showsPrec 10 k
)

-- | The explicit dictionary `Parameter` describes how to translate the request
-- parameters to some Haskell value. The first field in the `Header`
-- | The explicit dictionary `Param` describes how to translate the request
-- parameters to some Haskell value. The first field in the `Param`
-- constructor is a white list of paramters we can recognize, used in generic
-- validation and for generating documentation. The second field is a custom
-- parser that can fail with a `DataError` or can produce a some value. When
Expand All @@ -140,13 +140,14 @@ instance Show (Param p) where
-- needs of the backend resource.

data Input i where
JsonI :: (Typeable i, FromJSON i, JSONSchema i) => Input i
ReadI :: (Info i, Read i, Show i) => Input i
StringI :: Input String
FileI :: Input ByteString
XmlI :: (Typeable i, XmlPickler i) => Input i
XmlTextI :: Input Text
RawXmlI :: Input ByteString
JsonI :: (Typeable i, FromJSON i, JSONSchema i) => Input i
ReadI :: (Info i, Read i, Show i) => Input i
StringI :: Input String
FileI :: Input ByteString
MultipartI :: Input [BodyPart]
XmlI :: (Typeable i, XmlPickler i) => Input i
XmlTextI :: Input Text
RawXmlI :: Input ByteString

deriving instance Show (Input i)
deriving instance Eq (Input i)
Expand Down
102 changes: 54 additions & 48 deletions rest-core/src/Rest/Driver/Perform.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,7 @@ import Data.List.Split
import Data.Maybe
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.UUID (UUID)
import Network.Multipart (BodyPart (..), MultiPart (..), showMultipartBody)
import Network.Multipart (BodyPart (..), MultiPart (..), showMultipartBody, parseMultipartBody)
import Safe
import System.IO.Unsafe
import System.Random (randomIO)
Expand Down Expand Up @@ -160,30 +160,33 @@ fetchInputs dict =
None -> return ()
_ ->
case ct of
Just XmlFormat -> parser XmlFormat inputs bs
Just JsonFormat -> parser JsonFormat inputs bs
Just StringFormat -> parser StringFormat inputs bs
Just FileFormat -> parser FileFormat inputs bs
Just x -> throwError (UnsupportedFormat (show x))
Nothing | B.null bs -> parser NoFormat inputs bs
Nothing -> throwError (UnsupportedFormat "unknown")
Just XmlFormat -> parser XmlFormat inputs bs
Just JsonFormat -> parser JsonFormat inputs bs
Just StringFormat -> parser StringFormat inputs bs
Just FileFormat -> parser FileFormat inputs bs
Just (MultipartFormat k) -> parser (MultipartFormat k) inputs bs
Just x -> throwError (UnsupportedFormat (show x))
Nothing | B.null bs -> parser NoFormat inputs bs
Nothing -> throwError (UnsupportedFormat "unknown")
return (Env h p j)

parseContentType :: Rest m => m (Maybe Format)
parseContentType =
do ct <- fromMaybe "" <$> getHeader "Content-Type"
Copy link
Member

@hesselink hesselink Sep 30, 2014

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This part has the only real problem I saw. You no longer split on '/', but you still pattern match on "application" and "image", which is never going to work, since those cases previously matched any content type starting with "application/" or "image/", but now they only match those literal strings.

I think a good solution would be to use the content type header parser from the 'multipart' package (which we're already using for the multipart stuff). That will give an actual data type containing the type, subtype and parameters.

let segs = concat (take 1 . splitOn ";" <$> splitOn "," ct)
types = flip concatMap segs $ \ty ->
case splitOn "/" ty of
["application", "xml"] -> [XmlFormat]
["application", "json"] -> [JsonFormat]
["text", "xml"] -> [XmlFormat]
["text", "json"] -> [JsonFormat]
["text", "plain"] -> [StringFormat]
["application", "octet-stream"] -> [FileFormat]
["application", _ ] -> [FileFormat]
["image", _ ] -> [FileFormat]
_ -> []
let hdrGrp :: [[String]]
hdrGrp = filter (not . null) . splitOneOf ";= " <$> splitOn "," ct
types = flip concatMap hdrGrp $ \ty ->
case (ty :: [String]) of
"application/xml":_ -> [XmlFormat]
"application/json":_ -> [JsonFormat]
"text/xml":_ -> [XmlFormat]
"text/json":_ -> [JsonFormat]
"text/plain":_ -> [StringFormat]
"application/octet-stream":_ -> [FileFormat]
"application": _ -> [FileFormat]
"image":_ -> [FileFormat]
"multipart/mixed":"boundary":bnd:_ -> [MultipartFormat bnd]
_ -> []
return (headMay types)

headers :: Rest m => Header h -> ErrorT DataError m h
Expand All @@ -201,6 +204,7 @@ parser NoFormat None _ = return ()
parser f None _ = throwError (UnsupportedFormat (show f))
parser f (Dicts ds) v = parserD f ds
where
unMultipart (Multipart bps) = bps
parserD :: Monad m => Format -> [D.Input j] -> ErrorT DataError m j
parserD XmlFormat (XmlI : _ ) = case eitherFromXML (UTF8.toString v) of
Left err -> throwError (ParseError err)
Expand All @@ -212,6 +216,7 @@ parser f (Dicts ds) v = parserD f ds
Left e -> throwError (ParseError e)
parserD StringFormat (StringI : _ ) = return (UTF8.toString v)
parserD FileFormat (FileI : _ ) = return v
parserD (MultipartFormat bnd) (MultipartI:_) = return (unMultipart $ parseMultipartBody bnd v)
parserD XmlFormat (RawXmlI : _ ) = return v
parserD t [] = throwError (UnsupportedFormat (show t))
parserD t (_ : xs) = parserD t xs
Expand Down Expand Up @@ -252,12 +257,12 @@ failureWriter es err =

formatCT v =
case v of
XmlFormat -> "xml"
JsonFormat -> "json"
StringFormat -> "text/plain"
FileFormat -> "application/octet-stream"
MultipartFormat -> "multipart/mixed"
NoFormat -> "any"
XmlFormat -> "xml"
JsonFormat -> "json"
StringFormat -> "text/plain"
FileFormat -> "application/octet-stream"
(MultipartFormat _) -> "multipart/mixed"
NoFormat -> "any"

fromMaybeT def = runMaybeT >=> maybe def return

Expand All @@ -277,11 +282,11 @@ validator outputs = lift accept >>= \formats -> OutputError `mapE`

where
try :: Outputs v -> Format -> ErrorT DataError m ()
try None NoFormat = return ()
try None XmlFormat = return ()
try None JsonFormat = return ()
try None StringFormat = return ()
try None MultipartFormat = return ()
try None NoFormat = return ()
try None XmlFormat = return ()
try None JsonFormat = return ()
try None StringFormat = return ()
try None (MultipartFormat _ ) = return ()
try None FileFormat = throwError (UnsupportedFormat (show FileFormat))
try (Dicts ds) f = tryD ds f
where
Expand All @@ -301,20 +306,20 @@ outputWriter outputs v = lift accept >>= \formats -> OutputError `mapE`

where
try :: Outputs v -> Format -> ErrorT DataError m UTF8.ByteString
try None NoFormat = contentType NoFormat >> ok ""
try None XmlFormat = contentType NoFormat >> ok "<done/>"
try None JsonFormat = contentType NoFormat >> ok "{}"
try None StringFormat = contentType NoFormat >> ok "done"
try None FileFormat = throwError (UnsupportedFormat (show FileFormat))
try None MultipartFormat = contentType NoFormat >> ok ""
try None NoFormat = contentType NoFormat >> ok ""
try None XmlFormat = contentType NoFormat >> ok "<done/>"
try None JsonFormat = contentType NoFormat >> ok "{}"
try None StringFormat = contentType NoFormat >> ok "done"
try None FileFormat = throwError (UnsupportedFormat (show FileFormat))
try None (MultipartFormat _) = contentType NoFormat >> ok ""
try (Dicts ds) f = tryD ds f
where
tryD :: forall v'. FromMaybe () v ~ v' => [Output v'] -> Format -> ErrorT DataError m UTF8.ByteString
tryD (XmlO : _ ) XmlFormat = contentType XmlFormat >> ok (UTF8.fromString (toXML v))
tryD (RawXmlO : _ ) XmlFormat = contentType XmlFormat >> ok v
tryD (JsonO : _ ) JsonFormat = contentType JsonFormat >> ok (encode v)
tryD (StringO : _ ) StringFormat = contentType StringFormat >> ok (UTF8.fromString v)
tryD (MultipartO : _ ) _ = outputMultipart v
tryD (XmlO : _ ) XmlFormat = contentType XmlFormat >> ok (UTF8.fromString (toXML v))
tryD (RawXmlO : _ ) XmlFormat = contentType XmlFormat >> ok v
tryD (JsonO : _ ) JsonFormat = contentType JsonFormat >> ok (encode v)
tryD (StringO : _ ) StringFormat = contentType StringFormat >> ok (UTF8.fromString v)
tryD (MultipartO : _ ) (MultipartFormat bnd) = outputMultipart bnd v
tryD (FileO : _ ) FileFormat =
do let ext = (reverse . takeWhile (/='.') . reverse) $ snd v
mime <- fromMaybe "application/octet-stream" <$> lookupMimeType (map toLower ext)
Expand All @@ -328,11 +333,10 @@ outputWriter outputs v = lift accept >>= \formats -> OutputError `mapE`
escapeQuotes :: String -> String
escapeQuotes = intercalate "\\\"" . splitOn "\""

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

accept :: Rest m => m [Format]
accept =
Expand All @@ -348,7 +352,9 @@ accept =
return (fromQuery ++ fromAccept)

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

match ct ty =
Expand Down