    {-# LANGUAGE ForeignFunctionInterface #-}
    --------------------------------------------------------------------
    -- |
    -- Module    : Network.Curl.Post
    -- Copyright : (c) Galois Inc 2007-2009
    -- License   : BSD3
    --
    -- Maintainer: Sigbjorn Finne <sof@galois.com>
    -- Stability : provisional
    -- Portability: portable
    --
    -- Representing and marshalling formdata (as part of POST uploads\/submissions.)
    -- If you are only looking to submit a sequence of name=value pairs,
    -- you are better off using the CurlPostFields constructor; much simpler.
    --
    --------------------------------------------------------------------
    module Network.Curl.Post where

    import Network.Curl.Types

    import Control.Monad
    import Foreign.Ptr
    import Foreign.Storable
    import Foreign.Marshal.Alloc
    import Foreign.C.Types
    import Foreign.C.String

    type Header = String

    data HttpPost
     = HttpPost
         { HttpPost -> String
    postName     :: String
         , HttpPost -> Maybe String
    contentType  :: Maybe String
         , HttpPost -> Content
    content      :: Content
         , HttpPost -> [String]
    extraHeaders :: [Header]
    -- not yet:     , extraEntries :: [HttpPost]
         , HttpPost -> Maybe String
    showName     :: Maybe String
         } deriving ( HttpPost -> HttpPost -> Bool
    (HttpPost -> HttpPost -> Bool)
    -> (HttpPost -> HttpPost -> Bool) -> Eq HttpPost
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: HttpPost -> HttpPost -> Bool
    == :: HttpPost -> HttpPost -> Bool
    $c/= :: HttpPost -> HttpPost -> Bool
    /= :: HttpPost -> HttpPost -> Bool
    Eq, Int -> HttpPost -> ShowS
    [HttpPost] -> ShowS
    HttpPost -> String
    (Int -> HttpPost -> ShowS)
    -> (HttpPost -> String) -> ([HttpPost] -> ShowS) -> Show HttpPost
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> HttpPost -> ShowS
    showsPrec :: Int -> HttpPost -> ShowS
    $cshow :: HttpPost -> String
    show :: HttpPost -> String
    $cshowList :: [HttpPost] -> ShowS
    showList :: [HttpPost] -> ShowS
    Show )

    data Content
     = ContentFile   FilePath
     | ContentBuffer (Ptr CChar) Long -- byte arrays also?
     | ContentString String
       deriving ( Content -> Content -> Bool
    (Content -> Content -> Bool)
    -> (Content -> Content -> Bool) -> Eq Content
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Content -> Content -> Bool
    == :: Content -> Content -> Bool
    $c/= :: Content -> Content -> Bool
    /= :: Content -> Content -> Bool
    Eq, Int -> Content -> ShowS
    [Content] -> ShowS
    Content -> String
    (Int -> Content -> ShowS)
    -> (Content -> String) -> ([Content] -> ShowS) -> Show Content
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Content -> ShowS
    showsPrec :: Int -> Content -> ShowS
    $cshow :: Content -> String
    show :: Content -> String
    $cshowList :: [Content] -> ShowS
    showList :: [Content] -> ShowS
    Show )

    multiformString :: String -> String -> HttpPost
    multiformString :: String -> String -> HttpPost
    multiformString String
    x String
    y =
      HttpPost { postName :: String
    postName      = String
    x
               , content :: Content
    content       = String -> Content
    ContentString String
    y
               , contentType :: Maybe String
    contentType   = Maybe String
    forall a. Maybe a
    Nothing
               , extraHeaders :: [String]
    extraHeaders  = []
               , showName :: Maybe String
    showName      = Maybe String
    forall a. Maybe a
    Nothing
               }

    -- lower-level marshalling code.

    sizeof_httppost :: Int
    sizeof_httppost :: Int
    sizeof_httppost = Int
    12 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Ptr CChar -> Int
    forall a. Storable a => a -> Int
    sizeOf (Ptr CChar
    forall a. Ptr a
    nullPtr :: Ptr CChar)

    marshallPosts :: [HttpPost] -> IO (Ptr HttpPost)
    marshallPosts :: [HttpPost] -> IO (Ptr HttpPost)
    marshallPosts [] = Ptr HttpPost -> IO (Ptr HttpPost)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Ptr HttpPost
    forall a. Ptr a
    nullPtr
    marshallPosts [HttpPost]
    ps = do
      ms <- (HttpPost -> IO (Ptr HttpPost)) -> [HttpPost] -> IO [Ptr HttpPost]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HttpPost -> IO (Ptr HttpPost)
    marshallPost [HttpPost]
    ps
      case ms of
        [] -> Ptr HttpPost -> IO (Ptr HttpPost)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Ptr HttpPost
    forall a. Ptr a
    nullPtr
        (Ptr HttpPost
    x:[Ptr HttpPost]
    xs) -> do
          Ptr HttpPost -> [Ptr HttpPost] -> IO ()
    forall {b}. Ptr b -> [Ptr b] -> IO ()
    linkUp Ptr HttpPost
    x [Ptr HttpPost]
    xs
          Ptr HttpPost -> IO (Ptr HttpPost)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Ptr HttpPost
    x
     where
      linkUp :: Ptr b -> [Ptr b] -> IO ()
    linkUp Ptr b
    p [] = Ptr b -> Int -> Ptr (ZonkAny 10) -> IO ()
    forall b. Ptr b -> Int -> Ptr (ZonkAny 10) -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr b
    p Int
    0 Ptr (ZonkAny 10)
    forall a. Ptr a
    nullPtr
      linkUp Ptr b
    p (Ptr b
    x:[Ptr b]
    xs) = do
        Ptr b -> Int -> Ptr b -> IO ()
    forall b. Ptr b -> Int -> Ptr b -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr b
    p Int
    0 Ptr b
    x
        Ptr b -> [Ptr b] -> IO ()
    linkUp Ptr b
    x [Ptr b]
    xs

    marshallPost :: HttpPost -> IO (Ptr HttpPost)
    marshallPost :: HttpPost -> IO (Ptr HttpPost)
    marshallPost HttpPost
    p = do
      php <- Int -> IO (Ptr HttpPost)
    forall a. Int -> IO (Ptr a)
    mallocBytes Int
    sizeof_httppost
      pokeByteOff php 0 nullPtr
      newCString (postName p) >>= pokeByteOff php (ptrIndex 1)
      pokeByteOff php (ptrIndex 2) (length (postName p))
      case content p of
        ContentFile String
    f -> do
          String -> IO (Ptr CChar)
    newCString String
    f IO (Ptr CChar) -> (Ptr CChar -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Ptr HttpPost -> Int -> Ptr CChar -> IO ()
    forall b. Ptr b -> Int -> Ptr CChar -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    3)
          Ptr HttpPost -> Int -> Int -> IO ()
    forall b. Ptr b -> Int -> Int -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    4) (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    f)
          Ptr HttpPost -> Int -> Ptr (ZonkAny 1) -> IO ()
    forall b. Ptr b -> Int -> Ptr (ZonkAny 1) -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    5) Ptr (ZonkAny 1)
    forall a. Ptr a
    nullPtr
          Ptr HttpPost -> Int -> Ptr (ZonkAny 2) -> IO ()
    forall b. Ptr b -> Int -> Ptr (ZonkAny 2) -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    6) Ptr (ZonkAny 2)
    forall a. Ptr a
    nullPtr
          Ptr HttpPost -> Int -> Long -> IO ()
    forall b. Ptr b -> Int -> Long -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    10) (Long
    0x1 :: Long)
        ContentBuffer Ptr CChar
    ptr Long
    len -> do
          Ptr HttpPost -> Int -> Ptr (ZonkAny 3) -> IO ()
    forall b. Ptr b -> Int -> Ptr (ZonkAny 3) -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    3) Ptr (ZonkAny 3)
    forall a. Ptr a
    nullPtr
          Ptr HttpPost -> Int -> Ptr (ZonkAny 4) -> IO ()
    forall b. Ptr b -> Int -> Ptr (ZonkAny 4) -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    4) Ptr (ZonkAny 4)
    forall a. Ptr a
    nullPtr
          Ptr HttpPost -> Int -> Ptr CChar -> IO ()
    forall b. Ptr b -> Int -> Ptr CChar -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    5) Ptr CChar
    ptr
          Ptr HttpPost -> Int -> Long -> IO ()
    forall b. Ptr b -> Int -> Long -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    6) Long
    len
          Ptr HttpPost -> Int -> Long -> IO ()
    forall b. Ptr b -> Int -> Long -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    10) (Long
    0x10 :: Long)
        ContentString String
    s -> do
          String -> IO (Ptr CChar)
    newCString String
    s IO (Ptr CChar) -> (Ptr CChar -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Ptr HttpPost -> Int -> Ptr CChar -> IO ()
    forall b. Ptr b -> Int -> Ptr CChar -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    3)
          Ptr HttpPost -> Int -> Int -> IO ()
    forall b. Ptr b -> Int -> Int -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    4) (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    s)
          Ptr HttpPost -> Int -> Ptr (ZonkAny 5) -> IO ()
    forall b. Ptr b -> Int -> Ptr (ZonkAny 5) -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    5) Ptr (ZonkAny 5)
    forall a. Ptr a
    nullPtr
          Ptr HttpPost -> Int -> Ptr (ZonkAny 6) -> IO ()
    forall b. Ptr b -> Int -> Ptr (ZonkAny 6) -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    6) Ptr (ZonkAny 6)
    forall a. Ptr a
    nullPtr
          Ptr HttpPost -> Int -> Long -> IO ()
    forall b. Ptr b -> Int -> Long -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    10) (Long
    0x4 :: Long)

      cs1 <- case contentType p of
        Maybe String
    Nothing -> Ptr CChar -> IO (Ptr CChar)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Ptr CChar
    forall a. Ptr a
    nullPtr
        Just String
    s  -> String -> IO (Ptr CChar)
    newCString String
    s
      pokeByteOff php (ptrIndex 7) cs1
      cs2 <- mapM newCString (extraHeaders p)
      ip <- foldM curl_slist_append nullPtr cs2
      pokeByteOff php (ptrIndex 8) ip
      pokeByteOff php (ptrIndex 9) nullPtr
      case showName p of
        Maybe String
    Nothing -> Ptr HttpPost -> Int -> Ptr (ZonkAny 8) -> IO ()
    forall b. Ptr b -> Int -> Ptr (ZonkAny 8) -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    11) Ptr (ZonkAny 8)
    forall a. Ptr a
    nullPtr
        Just String
    s  -> String -> IO (Ptr CChar)
    newCString String
    s IO (Ptr CChar) -> (Ptr CChar -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Ptr HttpPost -> Int -> Ptr CChar -> IO ()
    forall b. Ptr b -> Int -> Ptr CChar -> IO ()
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
    pokeByteOff Ptr HttpPost
    php (Int -> Int
    ptrIndex Int
    11)
      return php
     where
      ptrIndex :: Int -> Int
    ptrIndex Int
    n = Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Ptr (ZonkAny 9) -> Int
    forall a. Storable a => a -> Int
    sizeOf Ptr (ZonkAny 9)
    forall a. Ptr a
    nullPtr

    foreign import ccall
      "curl_slist_append" curl_slist_append :: Ptr Slist_ -> CString -> IO (Ptr Slist_)
    foreign import ccall
      "curl_slist_free_all" curl_slist_free :: Ptr Slist_ -> IO ()

    foreign import ccall
      "curl_formfree" curl_formfree :: Ptr a -> IO ()