{-# LANGUAGE OverloadedStrings #-}
-- | This module handles building multipart/form-data. Example usage:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > import Network
-- > import Network.HTTP.Client
-- > import Network.HTTP.Client.MultipartFormData
-- >
-- > import Data.Text.Encoding as TE
-- >
-- > import Control.Monad
-- >
-- > main = void $ withManager defaultManagerSettings $ \m -> do
-- >     req1 <- parseRequest "http://random-cat-photo.net/cat.jpg"
-- >     res <- httpLbs req1 m
-- >     req2 <- parseRequest "http://example.org/~friedrich/blog/addPost.hs"
-- >     flip httpLbs m =<<
-- >         (formDataBody [partBS "title" "Bleaurgh"
-- >                       ,partBS "text" $ TE.encodeUtf8 "矢田矢田矢田矢田矢田"
-- >                       ,partFileSource "file1" "/home/friedrich/Photos/MyLittlePony.jpg"
-- >                       ,partFileRequestBody "file2" "cat.jpg" $ RequestBodyLBS $ responseBody res]
-- >             req2)
module Network.HTTP.Client.MultipartFormData
    (
    -- * Part type
     Part
    ,PartM
    ,partName
    ,partFilename
    ,partContentType
    ,partHeaders
    ,partGetBody
    -- * Constructing parts
    ,partBS
    ,partLBS
    ,partFile
    ,partFileSource
    ,partFileSourceChunked
    ,partFileRequestBody
    ,partFileRequestBodyM
    -- * Headers
    ,addPartHeaders
    -- * Building form data
    ,formDataBody
    ,formDataBodyWithBoundary
    -- * Boundary
    ,webkitBoundary
    ,webkitBoundaryPure
    -- * Misc
    ,renderParts
    ,renderPart
    ) where

import Network.HTTP.Client hiding (streamFile)
import Network.Mime
import Network.HTTP.Types (hContentType, methodPost, Header())
import Data.Monoid ((<>))
import Data.Foldable (foldMap)

import Blaze.ByteString.Builder

import Data.Text
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS

import qualified Data.CaseInsensitive as CI

import Control.Monad.Trans.State.Strict (state, runState)
import Control.Monad.IO.Class
import System.FilePath
import System.Random
import Data.Array.Base
import System.IO
import Data.Bits
import Data.Word
import Data.Monoid (Monoid(..))
import Control.Monad
import Data.ByteString.Lazy.Internal (defaultChunkSize)

type Part = PartM IO

-- | A single part of a multipart message.
data PartM m = Part
    { PartM m -> Text
partName :: Text -- ^ Name of the corresponding \<input\>
    , PartM m -> Maybe String
partFilename :: Maybe String -- ^ A file name, if this is an attached file
    , PartM m -> Maybe MimeType
partContentType :: Maybe MimeType -- ^ Content type
    , PartM m -> [Header]
partHeaders :: [Header] -- ^ List of additional headers
    , PartM m -> m RequestBody
partGetBody :: m RequestBody -- ^ Action in m which returns the body
                                   -- of a message.
    }

instance Show (PartM m) where
    showsPrec :: Int -> PartM m -> ShowS
showsPrec d :: Int
d (Part n :: Text
n f :: Maybe String
f c :: Maybe MimeType
c h :: [Header]
h _) =
        Bool -> ShowS -> ShowS
showParen (Int
dInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=11) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString "Part "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 Text
n
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 Maybe String
f
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe MimeType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 Maybe MimeType
c
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Header] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 [Header]
h
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "<m (RequestBody m)>"

-- | Make a 'Part' whose content is a strict 'BS.ByteString'.
--
-- The 'Part' does not have a file name or content type associated
-- with it.
partBS :: Applicative m
       => Text              -- ^ Name of the corresponding \<input\>.
       -> BS.ByteString     -- ^ The body for this 'Part'.
       -> PartM m
partBS :: Text -> MimeType -> PartM m
partBS n :: Text
n b :: MimeType
b = Text
-> Maybe String
-> Maybe MimeType
-> [Header]
-> m RequestBody
-> PartM m
forall (m :: * -> *).
Text
-> Maybe String
-> Maybe MimeType
-> [Header]
-> m RequestBody
-> PartM m
Part Text
n Maybe String
forall a. Monoid a => a
Data.Monoid.mempty Maybe MimeType
forall a. Monoid a => a
mempty [Header]
forall a. Monoid a => a
mempty (m RequestBody -> PartM m) -> m RequestBody -> PartM m
forall a b. (a -> b) -> a -> b
$ RequestBody -> m RequestBody
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestBody -> m RequestBody) -> RequestBody -> m RequestBody
forall a b. (a -> b) -> a -> b
$ MimeType -> RequestBody
RequestBodyBS MimeType
b

-- | Make a 'Part' whose content is a lazy 'BL.ByteString'.
--
-- The 'Part' does not have a file name or content type associated
-- with it.
partLBS :: Applicative m
        => Text             -- ^ Name of the corresponding \<input\>.
        -> BL.ByteString    -- ^ The body for this 'Part'.
        -> PartM m
partLBS :: Text -> ByteString -> PartM m
partLBS n :: Text
n b :: ByteString
b = Text
-> Maybe String
-> Maybe MimeType
-> [Header]
-> m RequestBody
-> PartM m
forall (m :: * -> *).
Text
-> Maybe String
-> Maybe MimeType
-> [Header]
-> m RequestBody
-> PartM m
Part Text
n Maybe String
forall a. Monoid a => a
mempty Maybe MimeType
forall a. Monoid a => a
mempty [Header]
forall a. Monoid a => a
mempty (m RequestBody -> PartM m) -> m RequestBody -> PartM m
forall a b. (a -> b) -> a -> b
$ RequestBody -> m RequestBody
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestBody -> m RequestBody) -> RequestBody -> m RequestBody
forall a b. (a -> b) -> a -> b
$ ByteString -> RequestBody
RequestBodyLBS ByteString
b

-- | Make a 'Part' from a file.
--
-- The entire file will reside in memory at once.  If you want
-- constant memory usage, use 'partFileSource'.
--
-- The 'FilePath' supplied will be used as the file name of the
-- 'Part'. If you do not want to reveal this name to the server, you
-- must remove it prior to uploading.
--
-- The 'Part' does not have a content type associated with it.
partFile :: Text            -- ^ Name of the corresponding \<input\>.
         -> FilePath        -- ^ The name of the local file to upload.
         -> Part
partFile :: Text -> String -> Part
partFile n :: Text
n f :: String
f =
    Text -> String -> IO RequestBody -> Part
forall (m :: * -> *). Text -> String -> m RequestBody -> PartM m
partFileRequestBodyM Text
n String
f (IO RequestBody -> Part) -> IO RequestBody -> Part
forall a b. (a -> b) -> a -> b
$ do
        (MimeType -> RequestBody) -> IO MimeType -> IO RequestBody
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM MimeType -> RequestBody
RequestBodyBS (IO MimeType -> IO RequestBody) -> IO MimeType -> IO RequestBody
forall a b. (a -> b) -> a -> b
$ IO MimeType -> IO MimeType
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MimeType -> IO MimeType) -> IO MimeType -> IO MimeType
forall a b. (a -> b) -> a -> b
$ String -> IO MimeType
BS.readFile String
f

-- | Stream a 'Part' from a file.
--
-- The 'FilePath' supplied will be used as the file name of the
-- 'Part'. If you do not want to reveal this name to the server, you
-- must remove it prior to uploading.
--
-- The 'Part' does not have a content type associated with it.
partFileSource :: Text      -- ^ Name of the corresponding \<input\>.
               -> FilePath  -- ^ The name of the local file to upload.
               -> Part
partFileSource :: Text -> String -> Part
partFileSource n :: Text
n f :: String
f =
    Text -> String -> IO RequestBody -> Part
forall (m :: * -> *). Text -> String -> m RequestBody -> PartM m
partFileRequestBodyM Text
n String
f (IO RequestBody -> Part) -> IO RequestBody -> Part
forall a b. (a -> b) -> a -> b
$ do
        Integer
size <- IO Integer -> IO Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> IO Integer) -> IO Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO Integer) -> IO Integer
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
f IOMode
ReadMode Handle -> IO Integer
hFileSize
        RequestBody -> IO RequestBody
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestBody -> IO RequestBody) -> RequestBody -> IO RequestBody
forall a b. (a -> b) -> a -> b
$ Int64 -> GivesPopper () -> RequestBody
RequestBodyStream (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
size) (GivesPopper () -> RequestBody) -> GivesPopper () -> RequestBody
forall a b. (a -> b) -> a -> b
$ String -> GivesPopper ()
streamFile String
f

streamFile :: FilePath -> GivesPopper ()
streamFile :: String -> GivesPopper ()
streamFile fp :: String
fp np :: NeedsPopper ()
np =
    String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ NeedsPopper ()
np NeedsPopper () -> (Handle -> IO MimeType) -> Handle -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO MimeType
go
  where
    go :: Handle -> IO MimeType
go h :: Handle
h = Handle -> Int -> IO MimeType
BS.hGetSome Handle
h Int
defaultChunkSize

-- | 'partFileSourceChunked' will read a file and send it in chunks.
--
-- Note that not all servers support this. Only use 'partFileSourceChunked'
-- if you know the server you're sending to supports chunked request bodies.
--
-- The 'FilePath' supplied will be used as the file name of the
-- 'Part'. If you do not want to reveal this name to the server, you
-- must remove it prior to uploading.
--
-- The 'Part' does not have a content type associated with it.
partFileSourceChunked :: Text -> FilePath -> Part
partFileSourceChunked :: Text -> String -> Part
partFileSourceChunked n :: Text
n f :: String
f =
    Text -> String -> RequestBody -> Part
forall (m :: * -> *).
Applicative m =>
Text -> String -> RequestBody -> PartM m
partFileRequestBody Text
n String
f (RequestBody -> Part) -> RequestBody -> Part
forall a b. (a -> b) -> a -> b
$ do
        GivesPopper () -> RequestBody
RequestBodyStreamChunked (GivesPopper () -> RequestBody) -> GivesPopper () -> RequestBody
forall a b. (a -> b) -> a -> b
$ String -> GivesPopper ()
streamFile String
f

-- | Construct a 'Part' from form name, filepath and a 'RequestBody'
--
-- > partFileRequestBody "who_calls" "caller.json" $ RequestBodyBS "{\"caller\":\"Jason J Jason\"}"
--
-- > -- empty upload form
-- > partFileRequestBody "file" mempty mempty
--
-- The 'Part' does not have a content type associated with it.
partFileRequestBody :: Applicative m
                    => Text        -- ^ Name of the corresponding \<input\>.
                    -> FilePath    -- ^ File name to supply to the server.
                    -> RequestBody -- ^ Data to upload.
                    -> PartM m
partFileRequestBody :: Text -> String -> RequestBody -> PartM m
partFileRequestBody n :: Text
n f :: String
f rqb :: RequestBody
rqb =
    Text -> String -> m RequestBody -> PartM m
forall (m :: * -> *). Text -> String -> m RequestBody -> PartM m
partFileRequestBodyM Text
n String
f (m RequestBody -> PartM m) -> m RequestBody -> PartM m
forall a b. (a -> b) -> a -> b
$ RequestBody -> m RequestBody
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequestBody
rqb

-- | Construct a 'Part' from action returning the 'RequestBody'
--
-- > partFileRequestBodyM "cat_photo" "haskell-the-cat.jpg" $ do
-- >     size <- fromInteger <$> withBinaryFile "haskell-the-cat.jpg" ReadMode hFileSize
-- >     return $ RequestBodySource size $ CB.sourceFile "haskell-the-cat.jpg" $= CL.map fromByteString
--
-- The 'Part' does not have a content type associated with it.
partFileRequestBodyM :: Text        -- ^ Name of the corresponding \<input\>.
                     -> FilePath    -- ^ File name to supply to the server.
                     -> m RequestBody -- ^ Action that will supply data to upload.
                     -> PartM m
partFileRequestBodyM :: Text -> String -> m RequestBody -> PartM m
partFileRequestBodyM n :: Text
n f :: String
f rqb :: m RequestBody
rqb =
    Text
-> Maybe String
-> Maybe MimeType
-> [Header]
-> m RequestBody
-> PartM m
forall (m :: * -> *).
Text
-> Maybe String
-> Maybe MimeType
-> [Header]
-> m RequestBody
-> PartM m
Part Text
n (String -> Maybe String
forall a. a -> Maybe a
Just String
f) (MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
f) [Header]
forall a. Monoid a => a
mempty m RequestBody
rqb

{-# INLINE cp #-}
cp :: BS.ByteString -> RequestBody
cp :: MimeType -> RequestBody
cp bs :: MimeType
bs = Int64 -> Builder -> RequestBody
RequestBodyBuilder (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ MimeType -> Int
BS.length MimeType
bs) (Builder -> RequestBody) -> Builder -> RequestBody
forall a b. (a -> b) -> a -> b
$ MimeType -> Builder
copyByteString MimeType
bs

-- | Add a list of additional headers to this 'Part'.
addPartHeaders :: PartM m -> [Header] -> PartM m
addPartHeaders :: PartM m -> [Header] -> PartM m
addPartHeaders p :: PartM m
p hs :: [Header]
hs = PartM m
p { partHeaders :: [Header]
partHeaders = PartM m -> [Header]
forall (m :: * -> *). PartM m -> [Header]
partHeaders PartM m
p [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
hs }

renderPart :: Functor m
           => BS.ByteString     -- ^ Boundary between parts.
           -> PartM m -> m RequestBody
renderPart :: MimeType -> PartM m -> m RequestBody
renderPart boundary :: MimeType
boundary (Part name :: Text
name mfilename :: Maybe String
mfilename mcontenttype :: Maybe MimeType
mcontenttype hdrs :: [Header]
hdrs get :: m RequestBody
get) = RequestBody -> RequestBody
render (RequestBody -> RequestBody) -> m RequestBody -> m RequestBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m RequestBody
get
  where render :: RequestBody -> RequestBody
render renderBody :: RequestBody
renderBody =
            MimeType -> RequestBody
cp "--" RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp MimeType
boundary RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp "\r\n"
         RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp "Content-Disposition: form-data; name=\""
         RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
RequestBodyBS (Text -> MimeType
TE.encodeUtf8 Text
name)
         RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> (case Maybe String
mfilename of
                 Just f :: String
f -> MimeType -> RequestBody
cp "\"; filename=\""
                        RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
RequestBodyBS (Text -> MimeType
TE.encodeUtf8 (Text -> MimeType) -> Text -> MimeType
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
f)
                 _ -> RequestBody
forall a. Monoid a => a
mempty)
         RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp "\""
         RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> (case Maybe MimeType
mcontenttype of
                Just ct :: MimeType
ct -> MimeType -> RequestBody
cp "\r\n"
                        RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp "Content-Type: "
                        RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp MimeType
ct
                _ -> RequestBody
forall a. Monoid a => a
mempty)
         RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> (Header -> RequestBody) -> [Header] -> RequestBody
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Data.Foldable.foldMap (\(k :: CI MimeType
k, v :: MimeType
v) ->
               MimeType -> RequestBody
cp "\r\n"
            RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp (CI MimeType -> MimeType
forall s. CI s -> s
CI.original CI MimeType
k)
            RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp ": "
            RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp MimeType
v) [Header]
hdrs
         RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp "\r\n\r\n"
         RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> RequestBody
renderBody RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp "\r\n"

-- | Combine the 'Part's to form multipart/form-data body
renderParts :: Applicative m
            => BS.ByteString    -- ^ Boundary between parts.
            -> [PartM m] -> m RequestBody
renderParts :: MimeType -> [PartM m] -> m RequestBody
renderParts boundary :: MimeType
boundary parts :: [PartM m]
parts = (RequestBody -> RequestBody
fin (RequestBody -> RequestBody)
-> ([RequestBody] -> RequestBody) -> [RequestBody] -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RequestBody] -> RequestBody
forall a. Monoid a => [a] -> a
mconcat) ([RequestBody] -> RequestBody) -> m [RequestBody] -> m RequestBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PartM m -> m RequestBody) -> [PartM m] -> m [RequestBody]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (MimeType -> PartM m -> m RequestBody
forall (m :: * -> *).
Functor m =>
MimeType -> PartM m -> m RequestBody
renderPart MimeType
boundary) [PartM m]
parts
  where fin :: RequestBody -> RequestBody
fin = (RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp "--" RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp MimeType
boundary RequestBody -> RequestBody -> RequestBody
forall a. Semigroup a => a -> a -> a
<> MimeType -> RequestBody
cp "--\r\n")

-- | Generate a boundary simillar to those generated by WebKit-based browsers.
webkitBoundary :: IO BS.ByteString
webkitBoundary :: IO MimeType
webkitBoundary = (StdGen -> (MimeType, StdGen)) -> IO MimeType
forall a. (StdGen -> (a, StdGen)) -> IO a
getStdRandom StdGen -> (MimeType, StdGen)
forall g. RandomGen g => g -> (MimeType, g)
webkitBoundaryPure

webkitBoundaryPure :: RandomGen g => g -> (BS.ByteString, g)
webkitBoundaryPure :: g -> (MimeType, g)
webkitBoundaryPure g :: g
g = (State g MimeType -> g -> (MimeType, g)
forall s a. State s a -> s -> (a, s)
`runState` g
g) (State g MimeType -> (MimeType, g))
-> State g MimeType -> (MimeType, g)
forall a b. (a -> b) -> a -> b
$ do
    ([[Word8]] -> MimeType)
-> StateT g Identity [[Word8]] -> State g MimeType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MimeType -> MimeType -> MimeType
BS.append MimeType
prefix (MimeType -> MimeType)
-> ([[Word8]] -> MimeType) -> [[Word8]] -> MimeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> MimeType
BS.pack ([Word8] -> MimeType)
-> ([[Word8]] -> [Word8]) -> [[Word8]] -> MimeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Word8]] -> [Word8]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Prelude.concat) (StateT g Identity [[Word8]] -> State g MimeType)
-> StateT g Identity [[Word8]] -> State g MimeType
forall a b. (a -> b) -> a -> b
$ Int -> StateT g Identity [Word8] -> StateT g Identity [[Word8]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM 4 (StateT g Identity [Word8] -> StateT g Identity [[Word8]])
-> StateT g Identity [Word8] -> StateT g Identity [[Word8]]
forall a b. (a -> b) -> a -> b
$ do
        Int
randomness <- (g -> (Int, g)) -> StateT g Identity Int
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((g -> (Int, g)) -> StateT g Identity Int)
-> (g -> (Int, g)) -> StateT g Identity Int
forall a b. (a -> b) -> a -> b
$ g -> (Int, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random
        [Word8] -> StateT g Identity [Word8]
forall (m :: * -> *) a. Monad m => a -> m a
return [UArray Int Word8 -> Int -> Word8
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
unsafeAt UArray Int Word8
alphaNumericEncodingMap (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
randomness Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 24 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 0x3F
               ,UArray Int Word8 -> Int -> Word8
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
unsafeAt UArray Int Word8
alphaNumericEncodingMap (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
randomness Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 16 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 0x3F
               ,UArray Int Word8 -> Int -> Word8
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
unsafeAt UArray Int Word8
alphaNumericEncodingMap (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
randomness Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 0x3F
               ,UArray Int Word8 -> Int -> Word8
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
unsafeAt UArray Int Word8
alphaNumericEncodingMap (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
randomness Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 0x3F]
  where
    prefix :: MimeType
prefix = "----WebKitFormBoundary"
    alphaNumericEncodingMap :: UArray Int Word8
    alphaNumericEncodingMap :: UArray Int Word8
alphaNumericEncodingMap = (Int, Int) -> [Word8] -> UArray Int Word8
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (0, 63)
        [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, 0x30, 0x31, 0x32, 0x33,
         0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x41, 0x42]

-- | Add form data to the 'Request'.
--
-- This sets a new 'requestBody', adds a content-type request header and changes the method to POST.
formDataBody :: MonadIO m => [Part] -> Request -> m Request
formDataBody :: [Part] -> Request -> m Request
formDataBody a :: [Part]
a b :: Request
b = IO Request -> m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ do
    MimeType
boundary <- IO MimeType
webkitBoundary
    MimeType -> [Part] -> Request -> IO Request
forall (m :: * -> *).
Applicative m =>
MimeType -> [PartM m] -> Request -> m Request
formDataBodyWithBoundary MimeType
boundary [Part]
a Request
b

-- | Add form data with supplied boundary
formDataBodyWithBoundary :: Applicative m => BS.ByteString -> [PartM m] -> Request -> m Request
formDataBodyWithBoundary :: MimeType -> [PartM m] -> Request -> m Request
formDataBodyWithBoundary boundary :: MimeType
boundary parts :: [PartM m]
parts req :: Request
req = do
    (\ body :: RequestBody
body -> Request
req
        { method :: MimeType
method = MimeType
methodPost
        , requestHeaders :: [Header]
requestHeaders =
            (CI MimeType
hContentType, "multipart/form-data; boundary=" MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> MimeType
boundary)
          Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (\(x :: CI MimeType
x, _) -> CI MimeType
x CI MimeType -> CI MimeType -> Bool
forall a. Eq a => a -> a -> Bool
/= CI MimeType
hContentType) (Request -> [Header]
requestHeaders Request
req)
        , requestBody :: RequestBody
requestBody = RequestBody
body
        }) (RequestBody -> Request) -> m RequestBody -> m Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MimeType -> [PartM m] -> m RequestBody
forall (m :: * -> *).
Applicative m =>
MimeType -> [PartM m] -> m RequestBody
renderParts MimeType
boundary [PartM m]
parts