pinboard 0.9.7 → 0.9.8
raw patch · 10 files changed
+112/−64 lines, 10 filesdep +safe-exceptions
Dependencies added: safe-exceptions
Files
- README.md +6/−1
- changelog.md +8/−0
- pinboard.cabal +2/−1
- src/Pinboard/Api.hs +8/−8
- src/Pinboard/ApiRequest.hs +3/−4
- src/Pinboard/ApiTypes.hs +21/−23
- src/Pinboard/Client.hs +20/−22
- src/Pinboard/Error.hs +10/−2
- src/Pinboard/Types.hs +3/−2
- tests/Test.hs +31/−1
README.md view
@@ -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+ <http://hackage.haskell.org/package/pinboard>++## Stackage documentation++<https://www.stackage.org/package/pinboard> ## Pinboard Api documentation
changelog.md view
@@ -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
pinboard.cabal view
@@ -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
src/Pinboard/Api.hs view
@@ -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 ---------------------------------------------------------------------
src/Pinboard/ApiRequest.hs view
@@ -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)
src/Pinboard/ApiTypes.hs view
@@ -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)
src/Pinboard/Client.hs view
@@ -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
src/Pinboard/Error.hs view
@@ -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))
src/Pinboard/Types.hs view
@@ -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 ) ------------------------------------------------------------------------------
tests/Test.hs view
@@ -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