{-# 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.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 :: String -> PinboardConfig
fromApiToken String
token =
PinboardConfig
defaultPinboardConfig
{ apiToken :: ByteString
apiToken = String -> ByteString
pack String
token
}
defaultPinboardConfig :: PinboardConfig
defaultPinboardConfig :: PinboardConfig
defaultPinboardConfig =
PinboardConfig :: ByteString
-> Int
-> IORef UTCTime
-> (PinboardConfig -> IO ())
-> ExecLoggingT
-> (LogSource -> LogLevel -> Bool)
-> PinboardConfig
PinboardConfig
{ apiToken :: ByteString
apiToken = ByteString
forall a. Monoid a => a
mempty
, maxRequestRateMills :: Int
maxRequestRateMills = Int
0
, execLoggingT :: ExecLoggingT
execLoggingT = ExecLoggingT
forall (m :: * -> *) a. LoggingT m a -> m a
runNullLoggingT
, filterLoggingT :: LogSource -> LogLevel -> Bool
filterLoggingT = LogSource -> LogLevel -> Bool
infoLevelFilter
, lastRequestTime :: IORef UTCTime
lastRequestTime =
IO (IORef UTCTime) -> IORef UTCTime
forall a. IO a -> a
unsafePerformIO (IO (IORef UTCTime) -> IORef UTCTime)
-> IO (IORef UTCTime) -> IORef UTCTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> IO (IORef UTCTime)
forall a. a -> IO (IORef a)
newIORef (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
0) DiffTime
0)
, doThreadDelay :: PinboardConfig -> IO ()
doThreadDelay = PinboardConfig -> IO ()
Pinboard.Client.requestThreadDelay
}
{-# NOINLINE defaultPinboardConfig #-}
runPinboard
:: MonadUnliftIO m
=> PinboardConfig -> PinboardT m a -> m a
runPinboard :: PinboardConfig -> PinboardT m a -> m a
runPinboard PinboardConfig
config PinboardT m a
f = IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
newMgr m Manager -> (Manager -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Manager
mgr -> PinboardEnv -> PinboardT m a -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
PinboardEnv -> PinboardT m a -> m a
runPinboardE (PinboardConfig
config, Manager
mgr) PinboardT m a
f
runPinboardE
:: MonadUnliftIO m
=> PinboardEnv -> PinboardT m a -> m a
runPinboardE :: PinboardEnv -> PinboardT m a -> m a
runPinboardE (PinboardConfig
config, Manager
mgr) PinboardT m a
f =
PinboardEnv -> PinboardT m a -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
PinboardEnv -> PinboardT m a -> m a
runPinboardT (PinboardConfig
config, Manager
mgr) PinboardT m a
f
pinboardJson
:: (MonadPinboard m, FromJSON a)
=> PinboardRequest -> m (Either PinboardError a)
pinboardJson :: PinboardRequest -> m (Either PinboardError a)
pinboardJson PinboardRequest
req =
LogSource
-> m (Either PinboardError a) -> m (Either PinboardError a)
forall (m :: * -> *) a.
(MonadLogger m, MonadUnliftIO m) =>
LogSource -> m a -> m a
logOnException LogSource
logSrc (m (Either PinboardError a) -> m (Either PinboardError a))
-> m (Either PinboardError a) -> m (Either PinboardError a)
forall a b. (a -> b) -> a -> b
$
do LogLevel -> LogSource -> LogSource -> m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> LogSource -> LogSource -> m ()
logNST LogLevel
LevelInfo LogSource
logSrc (PinboardRequest -> LogSource
forall a. Show a => a -> LogSource
toText PinboardRequest
req)
PinboardEnv
env <- m PinboardEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
Response ByteString
res <-
IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ PinboardEnv -> PinboardRequest -> IO (Response ByteString)
sendPinboardRequest PinboardEnv
env (ResultFormatType -> PinboardRequest -> PinboardRequest
ensureResultFormatType ResultFormatType
FormatJson PinboardRequest
req)
LogLevel -> LogSource -> LogSource -> m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> LogSource -> LogSource -> m ()
logNST LogLevel
LevelDebug LogSource
logSrc (Response ByteString -> LogSource
forall a. Show a => a -> LogSource
toText Response ByteString
res)
Either PinboardError a -> m (Either PinboardError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response ByteString -> Either PinboardError a
forall a.
FromJSON a =>
Response ByteString -> Either PinboardError a
parseJSONResponse Response ByteString
res)
where
logSrc :: LogSource
logSrc = LogSource
"pinboardJson"
runPinboardSingleRaw :: PinboardConfig
-> PinboardRequest
-> IO (Response LBS.ByteString)
runPinboardSingleRaw :: PinboardConfig -> PinboardRequest -> IO (Response ByteString)
runPinboardSingleRaw PinboardConfig
config PinboardRequest
req =
LogSource
-> PinboardConfig
-> LoggingT IO (Response ByteString)
-> IO (Response ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
LogSource -> PinboardConfig -> LoggingT m a -> m a
runLogOnException LogSource
logSrc PinboardConfig
config (LoggingT IO (Response ByteString) -> IO (Response ByteString))
-> LoggingT IO (Response ByteString) -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$
do Manager
mgr <- IO Manager -> LoggingT IO Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
newMgr
LogLevel -> LogSource -> LogSource -> LoggingT IO ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> LogSource -> LogSource -> m ()
logNST LogLevel
LevelInfo LogSource
logSrc (PinboardRequest -> LogSource
forall a. Show a => a -> LogSource
toText PinboardRequest
req)
Response ByteString
res <- IO (Response ByteString) -> LoggingT IO (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> LoggingT IO (Response ByteString))
-> IO (Response ByteString) -> LoggingT IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ PinboardEnv -> PinboardRequest -> IO (Response ByteString)
sendPinboardRequest (PinboardConfig
config, Manager
mgr) PinboardRequest
req
LogLevel -> LogSource -> LogSource -> LoggingT IO ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> LogSource -> LogSource -> m ()
logNST LogLevel
LevelDebug LogSource
logSrc (Response ByteString -> LogSource
forall a. Show a => a -> LogSource
toText Response ByteString
res)
Response ByteString -> LoggingT IO (Response ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Response ByteString
res
where
logSrc :: LogSource
logSrc = LogSource
"runPinboardSingleRaw"
runPinboardSingleRawBS
::
PinboardConfig -> PinboardRequest -> IO (Either PinboardError LBS.ByteString)
runPinboardSingleRawBS :: PinboardConfig
-> PinboardRequest -> IO (Either PinboardError ByteString)
runPinboardSingleRawBS PinboardConfig
config PinboardRequest
req = do
Response ByteString
res <- PinboardConfig -> PinboardRequest -> IO (Response ByteString)
runPinboardSingleRaw PinboardConfig
config PinboardRequest
req
case Response ByteString -> Either PinboardError ()
checkStatusCodeResponse Response ByteString
res of
Left PinboardError
e -> PinboardError -> IO (Either PinboardError ByteString)
forall (m :: * -> *) a b.
(MonadIO m, Show a) =>
a -> m (Either a b)
logErrorAndThrow PinboardError
e
Right ()
_ -> (Either PinboardError ByteString
-> IO (Either PinboardError ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PinboardError ByteString
-> IO (Either PinboardError ByteString))
-> (ByteString -> Either PinboardError ByteString)
-> ByteString
-> IO (Either PinboardError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either PinboardError ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return) (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res)
where
logSrc :: LogSource
logSrc = LogSource
"runPinboardSingleRawBS"
logErrorAndThrow :: a -> m (Either a b)
logErrorAndThrow a
e =
PinboardConfig -> ExecLoggingT
runConfigLoggingT PinboardConfig
config (LoggingT m (Either a b) -> m (Either a b))
-> LoggingT m (Either a b) -> m (Either a b)
forall a b. (a -> b) -> a -> b
$
do LogLevel -> LogSource -> LogSource -> LoggingT m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> LogSource -> LogSource -> m ()
logNST LogLevel
LevelError LogSource
logSrc (a -> LogSource
forall a. Show a => a -> LogSource
toText a
e)
Either a b -> LoggingT m (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a b
forall a b. a -> Either a b
Left a
e)
runPinboardSingleJson
:: FromJSON a
=> PinboardConfig -> PinboardRequest -> IO (Either PinboardError a)
runPinboardSingleJson :: PinboardConfig -> PinboardRequest -> IO (Either PinboardError a)
runPinboardSingleJson PinboardConfig
config = PinboardConfig
-> PinboardT IO (Either PinboardError a)
-> IO (Either PinboardError a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
PinboardConfig -> PinboardT m a -> m a
runPinboard PinboardConfig
config (PinboardT IO (Either PinboardError a)
-> IO (Either PinboardError a))
-> (PinboardRequest -> PinboardT IO (Either PinboardError a))
-> PinboardRequest
-> IO (Either PinboardError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PinboardRequest -> PinboardT IO (Either PinboardError a)
forall (m :: * -> *) a.
(MonadPinboard m, FromJSON a) =>
PinboardRequest -> m (Either PinboardError a)
pinboardJson
sendPinboardRequest :: PinboardEnv
-> PinboardRequest
-> IO (Response LBS.ByteString)
sendPinboardRequest :: PinboardEnv -> PinboardRequest -> IO (Response ByteString)
sendPinboardRequest (cfg :: PinboardConfig
cfg@PinboardConfig {Int
ByteString
IORef UTCTime
LogSource -> LogLevel -> Bool
PinboardConfig -> IO ()
ExecLoggingT
filterLoggingT :: LogSource -> LogLevel -> Bool
execLoggingT :: ExecLoggingT
doThreadDelay :: PinboardConfig -> IO ()
lastRequestTime :: IORef UTCTime
maxRequestRateMills :: Int
apiToken :: ByteString
doThreadDelay :: PinboardConfig -> PinboardConfig -> IO ()
lastRequestTime :: PinboardConfig -> IORef UTCTime
filterLoggingT :: PinboardConfig -> LogSource -> LogLevel -> Bool
execLoggingT :: PinboardConfig -> ExecLoggingT
maxRequestRateMills :: PinboardConfig -> Int
apiToken :: PinboardConfig -> ByteString
..}, Manager
mgr) PinboardRequest {[Param]
LogSource
requestParams :: PinboardRequest -> [Param]
requestPath :: PinboardRequest -> LogSource
requestParams :: [Param]
requestPath :: LogSource
..} = do
let encodedParams :: [(ByteString, ByteString)]
encodedParams = (ByteString
"auth_token", Bool -> ByteString -> ByteString
urlEncode Bool
False ByteString
apiToken) (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [Param] -> [(ByteString, ByteString)]
encodeParams [Param]
requestParams
paramsText :: LogSource
paramsText = ByteString -> LogSource
T.decodeUtf8 ([(ByteString, ByteString)] -> ByteString
forall m. (Monoid m, IsString m) => [(m, m)] -> m
paramsToByteString [(ByteString, ByteString)]
encodedParams)
url :: String
url = LogSource -> String
T.unpack (LogSource -> String) -> LogSource -> String
forall a b. (a -> b) -> a -> b
$ [LogSource] -> LogSource
T.concat [LogSource
requestPath, LogSource
"?", LogSource
paramsText]
Request
req <- String -> IO Request
buildReq String
url
PinboardConfig -> IO ()
doThreadDelay PinboardConfig
cfg
Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
mgr
requestThreadDelay :: PinboardConfig -> IO ()
requestThreadDelay :: PinboardConfig -> IO ()
requestThreadDelay cfg :: PinboardConfig
cfg@PinboardConfig {Int
ByteString
IORef UTCTime
LogSource -> LogLevel -> Bool
PinboardConfig -> IO ()
ExecLoggingT
filterLoggingT :: LogSource -> LogLevel -> Bool
execLoggingT :: ExecLoggingT
doThreadDelay :: PinboardConfig -> IO ()
lastRequestTime :: IORef UTCTime
maxRequestRateMills :: Int
apiToken :: ByteString
doThreadDelay :: PinboardConfig -> PinboardConfig -> IO ()
lastRequestTime :: PinboardConfig -> IORef UTCTime
filterLoggingT :: PinboardConfig -> LogSource -> LogLevel -> Bool
execLoggingT :: PinboardConfig -> ExecLoggingT
maxRequestRateMills :: PinboardConfig -> Int
apiToken :: PinboardConfig -> ByteString
..} = do
UTCTime
currentTime <- IO UTCTime
getCurrentTime
UTCTime
lastTime <- IORef UTCTime -> IO UTCTime
forall a. IORef a -> IO a
readIORef IORef UTCTime
lastRequestTime
let elapsedtime :: NominalDiffTime
elapsedtime = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
currentTime UTCTime
lastTime
delaytime :: NominalDiffTime
delaytime = NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Ord a => a -> a -> a
max NominalDiffTime
0 (NominalDiffTime
maxRequestRateSecs NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
elapsedtime)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NominalDiffTime
delaytime NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do PinboardConfig -> ExecLoggingT
runConfigLoggingT PinboardConfig
cfg (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
let logTxt :: LogSource
logTxt =
LogSource
"DELAY " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
", lastTime: " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> UTCTime -> LogSource
forall a. Show a => a -> LogSource
toText UTCTime
lastTime LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<>
LogSource
", maxRequestRateSecs: " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<>
NominalDiffTime -> LogSource
forall a. Show a => a -> LogSource
toText NominalDiffTime
maxRequestRateSecs LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<>
LogSource
", elapsedTime: " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<>
NominalDiffTime -> LogSource
forall a. Show a => a -> LogSource
toText NominalDiffTime
elapsedtime LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<>
LogSource
", delayTime: " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<>
NominalDiffTime -> LogSource
forall a. Show a => a -> LogSource
toText NominalDiffTime
delaytime
in LogLevel -> LogSource -> LogSource -> LoggingT IO ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> LogSource -> LogSource -> m ()
logNST LogLevel
LevelInfo LogSource
"requestThreadDelay" LogSource
logTxt
Int -> IO ()
threadDelay (NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime
delaytime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000000))
UTCTime
currentTime' <- IO UTCTime
getCurrentTime
IORef UTCTime -> UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef UTCTime
lastRequestTime UTCTime
currentTime'
where
maxRequestRateSecs :: NominalDiffTime
maxRequestRateSecs = Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
maxRequestRateMills) NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
1000
buildReq :: String -> IO Request
buildReq :: String -> IO Request
buildReq String
url = do
Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ String
"https://api.pinboard.in/v1/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
url
Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$
Request -> Request
setRequestIgnoreStatus (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
Request
req
{ requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
"User-Agent", ByteString
"pinboard.hs/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
pack (Version -> String
showVersion Version
version))]
}
parseJSONResponse
:: FromJSON a
=> Response LBS.ByteString -> Either PinboardError a
parseJSONResponse :: Response ByteString -> Either PinboardError a
parseJSONResponse Response ByteString
response =
Response ByteString -> Either PinboardError ()
checkStatusCodeResponse Response ByteString
response
Either PinboardError ()
-> Either PinboardError a -> Either PinboardError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Either PinboardError a
forall a. FromJSON a => ByteString -> Either PinboardError a
decodeJSONResponse (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response)
decodeJSONResponse
:: FromJSON a
=> LBS.ByteString -> Either PinboardError a
decodeJSONResponse :: ByteString -> Either PinboardError a
decodeJSONResponse ByteString
s =
let r :: Either String a
r = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict' (ByteString -> ByteString
LBS.toStrict ByteString
s)
in (String -> Either PinboardError a)
-> (a -> Either PinboardError a)
-> Either String a
-> Either PinboardError a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (PinboardError -> Either PinboardError a
forall a b. a -> Either a b
Left (PinboardError -> Either PinboardError a)
-> (String -> PinboardError) -> String -> Either PinboardError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> PinboardError
createParserErr (LogSource -> PinboardError)
-> (String -> LogSource) -> String -> PinboardError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LogSource
T.pack) a -> Either PinboardError a
forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
r
checkStatusCodeResponse
:: Response LBS.ByteString -> Either PinboardError ()
checkStatusCodeResponse :: Response ByteString -> Either PinboardError ()
checkStatusCodeResponse Response ByteString
resp =
(Int -> Either PinboardError ()
checkStatusCode (Int -> Either PinboardError ())
-> (Response ByteString -> Int)
-> Response ByteString
-> Either PinboardError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode (Status -> Int)
-> (Response ByteString -> Status) -> Response ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> Status
forall body. Response body -> Status
responseStatus) Response ByteString
resp
Either PinboardError ()
-> (Either PinboardError () -> Either PinboardError ())
-> Either PinboardError ()
forall a b. a -> (a -> b) -> b
& ((PinboardError -> PinboardError)
-> Either PinboardError () -> Either PinboardError ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((PinboardError -> PinboardError)
-> Either PinboardError () -> Either PinboardError ())
-> (Response ByteString -> PinboardError -> PinboardError)
-> Response ByteString
-> Either PinboardError ()
-> Either PinboardError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> PinboardError -> PinboardError
addErrMsg (LogSource -> PinboardError -> PinboardError)
-> (Response ByteString -> LogSource)
-> Response ByteString
-> PinboardError
-> PinboardError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LogSource
forall a. Show a => a -> LogSource
toText (ByteString -> LogSource)
-> (Response ByteString -> ByteString)
-> Response ByteString
-> LogSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> ByteString
forall body. Response body -> body
responseBody) Response ByteString
resp
checkStatusCode
:: Int -> Either PinboardError ()
checkStatusCode :: Int -> Either PinboardError ()
checkStatusCode =
\case
Int
200 -> () -> Either PinboardError ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Int
400 -> PinboardErrorHTTPCode -> Either PinboardError ()
forall a. PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError PinboardErrorHTTPCode
BadRequest
Int
401 -> PinboardErrorHTTPCode -> Either PinboardError ()
forall a. PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError PinboardErrorHTTPCode
UnAuthorized
Int
402 -> PinboardErrorHTTPCode -> Either PinboardError ()
forall a. PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError PinboardErrorHTTPCode
RequestFailed
Int
403 -> PinboardErrorHTTPCode -> Either PinboardError ()
forall a. PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError PinboardErrorHTTPCode
Forbidden
Int
404 -> PinboardErrorHTTPCode -> Either PinboardError ()
forall a. PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError PinboardErrorHTTPCode
NotFound
Int
429 -> PinboardErrorHTTPCode -> Either PinboardError ()
forall a. PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError PinboardErrorHTTPCode
TooManyRequests
Int
c
| Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500 -> PinboardErrorHTTPCode -> Either PinboardError ()
forall a. PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError PinboardErrorHTTPCode
PinboardServerError
Int
_ -> PinboardErrorHTTPCode -> Either PinboardError ()
forall a. PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError PinboardErrorHTTPCode
UnknownHTTPCode
httpStatusPinboardError
:: PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError :: PinboardErrorHTTPCode -> Either PinboardError a
httpStatusPinboardError PinboardErrorHTTPCode
err =
PinboardError -> Either PinboardError a
forall a b. a -> Either a b
Left
PinboardError
defaultPinboardError
{ errorType :: PinboardErrorType
errorType = PinboardErrorType
HttpStatusFailure
, errorHTTP :: Maybe PinboardErrorHTTPCode
errorHTTP = PinboardErrorHTTPCode -> Maybe PinboardErrorHTTPCode
forall a. a -> Maybe a
Just PinboardErrorHTTPCode
err
}
addErrMsg :: T.Text -> PinboardError -> PinboardError
addErrMsg :: LogSource -> PinboardError -> PinboardError
addErrMsg LogSource
msg PinboardError
err =
PinboardError
err
{ errorMsg :: LogSource
errorMsg = LogSource
msg
}
createParserErr :: T.Text -> PinboardError
createParserErr :: LogSource -> PinboardError
createParserErr LogSource
msg = PinboardErrorType
-> LogSource
-> Maybe PinboardErrorCode
-> Maybe LogSource
-> Maybe PinboardErrorHTTPCode
-> PinboardError
PinboardError PinboardErrorType
ParseFailure LogSource
msg Maybe PinboardErrorCode
forall a. Maybe a
Nothing Maybe LogSource
forall a. Maybe a
Nothing Maybe PinboardErrorHTTPCode
forall a. Maybe a
Nothing
newMgr :: IO Manager
newMgr :: IO Manager
newMgr =
ManagerSettings -> IO Manager
newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetProxy (Maybe Proxy -> ProxyOverride
proxyEnvironment Maybe Proxy
forall a. Maybe a
Nothing) ManagerSettings
tlsManagerSettings
mgrFail
:: (Monad m)
=> PinboardErrorType -> SomeException -> m (Either PinboardError b)
mgrFail :: PinboardErrorType -> SomeException -> m (Either PinboardError b)
mgrFail PinboardErrorType
e SomeException
msg =
Either PinboardError b -> m (Either PinboardError b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PinboardError b -> m (Either PinboardError b))
-> Either PinboardError b -> m (Either PinboardError b)
forall a b. (a -> b) -> a -> b
$ PinboardError -> Either PinboardError b
forall a b. a -> Either a b
Left (PinboardError -> Either PinboardError b)
-> PinboardError -> Either PinboardError b
forall a b. (a -> b) -> a -> b
$ PinboardErrorType
-> LogSource
-> Maybe PinboardErrorCode
-> Maybe LogSource
-> Maybe PinboardErrorHTTPCode
-> PinboardError
PinboardError PinboardErrorType
e (SomeException -> LogSource
forall a. Show a => a -> LogSource
toText SomeException
msg) Maybe PinboardErrorCode
forall a. Maybe a
Nothing Maybe LogSource
forall a. Maybe a
Nothing Maybe PinboardErrorHTTPCode
forall a. Maybe a
Nothing