{-# 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
  [Ptr HttpPost]
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 [Ptr HttpPost]
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 Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
p Int
0 Ptr Any
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
  Ptr HttpPost
php <- Int -> IO (Ptr HttpPost)
forall a. Int -> IO (Ptr a)
mallocBytes Int
sizeof_httppost
  Ptr HttpPost -> Int -> Ptr Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php Int
0 Ptr Any
forall a. Ptr a
nullPtr
  String -> IO (Ptr CChar)
newCString (HttpPost -> String
postName HttpPost
p) 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
1)
  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
2) (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HttpPost -> String
postName HttpPost
p))
  case HttpPost -> Content
content HttpPost
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 Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
5) Ptr Any
forall a. Ptr a
nullPtr
      Ptr HttpPost -> Int -> Ptr Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
6) Ptr Any
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 Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
3) Ptr Any
forall a. Ptr a
nullPtr
      Ptr HttpPost -> Int -> Ptr Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
4) Ptr Any
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 Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
5) Ptr Any
forall a. Ptr a
nullPtr
      Ptr HttpPost -> Int -> Ptr Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
6) Ptr Any
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)
  
  Ptr CChar
cs1 <- case HttpPost -> Maybe String
contentType HttpPost
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
  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
7) Ptr CChar
cs1
  [Ptr CChar]
cs2 <- (String -> IO (Ptr CChar)) -> [String] -> IO [Ptr CChar]
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 String -> IO (Ptr CChar)
newCString (HttpPost -> [String]
extraHeaders HttpPost
p)
  Ptr Slist_
ip <- (Ptr Slist_ -> Ptr CChar -> IO (Ptr Slist_))
-> Ptr Slist_ -> [Ptr CChar] -> IO (Ptr Slist_)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Ptr Slist_ -> Ptr CChar -> IO (Ptr Slist_)
curl_slist_append Ptr Slist_
forall a. Ptr a
nullPtr [Ptr CChar]
cs2
  Ptr HttpPost -> Int -> Ptr Slist_ -> IO ()
forall b. Ptr b -> Int -> Ptr Slist_ -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
8) Ptr Slist_
ip
  Ptr HttpPost -> Int -> Ptr Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
9) Ptr Any
forall a. Ptr a
nullPtr
  case HttpPost -> Maybe String
showName HttpPost
p of
    Maybe String
Nothing -> Ptr HttpPost -> Int -> Ptr Any -> IO ()
forall b. Ptr b -> Int -> Ptr Any -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
11) Ptr Any
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)
  Ptr HttpPost -> IO (Ptr HttpPost)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr HttpPost
php
 where
  ptrIndex :: Int -> Int
ptrIndex Int
n = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Ptr Any -> Int
forall a. Storable a => a -> Int
sizeOf Ptr Any
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 ()