{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}

------------------------------------------------------------------------------
-- | 
-- Module      : Pinboard.Client
-- Copyright   : (c) Jon Schoning, 2015
-- Maintainer  : jonschoning@gmail.com
-- Stability   : experimental
-- Portability : POSIX
------------------------------------------------------------------------------
module Pinboard.Client
  (
    -- * Config
    fromApiToken
  , defaultPinboardConfig
   -- | The PinboardConfig provides authentication via apiToken
  , PinboardConfig(..)
   -- * Monadic
  , runPinboard
  , runPinboardE
  , pinboardJson
   -- * Single
  , runPinboardSingleRaw
  , runPinboardSingleRawBS
  , runPinboardSingleJson
   -- * Sending
  , sendPinboardRequest
   -- * Delaying
  , requestThreadDelay
   -- *  Manager (http-client)
  , newMgr
  , mgrFail
   -- * JSON Handling
  , parseJSONResponse
  , decodeJSONResponse
   -- * Status Codes
  , checkStatusCodeResponse
  , checkStatusCode
   -- * Error Helpers
  , addErrMsg
  , createParserErr
  , httpStatusPinboardError
   -- * Client Dependencies
  , 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

-- | Create a default PinboardConfig using the supplied apiToken (ex: "use:ABCDEF0123456789ABCD")
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 #-}

--------------------------------------------------------------------------------
-- | Execute computations in the Pinboard monad
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

-- | Execute computations in the Pinboard monad (with specified http Manager)
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

-- | Create a Pinboard value from a PinboardRequest w/ json deserialization
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

--------------------------------------------------------------------------------

-- | delays the thread, if the time since the previous request is less than the configured maxRequestRateMills 
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