module Network.Curl.Download (
openURI
, openURIString
, openAsTags
, openAsXML
, openAsFeed
, openURIWithOpts
) where
import Network.Curl
import Foreign
import Data.IORef
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Char8 as Char8
import qualified Text.HTML.TagSoup as TagSoup
import qualified Text.XML.Light as XML
import qualified Text.Feed.Import as Feed
import qualified Text.Feed.Types as Feed
openURI :: String -> IO (Either String S.ByteString)
openURI s = openURIWithOpts [] s
openURIString :: String -> IO (Either String String)
openURIString s = (fmap Char8.unpack) `fmap` openURI s
openURIWithOpts :: [CurlOption] -> String -> IO (Either String S.ByteString)
openURIWithOpts opts s = case parseURL s of
Nothing -> return $ Left $ "Malformed url: "++ s
Just url -> do
e <- getFile url opts
return $ case e of
Left err -> Left $ "Failed to connect: " ++ err
Right src -> Right src
openAsTags:: String -> IO (Either String [TagSoup.Tag String])
openAsTags s = (fmap TagSoup.parseTags) `fmap` openURIString s
openAsXML:: String -> IO (Either String [XML.Content])
openAsXML s = (fmap XML.parseXML) `fmap` openURIString s
openAsFeed :: String -> IO (Either String Feed.Feed)
openAsFeed s = do
e <- openURIString s
return $ case e of
Left err -> Left err
Right src -> case Feed.parseFeedString src of
Nothing -> Left "Unable to parse feed"
Just src' -> Right src'
newtype URL = URL String
parseURL :: String -> Maybe URL
parseURL s = Just (URL s)
getFile :: URL -> [CurlOption] -> IO (Either String S.ByteString)
getFile (URL url) flags = do
h <- initialize
let start = 1024
buf <- mallocBytes start
ref <- newIORef (P buf 0)
setopt h (CurlFailOnError True)
setDefaultSSLOpts h url
setopt h (CurlURL url)
setopt h (CurlWriteFunction (gather ref))
mapM_ (setopt h) flags
rc <- perform h
P buf' sz <- readIORef ref
if rc /= CurlOK
then do
free buf'
return $ Left (show rc)
else do
fp <- newForeignPtr finalizerFree buf'
return (Right $! S.fromForeignPtr fp 0 (fromIntegral sz))
data P = P !(Ptr Word8) !Int
gather :: IORef P -> WriteFunction
gather r = writer $ \(src, m) -> do
P dest n <- readIORef r
dest' <- reallocBytes dest (n + m)
S.memcpy (dest' `plusPtr` n) src (fromIntegral m)
writeIORef r (P dest' (n + m))
writer :: ((Ptr Word8, Int) -> IO ()) -> WriteFunction
writer f src sz nelems _ = do
let n' = sz * nelems
f (castPtr src, fromIntegral n')
return n'