{-# 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@ support for servant.
--
--   This is mostly useful for adding file upload support to
--   an API. See haddocks of 'MultipartForm' for an introduction.
module Servant.Multipart
  ( MultipartForm
  , MultipartForm'
  , MultipartData(..)
  , FromMultipart(..)
  , lookupInput
  , lookupFile
  , MultipartOptions(..)
  , defaultMultipartOptions
  , MultipartBackend(..)
  , Tmp
  , TmpBackendOptions(..)
  , Mem
  , 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.Array (listArray, (!))
import Data.List (find, foldl')
import Data.Maybe
import Data.Monoid
import Data.String.Conversions (cs)
import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable
import Network.HTTP.Media.MediaType ((//), (/:))
import Network.Wai
import Network.Wai.Parse
import Servant hiding (contentType)
import Servant.API.Modifiers (FoldLenient)
import Servant.Client.Core (HasClient(..), RequestBody(RequestBodySource), setRequestBody)
import Servant.Docs hiding (samples)
import Servant.Foreign hiding (contentType)
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

-- | Combinator for specifying a @multipart/form-data@ request
--   body, typically (but not always) issued from an HTML @\<form\>@.
--
--   @multipart/form-data@ can't be made into an ordinary content
--   type for now in servant because it doesn't just decode the
--   request body from some format but also performs IO in the case
--   of writing the uploaded files to disk, e.g in @/tmp@, which is
--   not compatible with servant's vision of a content type as things
--   stand now. This also means that 'MultipartForm' can't be used in
--   conjunction with 'ReqBody' in an endpoint.
--
--   The 'tag' type parameter instructs the function to handle data
--   either as data to be saved to temporary storage ('Tmp') or saved to
--   memory ('Mem').
--
--   The 'a' type parameter represents the Haskell type to which
--   you are going to decode the multipart data to, where the
--   multipart data consists in all the usual form inputs along
--   with the files sent along through @\<input type="file"\>@
--   fields in the form.
--
--   One option provided out of the box by this library is to decode
--   to 'MultipartData'.
--
--   Example:
--
--   @
--   type API = MultipartForm Tmp (MultipartData Tmp) :> Post '[PlainText] String
--
--   api :: Proxy API
--   api = Proxy
--
--   server :: MultipartData Tmp -> Handler String
--   server multipartData = return str
--
--     where str = "The form was submitted with "
--              ++ show nInputs ++ " textual inputs and "
--              ++ show nFiles  ++ " files."
--           nInputs = length (inputs multipartData)
--           nFiles  = length (files multipartData)
--   @
--
--   You can alternatively provide a 'FromMultipart' instance
--   for some type of yours, allowing you to regroup data
--   into a structured form and potentially selecting
--   a subset of the entire form data that was submitted.
--
--   Example, where we only look extract one input, /username/,
--   and one file, where the corresponding input field's /name/
--   attribute was set to /pic/:
--
--   @
--   data User = User { username :: Text, pic :: FilePath }
--
--   instance FromMultipart Tmp User where
--     fromMultipart multipartData =
--       User \<$\> lookupInput "username" multipartData
--            \<*\> fmap fdPayload (lookupFile "pic" multipartData)
--
--   type API = MultipartForm Tmp User :> Post '[PlainText] String
--
--   server :: User -> Handler String
--   server usr = return str
--
--     where str = username usr ++ "'s profile picture"
--              ++ " got temporarily uploaded to "
--              ++ pic usr ++ " and will be removed from there "
--              ++ " after this handler has run."
--   @
--
--   Note that the behavior of this combinator is configurable,
--   by using 'serveWith' from servant-server instead of 'serve',
--   which takes an additional 'Context' argument. It simply is an
--   heterogeneous list where you can for example store
--   a value of type 'MultipartOptions' that has the configuration that
--   you want, which would then get picked up by servant-multipart.
--
--   __Important__: as mentionned in the example above,
--   the file paths point to temporary files which get removed
--   after your handler has run, if they are still there. It is
--   therefore recommended to move or copy them somewhere in your
--   handler code if you need to keep the content around.
type MultipartForm tag a = MultipartForm' '[] tag a

-- | 'MultipartForm' which can be modified with 'Servant.API.Modifiers.Lenient'.
data MultipartForm' (mods :: [*]) tag a

-- | What servant gets out of a @multipart/form-data@ form submission.
--
--   The type parameter 'tag' tells if 'MultipartData' is stored as a
--   temporary file or stored in memory. 'tag' is type of either 'Mem'
--   or 'Tmp'.
--
--   The 'inputs' field contains a list of textual 'Input's, where
--   each input for which a value is provided gets to be in this list,
--   represented by the input name and the input value. See haddocks for
--   'Input'.
--
--   The 'files' field contains a list of files that were sent along with the
--   other inputs in the form. Each file is represented by a value of type
--   'FileData' which among other things contains the path to the temporary file
--   (to be removed when your handler is done running) with a given uploaded
--   file's content. See haddocks for 'FileData'.
data MultipartData tag = MultipartData
  { MultipartData tag -> [Input]
inputs :: [Input]
  , MultipartData tag -> [FileData tag]
files  :: [FileData tag]
  }

fromRaw :: forall tag. ([Network.Wai.Parse.Param], [File (MultipartResult tag)])
        -> MultipartData tag
fromRaw :: ([Param], [File (MultipartResult tag)]) -> MultipartData tag
fromRaw ([Param]
inputs, [File (MultipartResult tag)]
files) = [Input] -> [FileData tag] -> MultipartData tag
forall tag. [Input] -> [FileData tag] -> MultipartData tag
MultipartData [Input]
is [FileData tag]
fs

  where is :: [Input]
is = (Param -> Input) -> [Param] -> [Input]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
name, ByteString
val) -> Text -> Text -> Input
Input (ByteString -> Text
dec ByteString
name) (ByteString -> Text
dec ByteString
val)) [Param]
inputs
        fs :: [FileData tag]
fs = (File (MultipartResult tag) -> FileData tag)
-> [File (MultipartResult tag)] -> [FileData tag]
forall a b. (a -> b) -> [a] -> [b]
map File (MultipartResult tag) -> FileData tag
toFile [File (MultipartResult tag)]
files

        toFile :: File (MultipartResult tag) -> FileData tag
        toFile :: File (MultipartResult tag) -> FileData tag
toFile (ByteString
iname, FileInfo (MultipartResult tag)
fileinfo) =
          Text -> Text -> Text -> MultipartResult tag -> FileData tag
forall tag.
Text -> Text -> Text -> MultipartResult tag -> FileData tag
FileData (ByteString -> Text
dec ByteString
iname)
                   (ByteString -> Text
dec (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ FileInfo (MultipartResult tag) -> ByteString
forall c. FileInfo c -> ByteString
fileName FileInfo (MultipartResult tag)
fileinfo)
                   (ByteString -> Text
dec (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ FileInfo (MultipartResult tag) -> ByteString
forall c. FileInfo c -> ByteString
fileContentType FileInfo (MultipartResult tag)
fileinfo)
                   (FileInfo (MultipartResult tag) -> MultipartResult tag
forall c. FileInfo c -> c
fileContent FileInfo (MultipartResult tag)
fileinfo)

        dec :: ByteString -> Text
dec = ByteString -> Text
decodeUtf8

-- | Representation for an uploaded file, usually resulting from
--   picking a local file for an HTML input that looks like
--   @\<input type="file" name="somefile" /\>@.
data FileData tag = FileData
  { FileData tag -> Text
fdInputName :: Text     -- ^ @name@ attribute of the corresponding
                            --   HTML @\<input\>@
  , FileData tag -> Text
fdFileName  :: Text     -- ^ name of the file on the client's disk
  , FileData tag -> Text
fdFileCType :: Text     -- ^ MIME type for the file
  , FileData tag -> MultipartResult tag
fdPayload   :: MultipartResult tag
                            -- ^ path to the temporary file that has the
                            --   content of the user's original file. Only
                            --   valid during the execution of your handler as
                            --   it gets removed right after, which means you
                            --   really want to move or copy it in your handler.
  }

deriving instance Eq (MultipartResult tag) => Eq (FileData tag)
deriving instance Show (MultipartResult tag) => Show (FileData tag)

-- | Lookup a file input with the given @name@ attribute.
lookupFile :: Text -> MultipartData tag -> Either String (FileData tag)
lookupFile :: Text -> MultipartData tag -> Either String (FileData tag)
lookupFile Text
iname =
  Either String (FileData tag)
-> (FileData tag -> Either String (FileData tag))
-> Maybe (FileData tag)
-> Either String (FileData tag)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String (FileData tag)
forall a b. a -> Either a b
Left (String -> Either String (FileData tag))
-> String -> Either String (FileData tag)
forall a b. (a -> b) -> a -> b
$ String
"File " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
iname String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" not found") FileData tag -> Either String (FileData tag)
forall a b. b -> Either a b
Right
  (Maybe (FileData tag) -> Either String (FileData tag))
-> (MultipartData tag -> Maybe (FileData tag))
-> MultipartData tag
-> Either String (FileData tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileData tag -> Bool) -> [FileData tag] -> Maybe (FileData tag)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
iname) (Text -> Bool) -> (FileData tag -> Text) -> FileData tag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileData tag -> Text
forall tag. FileData tag -> Text
fdInputName)
  ([FileData tag] -> Maybe (FileData tag))
-> (MultipartData tag -> [FileData tag])
-> MultipartData tag
-> Maybe (FileData tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipartData tag -> [FileData tag]
forall tag. MultipartData tag -> [FileData tag]
files

-- | Representation for a textual input (any @\<input\>@ type but @file@).
--
--   @\<input name="foo" value="bar"\ />@ would appear as @'Input' "foo" "bar"@.
data Input = Input
  { Input -> Text
iName  :: Text -- ^ @name@ attribute of the input
  , Input -> Text
iValue :: Text -- ^ value given for that input
  } deriving (Input -> Input -> Bool
(Input -> Input -> Bool) -> (Input -> Input -> Bool) -> Eq Input
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Input -> Input -> Bool
$c/= :: Input -> Input -> Bool
== :: Input -> Input -> Bool
$c== :: Input -> Input -> Bool
Eq, Int -> Input -> ShowS
[Input] -> ShowS
Input -> String
(Int -> Input -> ShowS)
-> (Input -> String) -> ([Input] -> ShowS) -> Show Input
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Input] -> ShowS
$cshowList :: [Input] -> ShowS
show :: Input -> String
$cshow :: Input -> String
showsPrec :: Int -> Input -> ShowS
$cshowsPrec :: Int -> Input -> ShowS
Show)

-- | Lookup a textual input with the given @name@ attribute.
lookupInput :: Text -> MultipartData tag -> Either String Text
lookupInput :: Text -> MultipartData tag -> Either String Text
lookupInput Text
iname =
  Either String Text
-> (Input -> Either String Text)
-> Maybe Input
-> Either String Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Text
forall a b. a -> Either a b
Left (String -> Either String Text) -> String -> Either String Text
forall a b. (a -> b) -> a -> b
$ String
"Field " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
iname String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" not found") (Text -> Either String Text
forall a b. b -> Either a b
Right (Text -> Either String Text)
-> (Input -> Text) -> Input -> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Text
iValue)
  (Maybe Input -> Either String Text)
-> (MultipartData tag -> Maybe Input)
-> MultipartData tag
-> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> Bool) -> [Input] -> Maybe Input
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
iname) (Text -> Bool) -> (Input -> Text) -> Input -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Text
iName)
  ([Input] -> Maybe Input)
-> (MultipartData tag -> [Input])
-> MultipartData tag
-> Maybe Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipartData tag -> [Input]
forall tag. MultipartData tag -> [Input]
inputs

-- | 'MultipartData' is the type representing
--   @multipart/form-data@ form inputs. Sometimes
--   you may instead want to work with a more structured type
--   of yours that potentially selects only a fraction of
--   the data that was submitted, or just reshapes it to make
--   it easier to work with. The 'FromMultipart' class is exactly
--   what allows you to tell servant how to turn "raw" multipart
--   data into a value of your nicer type.
--
--   @
--   data User = User { username :: Text, pic :: FilePath }
--
--   instance FromMultipart Tmp User where
--     fromMultipart form =
--       User \<$\> lookupInput "username" (inputs form)
--            \<*\> fmap fdPayload (lookupFile "pic" $ files form)
--   @
class FromMultipart tag a where
  -- | Given a value of type 'MultipartData', which consists
  --   in a list of textual inputs and another list for
  --   files, try to extract a value of type @a@. When
  --   extraction fails, servant errors out with status code 400.
  fromMultipart :: MultipartData tag -> Either String a

instance FromMultipart tag (MultipartData tag) where
  fromMultipart :: MultipartData tag -> Either String (MultipartData tag)
fromMultipart = MultipartData tag -> Either String (MultipartData tag)
forall a b. b -> Either a b
Right

-- | 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 :: MultipartData tag -> MultipartData tag
toMultipart = MultipartData tag -> MultipartData tag
forall a. a -> a
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
--   @multipart/form-data@ and the call to 'fromMultipart' succeeds.
instance ( FromMultipart tag a
         , MultipartBackend tag
         , LookupContext config (MultipartOptions tag)
#if MIN_VERSION_servant_server(0,18,0)
         , LookupContext config ErrorFormatters
#endif
         , SBoolI (FoldLenient mods)
         , HasServer sublayout config )
      => HasServer (MultipartForm' mods tag a :> sublayout) config where

  type ServerT (MultipartForm' mods tag a :> sublayout) m =
    If (FoldLenient mods) (Either String a) a -> ServerT sublayout m

#if MIN_VERSION_servant_server(0,12,0)
  hoistServerWithContext :: Proxy (MultipartForm' mods tag a :> sublayout)
-> Proxy config
-> (forall x. m x -> n x)
-> ServerT (MultipartForm' mods tag a :> sublayout) m
-> ServerT (MultipartForm' mods tag a :> sublayout) n
hoistServerWithContext Proxy (MultipartForm' mods tag a :> sublayout)
_ Proxy config
pc forall x. m x -> n x
nt ServerT (MultipartForm' mods tag a :> sublayout) m
s = Proxy sublayout
-> Proxy config
-> (forall x. m x -> n x)
-> ServerT sublayout m
-> ServerT sublayout n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy sublayout
forall k (t :: k). Proxy t
Proxy :: Proxy sublayout) Proxy config
pc forall x. m x -> n x
nt (ServerT sublayout m -> ServerT sublayout n)
-> (If (FoldLenient mods) (Either String a) a
    -> ServerT sublayout m)
-> If (FoldLenient mods) (Either String a) a
-> ServerT sublayout n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (MultipartForm' mods tag a :> sublayout) m
If (FoldLenient mods) (Either String a) a -> ServerT sublayout m
s
#endif

  route :: Proxy (MultipartForm' mods tag a :> sublayout)
-> Context config
-> Delayed env (Server (MultipartForm' mods tag a :> sublayout))
-> Router env
route Proxy (MultipartForm' mods tag a :> sublayout)
Proxy Context config
config Delayed env (Server (MultipartForm' mods tag a :> sublayout))
subserver =
    Proxy sublayout
-> Context config -> Delayed env (Server sublayout) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Proxy sublayout
psub Context config
config Delayed env (Server sublayout)
subserver'
    where
      psub :: Proxy sublayout
psub  = Proxy sublayout
forall k (t :: k). Proxy t
Proxy :: Proxy sublayout
      pbak :: Proxy b
pbak  = forall b. Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b
      popts :: Proxy (MultipartOptions tag)
popts = Proxy (MultipartOptions tag)
forall k (t :: k). Proxy t
Proxy :: Proxy (MultipartOptions tag)
      multipartOpts :: MultipartOptions tag
multipartOpts = MultipartOptions tag
-> Maybe (MultipartOptions tag) -> MultipartOptions tag
forall a. a -> Maybe a -> a
fromMaybe (Proxy tag -> MultipartOptions tag
forall tag.
MultipartBackend tag =>
Proxy tag -> MultipartOptions tag
defaultMultipartOptions Proxy tag
forall b. Proxy b
pbak)
                    (Maybe (MultipartOptions tag) -> MultipartOptions tag)
-> Maybe (MultipartOptions tag) -> MultipartOptions tag
forall a b. (a -> b) -> a -> b
$ Proxy (MultipartOptions tag)
-> Context config -> Maybe (MultipartOptions tag)
forall (ctx :: [*]) a.
LookupContext ctx a =>
Proxy a -> Context ctx -> Maybe a
lookupContext Proxy (MultipartOptions tag)
popts Context config
config
      subserver' :: Delayed env (Server sublayout)
subserver' = Proxy tag
-> MultipartOptions tag
-> Context config
-> Delayed
     env (If (FoldLenient mods) (Either String a) a -> Server sublayout)
-> Delayed env (Server sublayout)
forall tag multipart (mods :: [*]) (config :: [*]) env a.
(FromMultipart tag multipart, MultipartBackend tag,
 LookupContext config ErrorFormatters, SBoolI (FoldLenient mods)) =>
Proxy tag
-> MultipartOptions tag
-> Context config
-> Delayed
     env
     (If (FoldLenient mods) (Either String multipart) multipart -> a)
-> Delayed env a
addMultipartHandling @tag @a @mods @config Proxy tag
forall b. Proxy b
pbak MultipartOptions tag
multipartOpts Context config
config Delayed env (Server (MultipartForm' mods tag a :> sublayout))
Delayed
  env (If (FoldLenient mods) (Either String a) a -> Server sublayout)
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' mods tag a :> api) where

  type Client m (MultipartForm' mods tag a :> api) =
    (LBS.ByteString, a) -> Client m api

  clientWithRoute :: Proxy m
-> Proxy (MultipartForm' mods tag a :> api)
-> Request
-> Client m (MultipartForm' mods tag a :> api)
clientWithRoute Proxy m
pm Proxy (MultipartForm' mods tag a :> api)
_ Request
req (ByteString
boundary, a
param) =
      Proxy m -> Proxy api -> Request -> Client m api
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (Proxy api
forall k (t :: k). Proxy t
Proxy @api) (Request -> Client m api) -> Request -> Client m api
forall a b. (a -> b) -> a -> b
$ RequestBody -> MediaType -> Request -> Request
setRequestBody RequestBody
newBody MediaType
newMedia Request
req
    where
      newBody :: RequestBody
newBody = ByteString -> MultipartData tag -> RequestBody
forall tag.
MultipartBackend tag =>
ByteString -> MultipartData tag -> RequestBody
multipartToBody ByteString
boundary (MultipartData tag -> RequestBody)
-> MultipartData tag -> RequestBody
forall a b. (a -> b) -> a -> b
$ a -> MultipartData tag
forall tag a. ToMultipart tag a => a -> MultipartData tag
toMultipart @tag a
param
      newMedia :: MediaType
newMedia = ByteString
"multipart" ByteString -> ByteString -> MediaType
// ByteString
"form-data" MediaType -> Param -> MediaType
/: (ByteString
"boundary", ByteString -> ByteString
LBS.toStrict ByteString
boundary)

  hoistClientMonad :: Proxy m
-> Proxy (MultipartForm' mods tag a :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (MultipartForm' mods tag a :> api)
-> Client mon' (MultipartForm' mods tag a :> api)
hoistClientMonad Proxy m
pm Proxy (MultipartForm' mods tag a :> api)
_ forall x. mon x -> mon' x
f Client mon (MultipartForm' mods tag a :> api)
cl = \(ByteString, a)
a ->
      Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (Proxy api
forall k (t :: k). Proxy t
Proxy @api) forall x. mon x -> mon' x
f (Client mon (MultipartForm' mods tag a :> api)
(ByteString, a) -> Client mon api
cl (ByteString, a)
a)

-- | Generates a boundary to be used to separate parts of the multipart.
-- Requires 'IO' because it is randomized.
genBoundary :: IO LBS.ByteString
genBoundary :: IO ByteString
genBoundary = [Word8] -> ByteString
LBS.pack
            ([Word8] -> ByteString)
-> ([Int] -> [Word8]) -> [Int] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Array Int Word8
validChars Array Int Word8 -> Int -> Word8
forall i e. Ix i => Array i e -> i -> e
!)
            ([Int] -> ByteString) -> IO [Int] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Int]
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 :: IO [Int]
indices = Int -> IO Int -> IO [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
55 (IO Int -> IO [Int])
-> ((StdGen -> (Int, StdGen)) -> IO Int)
-> (StdGen -> (Int, StdGen))
-> IO [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StdGen -> (Int, StdGen)) -> IO Int
forall a. (StdGen -> (a, StdGen)) -> IO a
getStdRandom ((StdGen -> (Int, StdGen)) -> IO [Int])
-> (StdGen -> (Int, StdGen)) -> IO [Int]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0,Int
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 :: Array Int Word8
validChars = (Int, Int) -> [Word8] -> Array Int Word8
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0 :: Int, Int
61)
                           -- 0-9
                           [ Word8
0x30, Word8
0x31, Word8
0x32, Word8
0x33, Word8
0x34, Word8
0x35, Word8
0x36, Word8
0x37
                           , Word8
0x38, Word8
0x39, Word8
0x41, Word8
0x42
                           -- A-Z, a-z
                           , Word8
0x43, Word8
0x44, Word8
0x45, Word8
0x46, Word8
0x47, Word8
0x48, Word8
0x49, Word8
0x4a
                           , Word8
0x4b, Word8
0x4c, Word8
0x4d, Word8
0x4e, Word8
0x4f, Word8
0x50, Word8
0x51, Word8
0x52
                           , Word8
0x53, Word8
0x54, Word8
0x55, Word8
0x56, Word8
0x57, Word8
0x58, Word8
0x59, Word8
0x5a
                           , Word8
0x61, Word8
0x62, Word8
0x63, Word8
0x64, Word8
0x65, Word8
0x66, Word8
0x67, Word8
0x68
                           , Word8
0x69, Word8
0x6a, Word8
0x6b, Word8
0x6c, Word8
0x6d, Word8
0x6e, Word8
0x6f, Word8
0x70
                           , Word8
0x71, Word8
0x72, Word8
0x73, Word8
0x74, Word8
0x75, Word8
0x76, Word8
0x77, Word8
0x78
                           , Word8
0x79, Word8
0x7a
                           ]

-- | Given a bytestring for the boundary, turns a `MultipartData` into
-- a 'RequestBody'
multipartToBody :: forall tag.
                MultipartBackend tag
                => LBS.ByteString
                -> MultipartData tag
                -> RequestBody
multipartToBody :: ByteString -> MultipartData tag -> RequestBody
multipartToBody ByteString
boundary MultipartData tag
mp = SourceIO ByteString -> RequestBody
RequestBodySource (SourceIO ByteString -> RequestBody)
-> SourceIO ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ SourceIO ByteString
files' SourceIO ByteString -> SourceIO ByteString -> SourceIO ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> SourceIO ByteString
forall a (m :: * -> *). [a] -> SourceT m a
source [ByteString
"--", ByteString
boundary, ByteString
"--"]
  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 forall b. (StepT m a -> m b) -> m b
l) mappend' :: SourceT m a -> SourceT m a -> SourceT m a
`mappend'` (SourceT forall b. (StepT m a -> m b) -> m b
r) = (forall b. (StepT m a -> m b) -> m b) -> SourceT m a
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((forall b. (StepT m a -> m b) -> m b) -> SourceT m a)
-> (forall b. (StepT m a -> m b) -> m b) -> SourceT m a
forall a b. (a -> b) -> a -> b
$ \StepT m a -> m b
k ->
                                                   (StepT m a -> m b) -> m b
forall b. (StepT m a -> m b) -> m b
l ((StepT m a -> m b) -> m b) -> (StepT m a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \StepT m a
lstep ->
                                                   (StepT m a -> m b) -> m b
forall b. (StepT m a -> m b) -> m b
r ((StepT m a -> m b) -> m b) -> (StepT m a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \StepT m a
rstep ->
                                                   StepT m a -> m b
k (StepT m a -> StepT m a -> StepT m a
forall (m :: * -> *) a.
Functor m =>
StepT m a -> StepT m a -> StepT m a
appendStep StepT m a
lstep StepT m a
rstep)
    appendStep :: StepT m a -> StepT m a -> StepT m a
appendStep StepT m a
Stop        StepT m a
r = StepT m a
r
    appendStep (Error String
err) StepT m a
_ = String -> StepT m a
forall (m :: * -> *) a. String -> StepT m a
Error String
err
    appendStep (Skip StepT m a
s)    StepT m a
r = StepT m a -> StepT m a -> StepT m a
appendStep StepT m a
s StepT m a
r
    appendStep (Yield a
x StepT m a
s) StepT m a
r = a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
Yield a
x (StepT m a -> StepT m a -> StepT m a
appendStep StepT m a
s StepT m a
r)
    appendStep (Effect m (StepT m a)
ms) StepT m a
r = m (StepT m a) -> StepT m a
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
Effect (m (StepT m a) -> StepT m a) -> m (StepT m a) -> StepT m a
forall a b. (a -> b) -> a -> b
$ ((StepT m a -> StepT m a -> StepT m a)
-> StepT m a -> StepT m a -> StepT m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StepT m a -> StepT m a -> StepT m a
appendStep StepT m a
r (StepT m a -> StepT m a) -> m (StepT m a) -> m (StepT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (StepT m a)
ms)
    mempty' :: SourceT m a
mempty' = (forall b. (StepT m a -> m b) -> m b) -> SourceT m a
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((StepT m a -> m b) -> StepT m a -> m b
forall a b. (a -> b) -> a -> b
$ StepT m a
forall (m :: * -> *) a. StepT m a
Stop)
    crlf :: ByteString
crlf = ByteString
"\r\n"
    lencode :: Text -> ByteString
lencode = ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
    renderInput :: Input -> SourceIO ByteString
renderInput Input
input = ByteString
-> ByteString
-> ByteString
-> SourceIO ByteString
-> SourceIO ByteString
renderPart (Text -> ByteString
lencode (Text -> ByteString) -> (Input -> Text) -> Input -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Text
iName (Input -> ByteString) -> Input -> ByteString
forall a b. (a -> b) -> a -> b
$ Input
input)
                                   ByteString
"text/plain"
                                   ByteString
""
                                   ([ByteString] -> SourceIO ByteString
forall a (m :: * -> *). [a] -> SourceT m a
source ([ByteString] -> SourceIO ByteString)
-> (Input -> [ByteString]) -> Input -> SourceIO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> [ByteString])
-> (Input -> ByteString) -> Input -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
lencode (Text -> ByteString) -> (Input -> Text) -> Input -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Text
iValue (Input -> SourceIO ByteString) -> Input -> SourceIO ByteString
forall a b. (a -> b) -> a -> b
$ Input
input)
    inputs' :: SourceIO ByteString
inputs' = (SourceIO ByteString -> Input -> SourceIO ByteString)
-> SourceIO ByteString -> [Input] -> SourceIO ByteString
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\SourceIO ByteString
acc Input
x -> SourceIO ByteString
acc SourceIO ByteString -> SourceIO ByteString -> SourceIO ByteString
forall (m :: * -> *) a.
Functor m =>
SourceT m a -> SourceT m a -> SourceT m a
`mappend'` Input -> SourceIO ByteString
renderInput Input
x) SourceIO ByteString
forall (m :: * -> *) a. SourceT m a
mempty' (MultipartData tag -> [Input]
forall tag. MultipartData tag -> [Input]
inputs MultipartData tag
mp)
    renderFile :: FileData tag -> SourceIO LBS.ByteString
    renderFile :: FileData tag -> SourceIO ByteString
renderFile FileData tag
file = ByteString
-> ByteString
-> ByteString
-> SourceIO ByteString
-> SourceIO ByteString
renderPart (Text -> ByteString
lencode (Text -> ByteString)
-> (FileData tag -> Text) -> FileData tag -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileData tag -> Text
forall tag. FileData tag -> Text
fdInputName (FileData tag -> ByteString) -> FileData tag -> ByteString
forall a b. (a -> b) -> a -> b
$ FileData tag
file)
                                 (Text -> ByteString
lencode (Text -> ByteString)
-> (FileData tag -> Text) -> FileData tag -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileData tag -> Text
forall tag. FileData tag -> Text
fdFileCType (FileData tag -> ByteString) -> FileData tag -> ByteString
forall a b. (a -> b) -> a -> b
$ FileData tag
file)
                                 (((ByteString -> ByteString -> ByteString)
-> ByteString -> ByteString -> ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
mappend) ByteString
"\"" (ByteString -> ByteString)
-> (FileData tag -> ByteString) -> FileData tag -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
mappend ByteString
"; filename=\""
                                                      (ByteString -> ByteString)
-> (FileData tag -> ByteString) -> FileData tag -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
lencode
                                                      (Text -> ByteString)
-> (FileData tag -> Text) -> FileData tag -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileData tag -> Text
forall tag. FileData tag -> Text
fdFileName (FileData tag -> ByteString) -> FileData tag -> ByteString
forall a b. (a -> b) -> a -> b
$ FileData tag
file)
                                 (Proxy tag -> MultipartResult tag -> SourceIO ByteString
forall tag.
MultipartBackend tag =>
Proxy tag -> MultipartResult tag -> SourceIO ByteString
loadFile (Proxy tag
forall k (t :: k). Proxy t
Proxy @tag) (MultipartResult tag -> SourceIO ByteString)
-> (FileData tag -> MultipartResult tag)
-> FileData tag
-> SourceIO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileData tag -> MultipartResult tag
forall tag. FileData tag -> MultipartResult tag
fdPayload (FileData tag -> SourceIO ByteString)
-> FileData tag -> SourceIO ByteString
forall a b. (a -> b) -> a -> b
$ FileData tag
file)
    files' :: SourceIO ByteString
files' = (SourceIO ByteString -> FileData tag -> SourceIO ByteString)
-> SourceIO ByteString -> [FileData tag] -> SourceIO ByteString
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\SourceIO ByteString
acc FileData tag
x -> SourceIO ByteString
acc SourceIO ByteString -> SourceIO ByteString -> SourceIO ByteString
forall (m :: * -> *) a.
Functor m =>
SourceT m a -> SourceT m a -> SourceT m a
`mappend'` FileData tag -> SourceIO ByteString
renderFile FileData tag
x) SourceIO ByteString
inputs' (MultipartData tag -> [FileData tag]
forall tag. MultipartData tag -> [FileData tag]
files MultipartData tag
mp)
    renderPart :: ByteString
-> ByteString
-> ByteString
-> SourceIO ByteString
-> SourceIO ByteString
renderPart ByteString
name ByteString
contentType ByteString
extraParams SourceIO ByteString
payload =
      [ByteString] -> SourceIO ByteString
forall a (m :: * -> *). [a] -> SourceT m a
source [ ByteString
"--"
             , ByteString
boundary
             , ByteString
crlf
             , ByteString
"Content-Disposition: form-data; name=\""
             , ByteString
name
             , ByteString
"\""
             , ByteString
extraParams
             , ByteString
crlf
             , ByteString
"Content-Type: "
             , ByteString
contentType
             , ByteString
crlf
             , ByteString
crlf
             ] SourceIO ByteString -> SourceIO ByteString -> SourceIO ByteString
forall (m :: * -> *) a.
Functor m =>
SourceT m a -> SourceT m a -> SourceT m a
`mappend'` SourceIO ByteString
payload SourceIO ByteString -> SourceIO ByteString -> SourceIO ByteString
forall (m :: * -> *) a.
Functor m =>
SourceT m a -> SourceT m a -> SourceT m a
`mappend'` [ByteString] -> SourceIO ByteString
forall a (m :: * -> *). [a] -> SourceT m a
source [ByteString
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
-- later on.
check :: MultipartBackend tag
      => Proxy tag
      -> MultipartOptions tag
      -> DelayedIO (MultipartData tag)
check :: Proxy tag -> MultipartOptions tag -> DelayedIO (MultipartData tag)
check Proxy tag
pTag MultipartOptions tag
tag = (Request -> DelayedIO (MultipartData tag))
-> DelayedIO (MultipartData tag)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO (MultipartData tag))
 -> DelayedIO (MultipartData tag))
-> (Request -> DelayedIO (MultipartData tag))
-> DelayedIO (MultipartData tag)
forall a b. (a -> b) -> a -> b
$ \Request
request -> do
  InternalState
st <- ResourceT IO InternalState -> DelayedIO InternalState
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT ResourceT IO InternalState
forall (m :: * -> *). Monad m => ResourceT m InternalState
getInternalState
  ([Param], [File (MultipartResult tag)])
rawData <- IO ([Param], [File (MultipartResult tag)])
-> DelayedIO ([Param], [File (MultipartResult tag)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO ([Param], [File (MultipartResult tag)])
 -> DelayedIO ([Param], [File (MultipartResult tag)]))
-> IO ([Param], [File (MultipartResult tag)])
-> DelayedIO ([Param], [File (MultipartResult tag)])
forall a b. (a -> b) -> a -> b
$ ParseRequestBodyOptions
-> BackEnd (MultipartResult tag)
-> Request
-> IO ([Param], [File (MultipartResult tag)])
forall y.
ParseRequestBodyOptions
-> BackEnd y -> Request -> IO ([Param], [File y])
parseRequestBodyEx
          ParseRequestBodyOptions
parseOpts
          (Proxy tag
-> MultipartBackendOptions tag
-> InternalState
-> BackEnd (MultipartResult tag)
forall tag ignored1 ignored2.
MultipartBackend tag =>
Proxy tag
-> MultipartBackendOptions tag
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO (MultipartResult tag)
backend Proxy tag
pTag (MultipartOptions tag -> MultipartBackendOptions tag
forall tag. MultipartOptions tag -> MultipartBackendOptions tag
backendOptions MultipartOptions tag
tag) InternalState
st)
          Request
request
  MultipartData tag -> DelayedIO (MultipartData tag)
forall (m :: * -> *) a. Monad m => a -> m a
return (([Param], [File (MultipartResult tag)]) -> MultipartData tag
forall tag.
([Param], [File (MultipartResult tag)]) -> MultipartData tag
fromRaw ([Param], [File (MultipartResult tag)])
rawData)
  where parseOpts :: ParseRequestBodyOptions
parseOpts = MultipartOptions tag -> ParseRequestBodyOptions
forall tag. MultipartOptions tag -> ParseRequestBodyOptions
generalOptions MultipartOptions tag
tag

-- Add multipart extraction support to a Delayed.
addMultipartHandling :: forall tag multipart (mods :: [*]) config env a.
                     ( FromMultipart tag multipart
                     , MultipartBackend tag
#if MIN_VERSION_servant_server(0,18,0)
                     , LookupContext config ErrorFormatters
#endif
                     )
                     => SBoolI (FoldLenient mods)
                     => Proxy tag
                     -> MultipartOptions tag
                     -> Context config
                     -> Delayed env (If (FoldLenient mods) (Either String multipart) multipart -> a)
                     -> Delayed env a
addMultipartHandling :: Proxy tag
-> MultipartOptions tag
-> Context config
-> Delayed
     env
     (If (FoldLenient mods) (Either String multipart) multipart -> a)
-> Delayed env a
addMultipartHandling Proxy tag
pTag MultipartOptions tag
opts Context config
_config Delayed
  env
  (If (FoldLenient mods) (Either String multipart) multipart -> a)
subserver =
  Delayed
  env
  (If (FoldLenient mods) (Either String multipart) multipart -> a)
-> DelayedIO ()
-> (()
    -> DelayedIO
         (If (FoldLenient mods) (Either String multipart) multipart))
-> Delayed env a
forall env a b c.
Delayed env (a -> b)
-> DelayedIO c -> (c -> DelayedIO a) -> Delayed env b
addBodyCheck Delayed
  env
  (If (FoldLenient mods) (Either String multipart) multipart -> a)
subserver DelayedIO ()
contentCheck ()
-> DelayedIO
     (If (FoldLenient mods) (Either String multipart) multipart)
bodyCheck
  where
    contentCheck :: DelayedIO ()
contentCheck = (Request -> DelayedIO ()) -> DelayedIO ()
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO ()) -> DelayedIO ())
-> (Request -> DelayedIO ()) -> DelayedIO ()
forall a b. (a -> b) -> a -> b
$ \Request
request ->
      ByteString -> DelayedIO ()
fuzzyMultipartCTCheck (Request -> ByteString
contentTypeH Request
request)

    bodyCheck :: ()
-> DelayedIO
     (If (FoldLenient mods) (Either String multipart) multipart)
bodyCheck () = (Request
 -> DelayedIO
      (If (FoldLenient mods) (Either String multipart) multipart))
-> DelayedIO
     (If (FoldLenient mods) (Either String multipart) multipart)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request
  -> DelayedIO
       (If (FoldLenient mods) (Either String multipart) multipart))
 -> DelayedIO
      (If (FoldLenient mods) (Either String multipart) multipart))
-> (Request
    -> DelayedIO
         (If (FoldLenient mods) (Either String multipart) multipart))
-> DelayedIO
     (If (FoldLenient mods) (Either String multipart) multipart)
forall a b. (a -> b) -> a -> b
$ \ Request
request -> do
      MultipartData tag
mpd <- Proxy tag -> MultipartOptions tag -> DelayedIO (MultipartData tag)
forall tag.
MultipartBackend tag =>
Proxy tag -> MultipartOptions tag -> DelayedIO (MultipartData tag)
check Proxy tag
pTag MultipartOptions tag
opts :: DelayedIO (MultipartData tag)
      case (SBool (FoldLenient mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldLenient mods), MultipartData tag -> Either String multipart
forall tag a.
FromMultipart tag a =>
MultipartData tag -> Either String a
fromMultipart @tag @multipart MultipartData tag
mpd) of
        (SBool (FoldLenient mods)
SFalse, Left String
msg) -> RouteResult
  (If (FoldLenient mods) (Either String multipart) multipart)
-> DelayedIO
     (If (FoldLenient mods) (Either String multipart) multipart)
forall a. RouteResult a -> DelayedIO a
liftRouteResult (RouteResult
   (If (FoldLenient mods) (Either String multipart) multipart)
 -> DelayedIO
      (If (FoldLenient mods) (Either String multipart) multipart))
-> RouteResult
     (If (FoldLenient mods) (Either String multipart) multipart)
-> DelayedIO
     (If (FoldLenient mods) (Either String multipart) multipart)
forall a b. (a -> b) -> a -> b
$ ServerError
-> RouteResult
     (If (FoldLenient mods) (Either String multipart) multipart)
forall a. ServerError -> RouteResult a
FailFatal (ServerError
 -> RouteResult
      (If (FoldLenient mods) (Either String multipart) multipart))
-> ServerError
-> RouteResult
     (If (FoldLenient mods) (Either String multipart) multipart)
forall a b. (a -> b) -> a -> b
$ Request -> String -> ServerError
formatError Request
request String
msg
        (SBool (FoldLenient mods)
SFalse, Right multipart
x) -> multipart -> DelayedIO multipart
forall (m :: * -> *) a. Monad m => a -> m a
return multipart
x
        (SBool (FoldLenient mods)
STrue, Either String multipart
res) -> Either String multipart -> DelayedIO (Either String multipart)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String multipart -> DelayedIO (Either String multipart))
-> Either String multipart -> DelayedIO (Either String multipart)
forall a b. (a -> b) -> a -> b
$ (String -> Either String multipart)
-> (multipart -> Either String multipart)
-> Either String multipart
-> Either String multipart
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String multipart
forall a b. a -> Either a b
Left (String -> Either String multipart)
-> ShowS -> String -> Either String multipart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a b. ConvertibleStrings a b => a -> b
cs) multipart -> Either String multipart
forall a b. b -> Either a b
Right Either String multipart
res

    contentTypeH :: Request -> ByteString
contentTypeH Request
req = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/octet-stream" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
          HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Content-Type" (Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)

    defaultFormatError :: a -> ServerError
defaultFormatError a
msg = ServerError
err400 { errBody :: ByteString
errBody = ByteString
"Could not decode multipart mime body: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> a -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs a
msg }
#if MIN_VERSION_servant_server(0,18,0)
    pFormatters :: Proxy ErrorFormatters
pFormatters = Proxy ErrorFormatters
forall k (t :: k). Proxy t
Proxy :: Proxy ErrorFormatters
    rep :: TypeRep
rep = Proxy MultipartForm' -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy MultipartForm'
forall k (t :: k). Proxy t
Proxy :: Proxy MultipartForm')
    formatError :: Request -> String -> ServerError
formatError Request
request =
      case Proxy ErrorFormatters -> Context config -> Maybe ErrorFormatters
forall (ctx :: [*]) a.
LookupContext ctx a =>
Proxy a -> Context ctx -> Maybe a
lookupContext Proxy ErrorFormatters
pFormatters Context config
_config of
        Maybe ErrorFormatters
Nothing -> String -> ServerError
forall a. ConvertibleStrings a ByteString => a -> ServerError
defaultFormatError
        Just ErrorFormatters
fmts -> ErrorFormatters -> ErrorFormatter
bodyParserErrorFormatter ErrorFormatters
fmts TypeRep
rep Request
request
#else
    formatError _ = defaultFormatError
#endif

-- Check that the content type is one of:
--   - application/x-www-form-urlencoded
--   - multipart/form-data; boundary=something
fuzzyMultipartCTCheck :: SBS.ByteString -> DelayedIO ()
fuzzyMultipartCTCheck :: ByteString -> DelayedIO ()
fuzzyMultipartCTCheck ByteString
ct
  | Bool
ctMatches = () -> DelayedIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFailFatal ServerError
err400 {
      errBody :: ByteString
errBody = ByteString
"The content type of the request body is not in application/x-www-form-urlencoded or multipart/form-data"
      }

  where (ByteString
ctype, [Param]
attrs) = ByteString -> (ByteString, [Param])
parseContentType ByteString
ct
        ctMatches :: Bool
ctMatches = case ByteString
ctype of
          ByteString
"application/x-www-form-urlencoded" -> Bool
True
          ByteString
"multipart/form-data" | Just ByteString
_bound <- ByteString -> [Param] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"boundary" [Param]
attrs -> Bool
True
          ByteString
_ -> Bool
False

-- | Global options for configuring how the
--   server should handle multipart data.
--
--   'generalOptions' lets you specify mostly multipart parsing
--   related options, such as the maximum file size, while
--   'backendOptions' lets you configure aspects specific to the chosen
--   backend. Note: there isn't anything to tweak in a memory
--   backend ('Mem'). Maximum file size etc. options are in
--   'ParseRequestBodyOptions'.
--
--   See haddocks for 'ParseRequestBodyOptions' and
--   'TmpBackendOptions' respectively for more information on
--   what you can tweak.
data MultipartOptions tag = MultipartOptions
  { MultipartOptions tag -> ParseRequestBodyOptions
generalOptions        :: ParseRequestBodyOptions
  , MultipartOptions tag -> MultipartBackendOptions tag
backendOptions        :: MultipartBackendOptions tag
  }

class MultipartBackend tag where
    type MultipartResult tag :: *
    type MultipartBackendOptions tag :: *

    backend :: Proxy tag
            -> MultipartBackendOptions tag
            -> InternalState
            -> ignored1
            -> ignored2
            -> 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
data Tmp

-- | Tag for data stored in memory
data Mem

instance MultipartBackend Tmp where
    type MultipartResult Tmp = FilePath
    type MultipartBackendOptions Tmp = TmpBackendOptions

    defaultBackendOptions :: Proxy Tmp -> MultipartBackendOptions Tmp
defaultBackendOptions Proxy Tmp
_ = TmpBackendOptions
MultipartBackendOptions Tmp
defaultTmpBackendOptions
    -- streams the file from disk
    loadFile :: Proxy Tmp -> MultipartResult Tmp -> SourceIO ByteString
loadFile Proxy Tmp
_ MultipartResult Tmp
fp =
        (forall b. (StepT IO ByteString -> IO b) -> IO b)
-> SourceIO ByteString
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
SourceT ((forall b. (StepT IO ByteString -> IO b) -> IO b)
 -> SourceIO ByteString)
-> (forall b. (StepT IO ByteString -> IO b) -> IO b)
-> SourceIO ByteString
forall a b. (a -> b) -> a -> b
$ \StepT IO ByteString -> IO b
k ->
        String -> IOMode -> (Handle -> IO b) -> IO b
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
MultipartResult Tmp
fp IOMode
ReadMode ((Handle -> IO b) -> IO b) -> (Handle -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Handle
hdl ->
        StepT IO ByteString -> IO b
k (Handle -> StepT IO ByteString
readHandle Handle
hdl)
      where
        readHandle :: Handle -> StepT IO ByteString
readHandle Handle
hdl = (ByteString -> Bool) -> IO ByteString -> StepT IO ByteString
forall (m :: * -> *) a.
Functor m =>
(a -> Bool) -> m a -> StepT m a
fromActionStep ByteString -> Bool
LBS.null (Handle -> Int -> IO ByteString
LBS.hGet Handle
hdl Int
4096)
    backend :: Proxy Tmp
-> MultipartBackendOptions Tmp
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO (MultipartResult Tmp)
backend Proxy Tmp
_ MultipartBackendOptions Tmp
opts = InternalState -> ignored1 -> ignored2 -> IO ByteString -> IO String
InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO (MultipartResult Tmp)
tmpBackend
      where
        tmpBackend :: InternalState -> ignored1 -> ignored2 -> IO ByteString -> IO String
tmpBackend = IO String
-> String
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO String
forall ignored1 ignored2.
IO String
-> String
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO String
tempFileBackEndOpts (TmpBackendOptions -> IO String
getTmpDir TmpBackendOptions
MultipartBackendOptions Tmp
opts) (TmpBackendOptions -> String
filenamePat TmpBackendOptions
MultipartBackendOptions Tmp
opts)

instance MultipartBackend Mem where
    type MultipartResult Mem = LBS.ByteString
    type MultipartBackendOptions Mem = ()

    defaultBackendOptions :: Proxy Mem -> MultipartBackendOptions Mem
defaultBackendOptions Proxy Mem
_ = ()
    loadFile :: Proxy Mem -> MultipartResult Mem -> SourceIO ByteString
loadFile Proxy Mem
_ = [ByteString] -> SourceIO ByteString
forall a (m :: * -> *). [a] -> SourceT m a
source ([ByteString] -> SourceIO ByteString)
-> (ByteString -> [ByteString])
-> ByteString
-> SourceIO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    backend :: Proxy Mem
-> MultipartBackendOptions Mem
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO (MultipartResult Mem)
backend Proxy Mem
_ MultipartBackendOptions Mem
_ InternalState
_ = ignored1 -> ignored2 -> IO ByteString -> IO (MultipartResult Mem)
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd

-- | Configuration for the temporary file based backend.
--
--   You can configure the way servant-multipart gets its hands
--   on a temporary directory (defaults to 'getTemporaryDirectory')
--   as well as the filename pattern used for generating the temporary files
--   (defaults to calling them /servant-multipartXXX.buf/, where /XXX/ is some
--   random number).
data TmpBackendOptions = TmpBackendOptions
  { TmpBackendOptions -> IO String
getTmpDir   :: IO FilePath
  , TmpBackendOptions -> String
filenamePat :: String
  }

-- | Default options for the temporary file backend:
--   'getTemporaryDirectory' and "servant-multipart.buf"
defaultTmpBackendOptions :: TmpBackendOptions
defaultTmpBackendOptions :: TmpBackendOptions
defaultTmpBackendOptions = TmpBackendOptions :: IO String -> String -> TmpBackendOptions
TmpBackendOptions
  { getTmpDir :: IO String
getTmpDir = IO String
getTemporaryDirectory
  , filenamePat :: String
filenamePat = String
"servant-multipart.buf"
  }

-- | Default configuration for multipart handling.
--
--   Uses 'defaultParseRequestBodyOptions' and
--   'defaultBackendOptions' respectively.
defaultMultipartOptions :: MultipartBackend tag => Proxy tag -> MultipartOptions tag
defaultMultipartOptions :: Proxy tag -> MultipartOptions tag
defaultMultipartOptions Proxy tag
pTag = MultipartOptions :: forall tag.
ParseRequestBodyOptions
-> MultipartBackendOptions tag -> MultipartOptions tag
MultipartOptions
  { generalOptions :: ParseRequestBodyOptions
generalOptions = ParseRequestBodyOptions
defaultParseRequestBodyOptions
  , backendOptions :: MultipartBackendOptions tag
backendOptions = Proxy tag -> MultipartBackendOptions tag
forall tag.
MultipartBackend tag =>
Proxy tag -> MultipartBackendOptions tag
defaultBackendOptions Proxy tag
pTag
  }

-- Utility class that's like HasContextEntry
-- but allows the lookup to fail, to make a context
-- entry for upload config optional (hence using
-- some default configuration when missing)
class LookupContext ctx a where
  lookupContext :: Proxy a -> Context ctx -> Maybe a

instance LookupContext '[] a where
  lookupContext :: Proxy a -> Context '[] -> Maybe a
lookupContext Proxy a
_ Context '[]
_ = Maybe a
forall a. Maybe a
Nothing

instance {-# OVERLAPPABLE #-}
         LookupContext cs a => LookupContext (c ': cs) a where
  lookupContext :: Proxy a -> Context (c : cs) -> Maybe a
lookupContext Proxy a
p (x
_ :. Context xs
cxts) =
    Proxy a -> Context xs -> Maybe a
forall (ctx :: [*]) a.
LookupContext ctx a =>
Proxy a -> Context ctx -> Maybe a
lookupContext Proxy a
p Context xs
cxts

instance {-# OVERLAPPING #-}
         LookupContext cs a => LookupContext (a ': cs) a where
  lookupContext :: Proxy a -> Context (a : cs) -> Maybe a
lookupContext Proxy a
_ (x
c :. Context xs
_) = x -> Maybe x
forall a. a -> Maybe a
Just x
c

instance HasLink sub => HasLink (MultipartForm tag a :> sub) where
#if MIN_VERSION_servant(0,14,0)
  type MkLink (MultipartForm tag a :> sub) r = MkLink sub r
  toLink :: (Link -> a)
-> Proxy (MultipartForm tag a :> sub)
-> Link
-> MkLink (MultipartForm tag a :> sub) a
toLink Link -> a
toA Proxy (MultipartForm tag a :> sub)
_ = (Link -> a) -> Proxy sub -> Link -> MkLink sub a
forall k (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> a
toA (Proxy sub
forall k (t :: k). Proxy t
Proxy :: Proxy sub)
#else
  type MkLink (MultipartForm tag a :> sub) = MkLink sub
  toLink _ = toLink (Proxy :: Proxy sub)
#endif

-- | The 'ToMultipartSample' class allows you to create sample 'MultipartData'
-- inputs for your type for use with "Servant.Docs".  This is used by the
-- 'HasDocs' instance for 'MultipartForm'.
--
-- Given the example 'User' type and 'FromMultipart' instance above, here is a
-- corresponding 'ToMultipartSample' instance:
--
-- @
--   data User = User { username :: Text, pic :: FilePath }
--
--   instance 'ToMultipartSample' 'Tmp' User where
--     'toMultipartSamples' proxy =
--       [ ( \"sample 1\"
--         , 'MultipartData'
--             [ 'Input' \"username\" \"Elvis Presley\" ]
--             [ 'FileData'
--                 \"pic\"
--                 \"playing_guitar.jpeg\"
--                 \"image/jpeg\"
--                 \"/tmp/servant-multipart000.buf\"
--             ]
--         )
--       ]
-- @
class ToMultipartSample tag a where
  toMultipartSamples :: Proxy a -> [(Text, MultipartData tag)]

-- | Format an 'Input' into a markdown list item.
multipartInputToItem :: Input -> Text
multipartInputToItem :: Input -> Text
multipartInputToItem (Input Text
name Text
val) =
  Text
"        - *" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"

-- | Format a 'FileData' into a markdown list item.
multipartFileToItem :: FileData tag -> Text
multipartFileToItem :: FileData tag -> Text
multipartFileToItem (FileData Text
name Text
_ Text
contentType MultipartResult tag
_) =
  Text
"        - *" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*, content-type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contentType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"

-- | Format a description and a sample 'MultipartData' into a markdown list
-- item.
multipartSampleToDesc
  :: Text -- ^ The description for the sample.
  -> MultipartData tag -- ^ The sample 'MultipartData'.
  -> Text -- ^ A markdown list item.
multipartSampleToDesc :: Text -> MultipartData tag -> Text
multipartSampleToDesc Text
desc (MultipartData [Input]
inputs [FileData tag]
files) =
  Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
  Text
"    - textual inputs (any `<input>` type but file):\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
  (Input -> Text) -> [Input] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Input
input -> Input -> Text
multipartInputToItem Input
input Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") [Input]
inputs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
  Text
"    - file inputs (any HTML input that looks like `<input type=\"file\" name=\"somefile\" />`):\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
  (FileData tag -> Text) -> [FileData tag] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\FileData tag
file -> FileData tag -> Text
forall tag. FileData tag -> Text
multipartFileToItem FileData tag
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") [FileData tag]
files

-- | Format a list of samples generated with 'ToMultipartSample' into sections
-- of markdown.
toMultipartDescriptions
  :: forall tag a.
     ToMultipartSample tag a
  => Proxy tag -> Proxy a -> [Text]
toMultipartDescriptions :: Proxy tag -> Proxy a -> [Text]
toMultipartDescriptions Proxy tag
_ Proxy a
proxyA = ((Text, MultipartData tag) -> Text)
-> [(Text, MultipartData tag)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> MultipartData tag -> Text)
-> (Text, MultipartData tag) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> MultipartData tag -> Text
forall tag. Text -> MultipartData tag -> Text
multipartSampleToDesc) [(Text, MultipartData tag)]
samples
  where
    samples :: [(Text, MultipartData tag)]
    samples :: [(Text, MultipartData tag)]
samples = Proxy a -> [(Text, MultipartData tag)]
forall tag a.
ToMultipartSample tag a =>
Proxy a -> [(Text, MultipartData tag)]
toMultipartSamples Proxy a
proxyA

-- | Create a 'DocNote' that represents samples for this multipart input.
toMultipartNotes
  :: ToMultipartSample tag a
  => Int -> Proxy tag -> Proxy a -> DocNote
toMultipartNotes :: Int -> Proxy tag -> Proxy a -> DocNote
toMultipartNotes Int
maxSamples' Proxy tag
proxyTag Proxy a
proxyA =
  let sampleLines :: [Text]
sampleLines = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
maxSamples' ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Proxy tag -> Proxy a -> [Text]
forall tag a.
ToMultipartSample tag a =>
Proxy tag -> Proxy a -> [Text]
toMultipartDescriptions Proxy tag
proxyTag Proxy a
proxyA
      body :: [Text]
body =
        [ Text
"This endpoint takes `multipart/form-data` requests.  The following is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          Text
"a list of sample requests:"
        , (Text -> Text) -> [Text] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") [Text]
sampleLines
        ]
  in String -> [String] -> DocNote
DocNote String
"Multipart Request Samples" ([String] -> DocNote) -> [String] -> DocNote
forall a b. (a -> b) -> a -> b
$ (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
unpack [Text]
body

-- | Declare an instance of 'ToMultipartSample' for your 'MultipartForm' type
-- to be able to use this 'HasDocs' instance.
instance (HasDocs api, ToMultipartSample tag a) => HasDocs (MultipartForm tag a :> api) where
  docsFor
    :: Proxy (MultipartForm tag a :> api)
    -> (Endpoint, Action)
    -> DocOptions
    -> API
  docsFor :: Proxy (MultipartForm tag a :> api)
-> (Endpoint, Action) -> DocOptions -> API
docsFor Proxy (MultipartForm tag a :> api)
_ (Endpoint
endpoint, Action
action) DocOptions
opts =
    let newAction :: Action
newAction =
          Action
action
            Action -> (Action -> Action) -> Action
forall a b. a -> (a -> b) -> b
& ([DocNote] -> Identity [DocNote]) -> Action -> Identity Action
Lens' Action [DocNote]
notes (([DocNote] -> Identity [DocNote]) -> Action -> Identity Action)
-> [DocNote] -> Action -> Action
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~
                [ Int -> Proxy tag -> Proxy a -> DocNote
forall tag a.
ToMultipartSample tag a =>
Int -> Proxy tag -> Proxy a -> DocNote
toMultipartNotes
                    (Getting Int DocOptions Int -> DocOptions -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int DocOptions Int
Iso' DocOptions Int
maxSamples DocOptions
opts)
                    (Proxy tag
forall k (t :: k). Proxy t
Proxy :: Proxy tag)
                    (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
                ]
    in Proxy api -> (Endpoint, Action) -> DocOptions -> API
forall k (api :: k).
HasDocs api =>
Proxy api -> (Endpoint, Action) -> DocOptions -> API
docsFor (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) (Endpoint
endpoint, Action
newAction) DocOptions
opts

instance (HasForeignType lang ftype a, HasForeign lang ftype api)
      => HasForeign lang ftype (MultipartForm t a :> api) where
  type Foreign ftype (MultipartForm t a :> api) = Foreign ftype api

  foreignFor :: Proxy lang
-> Proxy ftype
-> Proxy (MultipartForm t a :> api)
-> Req ftype
-> Foreign ftype (MultipartForm t a :> api)
foreignFor Proxy lang
lang Proxy ftype
ftype Proxy (MultipartForm t a :> api)
Proxy Req ftype
req =
    Proxy lang
-> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
forall k (lang :: k) ftype api.
HasForeign lang ftype api =>
Proxy lang
-> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
foreignFor Proxy lang
lang Proxy ftype
ftype (Proxy api
forall k (t :: k). Proxy t
Proxy @api) (Req ftype -> Foreign ftype api) -> Req ftype -> Foreign ftype api
forall a b. (a -> b) -> a -> b
$
      Req ftype
req Req ftype -> (Req ftype -> Req ftype) -> Req ftype
forall a b. a -> (a -> b) -> b
& (Maybe ftype -> Identity (Maybe ftype))
-> Req ftype -> Identity (Req ftype)
forall f. Lens' (Req f) (Maybe f)
reqBody ((Maybe ftype -> Identity (Maybe ftype))
 -> Req ftype -> Identity (Req ftype))
-> Maybe ftype -> Req ftype -> Req ftype
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ftype -> Maybe ftype
forall a. a -> Maybe a
Just ftype
t
          Req ftype -> (Req ftype -> Req ftype) -> Req ftype
forall a b. a -> (a -> b) -> b
& (ReqBodyContentType -> Identity ReqBodyContentType)
-> Req ftype -> Identity (Req ftype)
forall f. Lens' (Req f) ReqBodyContentType
reqBodyContentType ((ReqBodyContentType -> Identity ReqBodyContentType)
 -> Req ftype -> Identity (Req ftype))
-> ReqBodyContentType -> Req ftype -> Req ftype
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReqBodyContentType
ReqBodyMultipart
    where
      t :: ftype
t = Proxy lang -> Proxy ftype -> Proxy a -> ftype
forall k k1 (lang :: k) ftype (a :: k1).
HasForeignType lang ftype a =>
Proxy lang -> Proxy ftype -> Proxy a -> ftype
typeFor Proxy lang
lang Proxy ftype
ftype (Proxy a
forall k (t :: k). Proxy t
Proxy @a)