{-# 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 #-}
module Servant.Multipart
( MultipartForm
, MultipartForm'
, MultipartData(..)
, FromMultipart(..)
, lookupInput
, lookupFile
, MultipartOptions(..)
, defaultMultipartOptions
, MultipartBackend(..)
, Tmp
, TmpBackendOptions(..)
, Mem
, defaultTmpBackendOptions
, Input(..)
, FileData(..)
, genBoundary
, ToMultipart(..)
, multipartToBody
, 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
type MultipartForm tag a = MultipartForm' '[] tag a
data MultipartForm' (mods :: [*]) tag a
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 (inputs :: [Param]
inputs, files :: [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 (\(name :: ByteString
name, val :: 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 (iname :: ByteString
iname, fileinfo :: 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
data FileData tag = FileData
{ FileData tag -> Text
fdInputName :: Text
, FileData tag -> Text
fdFileName :: Text
, FileData tag -> Text
fdFileCType :: Text
, FileData tag -> MultipartResult tag
fdPayload :: MultipartResult tag
}
deriving instance Eq (MultipartResult tag) => Eq (FileData tag)
deriving instance Show (MultipartResult tag) => Show (FileData tag)
lookupFile :: Text -> MultipartData tag -> Either String (FileData tag)
lookupFile :: Text -> MultipartData tag -> Either String (FileData tag)
lookupFile iname :: 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
$ "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
<> " 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
data Input = Input
{ Input -> Text
iName :: Text
, Input -> Text
iValue :: Text
} 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)
lookupInput :: Text -> MultipartData tag -> Either String Text
lookupInput :: Text -> MultipartData tag -> Either String Text
lookupInput iname :: 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
$ "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
<> " 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
class FromMultipart tag a where
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
class ToMultipart tag a where
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
instance ( FromMultipart tag a
, MultipartBackend tag
, LookupContext config (MultipartOptions tag)
, 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 _ pc :: Proxy config
pc nt :: forall x. m x -> n x
nt s :: 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 config :: Context config
config subserver :: 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
-> Delayed
env (If (FoldLenient mods) (Either String a) a -> Server sublayout)
-> Delayed env (Server sublayout)
forall tag multipart (mods :: [*]) env a.
(FromMultipart tag multipart, MultipartBackend tag,
SBoolI (FoldLenient mods)) =>
Proxy tag
-> MultipartOptions tag
-> Delayed
env
(If (FoldLenient mods) (Either String multipart) multipart -> a)
-> Delayed env a
addMultipartHandling @tag @a @mods Proxy tag
forall b. Proxy b
pbak MultipartOptions tag
multipartOpts Delayed env (Server (MultipartForm' mods tag a :> sublayout))
Delayed
env (If (FoldLenient mods) (Either String a) a -> Server sublayout)
subserver
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 pm :: Proxy m
pm _ req :: Request
req (boundary :: ByteString
boundary, param :: 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 = "multipart" ByteString -> ByteString -> MediaType
// "form-data" MediaType -> Param -> MediaType
/: ("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 pm :: Proxy m
pm _ f :: forall x. mon x -> mon' x
f cl :: Client mon (MultipartForm' mods tag a :> api)
cl = \a :: (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)
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
indices :: IO [Int]
indices = Int -> IO Int -> IO [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM 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 (0,61)
validChars :: Array Int Word8
validChars = (Int, Int) -> [Word8] -> Array Int Word8
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (0 :: Int, 61)
[ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37
, 0x38, 0x39, 0x41, 0x42
, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a
, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50, 0x51, 0x52
, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a
, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68
, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70
, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78
, 0x79, 0x7a
]
multipartToBody :: forall tag.
MultipartBackend tag
=> LBS.ByteString
-> MultipartData tag
-> RequestBody
multipartToBody :: ByteString -> MultipartData tag -> RequestBody
multipartToBody boundary :: ByteString
boundary mp :: 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
boundary, "--"]
where
(SourceT l :: forall b. (StepT m a -> m b) -> m b
l) mappend' :: SourceT m a -> SourceT m a -> SourceT m a
`mappend'` (SourceT r :: 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
$ \k :: 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
$ \lstep :: 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
$ \rstep :: 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 Stop r :: StepT m a
r = StepT m a
r
appendStep (Error err :: String
err) _ = String -> StepT m a
forall (m :: * -> *) a. String -> StepT m a
Error String
err
appendStep (Skip s :: StepT m a
s) r :: StepT m a
r = StepT m a -> StepT m a -> StepT m a
appendStep StepT m a
s StepT m a
r
appendStep (Yield x :: a
x s :: StepT m a
s) r :: 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 ms :: m (StepT m a)
ms) r :: 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 = "\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
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)
"text/plain"
""
([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' (\acc :: SourceIO ByteString
acc x :: 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 file :: 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)
-> (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 "; 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' (\acc :: SourceIO ByteString
acc x :: 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 name :: ByteString
name contentType :: ByteString
contentType extraParams :: ByteString
extraParams payload :: SourceIO ByteString
payload =
[ByteString] -> SourceIO ByteString
forall a (m :: * -> *). [a] -> SourceT m a
source [ "--"
, ByteString
boundary
, ByteString
crlf
, "Content-Disposition: form-data; name=\""
, ByteString
name
, "\""
, ByteString
extraParams
, ByteString
crlf
, "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]
check :: MultipartBackend tag
=> Proxy tag
-> MultipartOptions tag
-> DelayedIO (MultipartData tag)
check :: Proxy tag -> MultipartOptions tag -> DelayedIO (MultipartData tag)
check pTag :: Proxy tag
pTag tag :: 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
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
addMultipartHandling :: forall tag multipart (mods :: [*]) env a. (FromMultipart tag multipart, MultipartBackend tag)
=> SBoolI (FoldLenient mods)
=> Proxy tag
-> MultipartOptions tag
-> Delayed env (If (FoldLenient mods) (Either String multipart) multipart -> a)
-> Delayed env a
addMultipartHandling :: Proxy tag
-> MultipartOptions tag
-> Delayed
env
(If (FoldLenient mods) (Either String multipart) multipart -> a)
-> Delayed env a
addMultipartHandling pTag :: Proxy tag
pTag opts :: MultipartOptions tag
opts subserver :: 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
request ->
ByteString -> DelayedIO ()
fuzzyMultipartCTCheck (Request -> ByteString
contentTypeH Request
request)
bodyCheck :: ()
-> DelayedIO
(If (FoldLenient mods) (Either String multipart) multipart)
bodyCheck () = 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
(SFalse, Left msg :: 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
err400 { errBody :: ByteString
errBody = "Could not decode multipart mime body: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
msg }
(SFalse, Right x :: multipart
x) -> multipart -> DelayedIO multipart
forall (m :: * -> *) a. Monad m => a -> m a
return multipart
x
(STrue, res :: Either String multipart
res) -> Either String multipart
-> DelayedIO
(If (FoldLenient mods) (Either String multipart) multipart)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String multipart
-> DelayedIO
(If (FoldLenient mods) (Either String multipart) multipart))
-> Either String multipart
-> DelayedIO
(If (FoldLenient mods) (Either String multipart) 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 req :: Request
req = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe "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 "Content-Type" (Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)
fuzzyMultipartCTCheck :: SBS.ByteString -> DelayedIO ()
fuzzyMultipartCTCheck :: ByteString -> DelayedIO ()
fuzzyMultipartCTCheck ct :: 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 = "The content type of the request body is not in application/x-www-form-urlencoded or multipart/form-data"
}
where (ctype :: ByteString
ctype, attrs :: [Param]
attrs) = ByteString -> (ByteString, [Param])
parseContentType ByteString
ct
ctMatches :: Bool
ctMatches = case ByteString
ctype of
"application/x-www-form-urlencoded" -> Bool
True
"multipart/form-data" | Just _bound :: ByteString
_bound <- ByteString -> [Param] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "boundary" [Param]
attrs -> Bool
True
_ -> Bool
False
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
data Tmp
data Mem
instance MultipartBackend Tmp where
type MultipartResult Tmp = FilePath
type MultipartBackendOptions Tmp = TmpBackendOptions
defaultBackendOptions :: Proxy Tmp -> MultipartBackendOptions Tmp
defaultBackendOptions _ = TmpBackendOptions
MultipartBackendOptions Tmp
defaultTmpBackendOptions
loadFile :: Proxy Tmp -> MultipartResult Tmp -> SourceIO ByteString
loadFile _ fp :: 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
$ \k :: 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
$ \hdl :: Handle
hdl ->
StepT IO ByteString -> IO b
k (Handle -> StepT IO ByteString
readHandle Handle
hdl)
where
readHandle :: Handle -> StepT IO ByteString
readHandle hdl :: 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 4096)
backend :: Proxy Tmp
-> MultipartBackendOptions Tmp
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO (MultipartResult Tmp)
backend _ opts :: 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 _ = ()
loadFile :: Proxy Mem -> MultipartResult Mem -> SourceIO ByteString
loadFile _ = [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 _ _ _ = ignored1 -> ignored2 -> IO ByteString -> IO (MultipartResult Mem)
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd
data TmpBackendOptions = TmpBackendOptions
{ TmpBackendOptions -> IO String
getTmpDir :: IO FilePath
, TmpBackendOptions -> String
filenamePat :: String
}
defaultTmpBackendOptions :: TmpBackendOptions
defaultTmpBackendOptions :: TmpBackendOptions
defaultTmpBackendOptions = TmpBackendOptions :: IO String -> String -> TmpBackendOptions
TmpBackendOptions
{ getTmpDir :: IO String
getTmpDir = IO String
getTemporaryDirectory
, filenamePat :: String
filenamePat = "servant-multipart.buf"
}
defaultMultipartOptions :: MultipartBackend tag => Proxy tag -> MultipartOptions tag
defaultMultipartOptions :: Proxy tag -> MultipartOptions tag
defaultMultipartOptions pTag :: 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
}
class LookupContext ctx a where
lookupContext :: Proxy a -> Context ctx -> Maybe a
instance LookupContext '[] a where
lookupContext :: Proxy a -> Context '[] -> Maybe a
lookupContext _ _ = 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 p :: Proxy a
p (_ :. cxts :: 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 _ (c :: x
c :. _) = 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 toA :: Link -> a
toA _ = (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
class ToMultipartSample tag a where
toMultipartSamples :: Proxy a -> [(Text, MultipartData tag)]
multipartInputToItem :: Input -> Text
multipartInputToItem :: Input -> Text
multipartInputToItem (Input name :: Text
name val :: Text
val) =
" - *" 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
forall a. Semigroup a => a -> a -> a
<> "`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`"
multipartFileToItem :: FileData tag -> Text
multipartFileToItem :: FileData tag -> Text
multipartFileToItem (FileData name :: Text
name _ contentType :: Text
contentType _) =
" - *" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "*, content-type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contentType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`"
multipartSampleToDesc
:: Text
-> MultipartData tag
-> Text
multipartSampleToDesc :: Text -> MultipartData tag -> Text
multipartSampleToDesc desc :: Text
desc (MultipartData inputs :: [Input]
inputs files :: [FileData tag]
files) =
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
" - 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 -> Input -> Text
multipartInputToItem Input
input Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n") [Input]
inputs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
" - 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 (\file :: 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
<> "\n") [FileData tag]
files
toMultipartDescriptions
:: forall tag a.
ToMultipartSample tag a
=> Proxy tag -> Proxy a -> [Text]
toMultipartDescriptions :: Proxy tag -> Proxy a -> [Text]
toMultipartDescriptions _ proxyA :: 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
toMultipartNotes
:: ToMultipartSample tag a
=> Int -> Proxy tag -> Proxy a -> DocNote
toMultipartNotes :: Int -> Proxy tag -> Proxy a -> DocNote
toMultipartNotes maxSamples' :: Int
maxSamples' proxyTag :: Proxy tag
proxyTag proxyA :: 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 =
[ "This endpoint takes `multipart/form-data` requests. The following is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
"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
<> "\n") [Text]
sampleLines
]
in String -> [String] -> DocNote
DocNote "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
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 _ (endpoint :: Endpoint
endpoint, action :: Action
action) opts :: 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. Monoid 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 lang :: Proxy lang
lang ftype :: Proxy ftype
ftype Proxy req :: 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 (MultipartForm t a :> api))
-> Req ftype -> Foreign ftype (MultipartForm t a :> 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)