Add client support (#26)

* preliminary client support

* changed upload test to use the new client support rather than http-client

* removed servant 0.15 constraint from travis build

* changed <> and mempty local functions to not conflict with the Prelude typeclass ones

Author: Sciencei

.travis.yml

@@ -155,8 +155,6 @@ script:
   - if [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='network == 2.8.*' all | color_cabal_output ; fi
   # Constraint set network-3.0
   - if [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='network == 3.0.*' all | color_cabal_output ; fi
-  # Constraint set servant-0.15
-  - if [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.15.*' all | color_cabal_output ; fi
   # Constraint set servant-0.16
   - if [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.16.*' all | color_cabal_output ; fi
 

cabal.haskell-ci

@@ -8,10 +8,6 @@ constraint-set network-3.0
   ghc: >= 8.0 && <8.8
   constraints: network == 3.0.*
 
-constraint-set servant-0.15
-  ghc: >= 8.0 && <8.8
-  constraints: servant ==0.15.*
-
 constraint-set servant-0.16
   ghc: >= 8.0 && <8.8
   constraints: servant ==0.16.*

exe/Upload.hs

@@ -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 @@ import qualified Data.ByteString.Lazy as LBS
 -- 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 @@ main = do
       -- 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"
+                             ]

servant-multipart.cabal

@@ -27,23 +27,26 @@ library
 
   -- 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.9
-    , lens             >=4.17     && <4.19
-    , 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.17
+    , servant-client-core >=0.16     && <0.17
+    , servant-docs        >=0.10     && <0.15
+    , servant-foreign     >=0.15     && <0.16
+    , servant-server      >=0.16     && <0.17
+    , wai                 >=3.2.1.2  && <3.3
+    , wai-extra           >=3.0.24.3 && <3.1
 
 test-suite upload
   type:             exitcode-stdio-1.0
@@ -58,6 +61,8 @@ test-suite upload
     , servant
     , servant-multipart
     , servant-server
+    , servant-client
+    , servant-client-core
     , text
     , transformers
     , wai

src/Servant/Multipart.hs

@@ -32,27 +32,38 @@ module Servant.Multipart
   , 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 @@ class FromMultipart tag a where
 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,100 @@ instance ( FromMultipart tag a
                     $ 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 
+            . foldr (\x acc -> validChars ! x : acc) [] 
+            <$> 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,73)
+    -- '()+_,=./+?0123456789:ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz
+    validChars = listArray (0 :: Int, 73)
+                           [ 0x27, 0x28, 0x29, 0x2b, 0x5f, 0x2c, 0x3d, 0x2e
+                           , 0x2f, 0x2b, 0x3f, 0x30, 0x31, 0x32, 0x33, 0x34
+                           , 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x41, 0x42
+                           , 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 +481,8 @@ class MultipartBackend tag where
             -> 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 +496,13 @@ instance MultipartBackend Tmp where
     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 +512,7 @@ instance MultipartBackend Mem where
     type MultipartBackendOptions Mem = ()
 
     defaultBackendOptions _ = ()
+    loadFile _ = source . pure
     backend _ opts _ = lbsBackEnd
 
 -- | Configuration for the temporary file based backend.