gistfile1.hs

{-# OPTIONS -Wall #-}
{-# LANGUAGE OverloadedStrings #-}


import Network.HTTP.Conduit
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as C8L
import Data.List (intersperse)

data MultipartValue
    = MultipartField B.ByteString
    | MultipartFile FilePath (Maybe B.ByteString) BL.ByteString
    deriving (Show)

multipartEncodeBody :: Monad m => [(B.ByteString, MultipartValue)] -> Request m' -> Request m
multipartEncodeBody headers req = req
        { requestBody = RequestBodyLBS lbs
        , method = "POST"
        , requestHeaders = (ct, mpart)
                         : filter ((/= ct) . fst) (requestHeaders req)
        }

    where
        ct = "Content-Type"
        mpart = "multipart/form-data; boundary=" `C8.append` b

        b = "----WebKitFormBoundary3TM1ugNKkhTAQrk3"
        bl = BL.fromChunks [b]
        streamStart = BL.concat ["--", bl, "\r\n"]

        midBoundary = BL.concat ["\r\n--", bl, "\r\n" ]
        endBoundary = BL.concat ["\r\n--", bl, "--\r\n" ]

        parts = intersperse midBoundary $ map (uncurry renderMultipart) headers

        lbs = BL.concat $ [streamStart] ++ parts ++ [endBoundary]


renderMultipart :: B.ByteString -> MultipartValue -> BL.ByteString
renderMultipart name (MultipartField bs) = BL.fromChunks
    [ "Content-Disposition: form-data; name=\""
    , name, "\"\r\n\r\n", bs
    ]
renderMultipart name (MultipartFile fname ct fbody) = BL.concat
    [ "Content-Disposition: form-data; name=\""
    , BL.fromChunks [name], "\"; filename=\"", C8L.pack fname, "\"\r\n"
    , maybe "" (\c -> C8L.fromChunks ["Content-Type: ", c, "\r\n\r\n"]) ct
    , fbody
    ]