Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Use git. Why not before?

  • Loading branch information...
commit f74cdfa10f68ec2f8fbdcf2ffe74067687579fad 0 parents
@elginer authored
7 LICENSE
@@ -0,0 +1,7 @@
+Copyright (c) 2009 Johnny Morrice
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
27 LICENSE.CURL
@@ -0,0 +1,27 @@
+Copyright (c) 2007-2009 Galois Inc.
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
266 Network/Shpider.hs
@@ -0,0 +1,266 @@
+{-# OPTIONS -XScopedTypeVariables #-}
+-- | This module exposes the main functionality of shpider
+-- It allows you to quickly write crawlers, and for simple cases even without reading the page source eg.
+--
+-- @
+-- `runShpider` $ do
+-- `download` \"http:\/\/hackage.haskell.org\/packages\/archive\/pkg-list.html\"
+-- l : _ <- `getLinksByText` \"shpider\"
+-- `download` $ linkAddress l
+-- @
+module Network.Shpider
+ ( module Network.Shpider.Code
+ , module Network.Shpider.State
+ , module Network.Shpider.URL
+ , module Network.Shpider.Options
+ , module Network.Shpider.Forms
+ , module Network.Shpider.Links
+ , download
+ , sendForm
+ , getLinksByText
+ , getLinksByTextRegex
+ , getLinksByAddressRegex
+ , getFormsByAction
+ , currentLinks
+ , currentForms
+ , parsePage
+ , isAuthorizedDomain
+ , withAuthorizedDomain
+ , haveVisited
+ )
+ where
+
+import Network.Shpider.Curl.Curl
+
+import Text.HTML.TagSoup
+import Text.Regex.Posix
+
+import qualified Data.Map as M
+import Data.Maybe
+
+import Text.HTML.TagSoup
+
+import Network.Shpider.State
+import Network.Shpider.URL
+import Network.Shpider.Code
+import Network.Shpider.Options
+import Network.Shpider.Forms
+import Network.Shpider.Links
+
+-- | if `keepTrack` has been set, then haveVisited will return `True` if the given URL has been visited.
+haveVisited :: String -> Shpider Bool
+haveVisited uncleanUrl = do
+ murl <- mkAbsoluteUrl uncleanUrl
+ maybe ( return False )
+ ( \ url -> do
+ shpider <- get
+ return $ maybe False
+ ( \ vs ->
+ elem url vs
+ )
+ ( visited shpider )
+ )
+ murl
+
+-- | Parse a given URL and source html into the `Page` datatype.
+-- This will set the current page.
+parsePage :: String -> String -> Shpider Page
+parsePage paddr html = do
+ let ts =
+ parseTags html
+ ls =
+ gatherLinks ts
+ fs =
+ gatherForms ts
+ nPge = emptyPage { addr = paddr }
+ -- seems weird, but this is the side effect needed here to create the absolute urls next
+ setCurrentPage nPge
+ maybeAbsFormActions <- mapM mkAbsoluteUrl $ map action fs
+ maybeAbsLinkAddrs <- mapM mkAbsoluteUrl $ map linkAddress ls
+ let absLinkAddrs = catMaybes maybeAbsLinkAddrs
+ absFormActions = catMaybes maybeAbsFormActions
+ absFs = zipWith ( \ form a -> form { action = a }) fs absFormActions
+ absLinks = zipWith ( \ laddr l -> l { linkAddress = laddr }) absLinkAddrs ls
+ newP =
+ nPge { links = absLinks
+ , forms = absFs
+ , source = html
+ , tags = ts
+ , addr = paddr
+ }
+ setCurrentPage newP
+ return newP
+
+curlDownload url = do
+ shpider <- get
+ res <- liftIO $ curlGetString url $ curlOpts shpider
+ r <- mkRes url res
+ return r
+
+mkRes url ( curlCode , html ) = do
+ p <- if curlCode == CurlOK
+ then
+ parsePage url html
+ else
+ return emptyPage
+ return ( ccToSh curlCode , p )
+
+
+curlDownloadPost url fields = do
+ shpider <- get
+ res <- liftIO $ curlGetString url $ CurlPostFields ( map toPostField fields ) : curlOpts shpider
+ mkRes url res
+
+
+curlDownloadHead urlStr = do
+ shpider <- get
+ liftIO $ curlHead urlStr $ curlOpts shpider
+
+validContentType ct =
+ or $ map ( \ htmlct ->
+ ct =~ htmlct
+ )
+ htmlContentTypes
+
+htmlContentTypes =
+ [ "text/html"
+ , "application/xhtml+xml"
+ ]
+
+-- | Fetch whatever is at this address, and attempt to parse the content into a Page.
+-- Return the status code with the parsed content.
+download :: String -> Shpider ( ShpiderCode , Page )
+download messyUrl = do
+ shpider <- get
+ let maybeWrite u =
+ maybe ( return ( ) )
+ ( \ vs ->
+ put $ shpider { visited = Just $ u : vs }
+ )
+ ( visited shpider )
+ if not $ isMailto messyUrl
+ then do
+ murl <- mkAbsoluteUrl messyUrl
+ maybe ( return ( InvalidURL , emptyPage ) )
+ ( \ url -> withAuthorizedDomain url $ do
+ res@( c , page ) <- downloadAPage url
+ maybeWrite $ addr page
+ return res
+ )
+ murl
+ else do
+ maybeWrite messyUrl --if it's mail we want to write it so we don't try it again
+ return ( UnsupportedProtocol , emptyPage )
+
+
+downloadAPage url = do
+ shpider <- get
+ if htmlOnlyDownloads shpider
+ then do
+ if isHttp url
+ then do
+ ( _ , headers ) <- curlDownloadHead url
+ let maybeContentType =
+ lookup "Content-Type" headers
+ maybe ( curlDownload url )
+ ( \ ct -> do
+ if validContentType ct
+ then
+ curlDownload url
+ else
+ return ( WrongData , emptyPage )
+ )
+ maybeContentType
+ else
+ curlDownload url
+ else
+ curlDownload url
+
+-- | withAuthorizedDomain will execute the function if the url given is an authorized domain.
+-- See `isAuthorizedDomain`.
+withAuthorizedDomain :: String -> Shpider ( ShpiderCode , Page ) -> Shpider ( ShpiderCode , Page )
+withAuthorizedDomain url f = do
+ shpider <- get
+ if dontLeaveDomain shpider
+ then do
+ let d = startPage shpider
+ if isSameDomain d url
+ then
+ f
+ else
+ return ( OffSite , emptyPage )
+ else
+ f
+
+-- | Send a form to the URL specified in its action attribute
+sendForm :: Form -> Shpider ( ShpiderCode , Page )
+sendForm form = do
+ mabsAddr <- mkAbsoluteUrl $ action form
+ maybe ( return (InvalidURL , emptyPage ) )
+ ( \ absAddr -> withAuthorizedDomain absAddr $ do
+ case method form of
+ GET -> do
+ let Just u = importURL addr -- we can do the indisputable pattern match because mkAbsoluteUrl already calls importURL
+ addr = exportURL $ foldl ( \ a i -> add_param a i
+ )
+ u
+ ( M.toList $ inputs form )
+ curlDownload addr
+ POST ->
+ curlDownloadPost absAddr $ M.toList $ inputs form
+ )
+ mabsAddr
+
+toPostField ( name , value ) =
+ name ++ "=" ++ value
+
+-- | Return the links on the current page.
+currentLinks :: Shpider [ Link ]
+currentLinks = do
+ p <- getCurrentPage
+ return $ links p
+
+-- | Return the forms on the current page.
+currentForms :: Shpider [ Form ]
+currentForms = do
+ p <- getCurrentPage
+ return $ forms p
+
+-- | Get all links which match this text.
+getLinksByText :: String -> Shpider [ Link ]
+getLinksByText t = do
+ cls <- currentLinks
+ return $ filter ( (==) t . linkText )
+ cls
+
+-- | If `stayOnDomain` has been set to true, then isAuthorizedDomain returns `True` if the given URL is on the domain and false otherwise. If `stayOnDomain` has not been set to True, then it returns `True`.
+isAuthorizedDomain :: String -> Shpider Bool
+isAuthorizedDomain url = do
+ shpider <- get
+ return $ if dontLeaveDomain shpider
+ then
+ isSameDomain ( startPage shpider ) url
+ else
+ True
+
+-- | Get all links whose text matches this regex.
+getLinksByTextRegex :: String -> Shpider [ Link ]
+getLinksByTextRegex r = do
+ cls <- currentLinks
+ return $ filter ( flip (=~) r . linkText )
+ cls
+
+-- | Get all forms whose action matches the given action
+getFormsByAction :: String -> Shpider [ Form ]
+getFormsByAction a = do
+ murl <- mkAbsoluteUrl a
+ maybe ( return [ ] )
+ ( \ url -> fmap (filter $ (==) url . action) currentForms )
+ murl
+
+-- | Get all links whose address matches this regex.
+getLinksByAddressRegex :: String -> Shpider [ Link ]
+getLinksByAddressRegex r = do
+ cls <- currentLinks
+ return $ filter ( flip (=~) r . linkAddress )
+ cls
38 Network/Shpider/Code.hs
@@ -0,0 +1,38 @@
+module Network.Shpider.Code
+ ( module Network.Shpider.Curl.Code
+ , ccToSh
+ , ShpiderCode (..)
+ )
+ where
+
+import Network.Shpider.Curl.Code
+
+-- | Converts a `CurlCode` to a `ShpiderCode`.
+ccToSh :: CurlCode -> ShpiderCode
+ccToSh curlCode =
+ case curlCode of
+ CurlOK ->
+ Ok
+ CurlHttpReturnedError ->
+ HttpError
+ CurlCouldntResolveHost ->
+ NoHost
+ CurlUnspportedProtocol ->
+ UnsupportedProtocol
+ CurlOperationTimeout ->
+ TimeOut
+ c ->
+ UnsupportedCurlStatus c
+
+-- | ShpiderCode describes the various contingencies which may occur during a shpider transaction.
+data ShpiderCode =
+ Ok
+ | InvalidURL
+ | HttpError
+ | OffSite
+ | WrongData
+ | NoHost
+ | UnsupportedProtocol
+ | TimeOut
+ | UnsupportedCurlStatus CurlCode
+ deriving ( Show , Eq )
109 Network/Shpider/Curl/Code.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS -fvia-C -#include "curl/curl.h" #-}
+--------------------------------------------------------------------
+-- |
+-- Module : Network.Curl.Code
+-- Copyright : (c) Galois Inc 2007-2009
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sof@galois.com>
+-- Stability : provisional
+-- Portability: portable
+--
+-- Representing Curl's status codes as a Haskell type.
+--
+--------------------------------------------------------------------
+
+module Network.Shpider.Curl.Code where
+
+import Foreign.C.Types
+
+data CurlCode
+ = CurlOK
+ | CurlUnspportedProtocol
+ | CurlFailedInit
+ | CurlUrlMalformat
+ | CurlUrlMalformatUser
+ | CurlCouldntResolveProxy
+ | CurlCouldntResolveHost
+ | CurlCouldntConnect
+ | CurlFtpWeirdServerReply
+ | CurlFtpAccessDenied
+ | CurlFtpUserPasswordIncorrect
+ | CurlFtpWeirdPassReply
+ | CurlFtpWeirdUserReply
+ | CurlFtpWeirdPASVReply
+ | CurlFtpWeird227Format
+ | CurlFtpCantGetHost
+ | CurlFtpCantReconnect
+ | CurlFtpCouldnSetBinary
+ | CurlPartialFile
+ | CurlFtpCouldntRetrFile
+ | CurlFtpWriteError
+ | CurlFtpQuoteError
+ | CurlHttpReturnedError
+ | CurlWriteError
+ | CurlMalformatError
+ | CurlFtpCouldnStorFile
+ | CurlReadError
+ | CurlOutOfMemory
+ | CurlOperationTimeout
+ | CurlFtpCouldntSetAscii
+ | CurlFtpPortFailed
+ | CurlFtpCouldntUseRest
+ | CurlFtpCouldntGetSize
+ | CurlHttpRangeError
+ | CurlHttpPostError
+ | CurlSSLConnectError
+ | CurlBadDownloadResume
+ | CurlFileCouldntReadFile
+ | CurlLDAPCannotBind
+ | CurlLDPAPSearchFailed
+ | CurlLibraryNotFound
+ | CurlFunctionNotFound
+ | CurlAbortedByCallback
+ | CurlBadFunctionArgument
+ | CurlBadCallingOrder
+ | CurlInterfaceFailed
+ | CurlBadPasswordEntered
+ | CurlTooManyRedirects
+ | CurlUnknownTelnetOption
+ | CurlTelnetOptionSyntax
+ | CurlObsolete
+ | CurlSSLPeerCertificate
+ | CurlGotNothing
+ | CurlSSLEngineNotFound
+ | CurlSSLEngineSetFailed
+ | CurlSendError
+ | CurlRecvError
+ | CurlShareInUse
+ | CurlSSLCertProblem
+ | CurlSSLCipher
+ | CurlSSLCACert
+ | CurlBadContentEncoding
+ | CurlLDAPInvalidUrl
+ | CurlFilesizeExceeded
+ | CurlFtpSSLFailed
+ | CurlSendFailRewind
+ | CurlSSLEngineInitFailed
+ | CurlLoginDenied
+ | CurlTFtpNotFound
+ | CurlTFtpPerm
+ | CurlTFtpDiskFull
+ | CurlTFtpIllegal
+ | CurlTFtpUnknownId
+ | CurlTFtpExists
+ | CurlTFtpNoSuchUser
+ | CurlConvFailed
+ | CurlConvReqd
+ | CurlSSLCACertBadFile
+ | CurlRemoveFileNotFound
+ | CurlSSH
+ | CurlSSLShutdownFailed
+ | CurlAgain
+ | CurlSSLCRLBadFile
+ | CurlSSLIssuerError
+ deriving ( Eq, Show, Enum )
+
+toCode :: CInt -> CurlCode
+toCode x = toEnum (fromIntegral x)
502 Network/Shpider/Curl/Curl.hs
@@ -0,0 +1,502 @@
+{-# OPTIONS_GHC -XTypeSynonymInstances -XFlexibleInstances #-}
+-- | Note: As you may have gathered, this is not the official module. The cookie handling in the curl package is non-determistic in its handling of cookies as they are written from curl_easy_cleanup during garbage collection, easy_cleanup is called explicitely, writing the cookies instantly . However, I have preserved the following copyright notice to give credit where it's due.
+--------------------------------------------------------------------
+-- Module : Network.Curl
+-- Copyright : (c) 2007-2009, Galois Inc
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sof@galois.com>
+-- Stability : provisional
+-- Portability: portable
+--
+-- A Haskell binding the libcurl library <http://curl.haxx.se/>, a
+-- proven and feature-rich library for interacting with HTTP(S)\/FTP
+-- servers.
+--
+-- The binding was initially made against version 7.16.2; libcurl does
+-- appear to be considerate in not introducing breaking changes wrt
+-- older versions. So, unless you're after the latest features (i.e.,
+-- constructors towards the end the Option type), there's a very good
+-- chance your code will work against older installations of libcurl.
+--
+--------------------------------------------------------------------
+
+module Network.Shpider.Curl.Curl
+ ( module Network.Shpider.Curl.Opts
+ , module Network.Shpider.Curl.Easy
+ , module Network.Shpider.Curl.Post
+ , module Network.Shpider.Curl.Info
+ , module Network.Shpider.Curl.Types
+ , module Network.Shpider.Curl.Code
+
+ -- controlled export of this module:
+ -- (ToDo: tighten it up even more)
+ , withCurlDo -- :: IO a -> IO a
+ , setopts -- :: Curl -> [CurlOption] -> IO ()
+
+ , CurlResponse_(..)
+ , CurlResponse
+
+ -- get resources and assoc. metadata.
+ , curlGet -- :: URLString -> [CurlOption] -> IO ()
+ , curlGetString -- :: URLString -> [CurlOption] -> IO (CurlCode, String)
+ , curlGetResponse -- :: URLString -> [CurlOption] -> IO CurlResponse
+ , perform_with_response -- :: Curl -> IO CurlResponse
+ , do_curl -- :: Curl -> URLString -> [CurlOption] -> IO CurlResponse
+
+ , curlGetString_ -- :: CurlBuffer ty => URLString -> [CurlOption] -> IO (CurlCode, ty)
+ , curlGetResponse_ -- :: URLString -> [CurlOption] -> IO (CurlResponse_ a b)
+ , perform_with_response_ -- :: Curl -> IO (CurlResponse_ a b)
+ , do_curl_ -- :: Curl -> URLString -> [CurlOption] -> IO (CurlResponse_ a b)
+ , curlHead_ -- :: URLString
+ -- -> [CurlOption]
+ -- -> IO (String,ty)
+
+ -- probing for gold..
+ , curlHead -- :: URLString
+ -- -> [CurlOption]
+ -- -> IO (String,[(String,String)])
+
+ -- posting requests.
+ , curlMultiPost -- :: URLString -> [CurlOption] -> [HttpPost] -> IO ()
+ , curlPost -- :: URLString -> [String] -> IO ()
+
+ --
+ , getResponseCode -- :: Curl -> IO Int
+
+ -- supporting cast
+ , setDefaultSSLOpts -- :: Curl -> URLString -> IO ()
+ , callbackWriter -- :: (String -> IO ()) -> WriteFunction
+ , easyWriter -- :: (String -> IO ()) -> WriteFunction
+ , ignoreOutput -- :: WriteFunction
+ , gatherOutput -- :: IORef [String] -> WriteFunction
+
+ , gatherOutput_ -- :: (CStringLen -> IO ()) -> WriteFunction
+ , CurlBuffer(..)
+ , CurlHeader(..)
+
+ , method_GET -- :: [CurlOption]
+ , method_HEAD -- :: [CurlOption]
+ , method_POST -- :: [CurlOption]
+
+ , parseStatusNHeaders
+ , parseHeader
+ -- ToDo: get rid of (pretty sure I can already...)
+ , concRev
+ ) where
+
+import Network.Shpider.Curl.Opts
+import Network.Shpider.Curl.Code
+import Network.Shpider.Curl.Types
+import Network.Shpider.Curl.Post
+import Network.Shpider.Curl.Info
+import Network.Shpider.Curl.Easy
+
+import Foreign.C.String
+import Data.IORef
+import Data.List(isPrefixOf)
+import System.IO
+import Control.Exception ( finally )
+
+import Data.ByteString ( ByteString, packCStringLen )
+import qualified Data.ByteString as BS ( concat )
+
+import qualified Data.ByteString.Lazy as LazyBS ( ByteString, fromChunks )
+
+-- | The @CurlBuffer@ class encodes the representation
+-- of response buffers, allowing you to provide your
+-- own app-specific buffer reps to be used..or use
+-- one of the standard instances (String and ByteStrings.)
+--
+class CurlBuffer bufferTy where
+ newIncoming :: IO (IO bufferTy, CStringLen -> IO ())
+
+
+-- | The @CurlHeader@ class encodes the representation
+-- of response headers. Similar to 'CurlBuffer'.
+--
+class CurlHeader headerTy where
+ newIncomingHeader :: IO (IO (String{-status-},headerTy), CStringLen -> IO ())
+
+instance CurlHeader [(String,String)] where
+ newIncomingHeader = do
+ ref <- newIORef []
+ let readFinalHeader = do
+ hss <- readIORef ref
+ let (st,hs) = parseStatusNHeaders (concRev [] hss)
+ return (st,hs)
+ return (readFinalHeader, \ v -> peekCStringLen v >>= \ x -> modifyIORef ref (x:))
+
+instance CurlBuffer String where
+ newIncoming = do
+ ref <- newIORef []
+ let readFinal = readIORef ref >>= return . concat . reverse
+ return (readFinal, \ v -> peekCStringLen v >>= \ x -> modifyIORef ref (x:))
+
+instance CurlBuffer ByteString where
+ newIncoming = do
+ ref <- newIORef []
+ let readFinal = readIORef ref >>= return . BS.concat . reverse
+ return (readFinal, \ v -> packCStringLen v >>= \ x -> modifyIORef ref (x:))
+
+instance CurlBuffer [ByteString] where
+ newIncoming = do
+ ref <- newIORef []
+ let readFinal = readIORef ref >>= return . reverse
+ return (readFinal, \ v -> packCStringLen v >>= \ x -> modifyIORef ref (x:))
+
+instance CurlBuffer LazyBS.ByteString where
+ newIncoming = do
+ ref <- newIORef []
+ let readFinal = readIORef ref >>= return . LazyBS.fromChunks . reverse
+ return (readFinal, \ v -> packCStringLen v >>= \ x -> modifyIORef ref (x:))
+
+-- | Should be used once to wrap all uses of libcurl.
+-- WARNING: the argument should not return before it
+-- is completely done with curl (e.g., no forking or lazy returns)
+withCurlDo :: IO a -> IO a
+withCurlDo m = do curl_global_init 3 -- initialize everything
+ finally m curl_global_cleanup
+
+-- | Set a list of options on a Curl handle.
+setopts :: Curl -> [CurlOption] -> IO ()
+setopts h opts = mapM_ (setopt h) opts
+
+
+method_GET :: [CurlOption]
+method_GET = [CurlPost False, CurlNoBody False]
+
+method_POST :: [CurlOption]
+method_POST = [CurlPost True, CurlNoBody False]
+
+method_HEAD :: [CurlOption]
+method_HEAD = [CurlPost False, CurlNoBody True]
+
+-- | 'curlGet' perform a basic GET, dumping the output on stdout.
+-- The list of options are set prior performing the GET request.
+curlGet :: URLString -> [CurlOption] -> IO ()
+curlGet url opts = initialize_no_cleanup >>= \ h -> do
+ setopt h (CurlFailOnError True)
+ setopt h (CurlURL url)
+ -- Note: later options may (and should, probably) override these defaults.
+ setDefaultSSLOpts h url
+ mapM_ (setopt h) opts
+ perform h
+ manual_cleanup h
+ return ()
+
+setDefaultSSLOpts :: Curl -> URLString -> IO ()
+setDefaultSSLOpts h url
+ | "https:" `isPrefixOf` url = do
+ -- the default options are pretty dire, really -- turning off
+ -- the peer verification checks!
+ mapM_ (setopt h)
+ [ CurlSSLVerifyPeer False
+ , CurlSSLVerifyHost 0
+ ]
+ | otherwise = return ()
+
+-- | 'curlGetString' performs the same request as 'curlGet', but
+-- returns the response body as a Haskell string.
+curlGetString :: URLString
+ -> [CurlOption]
+ -> IO (CurlCode, String)
+curlGetString url opts = initialize_no_cleanup >>= \ h -> do
+ ref <- newIORef []
+ -- Note: later options may (and should, probably) override these defaults.
+ setopt h (CurlFailOnError True)
+ setDefaultSSLOpts h url
+ setopt h (CurlURL url)
+ setopt h (CurlWriteFunction (gatherOutput ref))
+ mapM_ (setopt h) opts
+ rc <- perform h
+ manual_cleanup h
+ lss <- readIORef ref
+ return (rc, concat $ reverse lss)
+
+curlGetString_ :: (CurlBuffer ty)
+ => URLString
+ -> [CurlOption]
+ -> IO (CurlCode, ty)
+curlGetString_ url opts = initialize_no_cleanup >>= \ h -> do
+ (finalBody, gatherBody) <- newIncoming
+ setopt h (CurlFailOnError True)
+ setDefaultSSLOpts h url
+ setopt h (CurlURL url)
+ setopt h (CurlWriteFunction (gatherOutput_ gatherBody))
+ mapM_ (setopt h) opts
+ rc <- perform h
+ manual_cleanup h
+ bs <- finalBody
+ return (rc, bs)
+
+type CurlResponse = CurlResponse_ [(String,String)] String
+
+-- | 'CurlResponse_' is a record type encoding all the information
+-- embodied in a response to your Curl request. Currently only used
+-- to gather up the results of doing a GET in 'curlGetResponse'.
+data CurlResponse_ headerTy bodyTy
+ = CurlResponse
+ { respCurlCode :: CurlCode
+ , respStatus :: Int
+ , respStatusLine :: String
+ , respHeaders :: headerTy
+ , respBody :: bodyTy
+ , respGetInfo :: (Info -> IO InfoValue)
+ }
+
+
+-- | @curlGetResponse url opts@ performs a @GET@, returning all the info
+-- it can lay its hands on in the response, a value of type 'CurlResponse'.
+-- The representation of the body is overloaded
+curlGetResponse_ :: (CurlHeader hdr, CurlBuffer ty)
+ => URLString
+ -> [CurlOption]
+ -> IO (CurlResponse_ hdr ty)
+curlGetResponse_ url opts = do
+ h <- initialize_no_cleanup
+ -- Note: later options may (and should, probably) override these defaults.
+ setopt h (CurlFailOnError True)
+ setDefaultSSLOpts h url
+ setopt h (CurlURL url)
+ mapM_ (setopt h) opts
+ -- note that users cannot over-write the body and header handler
+ -- which makes sense because otherwise we will return a bogus reposnse.
+ manual_perform_with_response_ h
+
+{-# DEPRECATED curlGetResponse "Switch to using curlGetResponse_" #-}
+curlGetResponse :: URLString
+ -> [CurlOption]
+ -> IO CurlResponse
+curlGetResponse url opts = curlGetResponse_ url opts
+
+-- | Perform the actions already specified on the handle.
+-- Collects useful information about the returned message.
+-- Note that this function sets the
+-- 'CurlWriteFunction' and 'CurlHeaderFunction' options.
+perform_with_response :: (CurlHeader hdrTy, CurlBuffer bufTy)
+ => Curl
+ -> IO (CurlResponse_ hdrTy bufTy)
+perform_with_response h = perform_with_response_ h
+
+{-# DEPRECATED perform_with_response "Consider switching to perform_with_response_" #-}
+
+-- | Perform the actions already specified on the handle.
+-- Collects useful information about the returned message.
+-- Note that this function sets the
+-- 'CurlWriteFunction' and 'CurlHeaderFunction' options.
+-- The returned payload is overloaded over the representation of
+-- both headers and body via the 'CurlResponse_' type.
+-- Deterministic cleanup
+manual_perform_with_response_ :: (CurlHeader headerTy, CurlBuffer bodyTy)
+ => Curl
+ -> IO (CurlResponse_ headerTy bodyTy)
+manual_perform_with_response_ h = do
+ (finalHeader, gatherHeader) <- newIncomingHeader
+ (finalBody, gatherBody) <- newIncoming
+
+ -- Instead of allocating a separate handler for each
+ -- request we could just set this options one and forall
+ -- and just clear the IORefs.
+
+ setopt h (CurlWriteFunction (gatherOutput_ gatherBody))
+ setopt h (CurlHeaderFunction (gatherOutput_ gatherHeader))
+ rc <- perform h
+ manual_cleanup h
+ rspCode <- getResponseCode h
+ (st,hs) <- finalHeader
+ bs <- finalBody
+ return CurlResponse
+ { respCurlCode = rc
+ , respStatus = rspCode
+ , respStatusLine = st
+ , respHeaders = hs
+ , respBody = bs
+ -- note: we're holding onto the handle here..
+ -- note: with this interface this is not neccessary.
+ , respGetInfo = getInfo h
+ }
+
+-- | Perform the actions already specified on the handle.
+-- Collects useful information about the returned message.
+-- Note that this function sets the
+-- 'CurlWriteFunction' and 'CurlHeaderFunction' options.
+-- The returned payload is overloaded over the representation of
+-- both headers and body via the 'CurlResponse_' type.
+perform_with_response_ :: (CurlHeader headerTy, CurlBuffer bodyTy)
+ => Curl
+ -> IO (CurlResponse_ headerTy bodyTy)
+perform_with_response_ h = do
+ (finalHeader, gatherHeader) <- newIncomingHeader
+ (finalBody, gatherBody) <- newIncoming
+
+ -- Instead of allocating a separate handler for each
+ -- request we could just set this options one and forall
+ -- and just clear the IORefs.
+
+ setopt h (CurlWriteFunction (gatherOutput_ gatherBody))
+ setopt h (CurlHeaderFunction (gatherOutput_ gatherHeader))
+ rc <- perform h
+ rspCode <- getResponseCode h
+ (st,hs) <- finalHeader
+ bs <- finalBody
+ return CurlResponse
+ { respCurlCode = rc
+ , respStatus = rspCode
+ , respStatusLine = st
+ , respHeaders = hs
+ , respBody = bs
+ -- note: we're holding onto the handle here..
+ -- note: with this interface this is not neccessary.
+ , respGetInfo = getInfo h
+ }
+
+
+-- | Performs a curl request using an exisitng curl handle.
+-- The provided URL will overwride any 'CurlURL' options that
+-- are provided in the list of options. See also: 'perform_with_response'.
+do_curl :: Curl -> URLString -> [CurlOption] -> IO CurlResponse
+do_curl h url opts = do_curl_ h url opts
+
+{-# DEPRECATED do_curl "Consider switching to do_curl_" #-}
+
+do_curl_ :: (CurlHeader headerTy, CurlBuffer bodyTy)
+ => Curl
+ -> URLString
+ -> [CurlOption]
+ -> IO (CurlResponse_ headerTy bodyTy)
+do_curl_ h url opts = do
+ setDefaultSSLOpts h url
+ setopts h opts
+ setopt h (CurlURL url)
+ perform_with_response_ h
+
+
+-- | Get the headers associated with a particular URL.
+-- Returns the status line and the key-value pairs for the headers.
+curlHead :: URLString -> [CurlOption] -> IO (String,[(String,String)])
+curlHead url opts = initialize_no_cleanup >>= \ h ->
+ do ref <- newIORef []
+-- setopt h (CurlVerbose True)
+ setopt h (CurlURL url)
+ setopt h (CurlNoBody True)
+ mapM_ (setopt h) opts
+ setopt h (CurlHeaderFunction (gatherOutput ref))
+ perform h
+ manual_cleanup h
+ lss <- readIORef ref
+ return (parseStatusNHeaders (concRev [] lss))
+
+-- | Get the headers associated with a particular URL.
+-- Returns the status line and the key-value pairs for the headers.
+curlHead_ :: (CurlHeader headers)
+ => URLString
+ -> [CurlOption]
+ -> IO (String, headers)
+curlHead_ url opts = initialize_no_cleanup >>= \ h -> do
+ (finalHeader, gatherHeader) <- newIncomingHeader
+-- setopt h (CurlVerbose True)
+ setopt h (CurlURL url)
+ setopt h (CurlNoBody True)
+ mapM_ (setopt h) opts
+ setopt h (CurlHeaderFunction (gatherOutput_ gatherHeader))
+ perform h
+ manual_cleanup h
+ finalHeader
+
+
+-- utils
+
+concRev :: [a] -> [[a]] -> [a]
+concRev acc [] = acc
+concRev acc (x:xs) = concRev (x++acc) xs
+
+parseStatusNHeaders :: String -> (String, [(String,String)])
+parseStatusNHeaders ys =
+ case intoLines [] ys of
+ a:as -> (a,map parseHeader as)
+ [] -> ("",[])
+ where
+ intoLines acc "" = addLine acc []
+ intoLines acc ('\r':'\n':xs) = addLine acc (intoLines "" xs)
+ intoLines acc (x:xs) = intoLines (x:acc) xs
+
+ addLine "" ls = ls
+ addLine l ls = (reverse l) : ls
+
+parseHeader :: String -> (String,String)
+parseHeader xs =
+ case break (':' ==) xs of
+ (as,_:bs) -> (as, bs)
+ (as,_) -> (as,"")
+
+-- | 'curlMultiPost' perform a multi-part POST submission.
+curlMultiPost :: URLString -> [CurlOption] -> [HttpPost] -> IO ()
+curlMultiPost s os ps = initialize_no_cleanup >>= \ h -> do
+ setopt h (CurlVerbose True)
+ setopt h (CurlURL s)
+ setopt h (CurlHttpPost ps)
+ mapM_ (setopt h) os
+ perform h
+ manual_cleanup h
+ return ()
+
+
+-- | 'curlPost' performs. a common POST operation, namely that
+-- of submitting a sequence of name=value pairs.
+curlPost :: URLString -> [String] -> IO ()
+curlPost s ps = initialize_no_cleanup >>= \ h -> do
+ setopt h (CurlVerbose True)
+ setopt h (CurlPostFields ps)
+ setopt h (CurlCookieJar "cookies")
+ setopt h (CurlURL s)
+ perform h
+ manual_cleanup h
+ return ()
+
+
+
+-- Use 'callbackWriter' instead.
+{-# DEPRECATED #-}
+easyWriter :: (String -> IO ()) -> WriteFunction
+easyWriter = callbackWriter
+
+-- | Imports data into the Haskell world and invokes the callback.
+callbackWriter :: (String -> IO ()) -> WriteFunction
+callbackWriter f pBuf sz szI _ =
+ do let bytes = sz * szI
+ f =<< peekCStringLen (pBuf,fromIntegral bytes)
+ return bytes
+
+-- | Imports data into the Haskell world and invokes the callback.
+callbackWriter_ :: (CStringLen -> IO ()) -> WriteFunction
+callbackWriter_ f pBuf sz szI _ = do
+ do let bytes = sz * szI
+ f (pBuf,fromIntegral bytes)
+ return bytes
+
+-- | The output of Curl is ignored. This function
+-- does not marshall data into Haskell.
+ignoreOutput :: WriteFunction
+ignoreOutput _ x y _ = return (x*y)
+
+-- | Add chunks of data to an IORef as they arrive.
+gatherOutput :: IORef [String] -> WriteFunction
+gatherOutput r = callbackWriter (\ v -> modifyIORef r (v:))
+
+-- | Add chunks of data to an IORef as they arrive.
+gatherOutput_ :: (CStringLen -> IO ()) -> WriteFunction
+gatherOutput_ f = callbackWriter_ f
+
+getResponseCode :: Curl -> IO Int
+getResponseCode c = do
+ iv <- getInfo c ResponseCode
+ case iv of
+ IString s ->
+ case (reads s) of
+ ((v,_):_) -> return v
+ _ -> fail ("Curl.getResponseCode: not a valid integer string " ++ s)
+ IDouble d -> return (round d)
+ ILong x -> return (fromIntegral x)
+ IList{} -> fail ("Curl.getResponseCode: unexpected response code " ++ show iv)
+
24 Network/Shpider/Curl/Debug.hs
@@ -0,0 +1,24 @@
+--------------------------------------------------------------------
+-- |
+-- Module : Network.Curl.Debug
+-- Copyright : (c) Galois, Inc. 2008-2009
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sof@galois.com>
+-- Stability : provisional
+-- Portability:
+--
+-- Debug hooks
+
+module Network.Shpider.Curl.Debug (debug) where
+
+import System.IO
+
+debugging :: Bool
+debugging = False
+
+debug :: String -> IO ()
+debug msg
+ | debugging = putStrLn ("DEBUG: " ++ msg) >> hFlush stdout
+ | otherwise = return ()
+
235 Network/Shpider/Curl/Easy.hs
@@ -0,0 +1,235 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS -fvia-C -#include "curl/curl.h" #-}
+--------------------------------------------------------------------
+-- |
+-- Module : Network.Curl.Easy
+-- Copyright : (c) Galois Inc 2007-2009
+-- License :
+--
+-- Maintainer: Sigbjorn Finne <sof@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.Shpider.Curl.Easy
+ ( initialize -- :: IO Curl
+ , initialize_no_cleanup -- :: 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 ()
+
+ , curl_version_number -- :: IO Int
+ , curl_version_string -- :: IO String
+ ) where
+
+import Network.Shpider.Curl.Types
+import Network.Shpider.Curl.Opts
+import Network.Shpider.Curl.Code
+import Network.Shpider.Curl.Post
+
+import Network.Shpider.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
+
+-- | Initialize a curl instance
+-- | No automatic garbage colelction
+initialize_no_cleanup :: IO Curl
+initialize_no_cleanup = do
+ h <- easy_initialize
+ mkCurl_no_cleanup 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
+
+curl_version_number :: IO Int
+curl_version_number = do
+ x <- curl_version_num
+ return (fromIntegral x)
+
+curl_version_string :: IO String
+curl_version_string = do
+ cs <- curl_version_str
+ peekCString cs
+
+-- FFI decls
+
+
+foreign import ccall
+ "curl_version_num" curl_version_num :: IO CInt
+
+foreign import ccall
+ "curl_version_str" curl_version_str :: IO CString
+
+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_long" easy_setopt_long :: CurlH -> Int -> Long -> IO CInt
+
+foreign import ccall
+ "curl_easy_setopt_longlong" easy_setopt_llong :: CurlH -> Int -> LLong -> IO CInt
+
+foreign import ccall
+ "curl_easy_setopt_string" easy_setopt_string :: CurlH -> Int -> Ptr CChar -> IO CInt
+
+foreign import ccall
+ "curl_easy_setopt_ptr" easy_setopt_ptr :: CurlH -> Int -> Ptr a -> IO CInt
+
+foreign import ccall
+ "curl_easy_setopt_ptr" easy_setopt_fptr :: CurlH -> Int -> FunPtr a -> IO CInt
+
+foreign import ccall
+ "curl_easy_setopt_ptr" easy_setopt_wfun :: CurlH -> Int -> FunPtr WriteFunction -> IO CInt
+
+foreign import ccall
+ "curl_easy_setopt_ptr" 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)
+
+
196 Network/Shpider/Curl/Info.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS -fvia-C -#include "curl/curl.h" #-}
+--------------------------------------------------------------------
+-- |
+-- Module : Network.Curl.Info
+-- Copyright : (c) 2007-2009, Galois Inc
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sof@galois.com>
+-- Stability : provisional
+-- Portability: portable
+--
+-- Accessing the properties of a curl handle's current state\/request.
+--
+--------------------------------------------------------------------
+module Network.Shpider.Curl.Info
+ ( Info(..)
+ , InfoValue(..)
+ , getInfo -- :: Curl -> Info -> IO InfoValue
+ ) where
+
+import Network.Shpider.Curl.Types
+import Network.Shpider.Curl.Code
+
+import Control.Monad
+import Foreign.Ptr
+import Foreign.Marshal.Alloc
+import Foreign.Storable
+import Foreign.C
+
+
+data Info
+ = EffectiveUrl
+ | ResponseCode
+ | TotalTime
+ | NameLookupTime
+ | ConnectTime
+ | PreTransferTime
+ | SizeUpload
+ | SizeDownload
+ | SpeedDownload
+ | SpeedUpload
+ | HeaderSize
+ | RequestSize
+ | SslVerifyResult
+ | Filetime
+ | ContentLengthDownload
+ | ContentLengthUpload
+ | StartTransferTime
+ | ContentType
+ | RedirectTime
+ | RedirectCount
+ | Private
+ | HttpConnectCode
+ | HttpAuthAvail
+ | ProxyAuthAvail
+ | OSErrno
+ | NumConnects
+ | SslEngines
+ | CookieList
+ | LastSocket
+ | FtpEntryPath
+ deriving (Show,Enum,Bounded)
+
+data InfoValue
+ = IString String
+ | ILong Long
+ | IDouble Double
+ | IList [String]
+
+instance Show InfoValue where
+ show k =
+ case k of
+ IString s -> s
+ ILong l -> show l
+ IDouble d -> show d
+ IList ss -> show ss
+
+stringTag :: Long
+stringTag = 0x100000 -- CURLINFO_STRING
+
+longTag :: Long
+longTag = 0x200000 -- CURLINFO_LONG
+
+doubleTag :: Long
+doubleTag = 0x300000 -- CURLINFO_DOUBLE
+
+slistTag :: Long
+slistTag = 0x400000 -- CURLINFO_SLIST
+
+{- unused, unexported
+infoMask :: Long
+infoMask = 0x0fffff -- CURLINFO_MASK
+
+infoTypeMask :: Long
+infoTypeMask = 0xf00000 -- CURLINFO_TYPEMASK
+-}
+
+getInfo :: Curl -> Info -> IO InfoValue
+getInfo h i = do
+ case i of
+ EffectiveUrl -> getInfoStr h (show i) 1
+ ResponseCode -> getInfoLong h (show i) 2
+ TotalTime -> getInfoDouble h (show i) 3
+ NameLookupTime -> getInfoDouble h (show i) 4
+ ConnectTime -> getInfoDouble h (show i) 5
+ PreTransferTime -> getInfoDouble h (show i) 6
+ SizeUpload -> getInfoDouble h (show i) 7
+ SizeDownload -> getInfoDouble h (show i) 8
+ SpeedDownload -> getInfoDouble h (show i) 9
+ SpeedUpload -> getInfoDouble h (show i) 10
+ HeaderSize -> getInfoLong h (show i) 11
+ RequestSize -> getInfoLong h (show i) 12
+ SslVerifyResult -> getInfoLong h (show i) 13
+ Filetime -> getInfoLong h (show i) 14
+ ContentLengthDownload -> getInfoDouble h (show i) 15
+ ContentLengthUpload -> getInfoDouble h (show i) 16
+ StartTransferTime -> getInfoDouble h (show i) 17
+ ContentType -> getInfoStr h (show i) 18
+ RedirectTime -> getInfoDouble h (show i) 19
+ RedirectCount -> getInfoLong h (show i) 20
+ Private -> getInfoStr h (show i) 21
+ HttpConnectCode -> getInfoLong h (show i) 22
+ HttpAuthAvail -> getInfoLong h (show i) 23
+ ProxyAuthAvail -> getInfoLong h (show i) 24
+ OSErrno -> getInfoLong h (show i) 25
+ NumConnects -> getInfoLong h (show i) 26
+ SslEngines -> getInfoSList h (show i) 27
+ CookieList -> getInfoSList h (show i) 28
+ LastSocket -> getInfoLong h (show i) 29
+ FtpEntryPath -> getInfoStr h (show i) 30
+
+getInfoStr :: Curl -> String -> Long -> IO InfoValue
+getInfoStr h loc tg =
+ alloca $ \ ps -> do
+ rc <- curlPrim h $ \_ p -> easy_getinfo_str p tg ps
+ case rc of
+ 0 -> do
+ s <- peek ps
+ if s == nullPtr
+ then return (IString "")
+ else liftM IString $ peekCString s
+ _ -> fail ("getInfo{"++loc ++ "}: " ++ show (toCode rc))
+
+getInfoLong :: Curl -> String -> Long -> IO InfoValue
+getInfoLong h loc tg =
+ alloca $ \ pl -> do
+ rc <- curlPrim h $ \_ p -> easy_getinfo_long p tg pl
+ case rc of
+ 0 -> do
+ l <- peek pl
+ return (ILong l)
+ _ -> fail ("getInfo{"++loc ++ "}: " ++ show (toCode rc))
+
+getInfoDouble :: Curl -> String -> Long -> IO InfoValue
+getInfoDouble h loc tg =
+ alloca $ \ pd -> do
+ rc <- curlPrim h $ \_ p -> easy_getinfo_double p tg pd
+ case rc of
+ 0 -> do
+ d <- peek pd
+ return (IDouble d)
+ _ -> fail ("getInfo{"++loc ++ "}: " ++ show (toCode rc))
+
+getInfoSList :: Curl -> String -> Long -> IO InfoValue
+getInfoSList h loc tg =
+ alloca $ \ ps -> do
+ rc <- curlPrim h $ \_ p -> easy_getinfo_slist p tg ps
+ case rc of
+ 0 -> do
+ p <- peek ps
+ ls <- unmarshallList p
+ return (IList ls)
+ _ -> fail ("getInfo{"++loc ++ "}: " ++ show (toCode rc))
+ where
+ unmarshallList ptr
+ | ptr == nullPtr = return []
+ | otherwise = do
+ ps <- peekByteOff ptr 0
+ s <- if ps == nullPtr then return "" else peekCString ps
+ nx <- peekByteOff ptr (sizeOf nullPtr)
+ ls <- unmarshallList nx
+ return (s:ls)
+
+-- FFI decls
+foreign import ccall
+ "curl_easy_getinfo_long" easy_getinfo_long :: CurlH -> Long -> Ptr Long -> IO CInt
+
+foreign import ccall
+ "curl_easy_getinfo_string" easy_getinfo_str :: CurlH -> Long -> Ptr CString -> IO CInt
+
+foreign import ccall
+ "curl_easy_getinfo_double" easy_getinfo_double :: CurlH -> Long -> Ptr Double -> IO CInt
+
+foreign import ccall
+ "curl_easy_getinfo_slist" easy_getinfo_slist :: CurlH -> Long -> Ptr (Ptr (Ptr CChar)) -> IO CInt
708 Network/Shpider/Curl/Opts.hs
@@ -0,0 +1,708 @@
+--------------------------------------------------------------------
+-- |
+-- Module : Network.Curl.Opts
+-- Copyright : (c) Galois Inc 2007-2009
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sof@galois.com>
+-- Stability : provisional
+-- Portability: portable
+--
+-- This module contains the various options that specify what happens
+-- when we use @perform@ on a @Curl@ handle.
+--------------------------------------------------------------------
+module Network.Shpider.Curl.Opts where
+
+import Network.Shpider.Curl.Types
+import Network.Shpider.Curl.Post
+import Data.List
+
+import Foreign.Ptr
+import Foreign.C.Types
+import Data.Bits
+
+data CurlOption
+ = CurlFileObj (Ptr ()) -- ^ external pointer to pass to as 'WriteFunction's last argument.
+ | CurlURL URLString -- ^ the URL to use for next request; can be the full URL or just the authority\/hostname.
+ | CurlPort Long -- ^ what port to use.
+ | CurlProxy String -- ^ name of proxy
+ | CurlUserPwd String -- ^ the "user:pass" string to use
+ | CurlProxyUserPwd String -- ^ same thing, but for the proxy.
+ | CurlRange String -- ^ byte range to fetch
+ | CurlInFile FilePath -- ^ external pointer to pass to as 'WriteFunction's last argument.
+ | CurlErrorBuffer (Ptr CChar) -- ^ buffer for curl to deposit error messages (must at least CURL_ERROR_SIZE bytes long). Uses standard error if not specified.
+ | CurlWriteFunction WriteFunction -- ^ callback to handle incoming data.
+ | CurlReadFunction ReadFunction -- ^ callback for supplying outgoing\/uploaded data.
+ | CurlTimeout Long{-secs-} -- ^ number of seconds before timing out curl operation\/request.
+ | CurlInFileSize Long{-bytes-} -- ^ expected size of uploaded data.
+ | CurlPostFields [String] -- ^ (Multipart) POST data.
+ | CurlReferer String -- ^ Set the Referer: header to the given string.
+ | CurlFtpPort String -- ^ The string to feed to the FTP PORT command.
+ | CurlUserAgent String -- ^ Set the User-Agent: header to the given string.
+ | CurlLowSpeed Long -- ^ If the bytes per sec drops below the given value, the operation is aborted.
+ | CurlLowSpeedTime Long -- ^ Upper bound for request to complete.
+ | CurlResumeFrom Long -- ^ Byte offset at which the transfer (HTTP or FTP) should start from.
+ | CurlCookie String -- ^ Set the Cookie: header to the given cookie (name=value pairs, semicolon-separated) string.
+ | CurlHttpHeaders [String] -- ^ Embellish the outgoing request with the given list of (formatted) header values.
+ | CurlHttpPost [HttpPost] -- ^ (Multipart) POST data.
+ | CurlSSLCert FilePath -- ^ file holding your private SSL certificates (default format is PEM).
+ | CurlSSLPassword String -- ^ password to the above file.
+ | CurlSSLKeyPassword String -- ^ an alias for the previous.
+ | CurlCRLF Bool -- ^ If true, convert Unix newlines into CRLFs when transferring.
+ | CurlQuote [String] -- ^ Sequence of FTP commands to execute prior to the main request.
+ | CurlWriteHeader (Ptr ()) -- ^ State \/ pointer argument to pass to WriteFunction callback.
+ | CurlCookieFile FilePath -- ^ Path to file holding initial cookie data; also enables cookie handling.
+ | CurlSSLVersion Long -- ^ What protocol to attempt using (0:default;1:TLS;2:SSLv2;3:SSLv3)
+ | CurlTimeCondition TimeCond -- ^ How to interpret a conditional time value.
+ | CurlTimeValue Long -- ^ Number of secs since Jan 1, 1970. Interpretation is determined by CurlTimeCondition.
+ | CurlCustomRequest String -- ^ String holding alternative request command (WebDAV anyone?)
+ {- | CurlStderr String {- XXX: should be FILE* ? -} -- ^ File object to use for outputting debug info to. -}
+ | CurlPostQuote [String] -- ^ List of commands to issue to FTP server after the main request.
+ | CurlWriteInfo String -- ^ Not sure what this one does; something about passing it to the output function.
+ | CurlVerbose Bool -- ^ Control verbosity
+ | CurlHeader Bool -- ^ Display outgoing and incoming headers
+ | CurlNoProgress Bool -- ^ Control progress meter
+ | CurlNoBody Bool -- ^ Use HEAD instead of GET
+ | CurlFailOnError Bool -- ^ If status response is >= 300, return an error (and no other output).
+ | CurlUpload Bool -- ^ Control the main dataflow, i.e., True to perform uploads.
+ | CurlPost Bool -- ^ Issue a POST request.
+ | CurlFtpListOnly Bool -- ^ Switch NLST for FTP directory listings
+ | CurlFtpAppend Bool -- ^ Control if FTP uploads append rather than overwrite files
+ | CurlUseNetRc NetRcOption -- ^ control how or if a user's.netrc will be consulted for user:password
+ | CurlFollowLocation Bool -- ^ Handle auto-redirects by chasing down Location: values in responses.
+ | CurlTransferTextASCII Bool -- ^ Turn on ASCII transfers for FTP transfers; default is binary (i.e. off).
+ | CurlPut Bool -- ^ Use PUT to upload data.
+ | CurlProgressFunction ProgressFunction -- ^ callback for showing progress
+ | CurlProgressData (Ptr ()) -- ^ state argumentto pass to progress callback.
+ | CurlAutoReferer Bool -- ^ Control if the Referer: field is set upon following Location: redirects
+ | CurlProxyPort Long -- ^ (Numeric) proxy port to use.
+ | CurlPostFieldSize Long -- ^ Size of the POSTed data.
+ | CurlHttpProxyTunnel Bool -- ^ tunnel all HTTP operations through the proxy.
+ | CurlInterface String -- ^ Interface name of outgoing network interface ( network interface, IP address, host name.)
+ | CurlKrb4Level String -- ^ Kerberos security level ("clear", "safe", "confidential", "private" are good values, seemingly.)
+ | CurlSSLVerifyPeer Bool -- ^ Enable the authentication of peer certificate. Default is True.
+ | CurlCAInfo FilePath -- ^ If verifying peer's certificate, use certificates in this file to do so.
+ | CurlMaxRedirs Long -- ^ Maximum number of Location: redirects to chase down before giving up.
+ | CurlFiletime Bool -- ^ Try to determine the modification date of remote document; can be queried for.
+ | CurlTelnetOptions [String] -- ^ List of commands to use for initial telnet negotiations.
+ | CurlMaxConnects Long -- ^ Maximum number of cached active connections.
+ | CurlClosePolicy Long -- ^ No effect (obsolete.)
+ | CurlFreshConnect Bool -- ^ Force the opening up a new connection rather than try to reuse active connections. Default is not to.
+ | CurlForbidReuse Bool -- ^ Do not reuse the connection of next transfer when done.
+ | CurlRandomFile FilePath -- ^ Path to file used to seed (Open)SSL PRNG.
+ | CurlEgdSocket FilePath -- ^ Path to domain socket of EG Daemon.
+ | CurlConnectTimeout Long -- ^ max number of seconds to wait for the initial connection to happen.
+ | CurlHeaderFunction WriteFunction -- ^ callback used to handle _incoming_ header data.
+ | CurlHttpGet Bool -- ^ Revert to a GET for the next request.
+ | CurlSSLVerifyHost Long -- ^ Perform Common name checking in peer certificate (1=> existence;2=> matches hostname.)
+ | CurlCookieJar FilePath -- ^ Path to file where additional cookie information will be stored.
+ | CurlSSLCipherList String -- ^ Colon-separated string list of cipher preferences to use for upcoming connection (e.g., "3DES:+RSA")
+ | CurlHttpVersion HttpVersion -- ^ What HTTP version to use, should you want to drop back for some reason.
+ | CurlFtpUseEPSV Bool -- ^ Attempt the use of EPSV before PASV for passive FTP downloads.
+ | CurlSSLCertType String -- ^ The format of your certificates ("PEM", "DER")
+ | CurlSSLKey FilePath -- ^ Filename of private key.
+ | CurlSSLKeyType String -- ^ Format of private key; use "ENG" to load from a crypto engine.
+ | CurlSSLEngine String -- ^ Name of crypto engine to use.
+ | CurlSSLEngineDefault -- ^ Make crypto engine the default for crypto operations.
+ | CurlDNSUseGlobalCache Bool -- ^ Have library uses its MT-unfriendly DNS global cache.
+ | CurlDNSCacheTimeout Long -- ^ Number of seconds to cache results of DNS lookups in memory.
+ | CurlPreQuote [String] -- ^ FTP commands to issue after connection and transfer mode has been set.
+ | CurlDebugFunction DebugFunction -- ^ callback to catch and report transfer operations.
+ | CurlDebugData (Ptr ()) -- ^ state argument to pass to debug callback.
+ | CurlCookieSession Bool -- ^ Signal the start of a cookie session, ignoring previous session cookies.
+ | CurlCAPath FilePath -- ^ Directory holding CA certificates; used when verifying peer certificate.
+ | CurlBufferSize Long -- ^ Turn (down, presumably) the buffers the received data is chunked up into (and reported to the WriteFunction.) A hint, library is free to ignore.
+ | CurlNoSignal Bool -- ^ Turn off use of signals internally.
+ | CurlShare (Ptr ()) -- ^ Share handles are used for sharing data among concurrent Curl objects.
+ | CurlProxyType Long -- ^ What type of proxy to use.
+ | CurlEncoding String -- ^ What to report in the Accept-Encoding: header
+ | CurlPrivate (Ptr ()) -- ^ Data associated with a Curl handle.
+ | CurlHttp200Aliases String -- ^ Alternatives to standard 200 OK response strings; whatever it takes, I suppose.
+ | CurlUnrestrictedAuth Bool -- ^ Pass on user:pass when following redirects.
+ | CurlFtppUseEPRT Bool -- ^ For active FTP downloads, try using EPRT command over LPRT.
+ | CurlHttpAuth [HttpAuth] -- ^ State your authentication preferences.
+ | CurlSSLCtxFunction SSLCtxtFunction -- ^ callback to handle setting up SSL connections; have the power to abort them.
+ | CurlSSLCtxData (Ptr ()) -- ^ state argument to pass into the above callback.
+ | CurlFtpCreateMissingDirs Bool -- ^ Have remote directories be created if not already there
+ | CurlProxyAuth [HttpAuth] -- ^ What preferred authentication schemes to use wrt. proxy.
+ | CurlFtpResponseTimeout Long -- ^ max number of seconds to wait for remote server to ACK commands.
+ | CurlIPResolve Long -- ^ Whether to resolve wrt IPv4 or IPv6.
+ | CurlMaxFileSize Long -- ^ Limit the number of bytes you're willing to download.
+ | CurlInFileSizeLarge LLong -- ^ Wider alternative of option giving upper bound of uploaded content (-1 => unknown.)
+ | CurlResumeFromLarge LLong -- ^ Wider alternative for specifying initial transfer offset.
+ | CurlMaxFileSizeLarge LLong -- ^ Wider alternative for specifying max download size.
+ | CurlNetrcFile FilePath -- ^ Path to user\'s .netrc
+ | CurlFtpSSL Long -- ^ Try enabling the use of SSL for FTP control connections and\/or transfers.
+ | CurlPostFieldSizeLarge LLong -- ^ Size of data to POST; if unspecified (or -1), curl uses strlen().
+ | CurlTCPNoDelay Bool -- ^ Turn on or off the TCP\/IP NODELAY option.
+ | CurlFtpSSLAuth Long -- ^ Twiddle if TLS or SSL is used.
+ | CurlIOCTLFunction (Ptr ()) -- ^ somewhat obscure callback for handling read stream resets.
+ | CurlIOCTLData (Ptr ()) -- ^ state argument to the above.
+ | CurlFtpAccount String -- ^ The string to use when server asks for account info.
+ | CurlCookieList String -- ^ Cookie string to pass cookie engine; "ALL" scrubs all cookie info; "SESS" scrubs session ones.
+ | CurlIgnoreContentLength Bool -- ^ If Content-Length: values are troublesome (wrong, perhaps?), use this option to ignore using them as guidance.
+ | CurlFtpSkipPASVIP Bool -- ^ Ignore IP address in 227 responses.
+ | CurlFtpFileMethod Long -- ^ How to navigate to a file on the remote server (single, multiple CWDs).
+ | CurlLocalPort Port -- ^ What local port to use for established connection.
+ | CurlLocalPortRange Port -- ^ Number of attempts at finding local ports (using LocalPort as initial base.)
+ | CurlConnectOnly Bool -- ^ If enabled, perform all steps up until actual transfer.
+ -- next three for completeness.
+ | CurlConvFromNetworkFunction (Ptr ()) -- ^ callback for doing character translations from network format.
+ | CurlConvToNetworkFunction (Ptr ()) -- ^ callback for doing character translations to network format.
+ | CurlConvFromUtf8Function (Ptr ()) -- ^ callback for translating UTF8 into host encoding.
+ | CurlMaxSendSpeedLarge LLong -- ^ Specifies throttle value for outgoing data.
+ | CurlMaxRecvSpeedLarge LLong -- ^ Specifies throttle for incoming data.
+ | CurlFtpAlternativeToUser String -- ^ Alternative (to user:pass) for FTP authentication; weird.
+ | CurlSockOptFunction (Ptr ()) -- ^ callback that's injected between socket creation and connection.
+ | CurlSockOptData (Ptr ()) -- ^ state argument to the above.
+ | CurlSSLSessionIdCache Bool -- ^ Enable the SSL session id cache; default is on, so use this to disable.
+ | CurlSSHAuthTypes [SSHAuthType] -- ^ SSH authentication methods to use.
+ | CurlSSHPublicKeyFile FilePath -- ^ Path to file holding user's SSH public key.
+ | CurlSSHPrivateKeyFile FilePath -- ^ Path to file holding user's SSH private key.
+ | CurlFtpSSLCCC Bool -- ^ Send CCC command after FTP connection has been authenticated.
+ | CurlTimeoutMS Long -- ^ Max number of milliseconds that a transfer may take.
+ | CurlConnectTimeoutMS Long -- ^ Max number of milliseconds that a connection attempt may take to complete.
+ | CurlHttpTransferDecoding Bool -- ^ Disable transfer decoding; if disabled, curl will turn off chunking.
+ | CurlHttpContentDecoding Bool -- ^ Disable content decoding, getting the raw bits.
+ -- sync'ed wrt 7.19.2
+ | CurlNewFilePerms Long
+ | CurlNewDirectoryPerms Long
+ | CurlPostRedirect Bool
+ -- no support for open socket callbacks/function overrides.
+ | CurlSSHHostPublicKeyMD5 String
+ | CurlCopyPostFields Bool
+ | CurlProxyTransferMode Long
+ -- no support for seeking in the input stream.
+ | CurlCRLFile FilePath
+ | CurlIssuerCert FilePath
+ | CurlAddressScope Long
+ | CurlCertInfo Long
+ | CurlUserName String
+ | CurlUserPassword String
+ | CurlProxyUser String
+ | CurlProxyPassword String
+
+
+instance Show CurlOption where
+ show x = showCurlOption x
+
+data HttpVersion
+ = HttpVersionNone
+ | HttpVersion10
+ | HttpVersion11
+ deriving ( Enum,Show )
+
+data TimeCond
+ = TimeCondNone
+ | TimeCondIfModSince
+ | TimeCondIfUnmodSince
+ | TimeCondLastMode
+ deriving ( Enum, Show )
+
+data NetRcOption
+ = NetRcIgnored
+ | NetRcOptional
+ | NetRcRequired
+ deriving ( Enum, Show )
+
+data HttpAuth
+ = HttpAuthNone
+ | HttpAuthBasic
+ | HttpAuthDigest
+ | HttpAuthGSSNegotiate
+ | HttpAuthNTLM
+ | HttpAuthAny
+ | HttpAuthAnySafe
+ deriving ( Enum, Show )
+
+toHttpAuthMask :: [HttpAuth] -> Long
+toHttpAuthMask [] = 0
+toHttpAuthMask (x:xs) =
+ let vs = toHttpAuthMask xs in
+ case x of
+ HttpAuthNone -> vs
+ HttpAuthBasic -> 0x1 .|. vs
+ HttpAuthDigest -> 0x2 .|. vs
+ HttpAuthGSSNegotiate -> 0x4 .|. vs
+ HttpAuthNTLM -> 0x8 .|. vs
+ HttpAuthAny -> (complement 0) .|. vs
+ HttpAuthAnySafe -> (complement 1) .|. vs
+
+
+data SSHAuthType
+ = SSHAuthAny
+ | SSHAuthNone
+ | SSHAuthPublickey
+ | SSHAuthPassword
+ | SSHAuthHost
+ | SSHAuthKeyboard
+ deriving ( Show )
+
+
+toSSHAuthMask :: [SSHAuthType] -> Long
+toSSHAuthMask [] = 0
+toSSHAuthMask (x:xs) =
+ let vs = toSSHAuthMask xs in
+ case x of
+ SSHAuthAny -> (complement 0) .|. vs
+ SSHAuthNone -> vs
+ SSHAuthPublickey -> 1 .|. vs
+ SSHAuthPassword -> 2 .|. vs
+ SSHAuthHost -> 4 .|. vs
+ SSHAuthKeyboard -> 8 .|. vs
+
+
+type WriteFunction
+ = Ptr CChar -- pointer to external buffer holding data
+ -> CInt -- width (in bytes) of each item
+ -> CInt -- number of items
+ -> Ptr () -- state argument (file pointer etc.)
+ -> IO CInt -- number of bytes written.
+
+type ReadFunction
+ = Ptr CChar -- pointer to external buffer to fill in.
+ -> CInt -- width (in bytes) of each item
+ -> CInt -- number of items
+ -> Ptr () -- state argument (file pointer etc.)
+ -> IO (Maybe CInt) -- how many bytes was copied into buffer; Nothing => abort.
+
+type ReadFunctionPrim
+ = Ptr CChar
+ -> CInt
+ -> CInt
+ -> Ptr ()
+ -> IO CInt
+
+
+type ProgressFunction
+ = Ptr () -- state argument
+ -> Double -- expected download totals
+ -> Double -- download totals so far
+ -> Double -- expected upload totals
+ -> Double -- upload totals so far
+ -> IO CInt -- not sure; 0 is a good one.
+
+type DebugFunction
+ = Curl -- connection handle
+ -> DebugInfo -- type of call
+ -> Ptr CChar -- data buffer
+ -> CInt -- length of buffer
+ -> Ptr () -- state argument
+ -> IO () -- always 0
+
+data DebugInfo
+ = InfoText
+ | InfoHeaderIn
+ | InfoHeaderOut
+ | InfoDataIn
+ | InfoDataOut
+ | InfoSslDataIn
+ | InfoSslDataOut
+ deriving ( Eq, Enum )
+
+type DebugFunctionPrim
+ = CurlH -- connection handle
+ -> CInt -- type of call
+ -> Ptr CChar -- data buffer
+ -> CInt -- length of buffer
+ -> Ptr () -- state argument
+ -> IO CInt -- always 0
+
+
+
+type SSLCtxtFunction
+ = CurlH -- connection handle
+ -> Ptr () -- the SSL_CTX handle
+ -> Ptr () -- state argument
+ -> IO CInt
+
+curl_readfunc_abort :: CInt
+curl_readfunc_abort = 0x10000000
+
+baseLong :: Int
+baseLong = 0
+
+baseObject :: Int
+baseObject = 10000
+
+baseFunction :: Int
+baseFunction = 20000
+
+baseOffT :: Int
+baseOffT = 30000
+
+unmarshallOption :: Unmarshaller a -> CurlOption -> IO a
+unmarshallOption um c =
+ let
+ l = (baseLong+)
+ o = (baseObject+)
+ f = (baseFunction+)
+ off = (baseOffT+)
+ in
+ case c of
+ CurlFileObj x -> u_ptr um (o 1) x
+ CurlURL x -> u_string um (o 2) x
+ CurlPort x -> u_long um (l 3) x
+ CurlProxy x -> u_string um (o 4) x
+ CurlUserPwd x -> u_string um (o 5) x
+ CurlProxyUserPwd x -> u_string um (o 6) x
+ CurlRange x -> u_string um (o 7) x
+ CurlInFile x -> u_string um (o 9) x
+ CurlErrorBuffer x -> u_cptr um (o 10) x
+ CurlWriteFunction x -> u_writeFun um (f 11) x
+ CurlReadFunction x -> u_readFun um (f 12) x
+ CurlTimeout x -> u_long um (l 13) x
+ CurlInFileSize x -> u_long um (l 14) x
+ CurlPostFields x -> u_string um (o 15) (concat $ intersperse "&" x)
+ CurlReferer x -> u_string um (o 16) x
+ CurlFtpPort x -> u_string um (o 17) x
+ CurlUserAgent x -> u_string um (o 18) x
+ CurlLowSpeed x -> u_long um (l 19) x
+ CurlLowSpeedTime x -> u_long um (l 20) x
+ CurlResumeFrom x -> u_long um (l 21) x
+ CurlCookie x -> u_string um (o 22) x
+ CurlHttpHeaders x -> u_strings um (o 23) x
+ CurlHttpPost x -> u_posts um (o 24) x
+ CurlSSLCert x -> u_string um (o 25) x
+ CurlSSLPassword x -> u_string um (o 26) x
+ CurlSSLKeyPassword x -> u_string um (o 26) x -- yes, duplicate.
+ CurlCRLF x -> u_bool um (l 27) x
+ CurlQuote x -> u_strings um (o 28) x
+ CurlWriteHeader x -> u_ptr um (o 29) x
+ CurlCookieFile x -> u_string um (o 31) x
+ CurlSSLVersion x -> u_long um (l 32) x
+ CurlTimeCondition x -> u_enum um (l 33) x
+ CurlTimeValue x -> u_long um (l 34) x
+ CurlCustomRequest x -> u_string um (o 36) x
+ -- CurlStderr x -> u_string um (o 37) x
+ CurlPostQuote x -> u_strings um (o 39) x
+ CurlWriteInfo x -> u_string um (o 40) x
+ CurlVerbose x -> u_bool um (l 41) x
+ CurlHeader x -> u_bool um (l 42) x
+ CurlNoProgress x -> u_bool um (l 43) x
+ CurlNoBody x -> u_bool um (l 44) x
+ CurlFailOnError x -> u_bool um (l 45) x
+ CurlUpload x -> u_bool um (l 46) x
+ CurlPost x -> u_bool um (l 47) x
+ CurlFtpListOnly x -> u_bool um (l 48) x
+ CurlFtpAppend x -> u_bool um (l 50) x
+ CurlUseNetRc x -> u_enum um (l 51) x
+ CurlFollowLocation x -> u_bool um (l 52) x
+ CurlTransferTextASCII x -> u_bool um (l 53) x
+ CurlPut x -> u_bool um (l 54) x
+ CurlProgressFunction x -> u_progressFun um (f 56) x
+ CurlProgressData x -> u_ptr um (o 57) x
+ CurlAutoReferer x -> u_bool um (l 58) x
+ CurlProxyPort x -> u_long um (l 59) x
+ CurlPostFieldSize x -> u_long um (l 60) x
+ CurlHttpProxyTunnel x -> u_bool um (l 61) x
+ CurlInterface x -> u_string um (o 62) x
+ CurlKrb4Level x -> u_string um (o 63) x
+ CurlSSLVerifyPeer x -> u_bool um (l 64) x
+ CurlCAInfo x -> u_string um (o 65) x
+ CurlMaxRedirs x -> u_long um (l 68) x
+ CurlFiletime x -> u_bool um (l 69) x
+ CurlTelnetOptions x -> u_strings um (o 70) x
+ CurlMaxConnects x -> u_long um (l 71) x
+ CurlClosePolicy x -> u_long um (l 72) x
+ CurlFreshConnect x -> u_bool um (l 74) x
+ CurlForbidReuse x -> u_bool um (l 75) x
+ CurlRandomFile x -> u_string um (o 76) x
+ CurlEgdSocket x -> u_string um (o 77) x
+ CurlConnectTimeout x -> u_long um (l 78) x
+ CurlHeaderFunction x -> u_writeFun um (f 79) x
+ CurlHttpGet x -> u_bool um (l 80) x
+ CurlSSLVerifyHost x -> u_long um (l 81) x
+ CurlCookieJar x -> u_string um (o 82) x
+ CurlSSLCipherList x -> u_string um (o 83) x -- a string (or a l-list of them)?
+ CurlHttpVersion x -> u_enum um (l 84) x
+ CurlFtpUseEPSV x -> u_bool um (l 85) x
+ CurlSSLCertType x -> u_string um (o 86) x
+ CurlSSLKey x -> u_string um (o 87) x
+ CurlSSLKeyType x -> u_string um (o 88) x
+ CurlSSLEngine x -> u_string um (o 89) x
+ CurlSSLEngineDefault -> u_bool um (l 90) True
+ CurlDNSUseGlobalCache x -> u_bool um (l 91) x
+ CurlDNSCacheTimeout x -> u_long um (l 92) x
+ CurlPreQuote x -> u_strings um (o 93) x
+ CurlDebugFunction x -> u_debugFun um (f 94) x
+ CurlDebugData x -> u_ptr um (o 95) x
+ CurlCookieSession x -> u_bool um (l 96) x
+ CurlCAPath x -> u_string um (o 97) x
+ CurlBufferSize x -> u_long um (l 98) x
+ CurlNoSignal x -> u_bool um (l 99) x
+ CurlShare x -> u_ptr um (o 100) x
+ CurlProxyType x -> u_enum um (l 101) x
+ CurlEncoding x -> u_string um (o 102) x
+ CurlPrivate x -> u_ptr um (o 103) x
+ CurlHttp200Aliases x -> u_string um (o 104) x -- correct?
+ CurlUnrestrictedAuth x -> u_bool um (l 105) x
+ CurlFtppUseEPRT x -> u_bool um (l 106) x
+ CurlHttpAuth xs -> u_long um (l 107) (toHttpAuthMask xs)
+ CurlSSLCtxFunction x -> u_sslctxt um (f 108) x
+ CurlSSLCtxData x -> u_ptr um (o 109) x
+ CurlFtpCreateMissingDirs x -> u_bool um (l 110) x
+ CurlProxyAuth x -> u_long um (l 111) (toHttpAuthMask x)
+ CurlFtpResponseTimeout x -> u_long um (l 112) x
+ CurlIPResolve x -> u_long um (l 113) x
+ CurlMaxFileSize x -> u_long um (l 114) x
+ CurlInFileSizeLarge x -> u_llong um (off 115) x
+ CurlResumeFromLarge x -> u_llong um (off 116) x
+ CurlMaxFileSizeLarge x -> u_llong um (off 117) x
+ CurlNetrcFile x -> u_string um (o 118) x
+ CurlFtpSSL x -> u_enum um (l 119) x
+ CurlPostFieldSizeLarge x -> u_llong um (off 120) x
+ CurlTCPNoDelay x -> u_bool um (l 121) x
+ CurlFtpSSLAuth x -> u_enum um (l 129) x
+ CurlIOCTLFunction x -> u_ioctl_fun um (f 130) x
+ CurlIOCTLData x -> u_ptr um (o 131) x
+ CurlFtpAccount x -> u_string um (o 134) x
+ CurlCookieList x -> u_string um (o 135) x
+ CurlIgnoreContentLength x -> u_bool um (l 136) x
+ CurlFtpSkipPASVIP x -> u_bool um (l 137) x
+ CurlFtpFileMethod x -> u_enum um (l 138) x
+ CurlLocalPort x -> u_long um (l 139) x
+ CurlLocalPortRange x -> u_long um (l 140) x
+ CurlConnectOnly x -> u_bool um (l 141) x
+ CurlConvFromNetworkFunction x -> u_convFromNetwork um (f 142) x
+ CurlConvToNetworkFunction x -> u_convToNetwork um (f 143) x
+ CurlConvFromUtf8Function x -> u_convFromUtf8 um (f 144) x
+ CurlMaxSendSpeedLarge x -> u_llong um (off 145) x
+ CurlMaxRecvSpeedLarge x -> u_llong um (off 146) x
+ CurlFtpAlternativeToUser x -> u_string um (o 147) x
+ CurlSockOptFunction x -> u_sockoptFun um (f 148) x
+ CurlSockOptData x -> u_ptr um (o 149) x
+ CurlSSLSessionIdCache x -> u_bool um (l 150) x
+ CurlSSHAuthTypes xs -> u_long um (l 151) (toSSHAuthMask xs)
+ CurlSSHPublicKeyFile x -> u_string um (o 152) x
+ CurlSSHPrivateKeyFile x -> u_string um (o 153) x
+ CurlFtpSSLCCC x -> u_bool um (l 154) x
+ CurlTimeoutMS x -> u_long um (l 155) x
+ CurlConnectTimeoutMS x -> u_long um (l 156) x
+ CurlHttpTransferDecoding x -> u_bool um (l 157) x
+ CurlHttpContentDecoding x -> u_bool um (l 158) x
+ CurlNewFilePerms x -> u_long um (l 159) x
+ CurlNewDirectoryPerms x -> u_long um (l 160) x
+ CurlPostRedirect x -> u_bool um (l 161) x
+ CurlSSHHostPublicKeyMD5 x -> u_string um (l 162) x
+ CurlCopyPostFields x -> u_bool um (l 165) x
+ CurlProxyTransferMode x -> u_long um (l 166) x
+ CurlCRLFile x -> u_string um (l 169) x
+ CurlIssuerCert x -> u_string um (l 170) x
+ CurlAddressScope x -> u_long um (l 171) x
+ CurlCertInfo x -> u_long um (l 172) x
+ CurlUserName x -> u_string um (l 173) x
+ CurlUserPassword x -> u_string um (l 174) x
+ CurlProxyUser x -> u_string um (l 175) x
+ CurlProxyPassword x -> u_string um (l 176) x
+
+data Unmarshaller a
+ = Unmarshaller
+ { u_long :: Int -> Long -> IO a
+ , u_llong :: Int -> LLong -> IO a
+ , u_string :: Int -> String -> IO a
+ , u_strings :: Int -> [String] -> IO a
+ , u_ptr :: Int -> Ptr () -> IO a
+ , u_writeFun :: Int -> WriteFunction -> IO a
+ , u_readFun :: Int -> ReadFunction -> IO a
+ , u_progressFun :: Int -> ProgressFunction -> IO a
+ , u_debugFun :: Int -> DebugFunction -> IO a
+ , u_posts :: Int -> [HttpPost] -> IO a
+ , u_sslctxt :: Int -> SSLCtxtFunction -> IO a
+ , u_ioctl_fun :: Int -> Ptr () -> IO a
+ , u_convFromNetwork :: Int -> Ptr () -> IO a
+ , u_convToNetwork :: Int -> Ptr () -> IO a
+ , u_convFromUtf8 :: Int -> Ptr () -> IO a
+ , u_sockoptFun :: Int -> Ptr () -> IO a
+ }
+
+verboseUnmarshaller :: Unmarshaller a -> Unmarshaller a
+verboseUnmarshaller u =
+ let two m f x y = putStrLn m >> f u x y
+ twoS m f x y = putStrLn (m ++ ": " ++ show (x,y)) >> f u x y
+ in u
+ { u_long = twoS "u_long" u_long
+ , u_llong = twoS "u_llong" u_llong
+ , u_string = twoS "u_string" u_string
+ , u_strings = twoS "u_strings" u_strings
+ , u_ptr = twoS "u_ptr" u_ptr
+ , u_writeFun = two "u_writeFun" u_writeFun
+ , u_readFun = two "u_readFun" u_readFun
+ , u_progressFun = two "u_progressFun" u_progressFun
+ , u_debugFun = two "u_debugFun" u_debugFun
+ , u_posts = two "u_posts" u_posts
+ , u_sslctxt = two "u_sslctxt" u_sslctxt
+ , u_ioctl_fun = two "u_ioctl_fun" u_ioctl_fun
+ , u_convFromNetwork = twoS "u_convFromNetwork" u_convFromNetwork
+ , u_convToNetwork = twoS "u_convToNetwork" u_convToNetwork
+ , u_convFromUtf8 = twoS "u_convFromUtf8" u_convFromUtf8
+ , u_sockoptFun = twoS "u_sockoptFun" u_sockoptFun
+ }
+
+
+u_bool :: Unmarshaller a -> Int -> Bool -> IO a
+u_bool um x b = u_long um x (if b then 1 else 0)
+
+u_enum :: Enum b => Unmarshaller a -> Int -> b -> IO a
+u_enum um x b = u_long um x (fromIntegral $ fromEnum b)
+
+u_cptr :: Unmarshaller a -> Int -> Ptr CChar -> IO a
+u_cptr um x p = u_ptr um x (castPtr p)
+
+showCurlOption :: CurlOption -> String
+showCurlOption o =
+ case o of
+ CurlFileObj p -> "CurlFileObj " ++ show p
+ CurlURL u -> "CurlURL " ++ show u
+ CurlPort p -> "CurlPort " ++ show p
+ CurlProxy s -> "CurlProxy " ++ show s
+ CurlUserPwd p -> "CurlUserPwd " ++ show p
+ CurlProxyUserPwd p -> "CurlProxyUserPwd " ++ show p
+ CurlRange p -> "CurlRange " ++ show p
+ CurlInFile p -> "CurlInFile " ++ show p
+ CurlErrorBuffer p -> "CurlErrorBuffer " ++ show p
+ CurlWriteFunction{} -> "CurlWriteFunction <fun>"
+ CurlReadFunction{} -> "CurlReadFunction <fun>"
+ CurlTimeout l -> "CurlTimeout " ++ show l
+ CurlInFileSize l -> "CurlInFileSize " ++ show l
+ CurlPostFields p -> "CurlPostFields " ++ show p
+ CurlReferer p -> "CurlReferer " ++ show p
+ CurlFtpPort p -> "CurlFtpPort " ++ show p
+ CurlUserAgent p -> "CurlUserAgent " ++ show p
+ CurlLowSpeed p -> "CurlLowSpeed " ++ show p
+ CurlLowSpeedTime p -> "CurlLowSpeedTime " ++ show p
+ CurlResumeFrom p -> "CurlResumeFrom " ++ show p
+ CurlCookie p -> "CurlCookie " ++ show p
+ CurlHttpHeaders p -> "CurlHttpHeaders " ++ show p
+ CurlHttpPost p -> "CurlHttpPost " ++ show p
+ CurlSSLCert p -> "CurlSSLCert " ++ show p
+ CurlSSLPassword p -> "CurlSSLPassword " ++ show p
+ CurlSSLKeyPassword p -> "CurlSSLKeyPassword " ++ show p
+ CurlCRLF p -> "CurlCRLF " ++ show p
+ CurlQuote p -> "CurlQuote " ++ show p
+ CurlWriteHeader p -> "CurlWriteHeader " ++ show p
+ CurlCookieFile p -> "CurlCookieFile " ++ show p
+ CurlSSLVersion p -> "CurlSSLVersion " ++ show p
+ CurlTimeCondition p -> "CurlTimeCondition " ++ show p
+ CurlTimeValue p -> "CurlTimeValue " ++ show p
+ CurlCustomRequest p -> "CurlCustomRequest " ++ show p
+ CurlPostQuote p -> "CurlPostQuote " ++ show p
+ CurlWriteInfo p -> "CurlWriteInfo " ++ show p
+ CurlVerbose p -> "CurlVerbose " ++ show p
+ CurlHeader p -> "CurlHeader " ++ show p
+ CurlNoProgress p -> "CurlNoProgress " ++ show p
+ CurlNoBody p -> "CurlNoBody " ++ show p
+ CurlFailOnError p -> "CurlFailOnError " ++ show p
+ CurlUpload p -> "CurlUpload " ++ show p
+ CurlPost p -> "CurlPost " ++ show p
+ CurlFtpListOnly p -> "CurlFtpListOnly " ++ show p
+ CurlFtpAppend p -> "CurlFtpAppend " ++ show p
+ CurlUseNetRc p -> "CurlUseNetRc " ++ show p
+ CurlFollowLocation p -> "CurlFollowLocation " ++ show p
+ CurlTransferTextASCII p -> "CurlTransferTextASCII " ++ show p
+ CurlPut p -> "CurlPut " ++ show p
+ CurlProgressFunction{} -> "CurlProgressFunction <fun>"
+ CurlProgressData p -> "CurlProgressData " ++ show p
+ CurlAutoReferer p -> "CurlAutoReferer " ++ show p
+ CurlProxyPort p -> "CurlProxyPort " ++ show p
+ CurlPostFieldSize p -> "CurlPostFieldSize " ++ show p
+ CurlHttpProxyTunnel p -> "CurlHttpProxyTunnel " ++ show p
+ CurlInterface p -> "CurlInterface " ++ show p
+ CurlKrb4Level p -> "CurlKrb4Level " ++ show p
+ CurlSSLVerifyPeer p -> "CurlSSLVerifyPeer " ++ show p
+ CurlCAInfo p -> "CurlCAInfo " ++ show p
+ CurlMaxRedirs p -> "CurlMaxRedirs " ++ show p
+ CurlFiletime p -> "CurlFiletime " ++ show p
+ CurlTelnetOptions p -> "CurlTelnetOptions " ++ show p
+ CurlMaxConnects p -> "CurlMaxConnects " ++ show p
+ CurlClosePolicy p -> "CurlClosePolicy " ++ show p
+ CurlFreshConnect p -> "CurlFreshConnect " ++ show p
+ CurlForbidReuse p -> "CurlForbidReuse " ++ show p
+ CurlRandomFile p -> "CurlRandomFile " ++ show p
+ CurlEgdSocket p -> "CurlEgdSocket " ++ show p
+ CurlConnectTimeout p -> "CurlConnectTimeout " ++ show p
+ CurlHeaderFunction{} -> "CurlHeaderFunction <fun>"
+ CurlHttpGet p -> "CurlHttpGet " ++ show p
+ CurlSSLVerifyHost p -> "CurlSSLVerifyHost " ++ show p
+ CurlCookieJar p -> "CurlCookieJar " ++ show p
+ CurlSSLCipherList p -> "CurlSSLCipherList " ++ show p
+ CurlHttpVersion p -> "CurlHttpVersion " ++ show p
+ CurlFtpUseEPSV p -> "CurlFtpUseEPSV " ++ show p
+ CurlSSLCertType p -> "CurlSSLCertType " ++ show p
+ CurlSSLKey p -> "CurlSSLKey " ++ show p
+ CurlSSLKeyType p -> "CurlSSLKeyType " ++ show p
+ CurlSSLEngine p -> "CurlSSLEngine " ++ show p
+ CurlSSLEngineDefault-> "CurlSSLEngineDefault"
+ CurlDNSUseGlobalCache p -> "CurlDNSUseGlobalCache " ++ show p
+ CurlDNSCacheTimeout p -> "CurlDNSCacheTimeout " ++ show p
+ CurlPreQuote p -> "CurlPreQuote " ++ show p
+ CurlDebugFunction{} -> "CurlDebugFunction <fun>"
+ CurlDebugData p -> "CurlDebugData " ++ show p
+ CurlCookieSession p -> "CurlCookieSession " ++ show p
+ CurlCAPath p -> "CurlCAPath " ++ show p
+ CurlBufferSize p -> "CurlBufferSize " ++ show p
+ CurlNoSignal p -> "CurlNoSignal " ++ show p
+ CurlShare p -> "CurlShare " ++ show p
+ CurlProxyType p -> "CurlProxyType " ++ show p
+ CurlEncoding p -> "CurlEncoding " ++ show p
+ CurlPrivate p -> "CurlPrivate " ++ show p
+ CurlHttp200Aliases p -> "CurlHttp200Aliases " ++ show p
+ CurlUnrestrictedAuth p -> "CurlUnrestrictedAuth " ++ show p
+ CurlFtppUseEPRT p -> "CurlFtppUseEPRT " ++ show p
+ CurlHttpAuth p -> "CurlHttpAuth " ++ show p
+ CurlSSLCtxFunction{} -> "CurlSSLCtxFunction <fun>"
+ CurlSSLCtxData p -> "CurlSSLCtxData " ++ show p
+ CurlFtpCreateMissingDirs p -> "CurlFtpCreateMissingDirs " ++ show p
+ CurlProxyAuth p -> "CurlProxyAuth " ++ show p
+ CurlFtpResponseTimeout p -> "CurlFtpResponseTimeout " ++ show p
+ CurlIPResolve p -> "CurlIPResolve " ++ show p
+ CurlMaxFileSize p -> "CurlMaxFileSize " ++ show p
+ CurlInFileSizeLarge p -> "CurlInFileSizeLarge " ++ show p
+ CurlResumeFromLarge p -> "CurlResumeFromLarge " ++ show p
+ CurlMaxFileSizeLarge p -> "CurlMaxFileSizeLarge " ++ show p
+ CurlNetrcFile p -> "CurlNetrcFile " ++ show p
+ CurlFtpSSL p -> "CurlFtpSSL " ++ show p
+ CurlPostFieldSizeLarge p -> "CurlPostFieldSizeLarge " ++ show p
+ CurlTCPNoDelay p -> "CurlTCPNoDelay " ++ show p
+ CurlFtpSSLAuth p -> "CurlFtpSSLAuth " ++ show p
+ CurlIOCTLFunction p -> "CurlIOCTLFunction " ++ show p
+ CurlIOCTLData p -> "CurlIOCTLData " ++ show p
+ CurlFtpAccount p -> "CurlFtpAccount " ++ show p
+ CurlCookieList p -> "CurlCookieList " ++ show p
+ CurlIgnoreContentLength p -> "CurlIgnoreContentLength " ++ show p
+ CurlFtpSkipPASVIP p -> "CurlFtpSkipPASVIP " ++ show p
+ CurlFtpFileMethod p -> "CurlFtpFileMethod " ++ show p
+ CurlLocalPort p -> "CurlLocalPort " ++ show p
+ CurlLocalPortRange p -> "CurlLocalPortRange " ++ show p
+ CurlConnectOnly p -> "CurlConnectOnly " ++ show p
+ CurlConvFromNetworkFunction p -> "CurlConvFromNetworkFunction " ++ show p
+ CurlConvToNetworkFunction p -> "CurlConvToNetworkFunction " ++ show p
+ CurlConvFromUtf8Function p -> "CurlConvFromUtf8Function " ++ show p
+ CurlMaxSendSpeedLarge p -> "CurlMaxSendSpeedLarge " ++ show p
+ CurlMaxRecvSpeedLarge p -> "CurlMaxRecvSpeedLarge " ++ show p
+ CurlFtpAlternativeToUser p -> "CurlFtpAlternativeToUser " ++ show p
+ CurlSockOptFunction p -> "CurlSockOptFunction " ++ show p
+ CurlSockOptData p -> "CurlSockOptData " ++ show p
+ CurlSSLSessionIdCache p -> "CurlSSLSessionIdCache " ++ show p
+ CurlSSHAuthTypes p -> "CurlSSHAuthTypes " ++ show p
+ CurlSSHPublicKeyFile p -> "CurlSSHPublicKeyFile " ++ show p
+ CurlSSHPrivateKeyFile p -> "CurlSSHPrivateKeyFile " ++ show p
+ CurlFtpSSLCCC p -> "CurlFtpSSLCCC " ++ show p
+ CurlTimeoutMS p -> "CurlTimeoutMS " ++ show p
+ CurlConnectTimeoutMS p -> "CurlConnectTimeoutMS " ++ show p
+ CurlHttpTransferDecoding p -> "CurlHttpTransferDecoding " ++ show p
+ CurlHttpContentDecoding p -> "CurlHttpContentDecoding " ++ show p
+ CurlNewFilePerms l -> "CurlNewFilePerms " ++ show l
+ CurlNewDirectoryPerms p -> "CurlNewDirectoryPerms " ++ show p
+ CurlPostRedirect p -> "CurlPostRedirect " ++ show p
+ CurlSSHHostPublicKeyMD5 p -> "CurlSSHHostPublicKeyMD5 " ++ show p
+ CurlCopyPostFields p -> "CurlCopyPostFields " ++ show p
+ CurlProxyTransferMode p -> "CurlProxyTransferMode " ++ show p
+ CurlCRLFile p -> "CurlCRLFile " ++ show p
+ CurlIssuerCert p -> "CurlIssuerCert " ++ show p
+ CurlAddressScope p -> "CurlAddressScope " ++ show p
+ CurlCertInfo p -> "CurlCertInfo " ++ show p
+ CurlUserName p -> "CurlUserName " ++ show p
+ CurlUserPassword p -> "CurlUserPassword " ++ show p
+ CurlProxyUser p -> "CurlProxyUser " ++ show p
+ CurlProxyPassword p -> "CurlProxyPassword " ++ show p
126 Network/Shpider/Curl/Post.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS -fvia-C -#include "curl/curl.h" #-}
+--------------------------------------------------------------------
+-- |
+-- 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.Shpider.Curl.Post where
+
+import Network.Shpider.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
+ { postName :: String
+ , contentType :: Maybe String
+ , content :: Content
+ , extraHeaders :: [Header]
+-- not yet: , extraEntries :: [HttpPost]
+ , showName :: Maybe String
+ } deriving ( Show )
+
+data Content
+ = ContentFile FilePath
+ | ContentBuffer (Ptr CChar) Long -- byte arrays also?
+ | ContentString String
+ deriving ( Show )
+
+multiformString :: String -> String -> HttpPost
+multiformString x y =
+ HttpPost { postName = x
+ , content = ContentString y
+ , contentType = Nothing
+ , extraHeaders = []
+ , showName = Nothing
+ }
+
+-- lower-level marshalling code.
+
+sizeof_httppost :: Int
+sizeof_httppost = 12 * sizeOf (nullPtr :: Ptr CChar)
+
+marshallPosts :: [HttpPost] -> IO (Ptr HttpPost)
+marshallPosts [] = return nullPtr
+marshallPosts ps = do
+ ms <- mapM marshallPost ps
+ case ms of
+ [] -> return nullPtr
+ (x:xs) -> do
+ linkUp x xs
+ return x
+ where
+ linkUp p [] = pokeByteOff p 0 nullPtr
+ linkUp p (x:xs) = do
+ pokeByteOff p 0 x
+ linkUp x xs
+
+marshallPost :: HttpPost -> IO (Ptr HttpPost)
+marshallPost p = do
+ php <- mallocBytes 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 f -> do
+ newCString f >>= pokeByteOff php (ptrIndex 3)
+ pokeByteOff php (ptrIndex 4) (length f)
+ pokeByteOff php (ptrIndex 5) nullPtr
+ pokeByteOff php (ptrIndex 6) nullPtr
+ pokeByteOff php (ptrIndex 10) (0x1 :: Long)
+ ContentBuffer ptr len -> do
+ pokeByteOff php (ptrIndex 3) nullPtr
+ pokeByteOff php (ptrIndex 4) nullPtr
+ pokeByteOff php (ptrIndex 5) ptr
+ pokeByteOff php (ptrIndex 6) len
+ pokeByteOff php (ptrIndex 10) (0x10 :: Long)
+ ContentString s -> do
+ newCString s >>= pokeByteOff php (ptrIndex 3)
+ pokeByteOff php (ptrIndex 4) (length s)
+ pokeByteOff php (ptrIndex 5) nullPtr
+ pokeByteOff php (ptrIndex 6) nullPtr
+ pokeByteOff php (ptrIndex 10) (0x4 :: Long)
+
+ cs1 <- case contentType p of
+ Nothing -> return nullPtr
+ Just s -> newCString 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
+ Nothing -> pokeByteOff php (ptrIndex 11) nullPtr
+ Just s -> newCString s >>= pokeByteOff php (ptrIndex 11)
+ return php
+ where
+ ptrIndex n = n * sizeOf 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 ()
+
+
174 Network/Shpider/Curl/Types.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
+--------------------------------------------------------------------
+-- |
+-- Module : Network.Curl.Types
+-- Copyright : (c) Galois Inc 2007-2009
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sof@galois.com>
+-- Stability : provisional
+-- Portability: portable
+--
+-- Basic set of types for the Haskell curl binding, including the
+-- @Curl@ handle type which holds the C library stateful connection
+-- handle along with a set of cleanup actions tht should be performed
+-- upon shutting down the curl session.
+--
+--------------------------------------------------------------------
+module Network.Shpider.Curl.Types
+ ( CurlH, URLString, Port, Long, LLong, Slist_
+ , Curl, curlPrim, mkCurl, mkCurlWithCleanup
+ , OptionMap, shareCleanup, runCleanup, updateCleanup
+ , manual_cleanup , mkCurl_no_cleanup
+ ) where
+
+import Network.Shpider.Curl.Debug
+
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
+import Data.Word
+import Control.Concurrent
+import Control.Monad.Fix(mfix)
+import Data.Maybe(fromMaybe)
+import qualified Data.IntMap as M
+import Data.IORef
+import System.IO
+
+data Curl_
+type CurlH = Ptr Curl_
+
+type URLString = String
+type Port = Long
+type Long = Word32
+type LLong = Word64
+data Slist_
+
+
+data Curl = Curl
+ { curlH :: MVar (ForeignPtr Curl_) -- libcurl is not thread-safe.
+ , curlCleanup :: IORef OptionMap -- deallocate Haskell curl data
+ }
+
+
+-- | Execute a "primitve" curl operation.
+-- NOTE: See warnings about the use of 'withForeginPtr'.
+curlPrim :: Curl -> (IORef OptionMap -> CurlH -> IO a) -> IO a
+curlPrim c f = withMVar (curlH c) $ \ h ->
+ withForeignPtr h $ f $ curlCleanup c
+
+
+-- | Allocates a Haskell handle from a C handle.
+-- | No garbage collection so cookies are written deterministically
+mkCurl_no_cleanup :: CurlH -> IO Curl
+mkCurl_no_cleanup h = do
+ debug "ALLOC: CURL"
+ fh <- newForeignPtr_ h
+ v1 <- newMVar fh
+ v2 <- newIORef om_empty
+ let new_h = Curl { curlH = v1, curlCleanup = v2 }
+ return new_h
+
+-- | Allocates a Haskell handle from a C handle.
+mkCurl :: CurlH -> IO Curl
+mkCurl h =
+ mkCurlWithCleanup h om_empty
+
+-- | Allocates a Haskell handle from a C handle.
+mkCurlWithCleanup :: CurlH -> OptionMap -> IO Curl
+mkCurlWithCleanup h clean = do
+ debug "ALLOC: CURL"
+ fh <- newForeignPtr_ h
+ v1 <- newMVar fh
+ v2 <- newIORef clean
+ let new_h = Curl { curlH = v1, curlCleanup = v2 }
+
+ fin <- mkIOfin $ do debug "FREE: CURL"
+ runCleanup v2
+ withForeignPtr fh easy_cleanup
+
+ addForeignPtrFinalizer fin fh
+
+ return new_h
+
+ -- Manually cleanup a curl instance, writing cookies etc.
+manual_cleanup curl = do
+ fh <- readMVar $ curlH curl
+ debug "FREE: CURL"
+ runCleanup $ curlCleanup curl
+ withForeignPtr fh easy_cleanup
+
+-- Admin code for cleaning up marshalled data.
+-- Note that these functions assume that they are running atomically,
+-- so access to them should be protected by a lock.
+--------------------------------------------------------------------------------
+runCleanup :: IORef OptionMap -> IO ()
+runCleanup r = do m <- readIORef r
+ om_cleanup m
+ writeIORef r om_empty
+
+shareCleanup :: IORef OptionMap -> IO OptionMap
+shareCleanup r = do old <- readIORef r
+ new <- om_dup old
+ writeIORef r new
+ return new
+
+updateCleanup :: IORef OptionMap -> Int -> IO () -> IO ()
+updateCleanup r option act = writeIORef r =<< om_set option act =<< readIORef r
+
+
+
+-- Maps that associate curl options with IO actions to
+-- perform cleanup for them.
+--------------------------------------------------------------------------------