pinboard 0.9.10 → 0.9.11
raw patch · 15 files changed
+1205/−1193 lines, 15 filesdep +monad-logger
Dependencies added: monad-logger
Files
- changelog.md +6/−0
- pinboard.cabal +3/−1
- src/Pinboard/Api.hs +76/−77
- src/Pinboard/ApiRequest.hs +119/−148
- src/Pinboard/ApiTypes.hs +178/−177
- src/Pinboard/ApiTypesLens.hs +199/−363
- src/Pinboard/Client.hs +162/−133
- src/Pinboard/Error.hs +71/−49
- src/Pinboard/Logging.hs +105/−0
- src/Pinboard/Types.hs +72/−60
- src/Pinboard/Util.hs +69/−62
- tests/ApproxEq.hs +26/−16
- tests/Instances.hs +41/−40
- tests/PropJSON.hs +33/−25
- tests/Test.hs +45/−42
changelog.md view
@@ -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
pinboard.cabal view
@@ -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
src/Pinboard/Api.hs view
@@ -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-
src/Pinboard/ApiRequest.hs view
@@ -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]-
src/Pinboard/ApiTypes.hs view
@@ -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-
src/Pinboard/ApiTypesLens.hs view
@@ -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 #-}
src/Pinboard/Client.hs view
@@ -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
src/Pinboard/Error.hs view
@@ -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
+ src/Pinboard/Logging.hs view
@@ -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
src/Pinboard/Types.hs view
@@ -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)
src/Pinboard/Util.hs view
@@ -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
tests/ApproxEq.hs view
@@ -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
tests/Instances.hs view
@@ -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]
tests/PropJSON.hs view
@@ -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)" (==~)
tests/Test.hs view
@@ -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