{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
module Pinboard.Client
(
fromApiToken
, defaultPinboardConfig
, PinboardConfig(..)
, runPinboard
, runPinboardE
, pinboardJson
, runPinboardSingleRaw
, runPinboardSingleRawBS
, runPinboardSingleJson
, sendPinboardRequest
, requestThreadDelay
, newMgr
, mgrFail
, parseJSONResponse
, decodeJSONResponse
, checkStatusCodeResponse
, checkStatusCode
, addErrMsg
, createParserErr
, httpStatusPinboardError
, module X
) where
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.IO.Unlift
import UnliftIO.Exception
import Data.ByteString.Char8 (pack)
import Data.Monoid ((<>))
import Data.Aeson (FromJSON, eitherDecodeStrict')
import Network.HTTP.Types (urlEncode)
import Network.HTTP.Types.Status (statusCode)
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Control.Concurrent (threadDelay)
import Control.Monad.Logger
import Pinboard.Types as X
import Pinboard.Error as X
import Pinboard.Util as X
import Pinboard.Logging as X
import Paths_pinboard (version)
import Data.Version (showVersion)
import qualified Data.ByteString.Lazy as LBS
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 Data.Bifunctor
import Data.Function
import Control.Applicative
import Prelude
fromApiToken :: String -> PinboardConfig
fromApiToken token =
defaultPinboardConfig
{ apiToken = pack token
}
defaultPinboardConfig :: PinboardConfig
defaultPinboardConfig =
PinboardConfig
{ apiToken = mempty
, maxRequestRateMills = 0
, execLoggingT = runNullLoggingT
, filterLoggingT = infoLevelFilter
, lastRequestTime =
unsafePerformIO $ newIORef (UTCTime (ModifiedJulianDay 0) 0)
, doThreadDelay = Pinboard.Client.requestThreadDelay
}
{-# NOINLINE defaultPinboardConfig #-}
runPinboard
:: MonadUnliftIO m
=> PinboardConfig -> PinboardT m a -> m a
runPinboard config f = liftIO newMgr >>= \mgr -> runPinboardE (config, mgr) f
runPinboardE
:: MonadUnliftIO m
=> PinboardEnv -> PinboardT m a -> m a
runPinboardE (config, mgr) f =
runPinboardT (config, mgr) f
pinboardJson
:: (MonadPinboard m, FromJSON a)
=> PinboardRequest -> m (Either PinboardError a)
pinboardJson req =
logOnException logSrc $
do logNST LevelInfo logSrc (toText req)
env <- ask
res <-
liftIO $ sendPinboardRequest env (ensureResultFormatType FormatJson req)
logNST LevelDebug logSrc (toText res)
pure (parseJSONResponse res)
where
logSrc = "pinboardJson"
runPinboardSingleRaw :: PinboardConfig
-> PinboardRequest
-> IO (Response LBS.ByteString)
runPinboardSingleRaw config req =
runLogOnException logSrc config $
do mgr <- liftIO newMgr
logNST LevelInfo logSrc (toText req)
res <- liftIO $ sendPinboardRequest (config, mgr) req
logNST LevelDebug logSrc (toText res)
return res
where
logSrc = "runPinboardSingleRaw"
runPinboardSingleRawBS
::
PinboardConfig -> PinboardRequest -> IO (Either PinboardError LBS.ByteString)
runPinboardSingleRawBS config req = do
res <- runPinboardSingleRaw config req
case checkStatusCodeResponse res of
Left e -> logErrorAndThrow e
Right _ -> (return . return) (responseBody res)
where
logSrc = "runPinboardSingleRawBS"
logErrorAndThrow e =
runConfigLoggingT config $
do logNST LevelError logSrc (toText e)
return (Left e)
runPinboardSingleJson
:: FromJSON a
=> PinboardConfig -> PinboardRequest -> IO (Either PinboardError a)
runPinboardSingleJson config = runPinboard config . pinboardJson
sendPinboardRequest :: PinboardEnv
-> PinboardRequest
-> IO (Response LBS.ByteString)
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]
req <- buildReq url
doThreadDelay cfg
httpLbs req mgr
requestThreadDelay :: PinboardConfig -> IO ()
requestThreadDelay cfg@PinboardConfig {..} = do
currentTime <- getCurrentTime
lastTime <- readIORef lastRequestTime
let elapsedtime = diffUTCTime currentTime lastTime
delaytime = max 0 (maxRequestRateSecs - elapsedtime)
when (delaytime > 0) $
do runConfigLoggingT cfg $
let logTxt =
"DELAY " <> ", lastTime: " <> toText lastTime <>
", maxRequestRateSecs: " <>
toText maxRequestRateSecs <>
", elapsedTime: " <>
toText elapsedtime <>
", delayTime: " <>
toText delaytime
in logNST LevelInfo "requestThreadDelay" logTxt
threadDelay (floor (delaytime * 1000000))
currentTime' <- getCurrentTime
writeIORef lastRequestTime currentTime'
where
maxRequestRateSecs = 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/" <> pack (showVersion version))]
}
parseJSONResponse
:: FromJSON a
=> Response LBS.ByteString -> Either PinboardError a
parseJSONResponse response =
checkStatusCodeResponse response
*> decodeJSONResponse (responseBody response)
decodeJSONResponse
:: FromJSON a
=> LBS.ByteString -> Either PinboardError a
decodeJSONResponse s =
let r = eitherDecodeStrict' (LBS.toStrict s)
in either (Left . createParserErr . T.pack) return r
checkStatusCodeResponse
:: Response LBS.ByteString -> Either PinboardError ()
checkStatusCodeResponse resp =
(checkStatusCode . statusCode . responseStatus) resp
& (first . addErrMsg . toText . responseBody) resp
checkStatusCode
:: Int -> Either PinboardError ()
checkStatusCode =
\case
200 -> return ()
400 -> httpStatusPinboardError BadRequest
401 -> httpStatusPinboardError UnAuthorized
402 -> httpStatusPinboardError RequestFailed
403 -> httpStatusPinboardError Forbidden
404 -> httpStatusPinboardError NotFound
429 -> httpStatusPinboardError TooManyRequests
c
| c >= 500 -> httpStatusPinboardError PinboardServerError
_ -> httpStatusPinboardError UnknownHTTPCode
httpStatusPinboardError
:: PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError err =
Left
defaultPinboardError
{ errorType = HttpStatusFailure
, errorHTTP = Just err
}
addErrMsg :: T.Text -> PinboardError -> PinboardError
addErrMsg msg err =
err
{ errorMsg = msg
}
createParserErr :: T.Text -> PinboardError
createParserErr msg = PinboardError ParseFailure msg Nothing Nothing Nothing
newMgr :: IO Manager
newMgr =
newManager $ managerSetProxy (proxyEnvironment Nothing) tlsManagerSettings
mgrFail
:: (Monad m)
=> PinboardErrorType -> SomeException -> m (Either PinboardError b)
mgrFail e msg =
return $ Left $ PinboardError e (toText msg) Nothing Nothing Nothing