pinboard 0.9.11 → 0.9.12
raw patch · 4 files changed
+160/−105 lines, 4 filesdep −eitherdep ~monad-logger
Dependencies removed: either
Dependency ranges changed: monad-logger
Files
- changelog.md +6/−0
- pinboard.cabal +91/−88
- src/Pinboard/Client.hs +58/−15
- src/Pinboard/Types.hs +5/−2
changelog.md view
@@ -1,3 +1,9 @@+__v0.9.12__++add runPinboardE++add ability to delay the thread if the time since the previous request exceeds the configured maxRequestRateMills (rename requestDelayMills to maxRequestRateMills)+ __v0.9.11__ add logging
pinboard.cabal view
@@ -1,92 +1,95 @@-name: pinboard-version: 0.9.11-synopsis: Access to the Pinboard API-license: MIT-license-file: LICENSE-author: Jon Schoning-maintainer: jonschoning@gmail.com-copyright: Copyright (c) 2015 Jon Schoning-homepage: https://github.com/jonschoning/pinboard-bug-reports: https://github.com/jonschoning/pinboard/issues-category: Network APIs-build-type: Simple-cabal-version: >=1.10-Description: - .- The Pinboard API is a way to interact programatically with- your bookmarks, notes and other Pinboard data. This- library wraps the API exposing functions and data- structures suitable for usage in Haskell programs.- .-Extra-Source-Files:- README.md changelog.md-library - hs-source-dirs: src- build-depends: base >=4.6 && < 5.0- , aeson >= 0.11.1 && < 2.0- , bytestring >= 0.10.0 && <0.11 - , containers >= 0.5.0.0 && <0.6 - , either >= 4.4.1 && < 4.5- , http-types >= 0.8 && <0.10- , http-client >= 0.5 && <0.6 - , http-client-tls >= 0.3.0 && < 0.4- , text >= 0.11 && < 1.3- , time >= 1.5 && < 1.7- , transformers >= 0.4.0.0- , vector >= 0.10.9 && < 0.12- , network >= 2.6.2 && < 2.7- , mtl >= 2.2.1- , profunctors >= 5- , random >= 1.1- , safe-exceptions < 0.2- , unordered-containers- , monad-logger+-- This file has been generated from package.yaml by hpack version 0.14.1.+--+-- see: https://github.com/sol/hpack - - default-language: Haskell2010- other-modules: - exposed-modules: - Pinboard- Pinboard.Api- Pinboard.ApiRequest- Pinboard.ApiTypes - Pinboard.ApiTypesLens - Pinboard.Client- Pinboard.Error- Pinboard.Types- Pinboard.Util- Pinboard.Logging- ghc-options: -Wall- -fwarn-incomplete-patterns- -funbox-strict-fields- -fexpose-all-unfoldings-test-suite tests- ghc-options: -Wall -fno-warn-orphans- type: exitcode-stdio-1.0- main-is: Test.hs- hs-source-dirs: tests- other-modules: - ApproxEq- Instances- PropJSON- build-depends: base >=4.6 && < 5.0,- pinboard,- bytestring,- containers,- hspec >= 1.8 ,- text,- time,- aeson,- semigroups,- QuickCheck,- mtl >= 2.2.1,- safe-exceptions < 0.2,- unordered-containers,- transformers >= 0.4.0.0- ghc-options: -Wall - -fno-warn-orphans- default-language: Haskell2010+name: pinboard+version: 0.9.12+synopsis: Access to the Pinboard API+description: .+ The Pinboard API is a way to interact programatically with+ your bookmarks, notes and other Pinboard data. This+ library wraps the API exposing functions and data+ structures suitable for usage in Haskell programs.+category: Network APIs+homepage: https://github.com/jonschoning/pinboard+bug-reports: https://github.com/jonschoning/pinboard/issues+author: Jon Schoning+maintainer: jonschoning@gmail.com+copyright: Copyright (c) 2015 Jon Schoning+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10 +extra-source-files:+ changelog.md+ README.md+ source-repository head- type: git+ type: git location: git://github.com/jonschoning/pinboard.git++library+ hs-source-dirs:+ src+ ghc-options: -Wall -fwarn-incomplete-patterns -funbox-strict-fields -fexpose-all-unfoldings+ build-depends:+ base >=4.6 && <5.0+ , transformers >=0.4.0.0+ , mtl >=2.2.1+ , safe-exceptions <0.2+ , unordered-containers+ , aeson >=0.11.1 && <2.0+ , bytestring >=0.10.0 && <0.11+ , containers >=0.5.0.0 && <0.6+ , http-types >=0.8 && <0.10+ , http-client >=0.5 && <0.6+ , http-client-tls >=0.3.0 && <0.4+ , text >=0.11 && <1.3+ , time >=1.5 && <1.7+ , vector >=0.10.9 && <0.12+ , network >=2.6.2 && <2.7+ , profunctors >=5+ , random >=1.1+ , monad-logger >=0.3 && <0.4+ exposed-modules:+ Pinboard+ Pinboard.Api+ Pinboard.ApiRequest+ Pinboard.ApiTypes+ Pinboard.ApiTypesLens+ Pinboard.Client+ Pinboard.Error+ Pinboard.Types+ Pinboard.Util+ Pinboard.Logging+ other-modules:+ Paths_pinboard+ default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Test.hs+ hs-source-dirs:+ tests+ ghc-options: -Wall -fno-warn-orphans -fno-warn-orphans+ build-depends:+ base >=4.6 && <5.0+ , transformers >=0.4.0.0+ , mtl >=2.2.1+ , safe-exceptions <0.2+ , unordered-containers+ , pinboard+ , bytestring+ , containers+ , hspec >=1.8+ , text+ , time+ , aeson+ , semigroups+ , QuickCheck+ other-modules:+ ApproxEq+ Instances+ PropJSON+ default-language: Haskell2010
src/Pinboard/Client.hs view
@@ -15,13 +15,15 @@ -- Portability : POSIX ------------------------------------------------------------------------------ module Pinboard.Client- ( -- * Config+ (+ -- * Config fromApiToken , defaultPinboardConfig -- | The PinboardConfig provides authentication via apiToken , PinboardConfig(..) -- * Monadic , runPinboard+ , runPinboardE , pinboardJson -- * Single , runPinboardSingleRaw@@ -29,6 +31,8 @@ , runPinboardSingleJson -- * Sending , sendPinboardRequest+ -- * Delaying+ , requestThreadDelay -- * Manager (http-client) , newMgr , mgrFail@@ -50,7 +54,7 @@ import Control.Monad.Reader import Control.Exception.Safe-import Control.Monad.Error.Class (throwError)+import Control.Monad.Error.Class import Data.ByteString.Char8 (pack) import Data.Monoid ((<>))@@ -75,10 +79,15 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T +import GHC.IO (unsafePerformIO)+import Data.IORef+import Data.Time.Clock+import Data.Time.Calendar+ import Control.Applicative import Prelude --- | Create a default PinboardConfig using the supplied apiToken+-- | Create a default PinboardConfig using the supplied apiToken (ex: "use:ABCDEF0123456789ABCD") fromApiToken :: String -> PinboardConfig fromApiToken token = defaultPinboardConfig@@ -89,9 +98,12 @@ defaultPinboardConfig = PinboardConfig { apiToken = mempty- , requestDelayMills = 0+ , maxRequestRateMills = 0 , execLoggingT = runNullLoggingT , filterLoggingT = infoLevelFilter+ , lastRequestTime =+ unsafePerformIO $ newIORef (UTCTime (ModifiedJulianDay 0) 0)+ , doThreadDelay = Pinboard.Client.requestThreadDelay } --------------------------------------------------------------------------------@@ -99,8 +111,13 @@ runPinboard :: (MonadIO m, MonadCatch m, MonadErrorPinboard e) => PinboardConfig -> PinboardT m a -> m (e a)-runPinboard config f = do- mgr <- liftIO newMgr+runPinboard config f = liftIO newMgr >>= \mgr -> runPinboardE (config, mgr) f++-- | Execute computations in the Pinboard monad (with specified http Manager)+runPinboardE+ :: (MonadIO m, MonadCatch m, MonadErrorPinboard e)+ => PinboardEnv -> PinboardT m a -> m (e a)+runPinboardE (config, mgr) f = eitherToMonadError <$> runPinboardT (config, mgr) f -- | Create a Pinboard value from a PinboardRequest w/ json deserialization@@ -138,14 +155,14 @@ runPinboardSingleRawBS config req = do res <- runPinboardSingleRaw config req case checkStatusCodeResponse res of- Left e ->- runConfigLoggingT- config- (do logNST LevelError logSrc (toText e)- return (throwError e))- Right _ -> return (return (responseBody res))+ Left e -> logErrorAndThrow e+ Right _ -> (return . return) (responseBody res) where logSrc = "runPinboardSingleRawBS"+ logErrorAndThrow e =+ runConfigLoggingT config $+ do logNST LevelError logSrc (toText e)+ return (throwError e) runPinboardSingleJson :: (MonadErrorPinboard e, FromJSON a)@@ -156,22 +173,48 @@ sendPinboardRequest :: PinboardEnv -> PinboardRequest -> IO (Response LBS.ByteString)-sendPinboardRequest (PinboardConfig {..}, mgr) PinboardRequest {..} = do+sendPinboardRequest (cfg@PinboardConfig {..}, mgr) PinboardRequest {..} = do let encodedParams = ("auth_token", urlEncode False apiToken) : encodeParams requestParams paramsText = T.decodeUtf8 (paramsToByteString encodedParams) url = T.unpack $ T.concat [requestPath, "?", paramsText]- when (requestDelayMills > 0) $ threadDelay (requestDelayMills * 1000) req <- buildReq url+ doThreadDelay cfg httpLbs req mgr --------------------------------------------------------------------------------++-- | delays the thread if the time since the previous request exceeds the configured maxRequestRateMills +requestThreadDelay :: PinboardConfig -> IO ()+requestThreadDelay cfg@PinboardConfig {..} = do+ currentTime <- getCurrentTime+ lastTime <- readIORef lastRequestTime+ let elapsedtime = diffUTCTime currentTime lastTime+ delaytime = max 0 (requestDelaySecs - elapsedtime)+ when (delaytime > 0) $+ do runConfigLoggingT cfg $+ let logTxt =+ "DELAY " <> ", lastTime: " <> toText lastTime <>+ ", requestDelaySecs: " <>+ toText requestDelaySecs <>+ ", elapsedTime: " <>+ toText elapsedtime <>+ ", delayTime: " <>+ toText delaytime+ in logNST LevelInfo "requestThreadDelay" logTxt+ threadDelay (maxRequestRateMills * 1000)+ currentTime' <- getCurrentTime+ writeIORef lastRequestTime currentTime'+ where+ requestDelaySecs = fromInteger (toInteger maxRequestRateMills) / 1000++-------------------------------------------------------------------------------- buildReq :: String -> IO Request buildReq url = do req <- parseRequest $ "https://api.pinboard.in/v1/" <> url return $ setRequestIgnoreStatus $ req- { requestHeaders = [("User-Agent", "pinboard.hs/0.9.11")]+ { requestHeaders = [("User-Agent", "pinboard.hs/0.9.12")] } --------------------------------------------------------------------------------
src/Pinboard/Types.hs view
@@ -35,6 +35,7 @@ import Data.Text (Text) import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime)+import Data.IORef import Network.HTTP.Client (Manager) import Pinboard.Error@@ -67,13 +68,15 @@ data PinboardConfig = PinboardConfig { apiToken :: !ByteString- , requestDelayMills :: !Int+ , maxRequestRateMills :: !Int+ , lastRequestTime :: IORef UTCTime+ , doThreadDelay :: PinboardConfig -> IO () , execLoggingT :: ExecLoggingT , filterLoggingT :: LogSource -> LogLevel -> Bool } instance Show PinboardConfig where- show (PinboardConfig a r _ _) =+ show (PinboardConfig a r _ _ _ _) = "{ apiToken = " ++ show a ++ ", requestDelayMills = " ++ show r ++ " }" runConfigLoggingT :: PinboardConfig -> ExecLoggingT