diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,8 +5,13 @@ library wraps the API exposing functions and data structures suitable for usage in Haskell programs. -## Hackage page and Haddock documentation +## Hackage documentation + + +## Stackage documentation + + ## Pinboard Api documentation diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,11 @@ +__v0.9.8__ + +use safe-exception + +avoid use of 'error' to communicate failure when parsing json + +includes a few changes to the types/api in Pinboard.Client + __v0.9.7__ add http-client-0.5.0 support diff --git a/pinboard.cabal b/pinboard.cabal --- a/pinboard.cabal +++ b/pinboard.cabal @@ -1,5 +1,5 @@ name: pinboard -version: 0.9.7 +version: 0.9.8 synopsis: Access to the Pinboard API license: MIT license-file: LICENSE @@ -38,6 +38,7 @@ , mtl >= 2.2.1 , profunctors >= 5 , random >= 1.1 + , safe-exceptions < 0.2 , unordered-containers diff --git a/src/Pinboard/Api.hs b/src/Pinboard/Api.hs --- a/src/Pinboard/Api.hs +++ b/src/Pinboard/Api.hs @@ -107,7 +107,7 @@ :: MonadPinboard m => Url -> m () -deletePost url = fromDoneResult <$> (pinboardJson $ deletePostRequest FormatJson url) +deletePost url = fromDoneResult <$> pinboardJson (deletePostRequest FormatJson url) -- | posts/add : Add or Update a bookmark addPost @@ -121,7 +121,7 @@ -> Maybe Shared -- ^ Make bookmark public. Default is "yes" unless user has enabled the "save all bookmarks as private" user setting, in which case default is "no" -> Maybe ToRead -- ^ Marks the bookmark as unread. Default is "no" -> m () -addPost url descr ext tags ctime repl shared toread = fromDoneResult <$> (pinboardJson $ addPostRequest FormatJson url descr ext tags ctime repl shared toread) +addPost url descr ext tags ctime repl shared toread = fromDoneResult <$> pinboardJson (addPostRequest FormatJson url descr ext tags ctime repl shared toread) -- | posts/add : Add or Update a bookmark, from a Post record addPostRec @@ -129,7 +129,7 @@ => Post -- ^ a Post record -> Replace -- ^ Replace any existing bookmark with the Posts URL. If set to no, will fail if bookmark exists -> m () -addPostRec post replace = fromDoneResult <$> (pinboardJson $ addPostRecRequest FormatJson post replace) +addPostRec post replace = fromDoneResult <$> pinboardJson (addPostRecRequest FormatJson post replace) -- TAGS ---------------------------------------------------------------------- @@ -139,7 +139,7 @@ getTags :: MonadPinboard m => m TagMap -getTags = fromJsonTagMap <$> (pinboardJson $ getTagsRequest FormatJson ) +getTags = fromJsonTagMap <$> pinboardJson (getTagsRequest FormatJson) -- | tags/delete : Delete an existing tag. @@ -147,7 +147,7 @@ :: MonadPinboard m => Tag -> m () -deleteTag tag = fromDoneResult <$> (pinboardJson $ deleteTagRequest FormatJson tag) +deleteTag tag = fromDoneResult <$> pinboardJson (deleteTagRequest FormatJson tag) -- | tags/rename : Rename an tag, or fold it in to an existing tag @@ -156,7 +156,7 @@ => Old -- ^ note: match is not case sensitive -> New -- ^ if empty, nothing will happen -> m () -renameTag old new = fromDoneResult <$> (pinboardJson $ renameTagRequest FormatJson old new) +renameTag old new = fromDoneResult <$> pinboardJson (renameTagRequest FormatJson old new) -- USER ---------------------------------------------------------------------- @@ -165,13 +165,13 @@ getUserSecretRssKey :: MonadPinboard m => m Text -getUserSecretRssKey = fromTextResult <$> (pinboardJson $ getUserSecretRssKeyRequest FormatJson ) +getUserSecretRssKey = fromTextResult <$> pinboardJson (getUserSecretRssKeyRequest FormatJson) -- | user/api_token : Returns the user's API token (for making API calls without a password) getUserApiToken :: MonadPinboard m => m Text -getUserApiToken = fromTextResult <$> (pinboardJson $ getUserApiTokenRequest FormatJson ) +getUserApiToken = fromTextResult <$> pinboardJson (getUserApiTokenRequest FormatJson) -- NOTES --------------------------------------------------------------------- diff --git a/src/Pinboard/ApiRequest.hs b/src/Pinboard/ApiRequest.hs --- a/src/Pinboard/ApiRequest.hs +++ b/src/Pinboard/ApiRequest.hs @@ -37,12 +37,11 @@ getNoteRequest, ) where -import Pinboard.Types (PinboardRequest (..), Param (..)) +import Pinboard.Types (PinboardRequest (..), Param (..), ResultFormatType (..)) import Pinboard.Util (()) -import Data.Text (unwords) -import Data.Maybe (catMaybes) +import Data.Text (unwords) +import Data.Maybe (catMaybes) import Pinboard.ApiTypes -import Pinboard.Types (ResultFormatType (..)) import Control.Applicative import Prelude hiding (unwords) diff --git a/src/Pinboard/ApiTypes.hs b/src/Pinboard/ApiTypes.hs --- a/src/Pinboard/ApiTypes.hs +++ b/src/Pinboard/ApiTypes.hs @@ -18,13 +18,13 @@ import Data.HashMap.Strict (HashMap, member, toList) import Data.Data (Data, Typeable) import Data.Text (Text, words, unwords, unpack, pack) -import Data.Time (UTCTime) +import Data.Time (UTCTime, parseTimeM) import Data.Time.Calendar (Day) import GHC.Generics (Generic) import qualified Data.HashMap.Strict as HM import qualified Data.Vector as V -import Data.Time.Format (parseTimeOrError, formatTime, defaultTimeLocale) +import Data.Time.Format (formatTime, defaultTimeLocale) import Control.Applicative import Prelude hiding (words, unwords) @@ -42,7 +42,7 @@ Posts <$> o .: "date" <*> o .: "user" <*> o .: "posts" - parseJSON _ = error "bad parse" + parseJSON _ = fail "bad parse" instance ToJSON Posts where toJSON Posts{..} = object @@ -73,7 +73,7 @@ <*> (boolFromYesNo <$> o .: "shared") <*> (boolFromYesNo <$> o .: "toread") <*> (words <$> o .: "tags") - parseJSON _ = error "bad parse" + parseJSON _ = fail "bad parse" instance ToJSON Post where toJSON Post{..} = object @@ -112,7 +112,7 @@ (dateStr, String countStr) <- toList o' return (read (unpack dateStr), read (unpack countStr)) parseDates _ = [] - parseJSON _ = error "bad parse" + parseJSON _ = fail "bad parse" instance ToJSON PostDates where toJSON PostDates{..} = object @@ -135,7 +135,7 @@ parseJSON (Object o) = NoteList <$> o .: "count" <*> o .: "notes" - parseJSON _ = error "bad parse" + parseJSON _ = fail "bad parse" instance ToJSON NoteList where toJSON NoteList{..} = object @@ -157,9 +157,9 @@ <*> o .: "hash" <*> o .: "title" <*> (read <$> (o .: "length")) - <*> (readNoteTime <$> o .: "created_at") - <*> (readNoteTime <$> o .: "updated_at") - parseJSON _ = error "bad parse" + <*> (readNoteTime =<< o .: "created_at") + <*> (readNoteTime =<< o .: "updated_at") + parseJSON _ = fail "bad parse" instance ToJSON NoteListItem where toJSON NoteListItem{..} = object @@ -188,9 +188,9 @@ <*> o .: "title" <*> o .: "text" <*> o .: "length" - <*> (readNoteTime <$> o .: "created_at") - <*> (readNoteTime <$> o .: "updated_at") - parseJSON _ = error "bad parse" + <*> (readNoteTime =<< o .: "created_at") + <*> (readNoteTime =<< o .: "updated_at") + parseJSON _ = fail "bad parse" instance ToJSON Note where toJSON Note{..} = object @@ -202,10 +202,8 @@ , "created_at" .= toJSON (showNoteTime noteCreatedAt) , "updated_at" .= toJSON (showNoteTime noteUpdatedAt) ] -readNoteTime :: String -> UTCTime -readNoteTime = parse' defaultTimeLocale "%F %T" - where - parse' = parseTimeOrError True +readNoteTime :: Monad m => String -> m UTCTime +readNoteTime = parseTimeM True defaultTimeLocale "%F %T" showNoteTime :: UTCTime -> String showNoteTime = formatTime defaultTimeLocale "%F %T" @@ -218,9 +216,9 @@ deriving (Show, Eq, Data, Typeable, Generic) instance FromJSON JsonTagMap where - parseJSON = return . toTags - where toTags (Object o) = ToJsonTagMap $ HM.map (\(String s)-> read (unpack s)) o - toTags _ = error "bad parse" + parseJSON = toTags + where toTags (Object o) = return . ToJsonTagMap $ HM.map (\(String s)-> read (unpack s)) o + toTags _ = fail "bad parse" instance ToJSON JsonTagMap where toJSON (ToJsonTagMap o) = toJSON $ show <$> o @@ -234,8 +232,8 @@ parseJSON (Object o) | member "popular" o = Popular <$> (o .: "popular") | member "recommended" o = Recommended <$> (o .: "recommended") - | otherwise = error "bad parse" - parseJSON _ = error "bad parse" + | otherwise = fail "bad parse" + parseJSON _ = fail "bad parse" instance ToJSON [Suggested] where @@ -256,14 +254,14 @@ parseDone :: Text -> Parser DoneResult parseDone "done" = return $ ToDoneResult () parseDone msg = ( fail . unpack ) msg - parseJSON _ = error "bad parse" + parseJSON _ = fail "bad parse" newtype TextResult = ToTextResult {fromTextResult :: Text} deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON TextResult where parseJSON (Object o) = ToTextResult <$> (o .: "result") - parseJSON _ = error "bad parse" + parseJSON _ = fail "bad parse" newtype UpdateTime = ToUpdateTime {fromUpdateTime :: UTCTime} deriving (Show, Eq, Data, Typeable, Generic, Ord) diff --git a/src/Pinboard/Client.hs b/src/Pinboard/Client.hs --- a/src/Pinboard/Client.hs +++ b/src/Pinboard/Client.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -47,11 +48,11 @@ ) where -import Control.Exception (catch, SomeException) import Control.Monad.IO.Class import Control.Monad.Reader -import Control.Monad.Except +import Control.Exception.Safe + import Data.ByteString.Char8 (pack) import Data.Monoid ((<>)) import Data.Aeson (FromJSON, eitherDecodeStrict') @@ -84,13 +85,13 @@ -------------------------------------------------------------------------------- -- | Execute computations in the Pinboard monad runPinboard - :: MonadIO m + :: (MonadIO m, MonadCatch m) => PinboardConfig -> PinboardT m a -> m (Either PinboardError a) -runPinboard config f = newMgr >>= go - where go mgr = runPinboardT (config, mgr) f - +runPinboard config f = newMgr >>= go + where go mgr = pinboardErrorToEither $ runPinboardT (config, mgr) f + -- | Create a Pinboard value from a PinboardRequest w/ json deserialization pinboardJson @@ -100,7 +101,7 @@ pinboardJson req = do env <- ask res <- sendPinboardRequest env (ensureResultFormatType FormatJson req) - parseJSONResponse res + either throw return (parseJSONResponse res) -------------------------------------------------------------------------------- @@ -108,10 +109,9 @@ :: MonadIO m => PinboardConfig -> PinboardRequest - -> m (Either PinboardError (Response LBS.ByteString)) + -> m (Response LBS.ByteString) runPinboardSingleRaw config req = liftIO $ newMgr >>= go - where go mgr = (Right <$> sendPinboardRequest (config, mgr) req) - `catch` mgrFail UnknownErrorType + where go mgr = sendPinboardRequest (config, mgr) req runPinboardSingleRawBS :: MonadIO m @@ -120,12 +120,10 @@ -> m (Either PinboardError LBS.ByteString) runPinboardSingleRawBS config req = do res <- runPinboardSingleRaw config req - return $ do - r <- res - responseBody r <$ checkStatusCodeResponse r + return $ responseBody res <$ checkStatusCodeResponse res runPinboardSingleJson - :: (MonadIO m, FromJSON a) + :: (MonadIO m, MonadCatch m, FromJSON a) => PinboardConfig -> PinboardRequest -> m (Either PinboardError a) @@ -152,28 +150,28 @@ buildReq url = do req <- liftIO $ parseRequest $ "https://api.pinboard.in/v1/" <> url return $ setRequestIgnoreStatus $ req { - requestHeaders = [("User-Agent","pinboard.hs/0.9.7")] + requestHeaders = [("User-Agent","pinboard.hs/0.9.8")] } -------------------------------------------------------------------------------- parseJSONResponse - :: (MonadError PinboardError m, FromJSON a) + :: FromJSON a => Response LBS.ByteString - -> m a + -> Either PinboardError a parseJSONResponse response = - either (throwError . addErrMsg (toText (responseBody response))) + either (Left . addErrMsg (toText (responseBody response))) (const $ decodeJSONResponse (responseBody response)) (checkStatusCodeResponse response) decodeJSONResponse - :: (MonadError PinboardError m, FromJSON a) + :: FromJSON a => LBS.ByteString - -> m a + -> Either PinboardError a decodeJSONResponse s = let r = eitherDecodeStrict' (LBS.toStrict s) - in either (throwError . createParserErr . toText) return r + in either (Left . createParserErr . T.pack) Right r -------------------------------------------------------------------------------- @@ -212,7 +210,7 @@ newMgr = liftIO $ withSocketsDo . newManager $ managerSetProxy (proxyEnvironment Nothing) tlsManagerSettings -mgrFail :: MonadIO m => PinboardErrorType -> SomeException -> m (Either PinboardError b) +mgrFail :: Monad m => PinboardErrorType -> SomeException -> m (Either PinboardError b) mgrFail e msg = return $ Left $ 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,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Pinboard.Error @@ -6,7 +7,8 @@ -- Stability : experimental -- Portability : POSIX module Pinboard.Error - ( defaultPinboardError + ( defaultPinboardError, + pinboardErrorToEither , PinboardErrorHTTPCode (..) , PinboardErrorType (..) , PinboardErrorCode (..) @@ -18,6 +20,7 @@ import Data.Monoid import Prelude +import Control.Exception.Safe ------------------------------------------------------------------------------ data PinboardErrorHTTPCode = BadRequest -- ^ 400 @@ -36,7 +39,7 @@ | HttpStatusFailure | ParseFailure | UnknownErrorType - deriving Show + deriving (Eq, Show) ------------------------------------------------------------------------------ data PinboardErrorCode = @@ -52,5 +55,10 @@ , errorHTTP :: Maybe PinboardErrorHTTPCode } deriving Show +instance Exception PinboardError + 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)) diff --git a/src/Pinboard/Types.hs b/src/Pinboard/Types.hs --- a/src/Pinboard/Types.hs +++ b/src/Pinboard/Types.hs @@ -24,7 +24,6 @@ import Control.Monad.Reader.Class (MonadReader) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Reader (runReaderT) -import Control.Monad.Error.Class (MonadError) import Control.Monad.IO.Class (MonadIO) import Data.ByteString (ByteString) @@ -36,6 +35,7 @@ import Pinboard.Error (PinboardError (..)) import Control.Applicative +import Control.Exception.Safe import Prelude ------------------------------------------------------------------------------ @@ -58,7 +58,8 @@ , Monad m , MonadIO m , MonadReader PinboardEnv m - , MonadError PinboardError m + , MonadThrow m + , MonadCatch m ) ------------------------------------------------------------------------------ diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Main where @@ -14,7 +16,9 @@ main :: IO () main = hspec $ do - prop "UTCTime" $ \(x :: UTCTime) -> (readNoteTime . showNoteTime) x == x + + prop "UTCTime" $ \(x :: UTCTime) -> (readNoteTime . showNoteTime) x == (return x :: Maybe UTCTime) + describe "JSON instances" $ do propJSONEq (Proxy :: Proxy UTCTime) propJSONEq (Proxy :: Proxy Post) @@ -25,3 +29,29 @@ propJSONEq (Proxy :: Proxy JsonTagMap) 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 + + +pinboardParseFailure :: Selector PinboardError +pinboardParseFailure e = errorType e == ParseFailure