{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
-- | @multipart/form-data@ client-side support for servant.
-- See servant-multipart-api for the API definitions.
module Servant.Multipart.Client
( genBoundary
, ToMultipart(..)
, multipartToBody
) 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 System.IO (IOMode (ReadMode), withFile)
import System.Random (getStdRandom, randomR)
import qualified Data.ByteString.Lazy as LBS
-- | 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, MultipartClient tag)
=> HasClient m (MultipartForm' mods tag a :> api) where
type Client m (MultipartForm' mods 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)
class MultipartClient tag where
loadFile :: Proxy tag -> MultipartResult tag -> SourceIO LBS.ByteString
instance MultipartClient Tmp where
-- 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)
instance MultipartClient Mem where
loadFile _ = source . pure @[]
-- | 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
. MultipartClient 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]