diff --git a/pinboard.cabal b/pinboard.cabal --- a/pinboard.cabal +++ b/pinboard.cabal @@ -1,5 +1,5 @@ name: pinboard -version: 0.9.8 +version: 0.9.9 synopsis: Access to the Pinboard API license: MIT license-file: LICENSE @@ -78,6 +78,7 @@ semigroups, QuickCheck, mtl >= 2.2.1, + safe-exceptions < 0.2, unordered-containers, transformers >= 0.4.0.0 ghc-options: -Wall diff --git a/src/Pinboard/Client.hs b/src/Pinboard/Client.hs --- a/src/Pinboard/Client.hs +++ b/src/Pinboard/Client.hs @@ -52,6 +52,7 @@ import Control.Monad.Reader import Control.Exception.Safe +import Control.Monad.Error.Class (throwError) import Data.ByteString.Char8 (pack) import Data.Monoid ((<>)) @@ -85,12 +86,13 @@ -------------------------------------------------------------------------------- -- | Execute computations in the Pinboard monad runPinboard - :: (MonadIO m, MonadCatch m) + :: (MonadIO m, MonadCatch m, MonadErrorPinboard e) => PinboardConfig -> PinboardT m a - -> m (Either PinboardError a) -runPinboard config f = newMgr >>= go - where go mgr = pinboardErrorToEither $ runPinboardT (config, mgr) f + -> m (e a) +runPinboard config f = do + mgr <- newMgr + eitherToMonadError <$> runPinboardT (config, mgr) f -- | Create a Pinboard value from a PinboardRequest w/ json deserialization @@ -100,8 +102,8 @@ -> m a pinboardJson req = do env <- ask - res <- sendPinboardRequest env (ensureResultFormatType FormatJson req) - either throw return (parseJSONResponse res) + res <- sendPinboardRequest env (ensureResultFormatType FormatJson req) + eitherToMonadThrow (parseJSONResponse res) -------------------------------------------------------------------------------- @@ -114,19 +116,19 @@ where go mgr = sendPinboardRequest (config, mgr) req runPinboardSingleRawBS - :: MonadIO m + :: (MonadIO m, MonadErrorPinboard e) => PinboardConfig -> PinboardRequest - -> m (Either PinboardError LBS.ByteString) + -> m (e LBS.ByteString) runPinboardSingleRawBS config req = do res <- runPinboardSingleRaw config req return $ responseBody res <$ checkStatusCodeResponse res runPinboardSingleJson - :: (MonadIO m, MonadCatch m, FromJSON a) - => PinboardConfig - -> PinboardRequest - -> m (Either PinboardError a) + :: (MonadIO m, MonadCatch m, MonadErrorPinboard e, FromJSON a) + => PinboardConfig + -> PinboardRequest + -> m (e a) runPinboardSingleJson config = runPinboard config . pinboardJson @@ -150,37 +152,39 @@ buildReq url = do req <- liftIO $ parseRequest $ "https://api.pinboard.in/v1/" <> url return $ setRequestIgnoreStatus $ req { - requestHeaders = [("User-Agent","pinboard.hs/0.9.8")] + requestHeaders = [("User-Agent","pinboard.hs/0.9.9")] } -------------------------------------------------------------------------------- parseJSONResponse - :: FromJSON a + :: (MonadErrorPinboard e, FromJSON a) => Response LBS.ByteString - -> Either PinboardError a + -> e a parseJSONResponse response = - either (Left . addErrMsg (toText (responseBody response))) - (const $ decodeJSONResponse (responseBody response)) + either (throwError . addErrMsg (toText (responseBody response))) + (const $ decodeJSONResponse (responseBody response)) (checkStatusCodeResponse response) + + decodeJSONResponse - :: FromJSON a + :: (MonadErrorPinboard e, FromJSON a) => LBS.ByteString - -> Either PinboardError a + -> e a decodeJSONResponse s = let r = eitherDecodeStrict' (LBS.toStrict s) - in either (Left . createParserErr . T.pack) Right r + in either (throwError . createParserErr . T.pack) return r -------------------------------------------------------------------------------- -checkStatusCodeResponse :: Response a -> Either PinboardError () +checkStatusCodeResponse :: MonadErrorPinboard e => Response a -> e () checkStatusCodeResponse = checkStatusCode . statusCode . responseStatus -checkStatusCode :: Int -> Either PinboardError () +checkStatusCode :: MonadErrorPinboard e => Int -> e () checkStatusCode = \case - 200 -> Right () + 200 -> return () 400 -> httpStatusPinboardError BadRequest 401 -> httpStatusPinboardError UnAuthorized 402 -> httpStatusPinboardError RequestFailed @@ -192,8 +196,8 @@ -------------------------------------------------------------------------------- -httpStatusPinboardError :: PinboardErrorHTTPCode -> Either PinboardError a -httpStatusPinboardError err = Left $ defaultPinboardError +httpStatusPinboardError :: MonadErrorPinboard e => PinboardErrorHTTPCode -> e a +httpStatusPinboardError err = throwError defaultPinboardError { errorType = HttpStatusFailure , errorHTTP = Just err } @@ -210,7 +214,5 @@ newMgr = liftIO $ withSocketsDo . 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 - - +mgrFail :: (Monad m, MonadErrorPinboard e) => PinboardErrorType -> SomeException -> m (e b) +mgrFail e msg = return $ throwError $ PinboardError e (toText msg) Nothing Nothing Nothing diff --git a/src/Pinboard/Error.hs b/src/Pinboard/Error.hs --- a/src/Pinboard/Error.hs +++ b/src/Pinboard/Error.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -7,20 +9,27 @@ -- Stability : experimental -- Portability : POSIX module Pinboard.Error - ( defaultPinboardError, - pinboardErrorToEither + ( MonadErrorPinboard + , defaultPinboardError + , pinboardExceptionToEither + , pinboardExceptionToMonadError + , exceptionToMonadErrorPinboard + , tryMonadError + , eitherToMonadError + , eitherToMonadThrow , PinboardErrorHTTPCode (..) , PinboardErrorType (..) , PinboardErrorCode (..) , PinboardError (..) ) where -import Data.Text (Text) +import Data.Text (Text, pack) import Data.Monoid import Prelude import Control.Exception.Safe +import Control.Monad.Error.Class (MonadError, throwError) ------------------------------------------------------------------------------ data PinboardErrorHTTPCode = BadRequest -- ^ 400 @@ -57,8 +66,25 @@ instance Exception PinboardError +type MonadErrorPinboard m = MonadError PinboardError m + defaultPinboardError :: PinboardError defaultPinboardError = PinboardError UnknownErrorType mempty Nothing Nothing Nothing -pinboardErrorToEither :: MonadCatch m => m (Either PinboardError a) -> m (Either PinboardError a) -pinboardErrorToEither = handle (\(e::PinboardError) -> return (Left e)) +pinboardExceptionToEither :: MonadCatch m => m (Either PinboardError a) -> m (Either PinboardError a) +pinboardExceptionToEither = handle (\(e::PinboardError) -> return (Left e)) + +tryMonadError :: (Exception e, MonadCatch m, MonadError e r) => m a -> m (r a) +tryMonadError a = eitherToMonadError <$> try a + +pinboardExceptionToMonadError :: (MonadCatch m, MonadErrorPinboard e) => m (e a) -> m (e a) +pinboardExceptionToMonadError = handle (\(e::PinboardError) -> return (throwError e)) + +exceptionToMonadErrorPinboard :: (MonadCatch m, MonadErrorPinboard e) => m (e a) -> m (e a) +exceptionToMonadErrorPinboard = handle (\(e::SomeException) -> return $ throwError $ defaultPinboardError { errorMsg = (pack.show) e }) + +eitherToMonadError :: MonadError e m => Either e a -> m a +eitherToMonadError = either throwError return + +eitherToMonadThrow :: (Exception e, MonadThrow m) => Either e a -> m a +eitherToMonadThrow = either throw return diff --git a/src/Pinboard/Types.hs b/src/Pinboard/Types.hs --- a/src/Pinboard/Types.hs +++ b/src/Pinboard/Types.hs @@ -13,6 +13,7 @@ , PinboardT , runPinboardT , MonadPinboard + , MonadErrorPinboard , PinboardRequest (..) , PinboardConfig (..) , ResultFormatType (..) @@ -32,7 +33,7 @@ import Data.Time.Clock(UTCTime) import Network.HTTP.Client (Manager) -import Pinboard.Error (PinboardError (..)) +import Pinboard.Error import Control.Applicative import Control.Exception.Safe @@ -45,21 +46,20 @@ type PinboardT m a = ReaderT PinboardEnv (ExceptT PinboardError m) a runPinboardT - :: PinboardEnv + :: MonadCatch m + => PinboardEnv -> PinboardT m a -> m (Either PinboardError a) -runPinboardT e f = runExceptT (runReaderT f e) +runPinboardT e f = pinboardExceptionToEither (runExceptT (runReaderT f e)) -- |Typeclass alias for the return type of the API functions (keeps the -- signatures less verbose) type MonadPinboard m = ( Functor m , Applicative m - , Monad m , MonadIO m - , MonadReader PinboardEnv m - , MonadThrow m , MonadCatch m + , MonadReader PinboardEnv m ) ------------------------------------------------------------------------------ diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -30,28 +30,27 @@ propJSONEq (Proxy :: Proxy Suggested) propJSONApproxEq (Proxy :: Proxy PostDates) - describe "decodeJSONResponse: handle parse failures" $ do - it "object parse failure" $ - let noteJson = "FAIL" - in case (decodeJSONResponse noteJson) of - Left PinboardError{..} -> errorType == ParseFailure - Right Note{..} -> False - it "field parse failure" $ - let noteJson = "{\"length\":0,\"hash\":\"\",\"text_FAIL\":\"\",\"updated_at\":\"1864-05-09 13:50:53\",\"created_at\":\"1864-05-09 18:21:35\",\"id\":\"\",\"title\":\"\"}" - in case (decodeJSONResponse noteJson) of - Left PinboardError{..} -> errorType == ParseFailure - Right Note{..} -> False - it "value parse failure" $ - let noteJson = "{\"length\":FAIL,\"hash\":\"\",\"text_FAIL\":\"\",\"updated_at\":\"1864-05-09 13:50:53\",\"created_at\":\"1864-05-09 18:21:35\",\"id\":\"\",\"title\":\"\"}" - in case (decodeJSONResponse noteJson) of - Left PinboardError{..} -> errorType == ParseFailure - Right Note{..} -> False - it "time parse failure" $ - let noteJson = "{\"length\":0,\"hash\":\"\",\"text\":\"\",\"updated_at\":\"FAIL-05-09 13:50:53\",\"created_at\":\"1864-05-09 18:21:35\",\"id\":\"\",\"title\":\"\"}" - in case (decodeJSONResponse noteJson) of - Left PinboardError{..} -> errorType == ParseFailure - Right Note{..} -> False - + describe "decodeJSONResponse: handle parse failures" $ do + it "object parse failure" $ + let noteJson = "FAIL" + in case decodeJSONResponse noteJson of + Left PinboardError{..} -> errorType == ParseFailure + Right Note{..} -> False + it "field parse failure" $ + let noteJson = "{\"length\":0,\"hash\":\"\",\"text_FAIL\":\"\",\"updated_at\":\"1864-05-09 13:50:53\",\"created_at\":\"1864-05-09 18:21:35\",\"id\":\"\",\"title\":\"\"}" + in case decodeJSONResponse noteJson of + Left PinboardError{..} -> errorType == ParseFailure + Right Note{..} -> False + it "value parse failure" $ + let noteJson = "{\"length\":FAIL,\"hash\":\"\",\"text_FAIL\":\"\",\"updated_at\":\"1864-05-09 13:50:53\",\"created_at\":\"1864-05-09 18:21:35\",\"id\":\"\",\"title\":\"\"}" + in case decodeJSONResponse noteJson of + Left PinboardError{..} -> errorType == ParseFailure + Right Note{..} -> False + it "time parse failure" $ + let noteJson = "{\"length\":0,\"hash\":\"\",\"text\":\"\",\"updated_at\":\"FAIL-05-09 13:50:53\",\"created_at\":\"1864-05-09 18:21:35\",\"id\":\"\",\"title\":\"\"}" + in case decodeJSONResponse noteJson of + Left PinboardError{..} -> errorType == ParseFailure + Right Note{..} -> False pinboardParseFailure :: Selector PinboardError pinboardParseFailure e = errorType e == ParseFailure