pinboard 0.9.8 → 0.9.9
raw patch · 5 files changed
+91/−63 lines, 5 files
Files
- pinboard.cabal +2/−1
- src/Pinboard/Client.hs +31/−29
- src/Pinboard/Error.hs +31/−5
- src/Pinboard/Types.hs +6/−6
- tests/Test.hs +21/−22
pinboard.cabal view
@@ -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
src/Pinboard/Client.hs view
@@ -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
src/Pinboard/Error.hs view
@@ -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
src/Pinboard/Types.hs view
@@ -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 ) ------------------------------------------------------------------------------
tests/Test.hs view
@@ -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