diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ------ diff --git a/servant-multipart-client.cabal b/servant-multipart-client.cabal --- a/servant-multipart-client.cabal +++ b/servant-multipart-client.cabal @@ -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 diff --git a/src/Servant/Multipart/Client.hs b/src/Servant/Multipart/Client.hs --- a/src/Servant/Multipart/Client.hs +++ b/src/Servant/Multipart/Client.hs @@ -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] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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"