servant-multipart 0.11.4 → 0.11.5

raw patch · 4 files changed

+195/−25 lines, 4 filesdep +arraydep +randomdep +servant-clientdep ~servantdep ~servant-serverPVP ok

version bump matches the API change (PVP)

Dependencies added: array, random, servant-client, servant-client-core

Dependency ranges changed: servant, servant-server

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• exe/Upload.hs +25/−10
• servant-multipart.cabal +18/−13
• src/Servant/Multipart.hs +146/−2

@@ -1,3 +1,9 @@+0.11.5+------++- Add `servant-client` support +- Support servant-0.17+ 0.11.4 ------ 

@@ -1,19 +1,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}  import Control.Concurrent import Control.Monad import Control.Monad.IO.Class-import Data.Text.Encoding (encodeUtf8) import Network.Socket (withSocketsDo) import Network.HTTP.Client hiding (Proxy)-import Network.HTTP.Client.MultipartFormData import Network.Wai import Network.Wai.Handler.Warp import Servant import Servant.Multipart import System.Environment (getArgs)+import Servant.Client (client, runClientM, mkClientEnv)+import Servant.Client.Core (BaseUrl(BaseUrl), Scheme(Http))  import qualified Data.ByteString.Lazy as LBS @@ -22,9 +23,20 @@ -- pretty-prints the data it got to stdout before returning 0. type API = MultipartForm Mem (MultipartData Mem) :> Post '[JSON] Integer +-- We want to load our file from disk, so we need to convert+-- the 'Mem's in the serverside API to 'Tmp's+type family MemToTmp api where+  MemToTmp (a :<|> b) = MemToTmp a :<|> MemToTmp b+  MemToTmp (a :> b) = MemToTmp a :> MemToTmp b+  MemToTmp (MultipartForm Mem (MultipartData Mem)) = MultipartForm Tmp (MultipartData Tmp)+  MemToTmp a = a+ api :: Proxy API api = Proxy +clientApi :: Proxy (MemToTmp API)+clientApi = Proxy+ -- The handler for our single endpoint. -- Its concrete type is: --   MultipartData -> Handler Integer@@ -58,14 +70,17 @@       -- we fork the server in a separate thread and send a test       -- request to it from the main thread.       manager <- newManager defaultManagerSettings-      req <- parseRequest "http://localhost:8080/"-      resp <- flip httpLbs manager =<< formDataBody form req+      boundary <- genBoundary+      let burl = BaseUrl Http "localhost" 8080 ""+          run cli = runClientM cli (mkClientEnv manager burl)+      resp <- run $ client clientApi (boundary, form)       print resp     _ -> putStrLn "Pass run to run" -  where form =-          [ partBS "title" "World"-          , partBS "text" $ encodeUtf8 "Hello"-          , partFileSource "file" "./servant-multipart.cabal"-          , partFileSource "otherfile" "./Setup.hs"-          ]+  where form = MultipartData [ Input "title" "World"+                             , Input "text" "Hello"+                             ]+                             [ FileData "file" "./servant-multipart.cabal"+                                        "text/plain" "./servant-multipart.cabal"+                             , FileData "otherfile" "./Setup.hs" "text/plain" "./Setup.hs"+                             ]

@@ -1,5 +1,5 @@ name:               servant-multipart-version:            0.11.4+version:            0.11.5 synopsis:           multipart/form-data (e.g file upload) support for servant description:   This package adds support for file upload to the servant ecosystem. It draws@@ -17,7 +17,7 @@ build-type:         Simple cabal-version:      >=1.10 extra-source-files: CHANGELOG.md-tested-with:        GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.3+tested-with:        GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1  library   default-language: Haskell2010@@ -26,23 +26,26 @@    -- ghc boot libs   build-depends:-      base          >=4.9      && <5+      array         >=0.5.1.1  && <0.6+    , base          >=4.9      && <5     , bytestring    >=0.10.8.1 && <0.11     , directory     >=1.3      && <1.4     , text          >=1.2.3.0  && <1.3     , transformers  >=0.5.2.0  && <0.6+    , random        >=0.1.1    && <1.2    -- other dependencies   build-depends:-      http-media       >=0.7.1.3  && <0.8-    , lens             >=4.17     && <4.18-    , resourcet        >=1.2.2    && <1.3-    , servant          >=0.15     && <0.17-    , servant-docs     >=0.10     && <0.15-    , servant-foreign  >=0.15     && <0.16-    , servant-server   >=0.15     && <0.17-    , wai              >=3.2.1.2  && <3.3-    , wai-extra        >=3.0.24.3 && <3.1+      http-media          >=0.7.1.3  && <0.9+    , lens                >=4.17     && <4.19+    , resourcet           >=1.2.2    && <1.3+    , servant             >=0.16     && <0.18+    , servant-client-core >=0.16     && <0.18+    , servant-docs        >=0.10     && <0.15+    , servant-foreign     >=0.15     && <0.16+    , servant-server      >=0.16     && <0.18+    , wai                 >=3.2.1.2  && <3.3+    , wai-extra           >=3.0.24.3 && <3.1  test-suite upload   type:             exitcode-stdio-1.0@@ -53,10 +56,12 @@       base     , bytestring     , http-client-    , network            >=2.8 && <3.1+    , network            >=2.8 && <3.2     , servant     , servant-multipart     , servant-server+    , servant-client+    , servant-client-core     , text     , transformers     , wai

@@ -32,27 +32,38 @@   , defaultTmpBackendOptions   , Input(..)   , FileData(..)+  -- * servant-client+  , genBoundary+  , ToMultipart(..)+  , multipartToBody   -- * servant-docs   , ToMultipartSample(..)   ) where  import Control.Lens ((<>~), (&), view, (.~))+import Control.Monad (replicateM) import Control.Monad.IO.Class import Control.Monad.Trans.Resource-import Data.Foldable (foldMap)+import Data.Array (listArray, (!))+import Data.Foldable (foldMap, foldl') import Data.List (find) import Data.Maybe import Data.Monoid import Data.Text (Text, unpack)-import Data.Text.Encoding (decodeUtf8)+import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Typeable+import Network.HTTP.Media.MediaType ((//), (/:)) import Network.Wai import Network.Wai.Parse import Servant+import Servant.Client.Core (HasClient(..), RequestBody(RequestBodySource), setRequestBody) import Servant.Docs import Servant.Foreign import Servant.Server.Internal+import Servant.Types.SourceT (SourceT(..), source, StepT(..), fromActionStep) import System.Directory+import System.IO (IOMode(ReadMode), withFile)+import System.Random (getStdRandom, Random(randomR))  import qualified Data.ByteString      as SBS import qualified Data.ByteString.Lazy as LBS@@ -240,6 +251,29 @@ instance FromMultipart tag (MultipartData tag) where   fromMultipart = Just +-- | Allows you to tell servant how to turn a more structured type+--   into a 'MultipartData', which is what is actually sent by the+--   client.+--+--   @+--   data User = User { username :: Text, pic :: FilePath }+--+--   instance toMultipart Tmp User where+--       toMultipart user = MultipartData [Input "username" $ username user]+--                                        [FileData "pic"+--                                                  (pic user)+--                                                  "image/png"+--                                                  (pic user)+--                                        ]+--   @+class ToMultipart tag a where+  -- | Given a value of type 'a', convert it to a+  -- 'MultipartData'.+  toMultipart :: a -> MultipartData tag++instance ToMultipart tag (MultipartData tag) where+  toMultipart = id+ -- | Upon seeing @MultipartForm a :> ...@ in an API type, ---  servant-server will hand a value of type @a@ to your handler --   assuming the request body's content type is@@ -267,6 +301,106 @@                     $ lookupContext popts config       subserver' = addMultipartHandling pbak multipartOpts subserver +-- | Upon seeing @MultipartForm a :> ...@ in an API type,+--   servant-client will take a parameter of type @(LBS.ByteString, a)@,+--   where the bytestring is the boundary to use (see 'genBoundary'), and+--   replace the request body with the contents of the form.+instance (ToMultipart tag a, HasClient m api, MultipartBackend tag)+      => HasClient m (MultipartForm tag a :> api) where++  type Client m (MultipartForm tag a :> api) = +    (LBS.ByteString, a) -> Client m api++  clientWithRoute pm _ req (boundary, param) =+      clientWithRoute pm (Proxy @api) $ setRequestBody newBody newMedia req+    where+      newBody = multipartToBody boundary $ toMultipart @tag param+      newMedia = "multipart" // "form-data" /: ("boundary", LBS.toStrict boundary)++  hoistClientMonad pm _ f cl = \a ->+      hoistClientMonad pm (Proxy @api) f (cl a)++-- | Generates a boundary to be used to separate parts of the multipart.+-- Requires 'IO' because it is randomized.+genBoundary :: IO LBS.ByteString+genBoundary = LBS.pack+            . map (validChars !)+            <$> indices+  where+    -- the standard allows up to 70 chars, but most implementations seem to be+    -- in the range of 40-60, so we pick 55+    indices = replicateM 55 . getStdRandom $ randomR (0,61)+    -- Following Chromium on this one:+    -- > The RFC 2046 spec says the alphanumeric characters plus the+    -- > following characters are legal for boundaries:  '()+_,-./:=?+    -- > However the following characters, though legal, cause some sites+    -- > to fail: (),./:=++    -- https://github.com/chromium/chromium/blob/6efa1184771ace08f3e2162b0255c93526d1750d/net/base/mime_util.cc#L662-L670+    validChars = listArray (0 :: Int, 61)+                           -- 0-9+                           [ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37+                           , 0x38, 0x39, 0x41, 0x42+                           -- A-Z, a-z+                           , 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a+                           , 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50, 0x51, 0x52+                           , 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a+                           , 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68+                           , 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70+                           , 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78+                           , 0x79, 0x7a+                           ]++-- | Given a bytestring for the boundary, turns a `MultipartData` into+-- a 'RequestBody'+multipartToBody :: forall tag. +                MultipartBackend tag+                => LBS.ByteString+                -> MultipartData tag+                -> RequestBody+multipartToBody boundary mp = RequestBodySource $ files' <> 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) +                                   "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)+                                 (loadFile (Proxy @tag) . fdPayload $ file)+    files' = foldl' (\acc x -> acc `mappend'` renderFile x) inputs' (files mp)+    renderPart name contentType extraParams payload =+      source [ "--"+             , boundary+             , crlf+             , "Content-Disposition: form-data; name=\""+             , name+             , "\""+             , extraParams+             , crlf+             , "Content-Type: "+             , contentType+             , crlf+             , crlf+             ] `mappend'` payload `mappend'` source [crlf]+ -- Try and extract the request body as multipart/form-data, -- returning the data as well as the resourcet InternalState -- that allows us to properly clean up the temporary files@@ -353,6 +487,8 @@             -> IO SBS.ByteString             -> IO (MultipartResult tag) +    loadFile :: Proxy tag -> MultipartResult tag -> SourceIO LBS.ByteString+     defaultBackendOptions :: Proxy tag -> MultipartBackendOptions tag  -- | Tag for data stored as a temporary file@@ -366,6 +502,13 @@     type MultipartBackendOptions Tmp = TmpBackendOptions      defaultBackendOptions _ = defaultTmpBackendOptions+    -- streams the file from disk +    loadFile _ fp =+        SourceT $ \k ->+        withFile fp ReadMode $ \hdl ->+        k (readHandle hdl)+      where+        readHandle hdl = fromActionStep LBS.null (LBS.hGet hdl 4096)     backend _ opts = tmpBackend       where         tmpBackend = tempFileBackEndOpts (getTmpDir opts) (filenamePat opts)@@ -375,6 +518,7 @@     type MultipartBackendOptions Mem = ()      defaultBackendOptions _ = ()+    loadFile _ = source . pure     backend _ opts _ = lbsBackEnd  -- | Configuration for the temporary file based backend.