content: {-# 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
      { partName :: Text -- ^ Name of the corresponding \<input\>
      , partFilename :: Maybe String -- ^ A file name, if this is an attached file
      , partContentType :: Maybe MimeType -- ^ Content type
      , partHeaders :: [Header] -- ^ List of additional headers
      , partGetBody :: m RequestBody -- ^ Action in m which returns the body
                                     -- of a message.
      }
  
  instance Show (PartM m) where
      showsPrec d (Part n f c h _) =
          showParen (d>=11) $ showString "Part "
              . showsPrec 11 n
              . showString " "
              . showsPrec 11 f
              . showString " "
              . showsPrec 11 c
              . showString " "
              . showsPrec 11 h
              . showString " "
              . 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 n b = Part n Data.Monoid.mempty mempty mempty $ pure $ RequestBodyBS 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 n b = Part n mempty mempty mempty $ pure $ RequestBodyLBS 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 n f =
      partFileRequestBodyM n f $ do
          liftM RequestBodyBS $ liftIO $ BS.readFile 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 n f =
      partFileRequestBodyM n f $ do
          size <- liftIO $ withBinaryFile f ReadMode hFileSize
          return $ RequestBodyStream (fromInteger size) $ streamFile f
  
  streamFile :: FilePath -> GivesPopper ()
  streamFile fp np =
      withFile fp ReadMode $ np . go
    where
      go h = BS.hGetSome h 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 n f =
      partFileRequestBody n f $ do
          RequestBodyStreamChunked $ streamFile 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 n f rqb =
      partFileRequestBodyM n f $ pure 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 n f rqb =
      Part n (Just f) (Just $ defaultMimeLookup $ pack f) mempty rqb
  
  {-# INLINE cp #-}
  cp :: BS.ByteString -> RequestBody
  cp bs = RequestBodyBuilder (fromIntegral $ BS.length bs) $ copyByteString bs
  
  -- | Add a list of additional headers to this 'Part'.
  addPartHeaders :: PartM m -> [Header] -> PartM m
  addPartHeaders p hs = p { partHeaders = partHeaders p <> hs }
  
  renderPart :: Functor m
             => BS.ByteString     -- ^ Boundary between parts.
             -> PartM m -> m RequestBody
  renderPart boundary (Part name mfilename mcontenttype hdrs get) = 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)
           <> Data.Foldable.foldMap (\(k, v) ->
                 cp "\r\n"
              <> cp (CI.original k)
              <> cp ": "
              <> cp v) hdrs
           <> cp "\r\n\r\n"
           <> renderBody <> 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 boundary parts = (fin . mconcat) <$> traverse (renderPart boundary) parts
    where fin = (<> cp "--" <> cp boundary <> cp "--\r\n")
  
  -- | Generate a boundary simillar to those generated by WebKit-based browsers.
  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]
  
  -- | 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 a b = liftIO $ do
      boundary <- webkitBoundary
      formDataBodyWithBoundary boundary a b
  
  -- | Add form data with supplied boundary
  formDataBodyWithBoundary :: Applicative m => BS.ByteString -> [PartM m] -> Request -> m Request
  formDataBodyWithBoundary boundary parts req = do
      (\ body -> req
          { method = methodPost
          , requestHeaders =
              (hContentType, "multipart/form-data; boundary=" <> boundary)
            : Prelude.filter (\(x, _) -> x /= hContentType) (requestHeaders req)
          , requestBody = body
          }) <$> renderParts boundary parts
  