servant-multipart-client 0.12.2 → 0.13.0
raw patch · 4 files changed
+143/−63 lines, 4 filesdep +http-typesdep +tastydep +tasty-waidep ~arraydep ~basedep ~bytestringnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: http-types, tasty, tasty-wai, transformers
Dependency ranges changed: array, base, bytestring, http-client, http-media, network, random, servant, servant-client, servant-client-core, servant-multipart, servant-multipart-api, servant-server, text, warp
API changes (from Hackage documentation)
+ Servant.Multipart.Client: class MultipartClient tag
+ Servant.Multipart.Client: loadFile :: MultipartClient tag => Proxy tag -> MultipartResult tag -> SourceIO ByteString
- Servant.Multipart.Client: multipartToBody :: forall tag. MultipartClient tag => ByteString -> MultipartData tag -> RequestBody
+ Servant.Multipart.Client: multipartToBody :: MultipartClient tag => ByteString -> MultipartData tag -> RequestBody
Files
- CHANGELOG.md +11/−0
- servant-multipart-client.cabal +43/−35
- src/Servant/Multipart/Client.hs +24/−28
- test/Test.hs +65/−0
CHANGELOG.md view
@@ -1,3 +1,14 @@+0.13.0+------++- Export the `MultipartClient` class.+- Escape double quotes and backslashes in input names, file input names and+ file names, percent-encode carriage returns and line feeds in them, and+ strip carriage returns and line feeds from file content types, so that+ they cannot corrupt or inject part headers.+- Require GHC >= 9.4 and servant >= 0.20.3; support up to GHC 9.12+ [#81](https://github.com/haskell-servant/servant-multipart/pull/81).+ 0.12.2 ------
servant-multipart-client.cabal view
@@ -1,5 +1,5 @@ name: servant-multipart-client-version: 0.12.2+version: 0.13.0 synopsis: multipart/form-data (e.g file upload) support for servant description: This package adds client-side support for file upload to the servant ecosystem.@@ -15,12 +15,11 @@ cabal-version: >=1.10 extra-source-files: CHANGELOG.md tested-with:- GHC ==8.6.5- || ==8.8.4- || ==8.10.7- || ==9.0.2- || ==9.2.8- || ==9.4.7+ GHC ==9.4.8+ || ==9.6.3+ || ==9.8.4+ || ==9.10.3+ || ==9.12.4 library default-language: Haskell2010@@ -29,25 +28,37 @@ -- ghc boot libs build-depends:- array >=0.5.1.1 && <0.6- , base >=4.9 && <5- , bytestring >=0.10.8.1 && <0.12- , text >=1.2.3.0 && <2.1- , random >=0.1.1 && <1.3+ array >=0.5.4.0 && <0.6+ , base >=4.17 && <5+ , bytestring >=0.11 && <0.13+ , text >=2.0 && <2.2+ , random >=1.2 && <1.4 -- other dependencies build-depends:- servant-multipart-api == 0.12.*- , http-media >=0.7.1.3 && <0.9- , servant >=0.16 && <0.21- , servant-client-core >=0.16 && <0.21+ servant-multipart-api == 0.13.*+ , http-media >=0.8 && <0.9+ , servant >=0.20.3 && <0.21+ , servant-client-core >=0.20.3 && <0.21 - -- servant-0.19 dropped support for GHC-8.4 (latest GHCJS version),- -- due to QuantifiedConstraints- if impl(ghcjs)- build-depends:- servant >=0.16 && <0.19- , servant-client-core >=0.16 && <0.19+test-suite servant-multipart-client-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Test.hs+ default-language: Haskell2010+ build-depends:+ base+ , bytestring+ , http-types+ , servant+ , servant-client-core+ , servant-multipart+ , servant-multipart-client+ , servant-server+ , tasty+ , tasty-wai+ , text+ , transformers executable upload hs-source-dirs: exe@@ -55,12 +66,12 @@ default-language: Haskell2010 build-depends: base- , http-client- , network >=2.8 && <3.2+ , http-client <0.8+ , network >=3.2 && <3.3 , servant- , servant-multipart-api+ , servant-multipart-api == 0.13.* , servant-multipart-client- , servant-client+ , servant-client <0.21 , servant-client-core executable server@@ -68,12 +79,9 @@ main-is: Server.hs default-language: Haskell2010 build-depends:- base- , bytestring- , network >=2.8 && <3.2- , servant-multipart- , servant-server- , warp-- if impl(ghcjs)- buildable: False+ base <5+ , bytestring <0.13+ , network >=3.2 && <3.3+ , servant-multipart == 0.13.*+ , servant-server <0.21+ , warp <3.5
src/Servant/Multipart/Client.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}@@ -20,27 +19,25 @@ ( genBoundary , ToMultipart(..) , multipartToBody+ , MultipartClient(..) ) where import Servant.Multipart.API import Control.Monad (replicateM) import Data.Array (listArray, (!))-import Data.List (foldl')-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif import Data.Text.Encoding (encodeUtf8) import Data.Typeable import Network.HTTP.Media.MediaType ((//), (/:)) import Servant.API import Servant.Client.Core (HasClient (..), RequestBody (RequestBodySource), setRequestBody)-import Servant.Types.SourceT (SourceT (..), StepT (..), fromActionStep, source)+import Servant.Types.SourceT (SourceT (..), fromActionStep, source) import System.IO (IOMode (ReadMode), withFile) import System.Random (getStdRandom, randomR) import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T -- | Upon seeing @MultipartForm a :> ...@ in an API type, -- servant-client will take a parameter of type @(LBS.ByteString, a)@,@@ -108,40 +105,39 @@ -- | Given a bytestring for the boundary, turns a `MultipartData` into -- a 'RequestBody'+--+-- Input names, file input names and file names are written as quoted+-- strings: double quotes and backslashes are escaped with a backslash, and+-- carriage returns and line feeds are percent-encoded as @%0D@ and @%0A@,+-- as browsers do. Carriage returns and line feeds are stripped from file+-- content types. multipartToBody :: forall tag . MultipartClient tag => LBS.ByteString -> MultipartData tag -> RequestBody-multipartToBody boundary mp = RequestBodySource $ files' <> source ["--", boundary, "--"]+multipartToBody boundary mp = RequestBodySource $+ foldMap renderInput (inputs mp) <> foldMap renderFile (files mp) <> source ["--", boundary, "--"] where- -- at time of writing no Semigroup or Monoid instance exists for SourceT and StepT- -- in releases of Servant; they are in master though- (SourceT l) `mappend'` (SourceT r) = SourceT $ \k ->- l $ \lstep ->- r $ \rstep ->- k (appendStep lstep rstep)- appendStep Stop r = r- appendStep (Error err) _ = Error err- appendStep (Skip s) r = appendStep s r- appendStep (Yield x s) r = Yield x (appendStep s r)- appendStep (Effect ms) r = Effect $ (flip appendStep r <$> ms)- mempty' = SourceT ($ Stop) crlf = "\r\n" lencode = LBS.fromStrict . encodeUtf8- renderInput input = renderPart (lencode . iName $ input)+ quotedValue = lencode . T.concatMap escapeQuoted+ escapeQuoted c = case c of+ '"' -> "\\\""+ '\\' -> "\\\\"+ '\r' -> "%0D"+ '\n' -> "%0A"+ _ -> T.singleton c+ headerValue = lencode . T.filter (`notElem` ['\r', '\n'])+ renderInput input = renderPart (quotedValue . iName $ input) "text/plain" "" (source . pure @[] . lencode . iValue $ input)- inputs' = foldl' (\acc x -> acc `mappend'` renderInput x) mempty' (inputs mp) renderFile :: FileData tag -> SourceIO LBS.ByteString- renderFile file = renderPart (lencode . fdInputName $ file)- (lencode . fdFileCType $ file)- ((flip mappend) "\"" . mappend "; filename=\""- . lencode- . fdFileName $ file)+ renderFile file = renderPart (quotedValue . fdInputName $ file)+ (headerValue . fdFileCType $ file)+ ("; filename=\"" <> quotedValue (fdFileName file) <> "\"") (loadFile (Proxy @tag) . fdPayload $ file)- files' = foldl' (\acc x -> acc `mappend'` renderFile x) inputs' (files mp) renderPart name contentType extraParams payload = source [ "--" , boundary@@ -155,4 +151,4 @@ , contentType , crlf , crlf- ] `mappend'` payload `mappend'` source [crlf]+ ] <> payload <> source [crlf]
+ test/Test.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++import Control.Monad.Trans.Except (runExceptT)+import Control.Monad.IO.Class (liftIO)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Types.Header (hContentType)+import Servant+import Servant.Client.Core (RequestBody (RequestBodySource))+import Servant.Multipart+import Servant.Multipart.Client+import Servant.Types.SourceT (runSourceT)+import Test.Tasty+import Test.Tasty.Wai++import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T++main :: IO ()+main = defaultMain $ testGroup "servant-multipart-client"+ [ testGroup "part header values round-trip to the server"+ [ roundTrip "plain names" "name" "file" "f.txt" "name" "file" "f.txt"+ , roundTrip "double quotes" "a\"b" "c\"d" "e\"f.txt" "a\"b" "c\"d" "e\"f.txt"+ , roundTrip "backslashes" "x\\" "y\\" "C:\\Users\\a\\f.txt" "x\\" "y\\" "C:\\Users\\a\\f.txt"+ , roundTrip "injected header" "a\"\r\nX: y" "b" "c.txt" "a\"%0D%0AX: y" "b" "c.txt"+ , roundTrip "carriage returns and line feeds" "a\rb" "c\nd" "e\r\nf.txt" "a%0Db" "c%0Ad" "e%0D%0Af.txt"+ ]+ ]++type EchoAPI = "echo" :> MultipartForm Mem (MultipartData Mem) :> Post '[PlainText] Text++echoApp :: Application+echoApp = serve @EchoAPI Proxy $ \md -> return . T.pack . show $ formNames md++formNames :: MultipartData tag -> ([(Text, Text)], [(Text, Text, Text)])+formNames md =+ ( map (\i -> (iName i, iValue i)) (inputs md)+ , map (\f -> (fdInputName f, fdFileName f, fdFileCType f)) (files md)+ )++roundTrip :: TestName -> Text -> Text -> Text -> Text -> Text -> Text -> TestTree+roundTrip name inputName fileInputName fileName expectedInputName expectedFileInputName expectedFileName =+ testWai echoApp name $ do+ let form = MultipartData+ [Input inputName "value"]+ [FileData fileInputName fileName "text/plain" "contents"]+ expected = MultipartData @Mem+ [Input expectedInputName "value"]+ [FileData expectedFileInputName expectedFileName "text/plain" "contents"]+ body <- liftIO $ renderBody "XX" form+ res <- srequest $ buildRequestWithHeaders POST "/echo" body+ [(hContentType, "multipart/form-data; boundary=XX")]+ assertStatus 200 res+ assertBody (LBS.fromStrict . encodeUtf8 . T.pack . show $ formNames expected) res++renderBody :: LBS.ByteString -> MultipartData Mem -> IO LBS.ByteString+renderBody boundary form =+ case multipartToBody boundary form of+ RequestBodySource src -> do+ chunks <- runExceptT (runSourceT src)+ either fail (return . LBS.concat) chunks+ _ -> fail "multipartToBody did not produce a streaming body"