list-t-libcurl (empty) → 0.2.0.0

raw patch · 4 files changed

+194/−0 lines, 4 filesdep +basedep +base-preludedep +bytestringsetup-changed

Dependencies added: base, base-prelude, bytestring, curlhs, either, list-t, mtl-prelude, resource-pool, stm, template-haskell

Files

LICENSE +22/−0
Setup.hs +2/−0
library/ListT/Libcurl.hs +109/−0
list-t-libcurl.cabal +61/−0

+ LICENSE view

@@ -0,0 +1,22 @@+Copyright (c) 2015, Nikita Volkov++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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ library/ListT/Libcurl.hs view

@@ -0,0 +1,109 @@+module ListT.Libcurl+(+  Session,+  Error,+  runSession,+  consumeURL,+)+where++import BasePrelude hiding (cons, uncons)+import Foreign hiding (Pool, void)+import MTLPrelude hiding (Error)+import Control.Monad.Trans.Either hiding (left, right)+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+import qualified Language.Haskell.TH.Syntax as TH+++-- |+-- A global sessions pool.+-- +-- Due to how the \"libcurl\" library integration is handled,+-- there may only exist one per application, +-- hence the API provides no way to establish another pool.+{-# NOINLINE pool #-}+pool :: P.Pool C.CURL+pool =+  unsafePerformIO $ P.createPool acquire release 1 30 100+  where+    acquire = do+      h <- C.curl_easy_init+      C.curl_easy_setopt h [C.CURLOPT_FAILONERROR True]+      return h+    release h = do+      C.curl_easy_cleanup h+++-- |+-- A monad for sequential execution of \"libcurl\" operations.+-- +-- To execute multiple requests concurrently you need to run multiple sessions.+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 $+  C.withlib C.CURL720 $+  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+      ]+    result <- newEmptyMVar :: IO (MVar (Either SomeException a))+    forkIO $ do+      r <- +        try $ consumer $ fix $ \loop -> do+          chunk <- +            lift $ atomically $+              tryTakeTMVar chunk >>= \case+                Just chunk -> return $ Just chunk+                _ -> readTVar active >>= \case+                  False -> return Nothing+                  _ -> retry+          case chunk of+            Nothing -> mzero+            Just chunk -> L.cons chunk loop+      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++

+ list-t-libcurl.cabal view

@@ -0,0 +1,61 @@+name:+  list-t-libcurl+version:+  0.2.0.0+synopsis:+  A "libcurl"-based streaming HTTP client+category:+  Streaming, HTTP+homepage:+  https://github.com/nikita-volkov/list-t-libcurl+bug-reports:+  https://github.com/nikita-volkov/list-t-libcurl/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2015, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10+++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/list-t-libcurl.git+++library+  hs-source-dirs:+    library+  other-modules:+  exposed-modules:+    ListT.Libcurl+  ghc-options:+    -funbox-strict-fields+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators+  default-language:+    Haskell2010+  build-depends:+    template-haskell == 2.*,+    resource-pool == 0.2.*,+    stm == 2.4.*,+    curlhs == 0.1.*,++    bytestring >= 0.10 && < 0.11,++    list-t >= 0.4.5 && < 0.5,+    either == 4.*,+    +    mtl-prelude >= 1 && < 3,+    base-prelude >= 0.1.19 && < 0.2,+    base < 5