diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +__v0.9.11__ + +add logging + +add option to delay between requests (requestDelayMills) + __v0.9.10__ avoid pre-lifting IO into MonadIO diff --git a/pinboard.cabal b/pinboard.cabal --- a/pinboard.cabal +++ b/pinboard.cabal @@ -1,5 +1,5 @@ name: pinboard -version: 0.9.10 +version: 0.9.11 synopsis: Access to the Pinboard API license: MIT license-file: LICENSE @@ -40,6 +40,7 @@ , random >= 1.1 , safe-exceptions < 0.2 , unordered-containers + , monad-logger default-language: Haskell2010 @@ -54,6 +55,7 @@ Pinboard.Error Pinboard.Types Pinboard.Util + Pinboard.Logging ghc-options: -Wall -fwarn-incomplete-patterns -funbox-strict-fields diff --git a/src/Pinboard/Api.hs b/src/Pinboard/Api.hs --- a/src/Pinboard/Api.hs +++ b/src/Pinboard/Api.hs @@ -14,50 +14,49 @@ -- < https://pinboard.in/api/ > -- -- Provides Pinboard Api Access (deserializes into Haskell data structures) - module Pinboard.Api - ( - -- ** Posts - getPostsRecent, - getPostsForDate, - getPostsAll, - getPostsDates, - getPostsMRUTime, - getSuggestedTags, - addPost, - addPostRec, - deletePost, - -- ** Tags - getTags, - renameTag, - deleteTag, - -- ** User - getUserSecretRssKey, - getUserApiToken, - -- ** Notes - getNoteList, - getNote, - ) where + ( -- ** Posts + getPostsRecent + , getPostsForDate + , getPostsAll + , getPostsDates + , getPostsMRUTime + , getSuggestedTags + , addPost + , addPostRec + , deletePost + -- ** Tags + , getTags + , renameTag + , deleteTag + -- ** User + , getUserSecretRssKey + , getUserApiToken + -- ** Notes + , getNoteList + , getNote + ) where -import Pinboard.Client (pinboardJson) -import Data.Text (Text) -import Data.Time (UTCTime) -import Pinboard.Types (MonadPinboard, ResultFormatType (..)) -import Pinboard.ApiTypes + +import Pinboard.Client (pinboardJson) +import Data.Text (Text) +import Data.Time (UTCTime) +import Pinboard.Types (MonadPinboard, ResultFormatType(..)) +import Pinboard.ApiTypes import Pinboard.ApiRequest import Control.Applicative -import Prelude +import Prelude -- POSTS --------------------------------------------------------------------- - -- | posts/recent : Returns a list of the user's most recent posts, filtered by tag. getPostsRecent :: MonadPinboard m => Maybe [Tag] -- ^ filter by up to three tags -> Maybe Count -- ^ number of results to return. Default is 15, max is 100 -> m Posts -getPostsRecent tags count = pinboardJson $ getPostsRecentRequest FormatJson tags count +getPostsRecent tags count = + pinboardJson $ getPostsRecentRequest FormatJson tags count -- | posts/all : Returns all bookmarks in the user's account. getPostsAll @@ -69,7 +68,8 @@ -> Maybe ToDateTime -- ^ return only bookmarks created before this time -> Maybe Meta -- ^ include a change detection signature for each bookmark -> m [Post] -getPostsAll tags start results fromdt todt meta = pinboardJson $ getPostsAllRequest FormatJson tags start results fromdt todt meta +getPostsAll tags start results fromdt todt meta = + pinboardJson $ getPostsAllRequest FormatJson tags start results fromdt todt meta -- | posts/get : Returns one or more posts on a single day matching the arguments. -- If no date or url is given, date of most recent bookmark will be used. @@ -79,7 +79,8 @@ -> Maybe Date -- ^ return results bookmarked on this day -> Maybe Url -- ^ return bookmark for this URL -> m Posts -getPostsForDate tags date url = pinboardJson $ getPostsForDateRequest FormatJson tags date url +getPostsForDate tags date url = + pinboardJson $ getPostsForDateRequest FormatJson tags date url -- | posts/dates : Returns a list of dates with the number of posts at each date. getPostsDates @@ -88,104 +89,102 @@ -> m PostDates getPostsDates tags = pinboardJson $ getPostsDatesRequest FormatJson tags - -- | posts/update : Returns the most recent time a bookmark was added, updated or deleted. -getPostsMRUTime :: MonadPinboard m => m UTCTime -getPostsMRUTime = fromUpdateTime <$> pinboardJson (getPostsMRUTimeRequest FormatJson) +getPostsMRUTime + :: MonadPinboard m + => m UTCTime +getPostsMRUTime = + fromUpdateTime <$> pinboardJson (getPostsMRUTimeRequest FormatJson) -- | posts/suggest : Returns a list of popular tags and recommended tags for a given URL. -- Popular tags are tags used site-wide for the url; -- Recommended tags are drawn from the user's own tags. getSuggestedTags :: MonadPinboard m - => Url - -> m [Suggested] + => Url -> m [Suggested] getSuggestedTags url = pinboardJson $ getSuggestedTagsRequest FormatJson url -- | posts/delete : Delete an existing bookmark. -deletePost +deletePost :: MonadPinboard m - => Url - -> m () -deletePost url = fromDoneResult <$> pinboardJson (deletePostRequest FormatJson url) + => Url -> m () +deletePost url = + fromDoneResult <$> pinboardJson (deletePostRequest FormatJson url) -- | posts/add : Add or Update a bookmark addPost :: MonadPinboard m - => Url -- ^ the URL of the item - -> Description -- ^ Title of the item. This field is unfortunately named 'description' for backwards compatibility with the delicious API + => Url -- ^ the URL of the item + -> Description -- ^ Title of the item. This field is unfortunately named 'description' for backwards compatibility with the delicious API -> Maybe Extended -- ^ Description of the item. Called 'extended' for backwards compatibility with delicious API - -> Maybe [Tag] -- ^ List of up to 100 tags + -> Maybe [Tag] -- ^ List of up to 100 tags -> Maybe DateTime -- ^ creation time for this bookmark. Defaults to current time. Datestamps more than 10 minutes ahead of server time will be reset to current server time - -> Maybe Replace -- ^ Replace any existing bookmark with this URL. Default is yes. If set to no, will fail if bookmark exists - -> 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" + -> Maybe Replace -- ^ Replace any existing bookmark with this URL. Default is yes. If set to no, will fail if bookmark exists + -> 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 :: MonadPinboard m - => Post -- ^ a Post record - -> Replace -- ^ Replace any existing bookmark with the Posts URL. If set to no, will fail if bookmark exists + => 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 ---------------------------------------------------------------------- - - -- | tags/get : Returns a full list of the user's tags along with the number of -- times they were used. -getTags +getTags :: MonadPinboard m => m TagMap getTags = fromJsonTagMap <$> pinboardJson (getTagsRequest FormatJson) - -- | tags/delete : Delete an existing tag. -deleteTag +deleteTag :: MonadPinboard m - => Tag - -> m () -deleteTag tag = fromDoneResult <$> pinboardJson (deleteTagRequest FormatJson tag) - + => Tag -> m () +deleteTag tag = + fromDoneResult <$> pinboardJson (deleteTagRequest FormatJson tag) -- | tags/rename : Rename an tag, or fold it in to an existing tag -renameTag +renameTag :: MonadPinboard m => 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 ---------------------------------------------------------------------- - -- | user/secret : Returns the user's secret RSS key (for viewing private feeds) -getUserSecretRssKey +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 +getUserApiToken :: MonadPinboard m => m Text -getUserApiToken = fromTextResult <$> pinboardJson (getUserApiTokenRequest FormatJson) - +getUserApiToken = + fromTextResult <$> pinboardJson (getUserApiTokenRequest FormatJson) -- NOTES --------------------------------------------------------------------- - -- | notes/list : Returns a list of the user's notes (note text detail is not included) -getNoteList +getNoteList :: MonadPinboard m => m NoteList -getNoteList = pinboardJson $ getNoteListRequest FormatJson +getNoteList = pinboardJson $ getNoteListRequest FormatJson -- | notes/id : Returns an individual user note. The hash property is a 20 character long sha1 hash of the note text. -getNote +getNote :: MonadPinboard m - => NoteId - -> m Note + => NoteId -> m Note getNote noteid = pinboardJson $ getNoteRequest FormatJson noteid - diff --git a/src/Pinboard/ApiRequest.hs b/src/Pinboard/ApiRequest.hs --- a/src/Pinboard/ApiRequest.hs +++ b/src/Pinboard/ApiRequest.hs @@ -12,43 +12,43 @@ -- These request builders allow you to build request params which can -- sent via Pinboard.Client, in the case you need more control -- for how the response should be processed over what Pinboard.Api provides. - module Pinboard.ApiRequest - ( - -- ** Posts - getPostsRecentRequest, - getPostsForDateRequest, - getPostsAllRequest, - getPostsDatesRequest, - getPostsMRUTimeRequest, - getSuggestedTagsRequest, - addPostRequest, - addPostRecRequest, - deletePostRequest, - -- ** Tags - getTagsRequest, - renameTagRequest, - deleteTagRequest, - -- ** User - getUserSecretRssKeyRequest, - getUserApiTokenRequest, - -- ** Notes - getNoteListRequest, - getNoteRequest, - ) where + ( + -- ** Posts + getPostsRecentRequest + , getPostsForDateRequest + , getPostsAllRequest + , getPostsDatesRequest + , getPostsMRUTimeRequest + , getSuggestedTagsRequest + , addPostRequest + , addPostRecRequest + , deletePostRequest + -- ** Tags + , getTagsRequest + , renameTagRequest + , deleteTagRequest + -- ** User + , getUserSecretRssKeyRequest + , getUserApiTokenRequest + -- ** Notes + , getNoteListRequest + , getNoteRequest + ) where -import Pinboard.Types (PinboardRequest (..), Param (..), ResultFormatType (..)) -import Pinboard.Util (()) -import Data.Text (unwords) -import Data.Maybe (catMaybes) -import Pinboard.ApiTypes +import Pinboard.Types + (PinboardRequest(..), Param(..), ResultFormatType(..)) + +import Pinboard.Util (()) +import Data.Text (unwords) +import Data.Maybe (catMaybes) +import Pinboard.ApiTypes + import Control.Applicative import Prelude hiding (unwords) - -- POSTS --------------------------------------------------------------------- - -- | posts/recent : Returns a list of the user's most recent posts, filtered by tag. getPostsRecentRequest :: ResultFormatType @@ -56,11 +56,10 @@ -> Maybe Count -- ^ number of results to return. Default is 15, max is 100 -> PinboardRequest getPostsRecentRequest fmt tags count = PinboardRequest path params - where - path = "posts/recent" - params = catMaybes [ Just (Format fmt) - , Tag . unwords <$> tags - , Count <$> count ] + where + path = "posts/recent" + params = + catMaybes [Just (Format fmt), Tag . unwords <$> tags, Count <$> count] -- | posts/all : Returns all bookmarks in the user's account. getPostsAllRequest @@ -72,18 +71,20 @@ -> Maybe ToDateTime -- ^ return only bookmarks created before this time -> Maybe Meta -- ^ include a change detection signature for each bookmark -> PinboardRequest -getPostsAllRequest fmt tags start results fromdt todt meta = +getPostsAllRequest fmt tags start results fromdt todt meta = PinboardRequest path params - where - path = "posts/all" - params = catMaybes [ Just (Format fmt) - , Tag . unwords <$> tags - , Start <$> start - , Results <$> results - , FromDateTime <$> fromdt - , ToDateTime <$> todt - , Meta <$> meta - ] + where + path = "posts/all" + params = + catMaybes + [ Just (Format fmt) + , Tag . unwords <$> tags + , Start <$> start + , Results <$> results + , FromDateTime <$> fromdt + , ToDateTime <$> todt + , Meta <$> meta + ] -- | posts/get : Returns one or more posts on a single day matching the arguments. -- If no date or url is given, date of most recent bookmark will be used. @@ -94,13 +95,11 @@ -> Maybe Url -- ^ return bookmark for this URL -> PinboardRequest getPostsForDateRequest fmt tags date url = PinboardRequest path params - where - path = "posts/get" - params = catMaybes [ Just (Format fmt) - , Tag . unwords <$> tags - , Date <$> date - , Url <$> url ] - + where + path = "posts/get" + params = + catMaybes + [Just (Format fmt), Tag . unwords <$> tags, Date <$> date, Url <$> url] -- | posts/dates : Returns a list of dates with the number of posts at each date. getPostsDatesRequest @@ -108,161 +107,133 @@ -> Maybe [Tag] -- ^ filter by up to three tags -> PinboardRequest getPostsDatesRequest fmt tags = PinboardRequest path params - where - path = "posts/dates" - params = catMaybes [ Just (Format fmt) - , Tag . unwords <$> tags ] - + where + path = "posts/dates" + params = catMaybes [Just (Format fmt), Tag . unwords <$> tags] -- | posts/update : Returns the most recent time a bookmark was added, updated or deleted. -getPostsMRUTimeRequest - :: ResultFormatType - -> PinboardRequest +getPostsMRUTimeRequest :: ResultFormatType -> PinboardRequest getPostsMRUTimeRequest fmt = PinboardRequest path params - where - path = "posts/update" + where + path = "posts/update" params = [Format fmt] -- | posts/suggest : Returns a list of popular tags and recommended tags for a given URL. -- Popular tags are tags used site-wide for the url; -- Recommended tags are drawn from the user's own tags. -getSuggestedTagsRequest - :: ResultFormatType - -> Url - -> PinboardRequest +getSuggestedTagsRequest :: ResultFormatType -> Url -> PinboardRequest getSuggestedTagsRequest fmt url = PinboardRequest path params - where - path = "posts/suggest" - params = [ Format fmt, Url url ] + where + path = "posts/suggest" + params = [Format fmt, Url url] -- | posts/delete : Delete an existing bookmark. -deletePostRequest - :: ResultFormatType - -> Url - -> PinboardRequest +deletePostRequest :: ResultFormatType -> Url -> PinboardRequest deletePostRequest fmt url = PinboardRequest path params - where - path = "posts/delete" + where + path = "posts/delete" params = [Format fmt, Url url] - -- | posts/add : Add or Update a bookmark addPostRequest :: ResultFormatType - -> Url -- ^ the URL of the item - -> Description -- ^ Title of the item. This field is unfortunately named 'description' for backwards compatibility with the delicious API + -> Url -- ^ the URL of the item + -> Description -- ^ Title of the item. This field is unfortunately named 'description' for backwards compatibility with the delicious API -> Maybe Extended -- ^ Description of the item. Called 'extended' for backwards compatibility with delicious API - -> Maybe [Tag] -- ^ List of up to 100 tags + -> Maybe [Tag] -- ^ List of up to 100 tags -> Maybe DateTime -- ^ creation time for this bookmark. Defaults to current time. Datestamps more than 10 minutes ahead of server time will be reset to current server time - -> Maybe Replace -- ^ Replace any existing bookmark with this URL. Default is yes. If set to no, will throw an error if bookmark exists - -> 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" + -> Maybe Replace -- ^ Replace any existing bookmark with this URL. Default is yes. If set to no, will throw an error if bookmark exists + -> 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" -> PinboardRequest -addPostRequest fmt url descr ext tags ctime repl shared toread = +addPostRequest fmt url descr ext tags ctime repl shared toread = PinboardRequest path params - where - path = "posts/add" - params = catMaybes [ Just (Format fmt) - , Just $ Url url - , Just $ Description descr - , Extended <$> ext - , Tags . unwords <$> tags - , DateTime <$> ctime - , Replace <$> repl - , Shared <$> shared - , ToRead <$> toread ] + where + path = "posts/add" + params = + catMaybes + [ Just (Format fmt) + , Just $ Url url + , Just $ Description descr + , Extended <$> ext + , Tags . unwords <$> tags + , DateTime <$> ctime + , Replace <$> repl + , Shared <$> shared + , ToRead <$> toread + ] -- | posts/add : Add or Update a bookmark (from a Post record) addPostRecRequest :: ResultFormatType - -> Post -- ^ the Post record - -> Replace -- ^ Replace any existing bookmark with the Posts URL. If set to no, will throw an error if bookmark exists + -> Post -- ^ the Post record + -> Replace -- ^ Replace any existing bookmark with the Posts URL. If set to no, will throw an error if bookmark exists -> PinboardRequest -addPostRecRequest fmt Post{..} replace = addPostRequest fmt postHref - postDescription - ( Just postExtended ) - ( Just postTags ) - ( Just postTime ) - ( Just replace ) - ( Just postShared ) - ( Just postToRead ) +addPostRecRequest fmt Post {..} replace = + addPostRequest + fmt + postHref + postDescription + (Just postExtended) + (Just postTags) + (Just postTime) + (Just replace) + (Just postShared) + (Just postToRead) -- TAGS ---------------------------------------------------------------------- - - -- | tags/get : Returns a full list of the user's tags along with the number of -- times they were used. -getTagsRequest - :: ResultFormatType - -> PinboardRequest +getTagsRequest :: ResultFormatType -> PinboardRequest getTagsRequest fmt = PinboardRequest path params - where - path = "tags/get" + where + path = "tags/get" params = [Format fmt] - -- | tags/delete : Delete an existing tag. -deleteTagRequest - :: ResultFormatType - -> Tag - -> PinboardRequest +deleteTagRequest :: ResultFormatType -> Tag -> PinboardRequest deleteTagRequest fmt tag = PinboardRequest path params - where - path = "tags/delete" + where + path = "tags/delete" params = [Format fmt, Tag tag] - -- | tags/rename : Rename an tag, or fold it in to an existing tag -renameTagRequest +renameTagRequest :: ResultFormatType -> Old -- ^ note: match is not case sensitive -> New -- ^ if empty, nothing will happen -> PinboardRequest renameTagRequest fmt old new = PinboardRequest path params - where - path = "tags/rename" + where + path = "tags/rename" params = [Format fmt, Old old, New new] - -- USER ---------------------------------------------------------------------- - -- | user/secret : Returns the user's secret RSS key (for viewing private feeds) -getUserSecretRssKeyRequest - :: ResultFormatType - -> PinboardRequest +getUserSecretRssKeyRequest :: ResultFormatType -> PinboardRequest getUserSecretRssKeyRequest fmt = PinboardRequest path params - where - path = "user/secret" + where + path = "user/secret" params = [Format fmt] -- | user/api_token : Returns the user's API token (for making API calls without a password) -getUserApiTokenRequest - :: ResultFormatType - -> PinboardRequest +getUserApiTokenRequest :: ResultFormatType -> PinboardRequest getUserApiTokenRequest fmt = PinboardRequest path params - where - path = "user/api_token" + where + path = "user/api_token" params = [Format fmt] - -- NOTES --------------------------------------------------------------------- - -- | notes/list : Returns a list of the user's notes (note text detail is not included) -getNoteListRequest - :: ResultFormatType - -> PinboardRequest +getNoteListRequest :: ResultFormatType -> PinboardRequest getNoteListRequest fmt = PinboardRequest path params - where - path = "notes/list" + where + path = "notes/list" params = [Format fmt] -- | notes/id : Returns an individual user note. The hash property is a 20 character long sha1 hash of the note text. -getNoteRequest - :: ResultFormatType - -> NoteId - -> PinboardRequest +getNoteRequest :: ResultFormatType -> NoteId -> PinboardRequest getNoteRequest fmt noteid = PinboardRequest path params - where + where path = "notes" noteid params = [Format fmt] - diff --git a/src/Pinboard/ApiTypes.hs b/src/Pinboard/ApiTypes.hs --- a/src/Pinboard/ApiTypes.hs +++ b/src/Pinboard/ApiTypes.hs @@ -11,260 +11,257 @@ -- Maintainer : jonschoning@gmail.com -- Stability : experimental -- Portability : POSIX -module Pinboard.ApiTypes where +module Pinboard.ApiTypes where -import Data.Aeson -import Data.Aeson.Types (Parser) +import Data.Aeson +import Data.Aeson.Types (Parser) import Data.HashMap.Strict (HashMap, member, toList) -import Data.Data (Data, Typeable) -import Data.Text (Text, words, unwords, unpack, pack) -import Data.Time (UTCTime, parseTimeM) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Data (Data, Typeable) +import Data.Text (Text, words, unwords, unpack, pack) +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 (formatTime, defaultTimeLocale) -import Control.Applicative -import Prelude hiding (words, unwords) - +import Data.Time.Format (formatTime, defaultTimeLocale) +import Control.Applicative +import Prelude hiding (words, unwords) -- * Posts - -data Posts = Posts { - postsDate :: !UTCTime - , postsUser :: !Text - , postsPosts :: [Post] - } deriving (Show, Eq, Data, Typeable, Generic, Ord) +data Posts = Posts + { postsDate :: !UTCTime + , postsUser :: !Text + , postsPosts :: [Post] + } deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON Posts where - parseJSON (Object o) = - Posts <$> o .: "date" - <*> o .: "user" - <*> o .: "posts" - parseJSON _ = fail "bad parse" + parseJSON (Object o) = Posts <$> o .: "date" <*> o .: "user" <*> o .: "posts" + parseJSON _ = fail "bad parse" instance ToJSON Posts where - toJSON Posts{..} = object - [ "date" .= toJSON postsDate - , "user" .= toJSON postsUser - , "posts" .= toJSON postsPosts ] + toJSON Posts {..} = + object + [ "date" .= toJSON postsDate + , "user" .= toJSON postsUser + , "posts" .= toJSON postsPosts + ] -data Post = Post { - postHref :: !Text - , postDescription :: !Text - , postExtended :: !Text - , postMeta :: !Text - , postHash :: !Text - , postTime :: !UTCTime - , postShared :: !Bool - , postToRead :: !Bool - , postTags :: [Tag] - } deriving (Show, Eq, Data, Typeable, Generic, Ord) +data Post = Post + { postHref :: !Text + , postDescription :: !Text + , postExtended :: !Text + , postMeta :: !Text + , postHash :: !Text + , postTime :: !UTCTime + , postShared :: !Bool + , postToRead :: !Bool + , postTags :: [Tag] + } deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON Post where - parseJSON (Object o) = - Post <$> o .: "href" - <*> o .: "description" - <*> o .: "extended" - <*> o .: "meta" - <*> o .: "hash" - <*> o .: "time" - <*> (boolFromYesNo <$> o .: "shared") - <*> (boolFromYesNo <$> o .: "toread") - <*> (words <$> o .: "tags") - parseJSON _ = fail "bad parse" + parseJSON (Object o) = + Post <$> o .: "href" <*> o .: "description" <*> o .: "extended" <*> + o .: "meta" <*> + o .: "hash" <*> + o .: "time" <*> + (boolFromYesNo <$> o .: "shared") <*> + (boolFromYesNo <$> o .: "toread") <*> + (words <$> o .: "tags") + parseJSON _ = fail "bad parse" instance ToJSON Post where - toJSON Post{..} = object - [ "href" .= toJSON postHref - , "description" .= toJSON postDescription - , "extended" .= toJSON postExtended - , "meta" .= toJSON postMeta - , "hash" .= toJSON postHash - , "time" .= toJSON postTime - , "shared" .= boolToYesNo postShared - , "toread" .= boolToYesNo postToRead - , "tags" .= unwords postTags ] + toJSON Post {..} = + object + [ "href" .= toJSON postHref + , "description" .= toJSON postDescription + , "extended" .= toJSON postExtended + , "meta" .= toJSON postMeta + , "hash" .= toJSON postHash + , "time" .= toJSON postTime + , "shared" .= boolToYesNo postShared + , "toread" .= boolToYesNo postToRead + , "tags" .= unwords postTags + ] boolFromYesNo :: Text -> Bool boolFromYesNo "yes" = True -boolFromYesNo _ = False +boolFromYesNo _ = False boolToYesNo :: Bool -> Text boolToYesNo True = "yes" -boolToYesNo _ = "no" +boolToYesNo _ = "no" -data PostDates = PostDates { - postDatesUser :: !Text - , postDatesTag :: !Text - , postDatesCount :: [(Day, Int)] - } deriving (Show, Eq, Data, Typeable, Generic, Ord) +data PostDates = PostDates + { postDatesUser :: !Text + , postDatesTag :: !Text + , postDatesCount :: [(Day, Int)] + } deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON PostDates where - parseJSON (Object o) = - PostDates <$> o .: "user" - <*> o .: "tag" - <*> (parseDates <$> o .: "dates") - where - parseDates :: Value -> [DateCount] - parseDates (Object o')= do - (dateStr, String countStr) <- toList o' - return (read (unpack dateStr), read (unpack countStr)) - parseDates _ = [] - parseJSON _ = fail "bad parse" + parseJSON (Object o) = + PostDates <$> o .: "user" <*> o .: "tag" <*> (parseDates <$> o .: "dates") + where + parseDates :: Value -> [DateCount] + parseDates (Object o') = do + (dateStr, String countStr) <- toList o' + return (read (unpack dateStr), read (unpack countStr)) + parseDates _ = [] + parseJSON _ = fail "bad parse" instance ToJSON PostDates where - toJSON PostDates{..} = object - [ "user" .= toJSON postDatesUser - , "tag" .= toJSON postDatesTag - , "dates" .= object (dateCountToPair <$> postDatesCount) ] - where dateCountToPair (day, count) = ((pack.show) day, String $ (pack.show) count) + toJSON PostDates {..} = + object + [ "user" .= toJSON postDatesUser + , "tag" .= toJSON postDatesTag + , "dates" .= object (dateCountToPair <$> postDatesCount) + ] + where + dateCountToPair (day, count) = + ((pack . show) day, String $ (pack . show) count) type DateCount = (Day, Int) - -- * Notes - -data NoteList = NoteList { - noteListCount :: !Int - , noteListItems :: [NoteListItem] - } deriving (Show, Eq, Data, Typeable, Generic, Ord) +data NoteList = NoteList + { noteListCount :: !Int + , noteListItems :: [NoteListItem] + } deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON NoteList where - parseJSON (Object o) = - NoteList <$> o .: "count" - <*> o .: "notes" - parseJSON _ = fail "bad parse" + parseJSON (Object o) = NoteList <$> o .: "count" <*> o .: "notes" + parseJSON _ = fail "bad parse" instance ToJSON NoteList where - toJSON NoteList{..} = object - [ "count" .= toJSON noteListCount - , "notes" .= toJSON noteListItems ] + toJSON NoteList {..} = + object ["count" .= toJSON noteListCount, "notes" .= toJSON noteListItems] -data NoteListItem = NoteListItem { - noteListItemId :: !Text - , noteListItemHash :: !Text - , noteListItemTitle :: !Text - , noteListItemLength :: !Int - , noteListItemCreatedAt :: !UTCTime - , noteListItemUpdatedAt :: !UTCTime - } deriving (Show, Eq, Data, Typeable, Generic, Ord) +data NoteListItem = NoteListItem + { noteListItemId :: !Text + , noteListItemHash :: !Text + , noteListItemTitle :: !Text + , noteListItemLength :: !Int + , noteListItemCreatedAt :: !UTCTime + , noteListItemUpdatedAt :: !UTCTime + } deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON NoteListItem where - parseJSON (Object o) = - NoteListItem <$> o .: "id" - <*> o .: "hash" - <*> o .: "title" - <*> (read <$> (o .: "length")) - <*> (readNoteTime =<< o .: "created_at") - <*> (readNoteTime =<< o .: "updated_at") - parseJSON _ = fail "bad parse" + parseJSON (Object o) = + NoteListItem <$> o .: "id" <*> o .: "hash" <*> o .: "title" <*> + (read <$> (o .: "length")) <*> + (readNoteTime =<< o .: "created_at") <*> + (readNoteTime =<< o .: "updated_at") + parseJSON _ = fail "bad parse" instance ToJSON NoteListItem where - toJSON NoteListItem{..} = object - [ "id" .= toJSON noteListItemId - , "hash" .= toJSON noteListItemHash - , "title" .= toJSON noteListItemTitle - , "length" .= toJSON (show noteListItemLength) - , "created_at" .= toJSON (showNoteTime noteListItemCreatedAt) - , "updated_at" .= toJSON (showNoteTime noteListItemUpdatedAt) ] - + toJSON NoteListItem {..} = + object + [ "id" .= toJSON noteListItemId + , "hash" .= toJSON noteListItemHash + , "title" .= toJSON noteListItemTitle + , "length" .= toJSON (show noteListItemLength) + , "created_at" .= toJSON (showNoteTime noteListItemCreatedAt) + , "updated_at" .= toJSON (showNoteTime noteListItemUpdatedAt) + ] -data Note = Note { - noteId :: !Text - , noteHash :: !Text - , noteTitle :: !Text - , noteText :: !Text - , noteLength :: !Int - , noteCreatedAt :: !UTCTime - , noteUpdatedAt :: !UTCTime - } deriving (Show, Eq, Data, Typeable, Generic, Ord) +data Note = Note + { noteId :: !Text + , noteHash :: !Text + , noteTitle :: !Text + , noteText :: !Text + , noteLength :: !Int + , noteCreatedAt :: !UTCTime + , noteUpdatedAt :: !UTCTime + } deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON Note where - parseJSON (Object o) = - Note <$> o .: "id" - <*> o .: "hash" - <*> o .: "title" - <*> o .: "text" - <*> o .: "length" - <*> (readNoteTime =<< o .: "created_at") - <*> (readNoteTime =<< o .: "updated_at") - parseJSON _ = fail "bad parse" + parseJSON (Object o) = + Note <$> o .: "id" <*> o .: "hash" <*> o .: "title" <*> o .: "text" <*> + o .: "length" <*> + (readNoteTime =<< o .: "created_at") <*> + (readNoteTime =<< o .: "updated_at") + parseJSON _ = fail "bad parse" instance ToJSON Note where - toJSON Note{..} = object - [ "id" .= toJSON noteId - , "hash" .= toJSON noteHash - , "title" .= toJSON noteTitle - , "text" .= toJSON noteText - , "length" .= toJSON noteLength - , "created_at" .= toJSON (showNoteTime noteCreatedAt) - , "updated_at" .= toJSON (showNoteTime noteUpdatedAt) ] + toJSON Note {..} = + object + [ "id" .= toJSON noteId + , "hash" .= toJSON noteHash + , "title" .= toJSON noteTitle + , "text" .= toJSON noteText + , "length" .= toJSON noteLength + , "created_at" .= toJSON (showNoteTime noteCreatedAt) + , "updated_at" .= toJSON (showNoteTime noteUpdatedAt) + ] -readNoteTime :: Monad m => String -> m UTCTime +readNoteTime + :: Monad m + => String -> m UTCTime readNoteTime = parseTimeM True defaultTimeLocale "%F %T" showNoteTime :: UTCTime -> String showNoteTime = formatTime defaultTimeLocale "%F %T" -- * Tags - type TagMap = HashMap Tag Int -newtype JsonTagMap = ToJsonTagMap {fromJsonTagMap :: TagMap} - deriving (Show, Eq, Data, Typeable, Generic) +newtype JsonTagMap = ToJsonTagMap + { fromJsonTagMap :: TagMap + } deriving (Show, Eq, Data, Typeable, Generic) instance FromJSON JsonTagMap where parseJSON = toTags - where toTags (Object o) = return . ToJsonTagMap $ HM.map (\(String s)-> read (unpack s)) o - toTags _ = fail "bad parse" + 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 - -data Suggested = Popular [Text] - | Recommended [Text] - deriving (Show, Eq, Data, Typeable, Generic, Ord) +data Suggested + = Popular [Text] + | Recommended [Text] + deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON Suggested where - parseJSON (Object o) - | member "popular" o = Popular <$> (o .: "popular") - | member "recommended" o = Recommended <$> (o .: "recommended") - | otherwise = fail "bad parse" - parseJSON _ = fail "bad parse" - + parseJSON (Object o) + | member "popular" o = Popular <$> (o .: "popular") + | member "recommended" o = Recommended <$> (o .: "recommended") + | otherwise = fail "bad parse" + parseJSON _ = fail "bad parse" instance ToJSON [Suggested] where toJSON xs = Array $ toJSON <$> V.fromList xs instance ToJSON Suggested where - toJSON (Popular tags) = object [ "popular" .= toJSON tags] - toJSON (Recommended tags) = object [ "recommended" .= toJSON tags] + toJSON (Popular tags) = object ["popular" .= toJSON tags] + toJSON (Recommended tags) = object ["recommended" .= toJSON tags] -- * Scalars - -newtype DoneResult = ToDoneResult {fromDoneResult :: ()} - deriving (Show, Eq, Data, Typeable, Generic, Ord) +newtype DoneResult = ToDoneResult + { fromDoneResult :: () + } deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON DoneResult where parseJSON (Object o) = parseDone =<< (o .: "result" <|> o .: "result_code") where parseDone :: Text -> Parser DoneResult parseDone "done" = return $ ToDoneResult () - parseDone msg = ( fail . unpack ) msg + parseDone msg = (fail . unpack) msg parseJSON _ = fail "bad parse" -newtype TextResult = ToTextResult {fromTextResult :: Text} - deriving (Show, Eq, Data, Typeable, Generic, Ord) +newtype TextResult = ToTextResult + { fromTextResult :: Text + } deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON TextResult where parseJSON (Object o) = ToTextResult <$> (o .: "result") parseJSON _ = fail "bad parse" -newtype UpdateTime = ToUpdateTime {fromUpdateTime :: UTCTime} - deriving (Show, Eq, Data, Typeable, Generic, Ord) +newtype UpdateTime = ToUpdateTime + { fromUpdateTime :: UTCTime + } deriving (Show, Eq, Data, Typeable, Generic, Ord) instance FromJSON UpdateTime where parseJSON (Object o) = ToUpdateTime <$> (o .: "update_time") @@ -274,32 +271,35 @@ -- prettyString s = case parseExp s of -- ParseOk x -> prettyPrint x -- ParseFailed{} -> s - -- pretty :: Show a => a -> String -- pretty = prettyString . show - -- * Aliases - -- | as defined by RFC 3986. Allowed schemes are http, https, javascript, mailto, ftp and file. The Safari-specific feed scheme is allowed but will be treated as a synonym for http. type Url = Text -- | up to 255 characters long -type Description = Text +type Description = Text -- | up to 65536 characters long. Any URLs will be auto-linkified when displayed. type Extended = Text -- | up to 255 characters. May not contain commas or whitespace. -type Tag = Text +type Tag = Text + type Old = Tag + type New = Tag type Count = Int + type NumResults = Int + type StartOffset = Int type Shared = Bool + type Replace = Bool + type ToRead = Bool -- | UTC date in this format: 2010-12-11. Same range as datetime above @@ -307,10 +307,11 @@ -- | UTC timestamp in this format: 2010-12-11T19:48:02Z. Valid date range is Jan 1, 1 AD to January 1, 2100 (but see note below about future timestamps). type DateTime = UTCTime + type FromDateTime = DateTime + type ToDateTime = DateTime type Meta = Int type NoteId = Text - diff --git a/src/Pinboard/ApiTypesLens.hs b/src/Pinboard/ApiTypesLens.hs --- a/src/Pinboard/ApiTypesLens.hs +++ b/src/Pinboard/ApiTypesLens.hs @@ -5,450 +5,286 @@ import Pinboard.ApiTypes -import Data.Text (Text) -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) -import Control.Applicative -import Data.Profunctor -import Data.Either -import Prelude hiding (words, unwords) +import Control.Applicative +import Data.Profunctor +import Data.Either +import Prelude hiding (words, unwords) -- * Lens Aliases - type Lens_' s a = Lens_ s s a a -type Lens_ s t a b = forall (f :: * -> *). Functor f => (a -> f b) -> s -> f t +type Lens_ s t a b = forall (f :: * -> *). Functor f => + (a -> f b) -> s -> f t + type Prism_' s a = Prism_ s s a a -type Prism_ s t a b = forall (p :: * -> * -> *) (f :: * -> *). (Choice p, Applicative f) => p a (f b) -> p s (f t) --- * Posts +type Prism_ s t a b = forall (p :: * -> * -> *) (f :: * -> *). (Choice p + ,Applicative f) => + p a (f b) -> p s (f t) +-- * Posts postsDateL :: Lens_' Posts UTCTime -postsDateL f_acx6 (Posts x1_acx7 x2_acx8 x3_acx9) - = fmap - (\ y1_acxa -> Posts y1_acxa x2_acx8 x3_acx9) (f_acx6 x1_acx7) +postsDateL f_acx6 (Posts x1_acx7 x2_acx8 x3_acx9) = + fmap (\y1_acxa -> Posts y1_acxa x2_acx8 x3_acx9) (f_acx6 x1_acx7) + {-# INLINE postsDateL #-} + postsPostsL :: Lens_' Posts [Post] -postsPostsL f_acxb (Posts x1_acxc x2_acxd x3_acxe) - = fmap - (\ y1_acxf -> Posts x1_acxc x2_acxd y1_acxf) (f_acxb x3_acxe) +postsPostsL f_acxb (Posts x1_acxc x2_acxd x3_acxe) = + fmap (\y1_acxf -> Posts x1_acxc x2_acxd y1_acxf) (f_acxb x3_acxe) + {-# INLINE postsPostsL #-} + postsUserL :: Lens_' Posts Text -postsUserL f_acxg (Posts x1_acxh x2_acxi x3_acxj) - = fmap - (\ y1_acxk -> Posts x1_acxh y1_acxk x3_acxj) (f_acxg x2_acxi) -{-# INLINE postsUserL #-} +postsUserL f_acxg (Posts x1_acxh x2_acxi x3_acxj) = + fmap (\y1_acxk -> Posts x1_acxh y1_acxk x3_acxj) (f_acxg x2_acxi) +{-# INLINE postsUserL #-} -- * Post - postDescriptionL :: Lens_' Post Text -postDescriptionL - f_aczI - (Post x1_aczJ - x2_aczK - x3_aczL - x4_aczM - x5_aczN - x6_aczO - x7_aczP - x8_aczQ - x9_aczR) - = fmap - (\ y1_aczS - -> Post - x1_aczJ - y1_aczS - x3_aczL - x4_aczM - x5_aczN - x6_aczO - x7_aczP - x8_aczQ - x9_aczR) - (f_aczI x2_aczK) +postDescriptionL f_aczI (Post x1_aczJ x2_aczK x3_aczL x4_aczM x5_aczN x6_aczO x7_aczP x8_aczQ x9_aczR) = + fmap + (\y1_aczS -> + Post x1_aczJ y1_aczS x3_aczL x4_aczM x5_aczN x6_aczO x7_aczP x8_aczQ x9_aczR) + (f_aczI x2_aczK) + {-# INLINE postDescriptionL #-} + postExtendedL :: Lens_' Post Text -postExtendedL - f_aczT - (Post x1_aczU - x2_aczV - x3_aczW - x4_aczX - x5_aczY - x6_aczZ - x7_acA0 - x8_acA1 - x9_acA2) - = fmap - (\ y1_acA3 - -> Post - x1_aczU - x2_aczV - y1_acA3 - x4_aczX - x5_aczY - x6_aczZ - x7_acA0 - x8_acA1 - x9_acA2) - (f_aczT x3_aczW) +postExtendedL f_aczT (Post x1_aczU x2_aczV x3_aczW x4_aczX x5_aczY x6_aczZ x7_acA0 x8_acA1 x9_acA2) = + fmap + (\y1_acA3 -> + Post x1_aczU x2_aczV y1_acA3 x4_aczX x5_aczY x6_aczZ x7_acA0 x8_acA1 x9_acA2) + (f_aczT x3_aczW) + {-# INLINE postExtendedL #-} + postHashL :: Lens_' Post Text -postHashL - f_acA4 - (Post x1_acA5 - x2_acA6 - x3_acA7 - x4_acA8 - x5_acA9 - x6_acAa - x7_acAb - x8_acAc - x9_acAd) - = fmap - (\ y1_acAe - -> Post - x1_acA5 - x2_acA6 - x3_acA7 - x4_acA8 - y1_acAe - x6_acAa - x7_acAb - x8_acAc - x9_acAd) - (f_acA4 x5_acA9) +postHashL f_acA4 (Post x1_acA5 x2_acA6 x3_acA7 x4_acA8 x5_acA9 x6_acAa x7_acAb x8_acAc x9_acAd) = + fmap + (\y1_acAe -> + Post x1_acA5 x2_acA6 x3_acA7 x4_acA8 y1_acAe x6_acAa x7_acAb x8_acAc x9_acAd) + (f_acA4 x5_acA9) + {-# INLINE postHashL #-} + postHrefL :: Lens_' Post Text -postHrefL - f_acAf - (Post x1_acAg - x2_acAh - x3_acAi - x4_acAj - x5_acAk - x6_acAl - x7_acAm - x8_acAn - x9_acAo) - = fmap - (\ y1_acAp - -> Post - y1_acAp - x2_acAh - x3_acAi - x4_acAj - x5_acAk - x6_acAl - x7_acAm - x8_acAn - x9_acAo) - (f_acAf x1_acAg) +postHrefL f_acAf (Post x1_acAg x2_acAh x3_acAi x4_acAj x5_acAk x6_acAl x7_acAm x8_acAn x9_acAo) = + fmap + (\y1_acAp -> + Post y1_acAp x2_acAh x3_acAi x4_acAj x5_acAk x6_acAl x7_acAm x8_acAn x9_acAo) + (f_acAf x1_acAg) + {-# INLINE postHrefL #-} + postMetaL :: Lens_' Post Text -postMetaL - f_acAq - (Post x1_acAr - x2_acAs - x3_acAt - x4_acAu - x5_acAv - x6_acAw - x7_acAx - x8_acAy - x9_acAz) - = fmap - (\ y1_acAA - -> Post - x1_acAr - x2_acAs - x3_acAt - y1_acAA - x5_acAv - x6_acAw - x7_acAx - x8_acAy - x9_acAz) - (f_acAq x4_acAu) +postMetaL f_acAq (Post x1_acAr x2_acAs x3_acAt x4_acAu x5_acAv x6_acAw x7_acAx x8_acAy x9_acAz) = + fmap + (\y1_acAA -> + Post x1_acAr x2_acAs x3_acAt y1_acAA x5_acAv x6_acAw x7_acAx x8_acAy x9_acAz) + (f_acAq x4_acAu) + {-# INLINE postMetaL #-} + postSharedL :: Lens_' Post Bool -postSharedL - f_acAB - (Post x1_acAC - x2_acAD - x3_acAE - x4_acAF - x5_acAG - x6_acAH - x7_acAI - x8_acAJ - x9_acAK) - = fmap - (\ y1_acAL - -> Post - x1_acAC - x2_acAD - x3_acAE - x4_acAF - x5_acAG - x6_acAH - y1_acAL - x8_acAJ - x9_acAK) - (f_acAB x7_acAI) +postSharedL f_acAB (Post x1_acAC x2_acAD x3_acAE x4_acAF x5_acAG x6_acAH x7_acAI x8_acAJ x9_acAK) = + fmap + (\y1_acAL -> + Post x1_acAC x2_acAD x3_acAE x4_acAF x5_acAG x6_acAH y1_acAL x8_acAJ x9_acAK) + (f_acAB x7_acAI) + {-# INLINE postSharedL #-} + postTagsL :: Lens_' Post [Tag] -postTagsL - f_acAM - (Post x1_acAN - x2_acAO - x3_acAP - x4_acAQ - x5_acAR - x6_acAS - x7_acAT - x8_acAU - x9_acAV) - = fmap - (\ y1_acAW - -> Post - x1_acAN - x2_acAO - x3_acAP - x4_acAQ - x5_acAR - x6_acAS - x7_acAT - x8_acAU - y1_acAW) - (f_acAM x9_acAV) +postTagsL f_acAM (Post x1_acAN x2_acAO x3_acAP x4_acAQ x5_acAR x6_acAS x7_acAT x8_acAU x9_acAV) = + fmap + (\y1_acAW -> + Post x1_acAN x2_acAO x3_acAP x4_acAQ x5_acAR x6_acAS x7_acAT x8_acAU y1_acAW) + (f_acAM x9_acAV) + {-# INLINE postTagsL #-} + postTimeL :: Lens_' Post UTCTime -postTimeL - f_acAX - (Post x1_acAY - x2_acAZ - x3_acB0 - x4_acB1 - x5_acB2 - x6_acB3 - x7_acB4 - x8_acB5 - x9_acB6) - = fmap - (\ y1_acB7 - -> Post - x1_acAY - x2_acAZ - x3_acB0 - x4_acB1 - x5_acB2 - y1_acB7 - x7_acB4 - x8_acB5 - x9_acB6) - (f_acAX x6_acB3) +postTimeL f_acAX (Post x1_acAY x2_acAZ x3_acB0 x4_acB1 x5_acB2 x6_acB3 x7_acB4 x8_acB5 x9_acB6) = + fmap + (\y1_acB7 -> + Post x1_acAY x2_acAZ x3_acB0 x4_acB1 x5_acB2 y1_acB7 x7_acB4 x8_acB5 x9_acB6) + (f_acAX x6_acB3) + {-# INLINE postTimeL #-} + postToReadL :: Lens_' Post Bool -postToReadL - f_acB8 - (Post x1_acB9 - x2_acBa - x3_acBb - x4_acBc - x5_acBd - x6_acBe - x7_acBf - x8_acBg - x9_acBh) - = fmap - (\ y1_acBi - -> Post - x1_acB9 - x2_acBa - x3_acBb - x4_acBc - x5_acBd - x6_acBe - x7_acBf - y1_acBi - x9_acBh) - (f_acB8 x8_acBg) +postToReadL f_acB8 (Post x1_acB9 x2_acBa x3_acBb x4_acBc x5_acBd x6_acBe x7_acBf x8_acBg x9_acBh) = + fmap + (\y1_acBi -> + Post x1_acB9 x2_acBa x3_acBb x4_acBc x5_acBd x6_acBe x7_acBf y1_acBi x9_acBh) + (f_acB8 x8_acBg) + {-# INLINE postToReadL #-} -- * PostDates - postDatesCountL :: Lens_' PostDates [(Day, Int)] -postDatesCountL f_a1M4D (PostDates x1_a1M4E x2_a1M4F x3_a1M4G) - = fmap - (\ y1_a1M4H -> PostDates x1_a1M4E x2_a1M4F y1_a1M4H) - (f_a1M4D x3_a1M4G) +postDatesCountL f_a1M4D (PostDates x1_a1M4E x2_a1M4F x3_a1M4G) = + fmap (\y1_a1M4H -> PostDates x1_a1M4E x2_a1M4F y1_a1M4H) (f_a1M4D x3_a1M4G) + {-# INLINE postDatesCountL #-} + postDatesTagL :: Lens_' PostDates Text -postDatesTagL f_a1M4I (PostDates x1_a1M4J x2_a1M4K x3_a1M4L) - = fmap - (\ y1_a1M4M -> PostDates x1_a1M4J y1_a1M4M x3_a1M4L) - (f_a1M4I x2_a1M4K) +postDatesTagL f_a1M4I (PostDates x1_a1M4J x2_a1M4K x3_a1M4L) = + fmap (\y1_a1M4M -> PostDates x1_a1M4J y1_a1M4M x3_a1M4L) (f_a1M4I x2_a1M4K) + {-# INLINE postDatesTagL #-} + postDatesUserL :: Lens_' PostDates Text -postDatesUserL f_a1M4N (PostDates x1_a1M4O x2_a1M4P x3_a1M4Q) - = fmap - (\ y1_a1M4R -> PostDates y1_a1M4R x2_a1M4P x3_a1M4Q) - (f_a1M4N x1_a1M4O) +postDatesUserL f_a1M4N (PostDates x1_a1M4O x2_a1M4P x3_a1M4Q) = + fmap (\y1_a1M4R -> PostDates y1_a1M4R x2_a1M4P x3_a1M4Q) (f_a1M4N x1_a1M4O) + {-# INLINE postDatesUserL #-} -- * NoteList - noteListCountL :: Lens_' NoteList Int -noteListCountL f_acwZ (NoteList x1_acx0 x2_acx1) - = fmap (\ y1_acx2 -> NoteList y1_acx2 x2_acx1) (f_acwZ x1_acx0) +noteListCountL f_acwZ (NoteList x1_acx0 x2_acx1) = + fmap (\y1_acx2 -> NoteList y1_acx2 x2_acx1) (f_acwZ x1_acx0) + {-# INLINE noteListCountL #-} + noteListItemsL :: Lens_' NoteList [NoteListItem] -noteListItemsL f_acx3 (NoteList x1_acx4 x2_acx5) - = fmap (\ y1_acx6 -> NoteList x1_acx4 y1_acx6) (f_acx3 x2_acx5) -{-# INLINE noteListItemsL #-} +noteListItemsL f_acx3 (NoteList x1_acx4 x2_acx5) = + fmap (\y1_acx6 -> NoteList x1_acx4 y1_acx6) (f_acx3 x2_acx5) +{-# INLINE noteListItemsL #-} -- * NoteListItem - - noteListItemCreatedAtL :: Lens_' NoteListItem UTCTime -noteListItemCreatedAtL - f_acx0 - (NoteListItem x1_acx1 x2_acx2 x3_acx3 x4_acx4 x5_acx5 x6_acx6) - = fmap - (\ y1_acx7 - -> NoteListItem x1_acx1 x2_acx2 x3_acx3 x4_acx4 y1_acx7 x6_acx6) - (f_acx0 x5_acx5) +noteListItemCreatedAtL f_acx0 (NoteListItem x1_acx1 x2_acx2 x3_acx3 x4_acx4 x5_acx5 x6_acx6) = + fmap + (\y1_acx7 -> NoteListItem x1_acx1 x2_acx2 x3_acx3 x4_acx4 y1_acx7 x6_acx6) + (f_acx0 x5_acx5) + {-# INLINE noteListItemCreatedAtL #-} + noteListItemHashL :: Lens_' NoteListItem Text -noteListItemHashL - f_acx8 - (NoteListItem x1_acx9 x2_acxa x3_acxb x4_acxc x5_acxd x6_acxe) - = fmap - (\ y1_acxf - -> NoteListItem x1_acx9 y1_acxf x3_acxb x4_acxc x5_acxd x6_acxe) - (f_acx8 x2_acxa) +noteListItemHashL f_acx8 (NoteListItem x1_acx9 x2_acxa x3_acxb x4_acxc x5_acxd x6_acxe) = + fmap + (\y1_acxf -> NoteListItem x1_acx9 y1_acxf x3_acxb x4_acxc x5_acxd x6_acxe) + (f_acx8 x2_acxa) + {-# INLINE noteListItemHashL #-} + noteListItemIdL :: Lens_' NoteListItem Text -noteListItemIdL - f_acxg - (NoteListItem x1_acxh x2_acxi x3_acxj x4_acxk x5_acxl x6_acxm) - = fmap - (\ y1_acxn - -> NoteListItem y1_acxn x2_acxi x3_acxj x4_acxk x5_acxl x6_acxm) - (f_acxg x1_acxh) +noteListItemIdL f_acxg (NoteListItem x1_acxh x2_acxi x3_acxj x4_acxk x5_acxl x6_acxm) = + fmap + (\y1_acxn -> NoteListItem y1_acxn x2_acxi x3_acxj x4_acxk x5_acxl x6_acxm) + (f_acxg x1_acxh) + {-# INLINE noteListItemIdL #-} + noteListItemLengthL :: Lens_' NoteListItem Int -noteListItemLengthL - f_acxo - (NoteListItem x1_acxp x2_acxq x3_acxr x4_acxs x5_acxt x6_acxu) - = fmap - (\ y1_acxv - -> NoteListItem x1_acxp x2_acxq x3_acxr y1_acxv x5_acxt x6_acxu) - (f_acxo x4_acxs) +noteListItemLengthL f_acxo (NoteListItem x1_acxp x2_acxq x3_acxr x4_acxs x5_acxt x6_acxu) = + fmap + (\y1_acxv -> NoteListItem x1_acxp x2_acxq x3_acxr y1_acxv x5_acxt x6_acxu) + (f_acxo x4_acxs) + {-# INLINE noteListItemLengthL #-} + noteListItemTitleL :: Lens_' NoteListItem Text -noteListItemTitleL - f_acxw - (NoteListItem x1_acxx x2_acxy x3_acxz x4_acxA x5_acxB x6_acxC) - = fmap - (\ y1_acxD - -> NoteListItem x1_acxx x2_acxy y1_acxD x4_acxA x5_acxB x6_acxC) - (f_acxw x3_acxz) +noteListItemTitleL f_acxw (NoteListItem x1_acxx x2_acxy x3_acxz x4_acxA x5_acxB x6_acxC) = + fmap + (\y1_acxD -> NoteListItem x1_acxx x2_acxy y1_acxD x4_acxA x5_acxB x6_acxC) + (f_acxw x3_acxz) + {-# INLINE noteListItemTitleL #-} + noteListItemUpdatedAtL :: Lens_' NoteListItem UTCTime -noteListItemUpdatedAtL - f_acxE - (NoteListItem x1_acxF x2_acxG x3_acxH x4_acxI x5_acxJ x6_acxK) - = fmap - (\ y1_acxL - -> NoteListItem x1_acxF x2_acxG x3_acxH x4_acxI x5_acxJ y1_acxL) - (f_acxE x6_acxK) +noteListItemUpdatedAtL f_acxE (NoteListItem x1_acxF x2_acxG x3_acxH x4_acxI x5_acxJ x6_acxK) = + fmap + (\y1_acxL -> NoteListItem x1_acxF x2_acxG x3_acxH x4_acxI x5_acxJ y1_acxL) + (f_acxE x6_acxK) + {-# INLINE noteListItemUpdatedAtL #-} noteCreatedAtL :: Lens_' Note UTCTime -noteCreatedAtL - f_acx6 - (Note x1_acx7 x2_acx8 x3_acx9 x4_acxa x5_acxb x6_acxc x7_acxd) - = fmap - (\ y1_acxe - -> Note x1_acx7 x2_acx8 x3_acx9 x4_acxa x5_acxb y1_acxe x7_acxd) - (f_acx6 x6_acxc) +noteCreatedAtL f_acx6 (Note x1_acx7 x2_acx8 x3_acx9 x4_acxa x5_acxb x6_acxc x7_acxd) = + fmap + (\y1_acxe -> Note x1_acx7 x2_acx8 x3_acx9 x4_acxa x5_acxb y1_acxe x7_acxd) + (f_acx6 x6_acxc) + {-# INLINE noteCreatedAtL #-} + noteHashL :: Lens_' Note Text -noteHashL - f_acxf - (Note x1_acxg x2_acxh x3_acxi x4_acxj x5_acxk x6_acxl x7_acxm) - = fmap - (\ y1_acxn - -> Note x1_acxg y1_acxn x3_acxi x4_acxj x5_acxk x6_acxl x7_acxm) - (f_acxf x2_acxh) +noteHashL f_acxf (Note x1_acxg x2_acxh x3_acxi x4_acxj x5_acxk x6_acxl x7_acxm) = + fmap + (\y1_acxn -> Note x1_acxg y1_acxn x3_acxi x4_acxj x5_acxk x6_acxl x7_acxm) + (f_acxf x2_acxh) + {-# INLINE noteHashL #-} + noteIdL :: Lens_' Note Text -noteIdL - f_acxo - (Note x1_acxp x2_acxq x3_acxr x4_acxs x5_acxt x6_acxu x7_acxv) - = fmap - (\ y1_acxw - -> Note y1_acxw x2_acxq x3_acxr x4_acxs x5_acxt x6_acxu x7_acxv) - (f_acxo x1_acxp) +noteIdL f_acxo (Note x1_acxp x2_acxq x3_acxr x4_acxs x5_acxt x6_acxu x7_acxv) = + fmap + (\y1_acxw -> Note y1_acxw x2_acxq x3_acxr x4_acxs x5_acxt x6_acxu x7_acxv) + (f_acxo x1_acxp) + {-# INLINE noteIdL #-} + noteLengthL :: Lens_' Note Int -noteLengthL - f_acxx - (Note x1_acxy x2_acxz x3_acxA x4_acxB x5_acxC x6_acxD x7_acxE) - = fmap - (\ y1_acxF - -> Note x1_acxy x2_acxz x3_acxA x4_acxB y1_acxF x6_acxD x7_acxE) - (f_acxx x5_acxC) +noteLengthL f_acxx (Note x1_acxy x2_acxz x3_acxA x4_acxB x5_acxC x6_acxD x7_acxE) = + fmap + (\y1_acxF -> Note x1_acxy x2_acxz x3_acxA x4_acxB y1_acxF x6_acxD x7_acxE) + (f_acxx x5_acxC) + {-# INLINE noteLengthL #-} + noteTextL :: Lens_' Note Text -noteTextL - f_acxG - (Note x1_acxH x2_acxI x3_acxJ x4_acxK x5_acxL x6_acxM x7_acxN) - = fmap - (\ y1_acxO - -> Note x1_acxH x2_acxI x3_acxJ y1_acxO x5_acxL x6_acxM x7_acxN) - (f_acxG x4_acxK) +noteTextL f_acxG (Note x1_acxH x2_acxI x3_acxJ x4_acxK x5_acxL x6_acxM x7_acxN) = + fmap + (\y1_acxO -> Note x1_acxH x2_acxI x3_acxJ y1_acxO x5_acxL x6_acxM x7_acxN) + (f_acxG x4_acxK) + {-# INLINE noteTextL #-} + noteTitleL :: Lens_' Note Text -noteTitleL - f_acxP - (Note x1_acxQ x2_acxR x3_acxS x4_acxT x5_acxU x6_acxV x7_acxW) - = fmap - (\ y1_acxX - -> Note x1_acxQ x2_acxR y1_acxX x4_acxT x5_acxU x6_acxV x7_acxW) - (f_acxP x3_acxS) +noteTitleL f_acxP (Note x1_acxQ x2_acxR x3_acxS x4_acxT x5_acxU x6_acxV x7_acxW) = + fmap + (\y1_acxX -> Note x1_acxQ x2_acxR y1_acxX x4_acxT x5_acxU x6_acxV x7_acxW) + (f_acxP x3_acxS) + {-# INLINE noteTitleL #-} + noteUpdatedAtL :: Lens_' Note UTCTime -noteUpdatedAtL - f_acxY - (Note x1_acxZ x2_acy0 x3_acy1 x4_acy2 x5_acy3 x6_acy4 x7_acy5) - = fmap - (\ y1_acy6 - -> Note x1_acxZ x2_acy0 x3_acy1 x4_acy2 x5_acy3 x6_acy4 y1_acy6) - (f_acxY x7_acy5) +noteUpdatedAtL f_acxY (Note x1_acxZ x2_acy0 x3_acy1 x4_acy2 x5_acy3 x6_acy4 x7_acy5) = + fmap + (\y1_acy6 -> Note x1_acxZ x2_acy0 x3_acy1 x4_acy2 x5_acy3 x6_acy4 y1_acy6) + (f_acxY x7_acy5) + {-# INLINE noteUpdatedAtL #-} -- * Suggested (Prism) - popularP :: Prism_' Suggested [Text] -popularP - = dimap (\ x_acHs -> case x_acHs of - (Popular y1_acHt) -> Right y1_acHt - _ -> Left x_acHs) - (either pure (fmap Popular)) . right' +popularP = + dimap + (\x_acHs -> + case x_acHs of + (Popular y1_acHt) -> Right y1_acHt + _ -> Left x_acHs) + (either pure (fmap Popular)) . + right' + {-# INLINE popularP #-} - recommendedP :: Prism_' Suggested [Text] -recommendedP - = dimap (\ x_acHv -> case x_acHv of - (Recommended y1_acHw) -> Right y1_acHw - _ -> Left x_acHv) - (either pure (fmap Recommended)) . right' -{-# INLINE recommendedP #-} +recommendedP = + dimap + (\x_acHv -> + case x_acHv of + (Recommended y1_acHw) -> Right y1_acHw + _ -> Left x_acHv) + (either pure (fmap Recommended)) . + right' +{-# INLINE recommendedP #-} diff --git a/src/Pinboard/Client.hs b/src/Pinboard/Client.hs --- a/src/Pinboard/Client.hs +++ b/src/Pinboard/Client.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} @@ -14,39 +14,37 @@ -- Stability : experimental -- Portability : POSIX ------------------------------------------------------------------------------ - module Pinboard.Client - ( - -- * Config - fromApiToken - -- | The PinboardConfig provides authentication via apiToken - , PinboardConfig (..) - -- * Monadic - , runPinboard - , pinboardJson - -- * Single - , runPinboardSingleRaw - , runPinboardSingleRawBS - , runPinboardSingleJson - -- * Sending - , sendPinboardRequest - -- * Manager (http-client) - , newMgr - , mgrFail - -- * JSON Handling - ,parseJSONResponse - ,decodeJSONResponse - -- * Status Codes - ,checkStatusCodeResponse - ,checkStatusCode - -- * Error Helpers - ,addErrMsg - ,createParserErr - ,httpStatusPinboardError - -- * Client Dependencies - , module X - ) where - + ( -- * Config + fromApiToken + , defaultPinboardConfig + -- | The PinboardConfig provides authentication via apiToken + , PinboardConfig(..) + -- * Monadic + , runPinboard + , pinboardJson + -- * Single + , runPinboardSingleRaw + , runPinboardSingleRawBS + , runPinboardSingleJson + -- * Sending + , sendPinboardRequest + -- * Manager (http-client) + , newMgr + , mgrFail + -- * JSON Handling + , parseJSONResponse + , decodeJSONResponse + -- * Status Codes + , checkStatusCodeResponse + , checkStatusCode + -- * Error Helpers + , addErrMsg + , createParserErr + , httpStatusPinboardError + -- * Client Dependencies + , module X + ) where import Control.Monad.IO.Class import Control.Monad.Reader @@ -54,163 +52,194 @@ import Control.Exception.Safe import Control.Monad.Error.Class (throwError) -import Data.ByteString.Char8 (pack) -import Data.Monoid ((<>)) -import Data.Aeson (FromJSON, eitherDecodeStrict') - +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 (withSocketsDo) +import Network.HTTP.Types (urlEncode) +import Network.HTTP.Types.Status (statusCode) -import Network.HTTP.Client -import Network.HTTP.Client.TLS +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Control.Concurrent (threadDelay) +import Control.Monad.Logger import Pinboard.Types as X import Pinboard.Error as X import Pinboard.Util as X +import Pinboard.Logging as X -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +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 - -- | Create a default PinboardConfig using the supplied apiToken fromApiToken :: String -> PinboardConfig -fromApiToken token = PinboardConfig { apiToken = pack token } +fromApiToken token = + defaultPinboardConfig + { apiToken = pack token + } +defaultPinboardConfig :: PinboardConfig +defaultPinboardConfig = + PinboardConfig + { apiToken = mempty + , requestDelayMills = 0 + , execLoggingT = runNullLoggingT + , filterLoggingT = infoLevelFilter + } + -------------------------------------------------------------------------------- -- | Execute computations in the Pinboard monad runPinboard - :: (MonadIO m, MonadCatch m, MonadErrorPinboard e) - => PinboardConfig - -> PinboardT m a - -> m (e a) + :: (MonadIO m, MonadCatch m, MonadErrorPinboard e) + => PinboardConfig -> PinboardT m a -> m (e a) runPinboard config f = do mgr <- liftIO newMgr eitherToMonadError <$> runPinboardT (config, mgr) f - -- | Create a Pinboard value from a PinboardRequest w/ json deserialization -pinboardJson - :: (MonadPinboard m, FromJSON a) - => PinboardRequest - -> m a -pinboardJson req = do - env <- ask - res <- liftIO $ sendPinboardRequest env (ensureResultFormatType FormatJson req) - eitherToMonadThrow (parseJSONResponse res) +pinboardJson + :: (MonadPinboard m, FromJSON a) + => PinboardRequest -> m a +pinboardJson req = + logOnException logSrc $ + do logNST LevelInfo logSrc (toText req) + env <- ask + res <- + liftIO $ sendPinboardRequest env (ensureResultFormatType FormatJson req) + logNST LevelDebug logSrc (toText res) + eitherToMonadThrow (parseJSONResponse res) + where + logSrc = "pinboardJson" -------------------------------------------------------------------------------- - -runPinboardSingleRaw - :: PinboardConfig - -> PinboardRequest - -> IO (Response LBS.ByteString) -runPinboardSingleRaw config req = liftIO $ newMgr >>= go - where go mgr = sendPinboardRequest (config, mgr) req +runPinboardSingleRaw :: PinboardConfig + -> PinboardRequest + -> IO (Response LBS.ByteString) +runPinboardSingleRaw config req = + runLogOnException logSrc config $ + do mgr <- liftIO newMgr + logNST LevelInfo logSrc (toText req) + res <- liftIO $ sendPinboardRequest (config, mgr) req + logNST LevelDebug logSrc (toText res) + return res + where + logSrc = "runPinboardSingleRaw" runPinboardSingleRawBS - :: (MonadErrorPinboard e) - => PinboardConfig - -> PinboardRequest - -> IO (e LBS.ByteString) + :: (MonadErrorPinboard e) + => PinboardConfig -> PinboardRequest -> IO (e LBS.ByteString) runPinboardSingleRawBS config req = do res <- runPinboardSingleRaw config req - return $ responseBody res <$ checkStatusCodeResponse res + case checkStatusCodeResponse res of + Left e -> + runConfigLoggingT + config + (do logNST LevelError logSrc (toText e) + return (throwError e)) + Right _ -> return (return (responseBody res)) + where + logSrc = "runPinboardSingleRawBS" runPinboardSingleJson - :: (MonadErrorPinboard e, FromJSON a) - => PinboardConfig - -> PinboardRequest - -> IO (e a) + :: (MonadErrorPinboard e, FromJSON a) + => PinboardConfig -> PinboardRequest -> IO (e a) runPinboardSingleJson config = runPinboard config . pinboardJson - -------------------------------------------------------------------------------- - -sendPinboardRequest - :: PinboardEnv - -> PinboardRequest - -> IO (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 - httpLbs req mgr +sendPinboardRequest :: PinboardEnv + -> PinboardRequest + -> IO (Response LBS.ByteString) +sendPinboardRequest (PinboardConfig {..}, mgr) PinboardRequest {..} = do + let encodedParams = ("auth_token", urlEncode False apiToken) : encodeParams requestParams + paramsText = T.decodeUtf8 (paramsToByteString encodedParams) + url = T.unpack $ T.concat [requestPath, "?", paramsText] + when (requestDelayMills > 0) $ threadDelay (requestDelayMills * 1000) + req <- buildReq url + httpLbs req mgr -------------------------------------------------------------------------------- - buildReq :: String -> IO Request buildReq url = do req <- parseRequest $ "https://api.pinboard.in/v1/" <> url - return $ setRequestIgnoreStatus $ req { - requestHeaders = [("User-Agent","pinboard.hs/0.9.10")] + return $ + setRequestIgnoreStatus $ + req + { requestHeaders = [("User-Agent", "pinboard.hs/0.9.11")] } -------------------------------------------------------------------------------- - parseJSONResponse - :: (MonadErrorPinboard e, FromJSON a) - => Response LBS.ByteString - -> e a -parseJSONResponse response = - either (throwError . addErrMsg (toText (responseBody response))) - (const $ decodeJSONResponse (responseBody response)) - (checkStatusCodeResponse response) - - - + :: (MonadErrorPinboard e, FromJSON a) + => Response LBS.ByteString -> e a +parseJSONResponse response = + either + (throwError . addErrMsg (toText (responseBody response))) + (const $ decodeJSONResponse (responseBody response)) + (checkStatusCodeResponse response) decodeJSONResponse - :: (MonadErrorPinboard e, FromJSON a) - => LBS.ByteString - -> e a -decodeJSONResponse s = - let r = eitherDecodeStrict' (LBS.toStrict s) + :: (MonadErrorPinboard e, FromJSON a) + => LBS.ByteString -> e a +decodeJSONResponse s = + let r = eitherDecodeStrict' (LBS.toStrict s) in either (throwError . createParserErr . T.pack) return r -------------------------------------------------------------------------------- - -checkStatusCodeResponse :: MonadErrorPinboard e => Response a -> e () +checkStatusCodeResponse + :: MonadErrorPinboard e + => Response a -> e () checkStatusCodeResponse = checkStatusCode . statusCode . responseStatus -checkStatusCode :: MonadErrorPinboard e => Int -> e () -checkStatusCode = \case - 200 -> return () - 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 +checkStatusCode + :: MonadErrorPinboard e + => Int -> e () +checkStatusCode = + \case + 200 -> return () + 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 :: MonadErrorPinboard e => PinboardErrorHTTPCode -> e a -httpStatusPinboardError err = throwError defaultPinboardError - { errorType = HttpStatusFailure - , errorHTTP = Just err } +httpStatusPinboardError + :: MonadErrorPinboard e + => PinboardErrorHTTPCode -> e a +httpStatusPinboardError err = + throwError + defaultPinboardError + { errorType = HttpStatusFailure + , errorHTTP = Just err + } addErrMsg :: T.Text -> PinboardError -> PinboardError -addErrMsg msg err = err {errorMsg = msg} +addErrMsg msg err = + err + { errorMsg = msg + } createParserErr :: T.Text -> PinboardError -createParserErr msg = PinboardError ParseFailure msg Nothing Nothing Nothing +createParserErr msg = PinboardError ParseFailure msg Nothing Nothing Nothing -------------------------------------------------------------------------------- - - newMgr :: IO Manager -newMgr = withSocketsDo . newManager - $ managerSetProxy (proxyEnvironment Nothing) tlsManagerSettings +newMgr = + withSocketsDo . newManager $ managerSetProxy (proxyEnvironment Nothing) tlsManagerSettings -mgrFail :: (Monad m, MonadErrorPinboard e) => PinboardErrorType -> SomeException -> m (e b) -mgrFail e msg = return $ throwError $ 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 @@ -2,26 +2,27 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Pinboard.Error -- Copyright : (c) Jon Schoning, 2015 -- Maintainer : jonschoning@gmail.com -- Stability : experimental -- Portability : POSIX -module Pinboard.Error - ( MonadErrorPinboard - , defaultPinboardError - , pinboardExceptionToEither - , pinboardExceptionToMonadError - , exceptionToMonadErrorPinboard - , tryMonadError - , eitherToMonadError - , eitherToMonadThrow - , PinboardErrorHTTPCode (..) - , PinboardErrorType (..) - , PinboardErrorCode (..) - , PinboardError (..) - ) where +module Pinboard.Error + ( MonadErrorPinboard + , defaultPinboardError + , pinboardExceptionToEither + , pinboardExceptionToMonadError + , exceptionToMonadErrorPinboard + , tryMonadError + , eitherToMonadError + , eitherToMonadThrow + , PinboardErrorHTTPCode(..) + , PinboardErrorType(..) + , PinboardErrorCode(..) + , PinboardError(..) + ) where import Data.Text (Text, pack) @@ -30,61 +31,82 @@ import Control.Exception.Safe import Control.Monad.Error.Class (MonadError, throwError) + ------------------------------------------------------------------------------ -data PinboardErrorHTTPCode = - BadRequest -- ^ 400 - | UnAuthorized -- ^ 401 - | RequestFailed -- ^ 402 - | Forbidden -- ^ 403 - | NotFound -- ^ 404 - | TooManyRequests -- ^ 429 - | PinboardServerError -- ^ (>=500) - | UnknownHTTPCode -- ^ All other codes - deriving Show +data PinboardErrorHTTPCode + = BadRequest -- ^ 400 + | UnAuthorized -- ^ 401 + | RequestFailed -- ^ 402 + | Forbidden -- ^ 403 + | NotFound -- ^ 404 + | TooManyRequests -- ^ 429 + | PinboardServerError -- ^ (>=500) + | UnknownHTTPCode -- ^ All other codes + deriving (Show) ------------------------------------------------------------------------------ -data PinboardErrorType = - ConnectionFailure - | HttpStatusFailure - | ParseFailure - | UnknownErrorType - deriving (Eq, Show) +data PinboardErrorType + = ConnectionFailure + | HttpStatusFailure + | ParseFailure + | UnknownErrorType + deriving (Eq, Show) ------------------------------------------------------------------------------ data PinboardErrorCode = - UnknownError - deriving Show + UnknownError + deriving (Show) ------------------------------------------------------------------------------ -data PinboardError = PinboardError { - errorType :: PinboardErrorType - , errorMsg :: !Text - , errorCode :: Maybe PinboardErrorCode - , errorParam :: Maybe Text - , errorHTTP :: Maybe PinboardErrorHTTPCode - } deriving Show +data PinboardError = PinboardError + { errorType :: PinboardErrorType + , errorMsg :: !Text + , errorCode :: Maybe PinboardErrorCode + , errorParam :: Maybe Text + , errorHTTP :: Maybe PinboardErrorHTTPCode + } deriving (Show) instance Exception PinboardError type MonadErrorPinboard m = MonadError PinboardError m defaultPinboardError :: PinboardError -defaultPinboardError = PinboardError UnknownErrorType mempty Nothing Nothing Nothing +defaultPinboardError = PinboardError UnknownErrorType mempty Nothing Nothing Nothing -pinboardExceptionToEither :: MonadCatch m => m (Either PinboardError a) -> m (Either PinboardError a) -pinboardExceptionToEither = 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 + :: (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)) +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 }) +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 + :: MonadError e m + => Either e a -> m a eitherToMonadError = either throwError return -eitherToMonadThrow :: (Exception e, MonadThrow m) => Either e a -> m a +eitherToMonadThrow + :: (Exception e, MonadThrow m) + => Either e a -> m a eitherToMonadThrow = either throw return diff --git a/src/Pinboard/Logging.hs b/src/Pinboard/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Pinboard/Logging.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + +-- | +-- Module : Pinboard.Logging +-- Copyright : (c) Jon Schoning, 2015 +-- Maintainer : jonschoning@gmail.com +-- Stability : experimental +-- Portability : POSIX +module Pinboard.Logging + ( withStdoutLogging + , withStderrLogging + , withNoLogging + , logNST + , logOnException + , runLogOnException + , nullLogger + , runNullLoggingT + , errorLevelFilter + , infoLevelFilter + , debugLevelFilter + ) where + +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Exception.Safe +import Data.Time +import Data.Monoid + +import Data.Text as T + +import Pinboard.Types + +------------------------------------------------------------------------------ + +withStdoutLogging :: PinboardConfig -> PinboardConfig +withStdoutLogging p = + p + { execLoggingT = runStdoutLoggingT + } + +withStderrLogging :: PinboardConfig -> PinboardConfig +withStderrLogging p = + p + { execLoggingT = runStderrLoggingT + } + +withNoLogging :: PinboardConfig -> PinboardConfig +withNoLogging p = + p + { execLoggingT = runNullLoggingT + } + +------------------------------------------------------------------------------ + +logOnException + :: (MonadLogger m, MonadCatch m, MonadIO m) + => T.Text -> m a -> m a +logOnException src = + handle + (\(e :: SomeException) -> do + logNST LevelError src (toText e) + throw e) + +runLogOnException + :: (MonadCatch m, MonadIO m) + => T.Text -> PinboardConfig -> LoggingT m a -> m a +runLogOnException logSrc config = runConfigLoggingT config . logOnException logSrc + +------------------------------------------------------------------------------ + +logNST + :: (MonadIO m, MonadLogger m) + => LogLevel -> Text -> Text -> m () +logNST l s t = + liftIO (toText <$> getCurrentTime) >>= + \time -> logOtherNS ("[pinboard/" <> s <> "]") l ("@(" <> time <> ") " <> t) + +------------------------------------------------------------------------------ + +nullLogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO () +nullLogger _ _ _ _ = return () + +runNullLoggingT :: LoggingT m a -> m a +runNullLoggingT = (`runLoggingT` nullLogger) + +------------------------------------------------------------------------------ + +errorLevelFilter :: LogSource -> LogLevel -> Bool +errorLevelFilter = minLevelFilter LevelError + +infoLevelFilter :: LogSource -> LogLevel -> Bool +infoLevelFilter = minLevelFilter LevelInfo + +debugLevelFilter :: LogSource -> LogLevel -> Bool +debugLevelFilter = minLevelFilter LevelDebug + +minLevelFilter :: LogLevel -> LogSource -> LogLevel -> Bool +minLevelFilter l _ l' = l' >= l + +toText + :: Show a + => a -> Text +toText = T.pack . show diff --git a/src/Pinboard/Types.hs b/src/Pinboard/Types.hs --- a/src/Pinboard/Types.hs +++ b/src/Pinboard/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} -- | -- Module : Pinboard.Types @@ -13,94 +14,105 @@ , PinboardT , runPinboardT , MonadPinboard - , MonadErrorPinboard - , PinboardRequest (..) - , PinboardConfig (..) - , ResultFormatType (..) - , Param (..) + , ExecLoggingT + , PinboardConfig(..) + , runConfigLoggingT + , PinboardRequest(..) + , ResultFormatType(..) + , Param(..) , ParamsBS ) where -import Control.Monad.Reader (ReaderT) +import Control.Monad.Reader (ReaderT) import Control.Monad.Reader.Class (MonadReader) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Reader (runReaderT) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO) -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Time.Calendar(Day) -import Data.Time.Clock(UTCTime) -import Network.HTTP.Client (Manager) +import Control.Exception.Safe +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Network.HTTP.Client (Manager) + import Pinboard.Error +import Control.Monad.Logger import Control.Applicative -import Control.Exception.Safe import Prelude ------------------------------------------------------------------------------ - type PinboardEnv = (PinboardConfig, Manager) -type PinboardT m a = ReaderT PinboardEnv (ExceptT PinboardError m) a +type PinboardT m a = ReaderT PinboardEnv (ExceptT PinboardError (LoggingT m)) a -runPinboardT - :: MonadCatch m - => PinboardEnv - -> PinboardT m a - -> m (Either PinboardError a) -runPinboardT e f = pinboardExceptionToEither (runExceptT (runReaderT f e)) +runPinboardT + :: (MonadIO m, MonadCatch m) + => PinboardEnv -> PinboardT m a -> m (Either PinboardError a) +runPinboardT env@(config, _) f = + runConfigLoggingT + config + (pinboardExceptionToEither (runExceptT (runReaderT f env))) +------------------------------------------------------------------------------ -- |Typeclass alias for the return type of the API functions (keeps the -- signatures less verbose) -type MonadPinboard m = - ( Functor m - , Applicative m - , MonadIO m - , MonadCatch m - , MonadReader PinboardEnv m - ) +type MonadPinboard m = (Functor m, Applicative m, MonadIO m, MonadCatch m, MonadReader PinboardEnv m, MonadLogger m) ------------------------------------------------------------------------------ - -data PinboardRequest = PinboardRequest - { requestPath :: !Text -- ^ url path of PinboardRequest - , requestParams :: [Param] -- ^ Query Parameters of PinboardRequest - } deriving Show +type ExecLoggingT = forall m. MonadIO m => + forall a. LoggingT m a -> m a ------------------------------------------------------------------------------- data PinboardConfig = PinboardConfig - { apiToken :: !ByteString - } deriving Show + { apiToken :: !ByteString + , requestDelayMills :: !Int + , execLoggingT :: ExecLoggingT + , filterLoggingT :: LogSource -> LogLevel -> Bool + } ------------------------------------------------------------------------------- +instance Show PinboardConfig where + show (PinboardConfig a r _ _) = + "{ apiToken = " ++ show a ++ ", requestDelayMills = " ++ show r ++ " }" -type ParamsBS = [(ByteString, ByteString)] +runConfigLoggingT :: PinboardConfig -> ExecLoggingT +runConfigLoggingT config = + execLoggingT config . filterLogger (filterLoggingT config) ------------------------------------------------------------------------------ +data PinboardRequest = PinboardRequest + { requestPath :: !Text -- ^ url path of PinboardRequest + , requestParams :: [Param] -- ^ Query Parameters of PinboardRequest + } deriving (Show) -data ResultFormatType = FormatJson | FormatXml - deriving (Show, Eq) +------------------------------------------------------------------------------ +type ParamsBS = [(ByteString, ByteString)] -data Param = Format !ResultFormatType - | Tag !Text - | Tags !Text - | Old !Text - | New !Text - | Count !Int - | Start !Int - | Results !Int - | Url !Text - | Date !Day - | DateTime !UTCTime - | FromDateTime !UTCTime - | ToDateTime !UTCTime - | Replace !Bool - | Shared !Bool - | ToRead !Bool - | Description !Text - | Extended !Text - | Meta !Int - deriving (Show, Eq) +------------------------------------------------------------------------------ +data ResultFormatType + = FormatJson + | FormatXml + deriving (Show, Eq) +data Param + = Format !ResultFormatType + | Tag !Text + | Tags !Text + | Old !Text + | New !Text + | Count !Int + | Start !Int + | Results !Int + | Url !Text + | Date !Day + | DateTime !UTCTime + | FromDateTime !UTCTime + | ToDateTime !UTCTime + | Replace !Bool + | Shared !Bool + | ToRead !Bool + | Description !Text + | Extended !Text + | Meta !Int + deriving (Show, Eq) diff --git a/src/Pinboard/Util.hs b/src/Pinboard/Util.hs --- a/src/Pinboard/Util.hs +++ b/src/Pinboard/Util.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} + -- | -- Module : Pinboard.Util -- Copyright : (c) Jon Schoning, 2015 @@ -7,105 +8,111 @@ -- Stability : experimental -- Portability : POSIX module Pinboard.Util - ( - mkConfig - , paramsToByteString - , toText - , toTextLower - , () - , paramToName - , paramToText - , encodeParams - , ensureResultFormatType - ) where + ( paramsToByteString + , toText + , toTextLower + , () + , paramToName + , paramToText + , encodeParams + , ensureResultFormatType + ) where -import Data.String (IsString) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Pinboard.Types (PinboardRequest (..), PinboardConfig (..), ResultFormatType (..), Param (..), ParamsBS) -import Network.HTTP.Types(urlEncode) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Types (urlEncode) import Data.Monoid -import Prelude ------------------------------------------------------------------------------- +import Prelude -mkConfig :: PinboardConfig -mkConfig = PinboardConfig { apiToken = mempty } +import Pinboard.Types ------------------------------------------------------------------------------ -- | Conversion from a `Show` constrained type to `Text` toText - :: Show a - => a - -> Text + :: Show a + => a -> Text toText = T.pack . show ------------------------------------------------------------------------------ -- | Conversion from a `Show` constrained type to lowercase `Text` toTextLower - :: Show a - => a - -> Text + :: Show a + => a -> Text toTextLower = T.toLower . T.pack . show ------------------------------------------------------------------------------ -- | Conversion of a key value pair to a query parameterized string paramsToByteString - :: (Monoid m, IsString m) - => [(m, m)] - -> m -paramsToByteString [] = mempty -paramsToByteString [(x,y)] = x <> "=" <> y -paramsToByteString ((x,y) : xs) = - mconcat [ x, "=", y, "&" ] <> paramsToByteString xs + :: (Monoid m, IsString m) + => [(m, m)] -> m +paramsToByteString [] = mempty +paramsToByteString [(x, y)] = x <> "=" <> y +paramsToByteString ((x, y):xs) = + mconcat [x, "=", y, "&"] <> paramsToByteString xs -- | Retrieve and encode the optional parameters encodeParams :: [Param] -> ParamsBS -encodeParams xs = do - x <- xs +encodeParams xs = do + x <- xs let (k, v) = paramToText x - return ( T.encodeUtf8 k - , (urlEncode True . T.encodeUtf8 ) v - ) -ensureResultFormatType :: ResultFormatType -> PinboardRequest -> PinboardRequest -ensureResultFormatType fmt req = - if hasFormat then req else req { requestParams = Format fmt : params } - where params = requestParams req - hasFormat = Format fmt `elem` params + return (T.encodeUtf8 k, (urlEncode True . T.encodeUtf8) v) +ensureResultFormatType :: ResultFormatType -> PinboardRequest -> PinboardRequest +ensureResultFormatType fmt req = + if hasFormat + then req + else req + { requestParams = Format fmt : params + } + where + params = requestParams req + hasFormat = Format fmt `elem` params paramToText :: Param -> (Text, Text) -paramToText (Tag a) = ("tag", a) -paramToText (Tags a) = ("tags", a) -paramToText (Old a) = ("old", a) -paramToText (New a) = ("new", a) +paramToText (Tag a) = ("tag", a) +paramToText (Tags a) = ("tags", a) +paramToText (Old a) = ("old", a) +paramToText (New a) = ("new", a) paramToText (Format FormatJson) = ("format", "json") -paramToText (Format FormatXml) = ("format", "xml") -paramToText (Count a) = ("count", toText a) -paramToText (Start a) = ("start", toText a) -paramToText (Results a) = ("results", toText a) -paramToText (Url a) = ("url", a) -paramToText (Date a) = ("dt", toText a) +paramToText (Format FormatXml) = ("format", "xml") +paramToText (Count a) = ("count", toText a) +paramToText (Start a) = ("start", toText a) +paramToText (Results a) = ("results", toText a) +paramToText (Url a) = ("url", a) +paramToText (Date a) = ("dt", toText a) paramToText (DateTime a) = ("dt", toText a) paramToText (FromDateTime a) = ("fromdt", toText a) -paramToText (ToDateTime a) = ("todt", toText a) -paramToText (Replace a) = ("replace", if a then "yes" else "no") -paramToText (Shared a) = ("shared", if a then "yes" else "no") -paramToText (ToRead a) = ("toread", if a then "yes" else "no") +paramToText (ToDateTime a) = ("todt", toText a) +paramToText (Replace a) = + ( "replace" + , if a + then "yes" + else "no") +paramToText (Shared a) = + ( "shared" + , if a + then "yes" + else "no") +paramToText (ToRead a) = + ( "toread" + , if a + then "yes" + else "no") paramToText (Description a) = ("description", a) paramToText (Extended a) = ("extended", a) paramToText (Meta a) = ("meta", toText a) paramToName :: Param -> Text paramToName = fst . paramToText + ------------------------------------------------------------------------------ -- | Forward slash interspersion on `Monoid` and `IsString` -- constrained types () - :: (Monoid m, IsString m) - => m - -> m - -> m + :: (Monoid m, IsString m) + => m -> m -> m m1 m2 = m1 <> "/" <> m2 diff --git a/tests/ApproxEq.hs b/tests/ApproxEq.hs --- a/tests/ApproxEq.hs +++ b/tests/ApproxEq.hs @@ -6,35 +6,41 @@ module ApproxEq where -import Data.Text (Text) -import Data.Time.Clock -import Test.QuickCheck -import GHC.Generics as G +import Data.Text (Text) +import Data.Time.Clock +import Test.QuickCheck +import GHC.Generics as G -(==~) :: (ApproxEq a, Show a) => a -> a -> Property +(==~) + :: (ApproxEq a, Show a) + => a -> a -> Property a ==~ b = counterexample (show a ++ " !=~ " ++ show b) (a =~ b) -class GApproxEq f where +class GApproxEq f where gApproxEq :: f a -> f a -> Bool instance GApproxEq U1 where gApproxEq U1 U1 = True -instance (GApproxEq a, GApproxEq b) => GApproxEq (a :+: b) where +instance (GApproxEq a, GApproxEq b) => + GApproxEq (a :+: b) where gApproxEq (L1 a) (L1 b) = gApproxEq a b gApproxEq (R1 a) (R1 b) = gApproxEq a b gApproxEq _ _ = False -instance (GApproxEq a, GApproxEq b) => GApproxEq (a :*: b) where +instance (GApproxEq a, GApproxEq b) => + GApproxEq (a :*: b) where gApproxEq (a1 :*: b1) (a2 :*: b2) = gApproxEq a1 a2 && gApproxEq b1 b2 -instance (ApproxEq a) => GApproxEq (K1 i a) where +instance (ApproxEq a) => + GApproxEq (K1 i a) where gApproxEq (K1 a) (K1 b) = a =~ b -instance (GApproxEq f) => GApproxEq (M1 i t f) where +instance (GApproxEq f) => + GApproxEq (M1 i t f) where gApproxEq (M1 a) (M1 b) = gApproxEq a b -class ApproxEq a where +class ApproxEq a where (=~) :: a -> a -> Bool default (=~) :: (Generic a, GApproxEq (Rep a)) => a -> a -> Bool a =~ b = gApproxEq (G.from a) (G.from b) @@ -54,18 +60,22 @@ instance ApproxEq Double where (=~) = (==) -instance ApproxEq a => ApproxEq (Maybe a) +instance ApproxEq a => + ApproxEq (Maybe a) instance ApproxEq UTCTime where (=~) = (==) -instance ApproxEq a => ApproxEq [a] where +instance ApproxEq a => + ApproxEq [a] where as =~ bs = and (zipWith (=~) as bs) -instance (ApproxEq l, ApproxEq r) => ApproxEq (Either l r) where +instance (ApproxEq l, ApproxEq r) => + ApproxEq (Either l r) where Left a =~ Left b = a =~ b Right a =~ Right b = a =~ b _ =~ _ = False -instance (ApproxEq l, ApproxEq r) => ApproxEq (l, r) where - (=~) (l1,r1) (l2,r2) = l1 =~ l2 && r1 =~ r2 +instance (ApproxEq l, ApproxEq r) => + ApproxEq (l, r) where + (=~) (l1, r1) (l2, r2) = l1 =~ l2 && r1 =~ r2 diff --git a/tests/Instances.hs b/tests/Instances.hs --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -1,11 +1,11 @@ module Instances where -import Data.Text (Text, pack) -import Data.Char (isSpace) -import Data.List (sort) -import Data.Time.Calendar (Day(..)) -import Data.Time.Clock (UTCTime(..), secondsToDiffTime) -import Test.QuickCheck +import Data.Text (Text, pack) +import Data.Char (isSpace) +import Data.List (sort) +import Data.Time.Calendar (Day(..)) +import Data.Time.Clock (UTCTime(..), secondsToDiffTime) +import Test.QuickCheck import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set @@ -20,73 +20,74 @@ shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay instance Arbitrary UTCTime where - arbitrary = UTCTime <$> arbitrary <*> (secondsToDiffTime <$> choose (0, 86401)) + arbitrary = + UTCTime <$> arbitrary <*> (secondsToDiffTime <$> choose (0, 86401)) instance Arbitrary Note where - arbitrary = Note <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = + Note <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> + arbitrary <*> + arbitrary instance Arbitrary NoteList where arbitrary = NoteList <$> arbitrary <*> resize 15 arbitrary instance Arbitrary NoteListItem where - arbitrary = NoteListItem <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = + NoteListItem <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> + arbitrary instance Arbitrary Posts where arbitrary = Posts <$> arbitrary <*> arbitrary <*> resize 15 arbitrary instance Arbitrary Post where - arbitrary = Post <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryTags + arbitrary = + Post <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitraryTags instance Arbitrary JsonTagMap where - arbitrary = ToJsonTagMap <$> (HM.fromList <$> listOf ((,) <$> arbitraryTag <*> arbitrary)) + arbitrary = + ToJsonTagMap <$> + (HM.fromList <$> listOf ((,) <$> arbitraryTag <*> arbitrary)) arbitraryTags :: Gen [Tag] arbitraryTags = listOf arbitraryTag arbitraryTag :: Gen Tag -arbitraryTag = pack <$> listOf1 (arbitrary `suchThat` (\c -> (not . isSpace) c && (',' /= c))) +arbitraryTag = + pack <$> + listOf1 (arbitrary `suchThat` (\c -> (not . isSpace) c && (',' /= c))) -- | Checks if a given list has no duplicates in _O(n log n)_. -hasNoDups :: (Ord a) => [a] -> Bool +hasNoDups + :: (Ord a) + => [a] -> Bool hasNoDups = go Set.empty where go _ [] = True go s (x:xs) - | s' <- Set.insert x s, - Set.size s' > Set.size s - = go s' xs + | s' <- Set.insert x s + , Set.size s' > Set.size s = go s' xs | otherwise = False instance Arbitrary PostDates where - arbitrary = PostDates <$> arbitrary <*> arbitrary <*> (arbitrary `suchThat` isValidDateCount) + arbitrary = + PostDates <$> arbitrary <*> arbitrary <*> + (arbitrary `suchThat` isValidDateCount) where isValidDateCount xs = hasNoDups (fst <$> xs) && all (> 0) (snd <$> xs) -instance ApproxEq Day where (=~) = (==) +instance ApproxEq Day where + (=~) = (==) + instance ApproxEq PostDates where (=~) a b = - postDatesUser a =~ postDatesUser b - && postDatesTag a =~ postDatesTag b - && sort (postDatesCount a) =~ sort (postDatesCount b) + postDatesUser a =~ postDatesUser b && + postDatesTag a =~ postDatesTag b && + sort (postDatesCount a) =~ sort (postDatesCount b) instance Arbitrary Suggested where arbitrary = arbitrary >>= \a -> elements [Popular a, Recommended a] diff --git a/tests/PropJSON.hs b/tests/PropJSON.hs --- a/tests/PropJSON.hs +++ b/tests/PropJSON.hs @@ -4,35 +4,43 @@ module PropJSON where -import Data.Aeson -import Data.Aeson.Types (parseEither) -import Data.Monoid ((<>)) -import Data.Typeable (Proxy(..), typeOf, Typeable) +import Data.Aeson +import Data.Aeson.Types (parseEither) +import Data.Monoid ((<>)) +import Data.Typeable (Proxy(..), typeOf, Typeable) import qualified Data.ByteString.Lazy.Char8 as BL8 -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Property -import Test.Hspec.QuickCheck (prop) +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Property +import Test.Hspec.QuickCheck (prop) -import ApproxEq +import ApproxEq type ArbitraryJSON a = (Arbitrary a, ToJSON a, FromJSON a, Show a, Typeable a) -propJSON :: forall a b. (ArbitraryJSON a, Testable b) - => String - -> (a -> a -> b) - -> Proxy a - -> Spec -propJSON eqDescr eq _ = prop (show (typeOf (undefined :: a)) <> " FromJSON/ToJSON roundtrip " <> eqDescr) $ \(x :: a) -> - let actual = parseEither parseJSON (toJSON x) - expected = Right x - failMsg = "ACTUAL: " <> show actual <> "\nJSON: " <> BL8.unpack (encode x) - in counterexample failMsg $ either reject property (eq <$> actual <*> expected) - where reject = property . const rejected - -propJSONEq :: (ArbitraryJSON a, Eq a) => Proxy a -> Spec -propJSONEq = propJSON "(Eq)" (==) +propJSON + :: forall a b. + (ArbitraryJSON a, Testable b) + => String -> (a -> a -> b) -> Proxy a -> Spec +propJSON eqDescr eq _ = + prop + (show (typeOf (undefined :: a)) <> " FromJSON/ToJSON roundtrip " <> eqDescr) $ + \(x :: a) -> + let actual = parseEither parseJSON (toJSON x) + expected = Right x + failMsg = + "ACTUAL: " <> show actual <> "\nJSON: " <> BL8.unpack (encode x) + in counterexample failMsg $ + either reject property (eq <$> actual <*> expected) + where + reject = property . const rejected -propJSONApproxEq :: (ArbitraryJSON a, ApproxEq a) => Proxy a -> Spec -propJSONApproxEq = propJSON "(ApproxEq)" (==~) +propJSONEq + :: (ArbitraryJSON a, Eq a) + => Proxy a -> Spec +propJSONEq = propJSON "(Eq)" (==) +propJSONApproxEq + :: (ArbitraryJSON a, ApproxEq a) + => Proxy a -> Spec +propJSONApproxEq = propJSON "(ApproxEq)" (==~) diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -4,50 +4,53 @@ module Main where -import Data.Time.Clock (UTCTime(..)) -import Data.Typeable (Proxy(..)) -import Test.Hspec -import Test.Hspec.QuickCheck (prop) +import Data.Time.Clock (UTCTime(..)) +import Data.Typeable (Proxy(..)) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) import PropJSON -import Instances() +import Instances () -import Pinboard +import Pinboard main :: IO () -main = hspec $ do - - prop "UTCTime" $ \(x :: UTCTime) -> (readNoteTime . showNoteTime) x == (return x :: Maybe UTCTime) - - describe "JSON instances" $ do - propJSONEq (Proxy :: Proxy UTCTime) - propJSONEq (Proxy :: Proxy Post) - propJSONEq (Proxy :: Proxy Posts) - propJSONEq (Proxy :: Proxy Note) - propJSONEq (Proxy :: Proxy NoteList) - propJSONEq (Proxy :: Proxy NoteListItem) - propJSONEq (Proxy :: Proxy JsonTagMap) - propJSONEq (Proxy :: Proxy Suggested) - propJSONApproxEq (Proxy :: Proxy PostDates) - - describe "decodeJSONResponse: handle parse failures" $ do - it "malformed object parses as ParseFailure" $ - let noteJson = "FAIL" - in case decodeJSONResponse noteJson of - Left PinboardError{..} -> errorType == ParseFailure - Right Note{..} -> False - it "malformed field parses as ParseFailure" $ - 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 "malformed value parses as ParseFailure" $ - let noteJson = "{\"length\":FAIL,\"hash\":\"\",\"text\":\"\",\"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 "malformed time parses as ParseFailure" $ - 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 +main = + hspec $ + do prop "UTCTime" $ + \(x :: UTCTime) -> + (readNoteTime . showNoteTime) x == (return x :: Maybe UTCTime) + describe "JSON instances" $ + do propJSONEq (Proxy :: Proxy UTCTime) + propJSONEq (Proxy :: Proxy Post) + propJSONEq (Proxy :: Proxy Posts) + propJSONEq (Proxy :: Proxy Note) + propJSONEq (Proxy :: Proxy NoteList) + propJSONEq (Proxy :: Proxy NoteListItem) + propJSONEq (Proxy :: Proxy JsonTagMap) + propJSONEq (Proxy :: Proxy Suggested) + propJSONApproxEq (Proxy :: Proxy PostDates) + describe "decodeJSONResponse: handle parse failures" $ + do it "malformed object parses as ParseFailure" $ + let noteJson = "FAIL" + in case decodeJSONResponse noteJson of + Left PinboardError {..} -> errorType == ParseFailure + Right Note {..} -> False + it "malformed field parses as ParseFailure" $ + 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 "malformed value parses as ParseFailure" $ + let noteJson = + "{\"length\":FAIL,\"hash\":\"\",\"text\":\"\",\"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 "malformed time parses as ParseFailure" $ + 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