From f1b1f439e112d7ec3c570293298080e781b96907 Mon Sep 17 00:00:00 2001 From: Daniel Gorin Date: Mon, 9 Feb 2015 11:00:23 +0000 Subject: [PATCH 1/2] Fix typos in haddock for Param dictionary --- rest-core/src/Rest/Dictionary/Types.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/rest-core/src/Rest/Dictionary/Types.hs b/rest-core/src/Rest/Dictionary/Types.hs index e94a15a..3f71f55 100644 --- a/rest-core/src/Rest/Dictionary/Types.hs +++ b/rest-core/src/Rest/Dictionary/Types.hs @@ -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 From e391b3d65319e4a24b978b82bc36b734db9bc7f9 Mon Sep 17 00:00:00 2001 From: Daniel Austin Date: Sun, 21 Sep 2014 03:26:13 +0200 Subject: [PATCH 2/2] Add multipartI modifier. Formatting updates requested by @hesselink --- rest-core/src/Rest/Dictionary/Combinators.hs | 6 ++ rest-core/src/Rest/Dictionary/Types.hs | 19 ++-- rest-core/src/Rest/Driver/Perform.hs | 102 ++++++++++--------- 3 files changed, 70 insertions(+), 57 deletions(-) diff --git a/rest-core/src/Rest/Dictionary/Combinators.hs b/rest-core/src/Rest/Dictionary/Combinators.hs index 04005c9..35d91f4 100644 --- a/rest-core/src/Rest/Dictionary/Combinators.hs +++ b/rest-core/src/Rest/Dictionary/Combinators.hs @@ -17,6 +17,7 @@ module Rest.Dictionary.Combinators , xmlI , rawXmlI , jsonI + , multipartI -- ** Output dictionaries @@ -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`. diff --git a/rest-core/src/Rest/Dictionary/Types.hs b/rest-core/src/Rest/Dictionary/Types.hs index 3f71f55..af01d96 100644 --- a/rest-core/src/Rest/Dictionary/Types.hs +++ b/rest-core/src/Rest/Dictionary/Types.hs @@ -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 @@ -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) diff --git a/rest-core/src/Rest/Driver/Perform.hs b/rest-core/src/Rest/Driver/Perform.hs index 14bf3b4..c5a0cc7 100644 --- a/rest-core/src/Rest/Driver/Perform.hs +++ b/rest-core/src/Rest/Driver/Perform.hs @@ -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) @@ -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" - 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 @@ -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) @@ -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 @@ -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 @@ -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 @@ -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 "" - 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 "" + 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) @@ -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 = @@ -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 =