module Pinboard.Client
(
fromApiToken
, PinboardConfig (..)
, runPinboard
, pinboardJson
, runPinboardSingleRaw
, runPinboardSingleRawBS
, runPinboardSingleJson
, sendPinboardRequest
, newMgr
, mgrFail
,parseJSONResponse
,decodeJSONResponse
,checkStatusCodeResponse
,checkStatusCode
,addErrMsg
,createParserErr
,httpStatusPinboardError
, module Pinboard.Error
, module Pinboard.Types
, module Pinboard.Util
) where
import Control.Exception (catch, SomeException)
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Except
import Data.ByteString.Char8 (pack)
import Data.Monoid ((<>))
import Data.Aeson (FromJSON, eitherDecodeStrict')
import Network (withSocketsDo)
import Network.HTTP.Types (urlEncode)
import Network.HTTP.Types.Status (statusCode)
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Pinboard.Types
import Pinboard.Error
import Pinboard.Util
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Control.Applicative
import Prelude
fromApiToken :: String -> PinboardConfig
fromApiToken token = PinboardConfig { apiToken = pack token }
runPinboard
:: MonadIO m
=> PinboardConfig
-> PinboardT m a
-> m (Either PinboardError a)
runPinboard config f = newMgr >>= go
where go mgr = runPinboardT (config, mgr) f
pinboardJson
:: (MonadPinboard m, FromJSON a)
=> PinboardRequest
-> m a
pinboardJson req = do
env <- ask
res <- sendPinboardRequest env (ensureResultFormatType FormatJson req)
parseJSONResponse res
runPinboardSingleRaw
:: MonadIO m
=> PinboardConfig
-> PinboardRequest
-> m (Either PinboardError (Response LBS.ByteString))
runPinboardSingleRaw config req = liftIO $ newMgr >>= go
where go mgr = (Right <$> sendPinboardRequest (config, mgr) req)
`catch` mgrFail UnknownErrorType
runPinboardSingleRawBS
:: MonadIO m
=> PinboardConfig
-> PinboardRequest
-> m (Either PinboardError LBS.ByteString)
runPinboardSingleRawBS config req = do
res <- runPinboardSingleRaw config req
return $ do
r <- res
responseBody r <$ checkStatusCodeResponse r
runPinboardSingleJson
:: (Functor m, MonadIO m, FromJSON a)
=> PinboardConfig
-> PinboardRequest
-> m (Either PinboardError a)
runPinboardSingleJson config = runPinboard config . pinboardJson
sendPinboardRequest
:: MonadIO m
=> PinboardEnv
-> PinboardRequest
-> m (Response LBS.ByteString)
sendPinboardRequest (PinboardConfig{..}, mgr) PinboardRequest{..} = do
let url = T.concat [ requestPath
, "?"
, T.decodeUtf8 $ paramsToByteString $ ("auth_token", urlEncode False apiToken) : encodeParams requestParams ]
req <- buildReq $ T.unpack url
res <- liftIO $ httpLbs req mgr
return res
buildReq :: MonadIO m => String -> m Request
buildReq url = do
req <- liftIO $ parseUrl $ "https://api.pinboard.in/v1/" <> url
return $ req
{ requestHeaders = [("User-Agent","pinboard.hs/0.9.3")]
, checkStatus = \_ _ _ -> Nothing
}
parseJSONResponse
:: (MonadError PinboardError m, FromJSON a)
=> Response LBS.ByteString
-> m a
parseJSONResponse response =
either (throwError . addErrMsg (toText (responseBody response)))
(const $ decodeJSONResponse (responseBody response))
(checkStatusCodeResponse response)
decodeJSONResponse
:: (MonadError PinboardError m, FromJSON a)
=> LBS.ByteString
-> m a
decodeJSONResponse s =
let r = eitherDecodeStrict' (LBS.toStrict s)
in either (throwError . createParserErr . toText) (return . id) r
checkStatusCodeResponse :: Response a -> Either PinboardError ()
checkStatusCodeResponse = checkStatusCode . statusCode . responseStatus
checkStatusCode :: Int -> Either PinboardError ()
checkStatusCode = \case
200 -> Right ()
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 :: MonadIO m => m Manager
newMgr = liftIO $ withSocketsDo . newManager
$ managerSetProxy (proxyEnvironment Nothing) tlsManagerSettings
mgrFail :: MonadIO m => PinboardErrorType -> SomeException -> m (Either PinboardError b)
mgrFail e msg = return $ Left $ PinboardError e (toText msg) Nothing Nothing Nothing