module Network.HTTP.Conduit.MultipartFormData
(
Part(..)
,partBS
,partLBS
,partFile
,partFileSource
,partFileSourceChunked
,partFileRequestBody
,partFileRequestBodyM
,formDataBody
,formDataBodyPure
,formDataBodyWithBoundary
,webkitBoundary
,webkitBoundaryPure
,renderParts
,renderPart
) where
import Network.HTTP.Conduit.Request
import Network.HTTP.Conduit.Util
import Network.Mime
import Network.HTTP.Types (hContentType, methodPost)
import Blaze.ByteString.Builder
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Binary as CB
import Data.Conduit
import Data.Text
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
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.Functor.Identity
import Data.Monoid (Monoid(..))
import Control.Monad
infixl 4 `_mmap`
_mmap :: Monad m => (a -> b) -> m a -> m b
_mmap = \f m -> m >>= return . f
data Part m m' = Part
{ partName :: Text
, partFilename :: Maybe String
, partContentType :: Maybe MimeType
, partGetBody :: m (RequestBody m')
}
instance Show (Part m m') where
showsPrec d (Part n f c _) =
showParen (d>=11) $ showString "Part "
. showsPrec 11 n
. showString " "
. showsPrec 11 f
. showString " "
. showsPrec 11 c
. showString " "
. showString "<m (RequestBody m)>"
partBS :: (Monad m, Monad m') => Text -> BS.ByteString -> Part m m'
partBS n b = Part n mempty mempty $ return $ RequestBodyBS b
partLBS :: (Monad m, Monad m') => Text -> BL.ByteString -> Part m m'
partLBS n b = Part n mempty mempty $ return $ RequestBodyLBS b
partFile :: (MonadIO m, Monad m') => Text -> FilePath -> Part m m'
partFile n f =
partFileRequestBodyM n f $ do
_mmap RequestBodyBS $ liftIO $ BS.readFile f
partFileSource :: (MonadIO m, MonadResource m') => Text -> FilePath -> Part m m'
partFileSource n f =
partFileRequestBodyM n f $ do
size <- liftIO $ withBinaryFile f ReadMode hFileSize
return $ RequestBodySource (fromInteger size) $
CB.sourceFile f $= CL.map fromByteString
partFileSourceChunked :: (Monad m, MonadResource m') => Text -> FilePath -> Part m m'
partFileSourceChunked n f =
partFileRequestBody n f $ do
RequestBodySourceChunked $ CB.sourceFile f $= CL.map fromByteString
partFileRequestBody :: (Monad m, Monad m') => Text -> FilePath -> RequestBody m' -> Part m m'
partFileRequestBody n f rqb =
partFileRequestBodyM n f $ return rqb
partFileRequestBodyM :: Monad m' => Text -> FilePath -> m (RequestBody m') -> Part m m'
partFileRequestBodyM n f rqb =
Part n (Just f) (Just $ defaultMimeLookup $ pack f) rqb
cp :: BS.ByteString -> RequestBody m
cp bs = RequestBodyBuilder (fromIntegral $ BS.length bs) $ copyByteString bs
renderPart :: (Monad m, Monad m') => BS.ByteString -> Part m m' -> m (RequestBody m')
renderPart boundary (Part name mfilename mcontenttype get) = _mmap render get
where render renderBody =
cp "--" <> cp boundary <> cp "\r\n"
<> cp "Content-Disposition: form-data; name=\""
<> RequestBodyBS (TE.encodeUtf8 name)
<> (case mfilename of
Just f -> cp "\"; filename=\""
<> RequestBodyBS (TE.encodeUtf8 $ pack $ takeFileName f)
_ -> mempty)
<> cp "\""
<> (case mcontenttype of
Just ct -> cp "\r\n"
<> cp "Content-Type: "
<> cp ct
_ -> mempty)
<> cp "\r\n\r\n"
<> renderBody <> cp "\r\n"
renderParts :: (Monad m, Monad m') => BS.ByteString -> [Part m m'] -> m (RequestBody m')
renderParts boundary parts = fin . mconcat `_mmap` mapM (renderPart boundary) parts
where fin = (<> cp "--" <> cp boundary <> cp "--\r\n")
webkitBoundary :: IO BS.ByteString
webkitBoundary = getStdRandom webkitBoundaryPure
webkitBoundaryPure :: RandomGen g => g -> (BS.ByteString, g)
webkitBoundaryPure g = (`runState` g) $ do
fmap (BS.append prefix . BS.pack . Prelude.concat) $ replicateM 4 $ do
randomness <- state $ random
return [unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 24 .&. 0x3F
,unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 16 .&. 0x3F
,unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 8 .&. 0x3F
,unsafeAt alphaNumericEncodingMap $ randomness .&. 0x3F]
where
prefix = "----WebKitFormBoundary"
alphaNumericEncodingMap :: UArray Int Word8
alphaNumericEncodingMap = 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]
formDataBody :: (MonadIO m, Monad m') => [Part m m'] -> Request m' -> m (Request m')
formDataBody a b = do
boundary <- liftIO webkitBoundary
formDataBodyWithBoundary boundary a b
formDataBodyPure :: Monad m => BS.ByteString -> [Part Identity m] -> Request m -> Request m
formDataBodyPure = \boundary parts req ->
runIdentity $ formDataBodyWithBoundary boundary parts req
formDataBodyWithBoundary :: (Monad m, Monad m') => BS.ByteString -> [Part m m'] -> Request m' -> m (Request m')
formDataBodyWithBoundary boundary parts req = do
body <- renderParts boundary parts
return $ req
{ method = methodPost
, requestHeaders =
(hContentType, "multipart/form-data; boundary=" <> boundary)
: Prelude.filter (\(x, _) -> x /= hContentType) (requestHeaders req)
, requestBody = body
}