{-# OPTIONS -fffi -fvia-C -#include "curl/curl.h" #-}
--------------------------------------------------------------------
-- |
-- Module    : Curl.Easy
-- Copyright : (c) Galois Inc 2007
-- License   :
--
-- Maintainer: emertens@galois.com
-- Stability : provisional
-- Portability: portable
--
-- Haskell binding to the libcurl <http://curl.haxx.se/> \"easy\" API.
-- The \"easy\" API provides a higher-level, easy-to-get-started calling
-- interface to the library's wide range of features for interacting
-- with HTTP\/FTP\/etc servers.
--
--------------------------------------------------------------------
module Network.Curl.Easy
        ( initialize    -- :: IO Curl
        , perform       -- :: Curl -> IO CurlCode
        , setopt        -- :: Curl -> CurlOption -> IO CurlCode
        , duphandle     -- :: Curl -> IO Curl
        , reset         -- :: Curl -> IO ()

        , curl_global_init    -- :: CInt -> IO CurlCode
        , curl_global_cleanup -- :: IO ()
        ) where

import Network.Curl.Types
import Network.Curl.Opts
import Network.Curl.Code
import Network.Curl.Post

import Network.Curl.Debug

import Data.IORef(IORef)
import Foreign.Ptr
import Foreign.Marshal.Alloc(free)
import Foreign.C.Types
import Foreign.C.String
import Control.Monad
import Data.Maybe

-- | Initialise a curl instance
initialize :: IO Curl
initialize = do
  h <- easy_initialize
  mkCurl h 

-- XXX: Is running cleanup here OK?
reset :: Curl -> IO ()
reset hh = curlPrim hh $ \r h -> easy_reset h >> runCleanup r

duphandle :: Curl -> IO Curl
duphandle hh = curlPrim hh $ \r h ->
  do h1      <- easy_duphandle h
     cleanup <- shareCleanup r
     mkCurlWithCleanup h1 cleanup

setopt :: Curl
       -> CurlOption
       -> IO CurlCode
setopt hh o = curlPrim hh $ \ r h -> unmarshallOption (easy_um r h) o
 where
  easy_um :: IORef OptionMap -> CurlH -> Unmarshaller CurlCode
  easy_um r h = 
    Unmarshaller
    { u_long    -- :: Int -> Long     -> IO CurlCode
       = \ i x -> liftM toCode $ easy_setopt_long h i x
    , u_llong   --  :: Int -> LLong    -> IO CurlCode
       = \ i x -> liftM toCode $ easy_setopt_llong h i x

    , u_string  -- :: Int -> String   -> IO CurlCode
       = \ i x -> do debug $ "ALLOC: " ++ x
                     c_x <- newCString x
                     updateCleanup r i $ debug ("FREE: "++ x) >> free c_x
                     liftM toCode $ easy_setopt_string h i c_x

    , u_strings -- :: Int -> [String] -> IO CurlCode
       = \ i x ->
           do debug ("ALLOC: " ++ show x)
              -- curl_slist_append will copy its string argument
              let addOne ip s = withCString s $ curl_slist_append ip 
              ip <- foldM addOne nullPtr x 
              updateCleanup r i $
                debug ("FREE: " ++ show x) >> curl_slist_free ip
              liftM toCode $ easy_setopt_string h i (castPtr ip)
     , u_ptr    -- :: Int -> Ptr ()   -> IO a
       = \ i x -> liftM toCode $ easy_setopt_ptr h i x
     , u_writeFun -- :: Int -> WriteFunction -> IO a
       = \ i x -> do
            debug "ALLOC: WRITER"
            fp <- mkWriter x
            updateCleanup r i $ debug "FREE: WRITER" >> freeHaskellFunPtr fp
            liftM toCode $ easy_setopt_wfun h i fp
     , u_readFun -- :: Int -> ReadFunction -> IO a
       = \ i x -> do
            let wrapResult f a b c d = do
                     mb <- f a b c d
                     return (fromMaybe curl_readfunc_abort mb)
            debug "ALLOC: READER"
            fp <- mkReader (wrapResult x)
            updateCleanup r i $ debug "FREE: READER" >> freeHaskellFunPtr fp
            liftM toCode $ easy_setopt_rfun h i fp
     , u_progressFun -- :: Int -> ProgressFunction -> IO a
       = \ i x -> do
            debug "ALLOC: PROGRESS" 
            fp <- mkProgress x
            updateCleanup r i $ debug "FREE: PROGRESS" >> freeHaskellFunPtr fp
            liftM toCode $ easy_setopt_fptr h i fp
     , u_debugFun -- :: Int -> DebugFunction -> IO a
       = \ i debFun -> do
            let wrapFun fun _a b c d e = 
                  fun hh (toEnum (fromIntegral b)) c d e >> return 0
            debug "ALLOC: DEBUG" 
            fp <- mkDebugFun (wrapFun debFun)
            updateCleanup r i $ debug "FREE: DEBUG" >> freeHaskellFunPtr fp
            liftM toCode $ easy_setopt_fptr h i fp
     , u_posts    -- :: Int -> [HttpPost] -> IO a
       = \ i x -> do
           debug "ALLOC: POSTS"
           p <- marshallPosts x
           updateCleanup r i $ debug "FREE: POSTS" >> curl_formfree p
           liftM toCode $ easy_setopt_ptr h i p 
     , u_sslctxt  -- :: Int -> SSLCtxtFunction -> IO a
       = \ i x -> do
           debug "ALLOC: SSL_FUN"
           p <- mkSslCtxtFun x
           updateCleanup r i $ debug "FREE: SSL_FUN" >> freeHaskellFunPtr p
           liftM toCode $ easy_setopt_fptr h i p
     , u_ioctl_fun -- :: Int -> Ptr () -> IO a
       = \ i x -> liftM toCode $ easy_setopt_ptr h i x
     , u_convFromNetwork -- :: Int -> Ptr () -> IO a
       = \ i x -> liftM toCode $ easy_setopt_ptr h i x
     , u_convToNetwork -- :: Int -> Ptr () -> IO a
       = \ i x -> liftM toCode $ easy_setopt_ptr h i x
     , u_convFromUtf8 -- :: Int -> Ptr () -> IO a
       = \ i x -> liftM toCode $ easy_setopt_ptr h i x
     , u_sockoptFun  -- :: Int -> Ptr () -> IO a
       = \ i x -> liftM toCode $ easy_setopt_ptr h i x
     }

perform :: Curl -> IO CurlCode
perform hh = liftM toCode $ curlPrim hh $ \_ h -> easy_perform_prim h

curl_global_init :: CInt -> IO CurlCode
curl_global_init v = liftM toCode $ curl_global_init_prim v

-- FFI decls


foreign import ccall
  "curl/easy.h curl_global_init" curl_global_init_prim :: CInt -> IO CInt

foreign import ccall
  "curl/easy.h curl_global_cleanup" curl_global_cleanup :: IO ()

foreign import ccall
  "curl/easy.h curl_easy_init" easy_initialize :: IO CurlH

foreign import ccall
  "curl/easy.h curl_easy_perform" easy_perform_prim :: CurlH -> IO CInt

foreign import ccall
  "curl_easy_duphandle" easy_duphandle :: CurlH -> IO CurlH

foreign import ccall
  "curl_easy_reset" easy_reset :: CurlH -> IO ()

foreign import ccall
  "curl_easy_setopt" easy_setopt_long :: CurlH -> Int -> Long -> IO CInt

foreign import ccall
  "curl_easy_setopt" easy_setopt_llong :: CurlH -> Int -> LLong -> IO CInt

foreign import ccall
  "curl_easy_setopt" easy_setopt_string :: CurlH -> Int -> Ptr CChar -> IO CInt

foreign import ccall
  "curl_easy_setopt" easy_setopt_ptr :: CurlH -> Int -> Ptr a -> IO CInt

foreign import ccall
  "curl_easy_setopt" easy_setopt_fptr :: CurlH -> Int -> FunPtr a -> IO CInt

foreign import ccall
  "curl_easy_setopt" easy_setopt_wfun :: CurlH -> Int -> FunPtr WriteFunction -> IO CInt

foreign import ccall
  "curl_easy_setopt" easy_setopt_rfun :: CurlH -> Int -> FunPtr ReadFunctionPrim -> IO CInt


foreign import ccall "wrapper"
   mkWriter :: WriteFunction -> IO (FunPtr WriteFunction)

foreign import ccall "wrapper"
   mkReader :: ReadFunctionPrim -> IO (FunPtr ReadFunctionPrim)

foreign import ccall "wrapper"
   mkProgress :: ProgressFunction -> IO (FunPtr ProgressFunction)

foreign import ccall "wrapper"
   mkDebugFun :: DebugFunctionPrim -> IO (FunPtr DebugFunctionPrim)

foreign import ccall "wrapper"
   mkSslCtxtFun :: SSLCtxtFunction -> IO (FunPtr SSLCtxtFunction)