{-# 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@ server-side support for servant.
--   See servant-multipart-api for the API definitions.
module Servant.Multipart
  ( MultipartForm
  , MultipartForm'
  , MultipartData(..)
  , FromMultipart(..)
  , lookupInput
  , lookupFile
  , MultipartOptions(..)
  , defaultMultipartOptions
  , MultipartBackend(..)
  , Tmp
  , TmpBackendOptions(..)
  , Mem
  , defaultTmpBackendOptions
  , Input(..)
  , FileData(..)
  -- * servant-docs
  , ToMultipartSample(..)
  ) where

import Servant.Multipart.API

import Control.Lens ((<>~), (&), view, (.~))
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.List (find)
import Data.Maybe
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.String.Conversions (cs)
import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8)
import Data.Typeable
import Network.Wai
import Network.Wai.Parse
import Servant hiding (contentType)
import Servant.API.Modifiers (FoldLenient)
import Servant.Docs hiding (samples)
import Servant.Foreign hiding (contentType)
import Servant.Server.Internal
import System.Directory

import qualified Data.ByteString      as SBS

-- | Lookup a textual input with the given @name@ attribute.
lookupInput :: Text -> MultipartData tag -> Either String Text
lookupInput :: forall tag. 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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
iname String -> String -> String
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

-- | Lookup a file input with the given @name@ attribute.
lookupFile :: Text -> MultipartData tag -> Either String (FileData tag)
lookupFile :: forall tag.
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
iname String -> String -> String
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

fromRaw :: forall tag. ([Network.Wai.Parse.Param], [File (MultipartResult tag)])
        -> MultipartData tag
fromRaw :: forall tag.
([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

class MultipartBackend tag where
    type MultipartBackendOptions tag :: *

    backend :: Proxy tag
            -> MultipartBackendOptions tag
            -> InternalState
            -> ignored1
            -> ignored2
            -> IO SBS.ByteString
            -> IO (MultipartResult tag)

    defaultBackendOptions :: Proxy tag -> MultipartBackendOptions tag

-- | 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 :: forall (m :: * -> *) (n :: * -> *).
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
forall (m :: * -> *) (n :: * -> *).
Proxy sublayout
-> Proxy config
-> (forall x. m x -> n x)
-> ServerT sublayout m
-> ServerT sublayout n
hoistServerWithContext (Proxy sublayout
forall {k} (t :: k). Proxy t
Proxy :: Proxy sublayout) Proxy config
pc m x -> n x
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 :: forall env.
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 env.
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  = Proxy b
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' = 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

-- 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 :: forall tag.
MultipartBackend tag =>
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 a. ResourceT IO a -> DelayedIO a
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 a. IO a -> DelayedIO a
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)
forall ignored1 ignored2.
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 a. a -> DelayedIO a
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 :: 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 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), 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) -> If (FoldLenient mods) (Either String multipart) multipart
-> DelayedIO
     (If (FoldLenient mods) (Either String multipart) multipart)
forall a. a -> DelayedIO a
forall (m :: * -> *) a. Monad m => a -> m a
return multipart
If (FoldLenient mods) (Either String multipart) multipart
x
        (SBool (FoldLenient mods)
STrue, Either String multipart
res) -> If (FoldLenient mods) (Either String multipart) multipart
-> DelayedIO
     (If (FoldLenient mods) (Either String multipart) multipart)
forall a. a -> DelayedIO a
forall (m :: * -> *) a. Monad m => a -> m a
return (If (FoldLenient mods) (Either String multipart) multipart
 -> DelayedIO
      (If (FoldLenient mods) (Either String multipart) multipart))
-> If (FoldLenient mods) (Either String multipart) multipart
-> DelayedIO
     (If (FoldLenient mods) (Either String multipart) multipart)
forall a b. (a -> b) -> a -> b
$ (String
 -> If (FoldLenient mods) (Either String multipart) multipart)
-> (multipart
    -> If (FoldLenient mods) (Either String multipart) multipart)
-> Either String multipart
-> If (FoldLenient mods) (Either String multipart) multipart
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String multipart
String -> If (FoldLenient mods) (Either String multipart) multipart
forall a b. a -> Either a b
Left (String
 -> If (FoldLenient mods) (Either String multipart) multipart)
-> (String -> String)
-> String
-> If (FoldLenient mods) (Either String multipart) multipart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a b. ConvertibleStrings a b => a -> b
cs) multipart -> Either String multipart
multipart
-> If (FoldLenient mods) (Either String multipart) 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 = "Could not decode multipart mime body: " <> cs 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 a. a -> DelayedIO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFailFatal ServerError
err400 {
      errBody = "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
  { forall tag. MultipartOptions tag -> ParseRequestBodyOptions
generalOptions        :: ParseRequestBodyOptions
  , forall tag. MultipartOptions tag -> MultipartBackendOptions tag
backendOptions        :: MultipartBackendOptions tag
  }

instance MultipartBackend Tmp where
    type MultipartBackendOptions Tmp = TmpBackendOptions

    defaultBackendOptions :: Proxy Tmp -> MultipartBackendOptions Tmp
defaultBackendOptions Proxy Tmp
_ = TmpBackendOptions
MultipartBackendOptions Tmp
defaultTmpBackendOptions
    backend :: forall ignored1 ignored2.
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 MultipartBackendOptions Mem = ()

    defaultBackendOptions :: Proxy Mem -> MultipartBackendOptions Mem
defaultBackendOptions Proxy Mem
_ = ()
    backend :: forall ignored1 ignored2.
Proxy Mem
-> MultipartBackendOptions Mem
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO (MultipartResult Mem)
backend Proxy Mem
_ MultipartBackendOptions Mem
_ InternalState
_ = ignored1 -> ignored2 -> IO ByteString -> IO ByteString
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
  { 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 :: forall tag.
MultipartBackend tag =>
Proxy tag -> MultipartOptions tag
defaultMultipartOptions Proxy tag
pTag = 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
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
c

-- | 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 :: forall tag. 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 :: forall tag. 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 m a. Monoid m => (a -> m) -> [a] -> m
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 m a. Monoid m => (a -> m) -> [a] -> m
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 :: forall tag a.
ToMultipartSample tag a =>
Proxy tag -> Proxy a -> [Text]
toMultipartDescriptions Proxy tag
_ Proxy a
proxyA = ((Text, MultipartData tag) -> Text)
-> [(Text, MultipartData tag)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
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 :: forall tag a.
ToMultipartSample tag a =>
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. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          Text
"The following is a list of sample requests:"
        , (Text -> Text) -> [Text] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
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 a b. (a -> b) -> [a] -> [b]
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 (forall {b}. Proxy b
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 ftype (f :: * -> *).
Functor f =>
(Maybe ftype -> f (Maybe ftype)) -> Req ftype -> f (Req ftype)
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 ftype (f :: * -> *).
Functor f =>
(ReqBodyContentType -> f ReqBodyContentType)
-> Req ftype -> f (Req ftype)
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 (forall {b}. Proxy b
forall {k} (t :: k). Proxy t
Proxy @a)