{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HttpPost -> HttpPost -> Bool
$c/= :: HttpPost -> HttpPost -> Bool
== :: HttpPost -> HttpPost -> Bool
$c== :: HttpPost -> HttpPost -> Bool
Eq, Int -> HttpPost -> ShowS
[HttpPost] -> ShowS
HttpPost -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HttpPost] -> ShowS
$cshowList :: [HttpPost] -> ShowS
show :: HttpPost -> String
$cshow :: HttpPost -> String
showsPrec :: Int -> HttpPost -> ShowS
$cshowsPrec :: Int -> HttpPost -> ShowS
Show )

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

-- lower-level marshalling code.

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

marshallPosts :: [HttpPost] -> IO (Ptr HttpPost)
marshallPosts :: [HttpPost] -> IO (Ptr HttpPost)
marshallPosts [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Ptr a
nullPtr
marshallPosts [HttpPost]
ps = do
  [Ptr HttpPost]
ms <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HttpPost -> IO (Ptr HttpPost)
marshallPost [HttpPost]
ps
  case [Ptr HttpPost]
ms of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Ptr a
nullPtr
    (Ptr HttpPost
x:[Ptr HttpPost]
xs) -> do
      forall {b}. Ptr b -> [Ptr b] -> IO ()
linkUp Ptr HttpPost
x [Ptr HttpPost]
xs
      forall (m :: * -> *) a. Monad m => a -> m a
return Ptr HttpPost
x
 where
  linkUp :: Ptr b -> [Ptr b] -> IO ()
linkUp Ptr b
p [] = forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
p Int
0 forall a. Ptr a
nullPtr
  linkUp Ptr b
p (Ptr b
x:[Ptr b]
xs) = do
    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 <- forall a. Int -> IO (Ptr a)
mallocBytes Int
sizeof_httppost
  forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php Int
0 forall a. Ptr a
nullPtr
  String -> IO (Ptr CChar)
newCString (HttpPost -> String
postName HttpPost
p) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
1)
  forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
2) (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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
3)
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
4) (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
f)
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
5) forall a. Ptr a
nullPtr
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
6) forall a. Ptr a
nullPtr
      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
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
3) forall a. Ptr a
nullPtr
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
4) forall a. Ptr a
nullPtr
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
5) Ptr CChar
ptr 
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
6) Long
len
      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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
3)
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
4) (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
5) forall a. Ptr a
nullPtr
      forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
6) forall a. Ptr a
nullPtr
      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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Ptr a
nullPtr
    Just String
s  -> String -> IO (Ptr CChar)
newCString String
s
  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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Ptr CChar)
newCString (HttpPost -> [String]
extraHeaders HttpPost
p)
  Ptr Slist_
ip <- 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 forall a. Ptr a
nullPtr [Ptr CChar]
cs2
  forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
8) Ptr Slist_
ip
  forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
9) forall a. Ptr a
nullPtr
  case HttpPost -> Maybe String
showName HttpPost
p of
    Maybe String
Nothing -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
11) forall a. Ptr a
nullPtr
    Just String
s  -> String -> IO (Ptr CChar)
newCString String
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
11)
  forall (m :: * -> *) a. Monad m => a -> m a
return Ptr HttpPost
php
 where
  ptrIndex :: Int -> Int
ptrIndex Int
n = Int
n forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf 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 ()