module ListT.Libcurl
(
Session,
Error,
runSession,
consumeURL,
)
where
import BasePrelude hiding (cons, uncons)
import Foreign hiding (Pool, void, unsafePerformIO)
import MTLPrelude hiding (Error)
import ListT (ListT)
import Data.ByteString (ByteString)
import Control.Concurrent.STM.TMVar
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as BU
import qualified Data.Pool as P
import qualified Network.CURL720 as C
import qualified ListT as L
pool :: P.Pool C.CURL
pool =
unsafePerformIO $ do
C.loadlib C.CURL720
P.createPool acquire release 1 30 100
where
acquire = do
h <- C.curl_easy_init
return h
release h = do
C.curl_easy_cleanup h
newtype Session a =
Session (ReaderT C.CURL IO a)
deriving (Functor, Applicative, Monad, MonadIO)
type Error =
C.CURLE
runSession :: Session a -> IO (Either Error a)
runSession (Session m) =
try $
P.withResource pool $
runReaderT m
consumeURL :: String -> (ListT IO ByteString -> IO a) -> Session a
consumeURL url consumer =
Session $ ReaderT $ \h -> do
syncState@(active, chunk) <- atomically $ newSyncState
C.curl_easy_setopt h
[
C.CURLOPT_WRITEFUNCTION $ Just (syncWriteFunction syncState),
C.CURLOPT_URL url,
C.CURLOPT_FOLLOWLOCATION True
]
result <- newEmptyMVar :: IO (MVar (Either SomeException a))
forkIO $ do
r <-
try $ consumer $ fix $ \loop -> join $ lift $ atomically $
tryTakeTMVar chunk >>= \case
Just chunk -> return $ L.cons chunk loop
_ -> readTVar active >>= \case
False -> return mzero
_ -> retry
atomically $ writeTVar active False
putMVar result r
catch (C.curl_easy_perform h) $ \case
C.CURLE _ _ _ C.CURLE_WRITE_ERROR -> return ()
e -> throwIO e
atomically $ writeTVar active False
either (throwIO :: SomeException -> IO a) return =<< takeMVar result
type SyncState =
(TVar Bool, TMVar ByteString)
newSyncState :: STM SyncState
newSyncState =
(,) <$> newTVar True <*> newEmptyTMVar
syncWriteFunction :: SyncState -> C.CURL_write_callback
syncWriteFunction (active, chunk) b =
atomically $ do
readTVar active >>= \case
False -> return C.CURL_WRITEFUNC_FAIL
True -> putTMVar chunk b >> return C.CURL_WRITEFUNC_OK