{-# LANGUAGE ForeignFunctionInterface #-}
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 = String
data HttpPost
= HttpPost
{ HttpPost -> String
postName :: String
, HttpPost -> Maybe String
contentType :: Maybe String
, HttpPost -> Content
content :: Content
, :: [Header]
, 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
/= :: HttpPost -> HttpPost -> Bool
$c/= :: HttpPost -> HttpPost -> Bool
== :: HttpPost -> HttpPost -> Bool
$c== :: 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
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
| ContentString String
deriving ( Content -> Content -> Bool
(Content -> Content -> Bool)
-> (Content -> Content -> Bool) -> Eq Content
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
(Int -> Content -> ShowS)
-> (Content -> String) -> ([Content] -> ShowS) -> Show Content
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 :: String
-> Maybe String -> Content -> [String] -> Maybe String -> HttpPost
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
}
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 (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)
mapM HttpPost -> IO (Ptr HttpPost)
marshallPost [HttpPost]
ps
case [Ptr HttpPost]
ms of
[] -> Ptr HttpPost -> IO (Ptr HttpPost)
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 (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 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 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 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr HttpPost -> 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 a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
2) (String -> 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr HttpPost -> 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 a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
4) (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
f)
Ptr HttpPost -> 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 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 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 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 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 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 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 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr HttpPost -> 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 a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr HttpPost
php (Int -> Int
ptrIndex Int
4) (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)
Ptr HttpPost -> 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 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 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 (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 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)
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 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 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 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr HttpPost -> 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 (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 ()