diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/pinboard.cabal b/pinboard.cabal --- a/pinboard.cabal +++ b/pinboard.cabal @@ -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 diff --git a/src/Pinboard/Client.hs b/src/Pinboard/Client.hs --- a/src/Pinboard/Client.hs +++ b/src/Pinboard/Client.hs @@ -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")] } -------------------------------------------------------------------------------- diff --git a/src/Pinboard/Types.hs b/src/Pinboard/Types.hs --- a/src/Pinboard/Types.hs +++ b/src/Pinboard/Types.hs @@ -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