diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +0.11.5 +------ + +- Add `servant-client` support +- Support servant-0.17 + 0.11.4 ------ diff --git a/exe/Upload.hs b/exe/Upload.hs --- a/exe/Upload.hs +++ b/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 @@ -- 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" + ] diff --git a/servant-multipart.cabal b/servant-multipart.cabal --- a/servant-multipart.cabal +++ b/servant-multipart.cabal @@ -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 diff --git a/src/Servant/Multipart.hs b/src/Servant/Multipart.hs --- a/src/Servant/Multipart.hs +++ b/src/Servant/Multipart.hs @@ -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.