{-# 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
, MultipartClient(..)
) where
import Servant.Multipart.API
import Control.Monad (replicateM)
import Data.Array (listArray, (!))
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 (..), 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)@,
-- 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'
--
-- 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 $
foldMap renderInput (inputs mp) <> foldMap renderFile (files mp) <> source ["--", boundary, "--"]
where
crlf = "\r\n"
lencode = LBS.fromStrict . encodeUtf8
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)
renderFile :: FileData tag -> SourceIO LBS.ByteString
renderFile file = renderPart (quotedValue . fdInputName $ file)
(headerValue . fdFileCType $ file)
("; filename=\"" <> quotedValue (fdFileName file) <> "\"")
(loadFile (Proxy @tag) . fdPayload $ file)
renderPart name contentType extraParams payload =
source [ "--"
, boundary
, crlf
, "Content-Disposition: form-data; name=\""
, name
, "\""
, extraParams
, crlf
, "Content-Type: "
, contentType
, crlf
, crlf
] <> payload <> source [crlf]