diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (C) 2012 Matvey Aksenov, Dmitry Malikov + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE UnicodeSyntax #-} +module Main where + +import Test.DocTest + + +main ∷ IO () +main = doctest ["-isrc", "-XOverloadedStrings", "src/Network/StackExchange/API.hs"] diff --git a/libstackexchange.cabal b/libstackexchange.cabal new file mode 100644 --- /dev/null +++ b/libstackexchange.cabal @@ -0,0 +1,76 @@ +name: libstackexchange +version: 0.1.0.0 +synopsis: StackExchange API interface +description: Provides interface for StackExchange v2.1 API +homepage: https://github.com/supki/libstackexchange +license: MIT +license-file: LICENSE +author: Matvey Aksenov, Dmitry Malikov +maintainer: matvey.aksenov@gmail.com +category: NetworkAPIs +build-type: Simple +cabal-version: >= 1.8 + +flag enable-examples + default: False +flag enable-doctests + default: False + +library + build-depends: base >= 4.6 && < 5, + bytestring, + containers, + data-default, + attoparsec, + text, + aeson, + http-conduit, + lens >= 3.0.4 + hs-source-dirs: src + exposed-modules: Network.StackExchange + Network.StackExchange.API + Network.StackExchange.Auth + Network.StackExchange.Request + Network.StackExchange.Response + ghc-options: -Wall + -fno-warn-unused-do-bind + +test-suite aeson-lens + build-depends: base >= 4.6, + template-haskell, + bytestring, + attoparsec, + aeson, + lens, + HUnit, + libstackexchange + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests/aeson-lens + other-modules: TH + ghc-options: -Wall + -fno-warn-unused-do-bind + +test-suite request + build-depends: base >= 4.6, + containers, + text, + QuickCheck, + libstackexchange + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests/request + ghc-options: -Wall + -fno-warn-unused-do-bind + +test-suite api + build-depends: base >= 4.6, + doctest >= 0.8, + http-conduit, + libstackexchange + if !flag(enable-doctests) + buildable: False + type: exitcode-stdio-1.0 + main-is: doctests.hs + ghc-options: -Wall + -fno-warn-unused-do-bind diff --git a/src/Network/StackExchange.hs b/src/Network/StackExchange.hs new file mode 100644 --- /dev/null +++ b/src/Network/StackExchange.hs @@ -0,0 +1,9 @@ +-- | Convenience module for the ease of importing +module Network.StackExchange + ( module S + ) where + +import Network.StackExchange.Request as S +import Network.StackExchange.Response as S +import Network.StackExchange.API as S +import Network.StackExchange.Auth as S diff --git a/src/Network/StackExchange/API.hs b/src/Network/StackExchange/API.hs new file mode 100644 --- /dev/null +++ b/src/Network/StackExchange/API.hs @@ -0,0 +1,1024 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} +-- | API methods list +module Network.StackExchange.API + ( -- * SE AccessToken + readAccessTokens, invalidateAccessTokens, applicationDeAuthenticate + -- * SE Answer + , answers, answersByIds, answersOnUsers + , answersOnQuestions, meAnswers, topUserAnswersInTags, meTagsTopAnswers + -- * SE Badge + , badges, badgesByIds, badgeRecipientsByIds + , badgesByName, badgeRecipients, badgesByTag + , badgesOnUsers, meBadges + -- * SE Comment + , commentsOnAnswers, comments, commentsByIds, deleteComment, editComment + , commentsOnPosts, createComment, commentsOnQuestions + , commentsOnUsers, meComments, commentsByUsersToUser, meCommentsTo + , mentionsOnUsers, meMentioned + -- * SE Error + , errors + -- * SE Event + , events + -- * SE Filter + , createFilter, readFilter + -- * SE InboxItems + , inbox, inboxUnread, userInbox, meInbox, userUnreadInbox, meUnreadInbox + -- * SE Info + , info + -- * SE NetworkUser + , associatedUsers, meAssociatedUsers + -- * SE AccountMerge + , mergeHistory, meMergeHistory + -- * SE Notification + , notifications, notificationsUnread, userNotifications, meNotifications + , userUnreadNotifications, meUnreadNotifications + -- * SE Post + , posts, postsByIds + -- * SE Privilege + , privileges, privilegesOnUsers, mePriviledges + -- * SE Question + , questions, questionsByIds, linkedQuestions, relatedQuestions + , featuredQuestions, unansweredQuestions, noAnswerQuestions + , search, advancedSearch, similar, faqsByTags, favoritesOnUsers + , meFavorites, questionsOnUsers, meQuestions, featuredQuestionsOnUsers + , meFeaturedQuestions, noAnswerQuestionsOnUsers, meNoAnswerQuestions + , unacceptedQuestionsOnUsers, meUnacceptedQuestions, unansweredQuestionsOnUsers + , meUnansweredQuestions, topUserQuestionsInTags, meTagsTopQuestions + -- * SE QuestionTimeline + , questionsTimeline + -- * SE Reputation + , reputationOnUsers, meReputation + -- * SE ReputationHistory + , reputationHistory, reputationHistoryFull + , meReputationHistory, meReputationHistoryFull + -- * SE Revision + , revisionsByIds, revisionsByGuids + -- * SE Site + , sites + -- * SE SuggestedEdit + , postsOnSuggestedEdits, suggestedEdits, suggestedEditsByIds + , suggestedEditsOnUsers, meSuggestedEdits + -- * SE Tag + , tags, moderatorOnlyTags, requiredTags + , tagsByName, relatedTags, tagsOnUsers, meTags + -- * SE TagScore + , topAnswerersOnTag, topAskersOnTag + -- * SE TagSynonym + , tagSynonyms, synonymsByTags + -- * SE TagWiki + , wikisByTags + -- * SE TopTag + , topAnswerTagsOnUsers, topQuestionTagsOnUsers + , meTopAnswerTags, meTopQuestionTags + -- * SE User + , users, usersByIds, me, moderators, electedModerators + -- * SE UserTimeline + , timelineOnUsers, meTimeline + -- * SE WritePermission + , writePermissions, meWritePermissions + ) where + +import Data.Monoid ((<>)) + +import Control.Exception (throw) +import Control.Lens ((^!)) +import Data.Aeson (Value) +import qualified Data.Aeson as A +import qualified Data.Attoparsec.Lazy as AP +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int (decimal) + +import Network.StackExchange.Response +import Network.StackExchange.Request + +-- $setup +-- >>> let t = site "stackoverflow" <> key "Lhg6xe5d5BvNK*C0S8jijA((" + +-------------------------- +-- Access Tokens +-------------------------- + +-- | +invalidateAccessTokens ∷ [Text] → Request a "invalidateAccessTokens" [SE AccessToken] +invalidateAccessTokens (T.intercalate ";" → ts) = + path ("access-tokens/" <> ts <> "/invalidate") <> + parse (attoparsec items ".access-tokens/{accessTokens}/invalidate: ") + + +-- | +readAccessTokens ∷ [Text] → Request a "readAccessTokens" [SE AccessToken] +readAccessTokens (T.intercalate ";" → ts) = + path ("access-tokens/" <> ts) <> + parse (attoparsec items ".access-tokens/{accessTokens}: ") + + +-- | +applicationDeAuthenticate ∷ [Text] → Request a "applicationDeAuthenticate" [SE AccessToken] +applicationDeAuthenticate (T.intercalate ";" → ts) = + path ("apps/" <> ts <> "/de-authenticate") <> + parse (attoparsec items ".apps/{accessTokens}/de-authenticate: ") + + +-------------------------- +-- Answers +-------------------------- + +-- | +-- +-- >>> fmap length $ askSE (answers <> t) +-- 30 +answers ∷ Request a "answers" [SE Answer] +answers = path "answers" <> parse (attoparsec items ".answers: ") + + +-- | +-- +-- >>> fmap length $ askSE (answersByIds [6841479, 215422, 8881376] <> t) +-- 3 +answersByIds ∷ [Int] → Request a "answersByIds" [SE Answer] +answersByIds (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("answers/" <> is) <> parse (attoparsec items ".answers/{ids}: ") + + +-- | +answersOnUsers ∷ [Int] → Request a "answersOnUsers" [SE Answer] +answersOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/answers") <> + parse (attoparsec items ".users/{ids}/answers: ") + + +-- | +answersOnQuestions ∷ [Int] → Request a "answersOnQuestions" [SE Answer] +answersOnQuestions (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("questions/" <> is <> "/answers") <> + parse (attoparsec items ".questions/{ids}/answers: ") + + +-- | +meAnswers ∷ Request RequireToken "meAnswers" [SE Answer] +meAnswers = + path "me/answers" <> parse (attoparsec items ".me/answers: ") + + +-- | +topUserAnswersInTags ∷ Int → [Text] → Request a "topUserAnswersInTags" [SE Answer] +topUserAnswersInTags (toLazyText . decimal → i) (T.intercalate ";" → ts) = + path ("users/" <> i <> "/tags/" <> ts <> "/top-answers") <> + parse (attoparsec items ".users/{id}/tags/{tags}/top-answers: ") + + +-- | +meTagsTopAnswers ∷ [Text] → Request RequireToken "meTagsTopAnswers" [SE Answer] +meTagsTopAnswers (T.intercalate ";" → ts) = + path ("me/tags/" <> ts <> "/top-answers") <> + parse (attoparsec items ".me/tags/{tags}/top-answers: ") + + +-------------------------- +-- Badges +-------------------------- + +-- | +badges ∷ Request a "badges" [SE Badge] +badges = path "badges" <> parse (attoparsec items ".badges: ") + + +-- | +badgesByIds ∷ [Int] → Request a "badgesByIds" [SE Badge] +badgesByIds (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("badges/" <> is) <> parse (attoparsec items ".badges/{ids}: ") + + +-- | +badgeRecipientsByIds ∷ [Int] → Request a "badgeRecipientsByIds" [SE Badge] +badgeRecipientsByIds (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("badges" <> is <> "/recipients") <> + parse (attoparsec items ".badges/{ids}/recipients: ") + + +-- | +badgesByName ∷ Request a "badgesByName" [SE Badge] +badgesByName = + path ("badges" <> "/name") <> parse (attoparsec items ".badges/name: ") + + +-- | +badgeRecipients ∷ Request a "badgeRecipients" [SE Badge] +badgeRecipients = + path ("badges" <> "/recipients") <> + parse (attoparsec items ".badges/recipients: ") + + +-- | +badgesByTag ∷ Request a "badgesByTag" [SE Badge] +badgesByTag = + path ("badges" <> "/tags") <> parse (attoparsec items ".badges/tags: ") + + +-- | +badgesOnUsers ∷ [Int] → Request a "badgesOnUsers" [SE Badge] +badgesOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/badges") <> + parse (attoparsec items ".users/{ids}/badges: ") + + +-- | +meBadges ∷ Request RequireToken "meBadges" [SE Badge] +meBadges = path "me/badges" <> parse (attoparsec items ".me/badges: ") + + + +-------------------------- +-- Comments +-------------------------- + +-- | +commentsOnAnswers ∷ [Int] → Request a "commentsOnAnswers" [SE Comment] +commentsOnAnswers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("answers/" <> is <> "/comments") <> + parse (attoparsec items ".answers/{ids}/comments: ") + + +-- | +comments ∷ Request a "comments" [SE Comment] +comments = path "comments" <> parse (attoparsec items ".comments: ") + + +-- | +deleteComment ∷ Int → Request RequireToken "deleteComment" () +deleteComment (toLazyText . decimal → i) = + path ("comments/" <> i <> "/delete") + + +-- | +editComment ∷ Int → Text → Request RequireToken "editComment" (SE Comment) +editComment (toLazyText . decimal → i) body = + path ("comments/" <> i <> "/edit") <> + query [("body", body)] <> + parse (attoparsec (return . SE) ".comments/{id}/edit:") + + +-- | +commentsByIds ∷ [Int] → Request a "commentsByIds" [SE Comment] +commentsByIds (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("comments/" <> is) <> parse (attoparsec items ".comments/{ids}: ") + + +-- | +commentsOnPosts ∷ [Int] → Request a "commentsOnPosts" [SE Comment] +commentsOnPosts (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("posts/" <> is <> "/comments") <> + parse (attoparsec items ".posts/{ids}/comments: ") + + +-- | +createComment ∷ Int → Text → Request RequireToken "createComment" (SE Comment) +createComment (toLazyText . decimal → i) body = + path ("posts/" <> i <> "/comments/add") <> + query [("body", body)] <> + parse (attoparsec (return . SE) ".posts/{id}/comments/add:") + + +-- | +commentsOnQuestions ∷ [Int] → Request a "commentsOnQuestions" [SE Comment] +commentsOnQuestions (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("questions/" <> is <> "/comments") <> + parse (attoparsec items ".questions/{ids}/comments: ") + + +-- | +commentsOnUsers ∷ [Int] → Request a "commentsOnUsers" [SE Comment] +commentsOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/comments") <> + parse (attoparsec items ".users/{ids}/comments: ") + + +-- | +meComments ∷ Request RequireToken "meComments" [SE Comment] +meComments = path "me/comments" <> parse (attoparsec items ".me/comments: ") + + +-- | +commentsByUsersToUser ∷ [Int] → Int → Request a "commentsByUsersToUser" [SE Comment] +commentsByUsersToUser (T.intercalate ";" . map (toLazyText . decimal) → is) + (toLazyText . decimal → toid) = + path ("users/" <> is <> "/comments/" <> toid) <> + parse (attoparsec items ".users/{ids}/comments/{toid}: ") + + +-- | +meCommentsTo ∷ Int → Request RequireToken "meCommentsTo" [SE Comment] +meCommentsTo (toLazyText . decimal → toid) = + path ("me/comments/" <> toid) <> + parse (attoparsec items ".me/comments/{toid}:") + + +-- | +mentionsOnUsers ∷ [Int] → Request a "mentionsOnUsers" [SE Comment] +mentionsOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/mentioned") <> + parse (attoparsec items ".users/{ids}/mentioned: ") + + +-- | +meMentioned ∷ Request RequireToken "meMentioned" [SE Comment] +meMentioned = path "me/mentioned" <> parse (attoparsec items ".me/mentioned: ") + + +-------------------------- +-- Errors +-------------------------- + +-- | +errors ∷ Request a "errors" [SE Error] +errors = path "errors" <> parse (attoparsec items ".errors: ") + + +-------------------------- +-- Events +-------------------------- + +-- | +events ∷ Request RequireToken "events" [SE Event] +events = path "events" <> parse (attoparsec items ".events: ") + + +-------------------------- +-- Filters +-------------------------- + +-- | +createFilter ∷ [Text] → [Text] → Text → Request a "createFilter" (SE Filter) +createFilter (T.intercalate ";" → include) (T.intercalate ";" → exclude) base = + path "filter/create" <> + query [("include", include), ("exclude", exclude), ("base", base)] <> + parse (attoparsec (return . SE) ".filter/create: ") + + +-- | +readFilter ∷ [Text] → Request a "readFilter" [SE Filter] +readFilter (T.intercalate ";" → fs) = + path ("filters/" <> fs) <> + parse (attoparsec items ".filters/{filters}: ") + + +-------------------------- +-- Inbox Items +-------------------------- + +-- | +inbox ∷ Request RequireToken "inbox" [SE InboxItem] +inbox = + path "inbox" <> + parse (attoparsec items ".inbox: ") + + +-- | +inboxUnread ∷ Request RequireToken "inboxUnread" [SE InboxItem] +inboxUnread = + path "inbox/unread" <> + parse (attoparsec items ".inbox/unread: ") + + +-- | +userInbox ∷ Int → Request RequireToken "userInbox" [SE InboxItem] +userInbox (toLazyText . decimal → i) = + path ("users/" <> i <> "/inbox") <> + parse (attoparsec items ".users/{id}/inbox: ") + + +-- | +meInbox ∷ Request RequireToken "meInbox" [SE InboxItem] +meInbox = + path "me/inbox" <> + parse (attoparsec items ".me/inbox: ") + + +-- | +userUnreadInbox ∷ Int → Request RequireToken "userUnreadInbox" [SE InboxItem] +userUnreadInbox (toLazyText . decimal → i) = + path ("users/" <> i <> "/inbox/unread") <> + parse (attoparsec items ".users/{id}/inbox/unread: ") + + +-- | +meUnreadInbox ∷ Request RequireToken "meUnreadInbox" [SE InboxItem] +meUnreadInbox = + path "me/inbox/unread" <> + parse (attoparsec items ".me/inbox/unread: ") + + +-------------------------- +-- Info +-------------------------- + +-- | +info ∷ Request a "info" (SE Info) +info = path "info" <> parse (attoparsec (return . SE) ".info: ") + + +-------------------------- +-- Network Users +-------------------------- + +-- | +associatedUsers ∷ [Int] → Request a "associatedUsers" [SE NetworkUser] +associatedUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/associated") <> + parse (attoparsec items ".users/{ids}/associated: ") + + +-- | +meAssociatedUsers ∷ Request RequireToken "meAssociatedUsers" [SE NetworkUser] +meAssociatedUsers = + path "me/associated" <> + parse (attoparsec items ".me/associated: ") + + +-------------------------- +-- Merge History +-------------------------- + +-- | +mergeHistory ∷ [Int] → Request a "mergeHistory" [SE AccountMerge] +mergeHistory (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/merges") <> + parse (attoparsec items ".users/{ids}/merges: ") + + +-- | +meMergeHistory ∷ Request RequireToken "meMergeHistory" [SE AccountMerge] +meMergeHistory = + path "me/merges" <> + parse (attoparsec items ".me/merges: ") + + +-------------------------- +-- Notifications +-------------------------- + +-- | +notifications ∷ Request RequireToken "notifications" [SE Notification] +notifications = path "notifications" <> parse (attoparsec items ".notifications: ") + + +-- | +notificationsUnread ∷ Request RequireToken "notificationsUnread" [SE Notification] +notificationsUnread = path "notifications/unread" <> parse (attoparsec items ".notifications/unread: ") + + +-- | +userNotifications ∷ Int → Request RequireToken "userNotifications" [SE Notification] +userNotifications (toLazyText . decimal → i) = + path ("users/" <> i <> "/notifications") <> + parse (attoparsec items ".users/{id}/notifications: ") + + +-- | +meNotifications ∷ Request RequireToken "meNotifications" [SE Notification] +meNotifications = + path "me/notifications" <> + parse (attoparsec items ".me/notifications: ") + + +-- | +userUnreadNotifications ∷ Int → Request RequireToken "userUnreadNotifications" [SE Notification] +userUnreadNotifications (toLazyText . decimal → i) = + path ("users/" <> i <> "/notifications/unread") <> + parse (attoparsec items ".users/{id}/notifications/unread: ") + + +-- | +meUnreadNotifications ∷ Request RequireToken "meUnreadNotifications" [SE Notification] +meUnreadNotifications = + path "me/notifications" <> + parse (attoparsec items ".me/notifications/unread: ") + + +-------------------------- +-- Posts +-------------------------- + +-- | +posts ∷ Request a "posts" [SE Post] +posts = path "posts" <> parse (attoparsec items ".posts: ") + + +-- | +postsByIds ∷ [Int] → Request a "postsByIds" [SE Post] +postsByIds (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("posts/" <> is) <> parse (attoparsec items ".posts/{ids}: ") + + +-------------------------- +-- Privileges +-------------------------- + +-- | +privileges ∷ Request a "privileges" [SE Privilege] +privileges = path "privileges" <> parse (attoparsec items ".privileges: ") + + +-- | +privilegesOnUsers ∷ Int → Request a "privilegesOnUsers" [SE Privilege] +privilegesOnUsers (toLazyText . decimal → i) = + path ("users/" <> i <> "/privileges") <> + parse (attoparsec items ".users/{ids}/privileges: ") + + +-- | +mePriviledges ∷ Request RequireToken "mePriviledges" [SE Privilege] +mePriviledges = path "me/privileges" <> parse (attoparsec items ".me/privileges: ") + + +-------------------------- +-- Questions +-------------------------- + +-- | +questions ∷ Request a "questions" [SE Question] +questions = path "questions" <> parse (attoparsec items ".questions: ") + + +-- | +questionsByIds ∷ [Int] → Request a "questionsByIds" [SE Question] +questionsByIds (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("questions/" <> is) <> parse (attoparsec items ".questions/{ids}: ") + + +-- | +linkedQuestions ∷ [Int] → Request a "linkedQuestions" [SE Question] +linkedQuestions (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("questions/" <> is <> "/linked") <> + parse (attoparsec items ".questions/{ids}/linked: ") + + +-- | +relatedQuestions ∷ [Int] → Request a "relatedQuestions" [SE Question] +relatedQuestions (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("questions/" <> is <> "/related") <> + parse (attoparsec items ".questions/{ids}/related: ") + + +-- | +featuredQuestions ∷ Request a "featuredQuestions" [SE Question] +featuredQuestions = + path "questions/featured" <> parse (attoparsec items ".questions/featured: ") + + +-- | +unansweredQuestions ∷ Request a "unansweredQuestions" [SE Question] +unansweredQuestions = + path "questions/unanswered" <> + parse (attoparsec items ".questions/unanswered: ") + + +-- | +noAnswerQuestions ∷ Request a "noAnswerQuestions" [SE Question] +noAnswerQuestions = + path "questions/no-answers" <> + parse (attoparsec items ".questions/no-answers: ") + + +-- | +search ∷ Text → [Text] → Request a "search" [SE Question] +search t (T.intercalate ";" → ts) = + path "search" <> + query [("intitle",t),("tagged",ts)] <> + parse (attoparsec items ".search: ") + + +-- | +advancedSearch ∷ Request a "advancedSearch" [SE Question] +advancedSearch = + path "search/advanced" <> parse (attoparsec items ".search/advanced: ") + + +-- | +similar ∷ Text → [Text] → Request a "similar" [SE Question] +similar t (T.intercalate ";" → ts) = + path "similar" <> + query [("title",t),("tagged",ts)] <> + parse (attoparsec items ".similar: ") + + +-- | +faqsByTags ∷ [Text] → Request a "faqsByTags" [SE Question] +faqsByTags (T.intercalate ";" → ts) = + path ("tags/" <> ts <> "/faq") <> + parse (attoparsec items ".tags/{tags}/faq: ") + + +-- | +favoritesOnUsers ∷ [Int] → Request a "favoritesOnUsers" [SE Question] +favoritesOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/favorites") <> + parse (attoparsec items ".users/{ids}/favorites: ") + + +-- | +meFavorites ∷ Request RequireToken "meFavorites" [SE Question] +meFavorites = path "me/favorites" <> parse (attoparsec items ".me/favorites: ") + + +-- | +questionsOnUsers ∷ [Int] → Request a "questionsOnUsers" [SE Question] +questionsOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/questions") <> + parse (attoparsec items ".users/{ids}/questions: ") + + +-- | +meQuestions ∷ Request RequireToken "meQuestions" [SE Question] +meQuestions = path "me/questions" <> parse (attoparsec items ".me/questions: ") + + +-- | +featuredQuestionsOnUsers ∷ [Int] → Request a "featuredQuestionsOnUsers" [SE Question] +featuredQuestionsOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/questions/featured") <> + parse (attoparsec items ".users/{ids}/questions/featured: ") + + +-- | +meFeaturedQuestions ∷ Request RequireToken "meFeaturedQuestions" [SE Question] +meFeaturedQuestions = path "me/questions/featured" <> parse (attoparsec items ".me/questions/featured: ") + + +-- | +noAnswerQuestionsOnUsers ∷ [Int] → Request a "noAnswerQuestionsOnUsers" [SE Question] +noAnswerQuestionsOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/questions/no-answers") <> + parse (attoparsec items ".users/{ids}/questions/no-answers: ") + + +-- | +meNoAnswerQuestions ∷ Request RequireToken "meNoAnswerQuestions" [SE Question] +meNoAnswerQuestions = path "me/questions/no-answers" <> parse (attoparsec items ".me/questions/no-answers: ") + + +-- | +unacceptedQuestionsOnUsers ∷ [Int] → Request a "unacceptedQuestionsOnUsers" [SE Question] +unacceptedQuestionsOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/questions/unaccepted") <> + parse (attoparsec items ".users/{ids}/questions/unaccepted: ") + + +-- | +meUnacceptedQuestions ∷ Request RequireToken "meUnacceptedQuestions" [SE Question] +meUnacceptedQuestions = path "me/questions/unaccepted" <> parse (attoparsec items ".me/questions/unaccepted: ") + + +-- | +unansweredQuestionsOnUsers ∷ [Int] → Request a "unansweredQuestionsOnUsers" [SE Question] +unansweredQuestionsOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/questions/unanswered") <> + parse (attoparsec items ".users/{ids}/questions/unanswered: ") + + +-- | +meUnansweredQuestions ∷ Request RequireToken "meUnansweredQuestions" [SE Question] +meUnansweredQuestions = path "me/questions/unanswered" <> parse (attoparsec items ".me/questions/unanswered: ") + + +-- | +topUserQuestionsInTags ∷ Int → [Text] → Request a "topUserQuestionsInTags" [SE Question] +topUserQuestionsInTags (toLazyText . decimal → i) (T.intercalate ";" → ts) = + path ("users/" <> i <> "/tags/" <> ts <> "/top-questions") <> + parse (attoparsec items ".users/{id}/tags/{tags}/top-questions: ") + + +-- | +meTagsTopQuestions ∷ [Text] → Request RequireToken "meTagsTopQuestions" [SE Question] +meTagsTopQuestions (T.intercalate ";" → ts) = + path ("me/tags/" <> ts <> "/top-questions") <> + parse (attoparsec items ".me/tags/{tags}/top-questions: ") + + +-------------------------- +-- Question Timelines +-------------------------- + +-- | +questionsTimeline ∷ [Int] → Request a "questionsTimeline" [SE QuestionTimeline] +questionsTimeline (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("questions/" <> is <> "/timeline") <> + parse (attoparsec items ".questions/{ids}/timeline: ") + + +-------------------------- +-- Reputation +-------------------------- + +-- | +reputationOnUsers ∷ [Int] → Request a "reputationOnUsers" [SE Reputation] +reputationOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/reputation") <> + parse (attoparsec items ".users/{ids}/reputation: ") + + +-- | +meReputation ∷ Request RequireToken "meReputation" [SE Reputation] +meReputation = path "me/reputation" <> parse (attoparsec items ".me/reputation: ") + + +-------------------------- +-- Reputation History +------------------------- + +-- | +reputationHistory ∷ [Int] → Request a "reputationHistory" [SE ReputationHistory] +reputationHistory (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/reputation-history") <> + parse (attoparsec items ".users/{ids}/reputation-history: ") + + +-- | +meReputationHistory ∷ Request RequireToken "meReputationHistory" [SE ReputationHistory] +meReputationHistory = + path "me/reputation-history" <> + parse (attoparsec items ".me/reputation-history: ") + + +-- | +reputationHistoryFull ∷ [Int] → Request RequireToken "reputationHistoryFull" [SE ReputationHistory] +reputationHistoryFull (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/reputation-history/full") <> + parse (attoparsec items ".users/{ids}/reputation-history/full: ") + + +-- | +meReputationHistoryFull ∷ Request RequireToken "meReputationHistoryFull" [SE ReputationHistory] +meReputationHistoryFull = + path "me/reputation-history/full" <> + parse (attoparsec items ".me/reputation-history/full: ") + + +-------------------------- +-- Revisions +-------------------------- + +-- | +revisionsByIds ∷ [Int] → Request a "revisionsByIds" [SE Revision] +revisionsByIds (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("posts/" <> is <> "/revisions") <> + parse (attoparsec items ".posts/{ids}/revisions: ") + + +-- | +revisionsByGuids ∷ [Text] → Request a "revisionsByGuids" [SE Revision] +revisionsByGuids (T.intercalate ";" → is) = + path ("revisions/" <> is) <> + parse (attoparsec items ".revisions/{ids}: ") + + +-------------------------- +-- Sites +-------------------------- + +-- | +sites ∷ Request a "sites" [SE Site] +sites = path "sites" <> parse (attoparsec items ".sites: ") + + +-------------------------- +-- Suggested Edits +-------------------------- + +-- | +postsOnSuggestedEdits ∷ [Int] → Request a "postsOnSuggestedEdits" [SE SuggestedEdit] +postsOnSuggestedEdits (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("posts/" <> is <> "/suggested-edits") <> + parse (attoparsec items ".posts/{ids}/suggested-edits: ") + + +-- | +suggestedEdits ∷ Request a "suggestedEdits" [SE SuggestedEdit] +suggestedEdits = + path "suggested-edits" <> parse (attoparsec items ".suggested-edits: ") + + +-- | +suggestedEditsByIds ∷ [Int] → Request a "suggestedEditsByIds" [SE SuggestedEdit] +suggestedEditsByIds (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("suggested-edits/" <> is ) <> + parse (attoparsec items ".suggested-edits/{ids}: ") + + +-- | +suggestedEditsOnUsers ∷ [Int] → Request a "suggestedEditsOnUsers" [SE SuggestedEdit] +suggestedEditsOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/suggested-edits") <> + parse (attoparsec items ".users/{ids}/suggested-edits: ") + + +-- | +meSuggestedEdits ∷ Request RequireToken "meSuggestedEdits" [SE SuggestedEdit] +meSuggestedEdits = + path "me/suggested-edits" <> + parse (attoparsec items ".me/suggested-edits: ") + + +-------------------------- +-- Tags +-------------------------- + +-- | +tags ∷ Request a "tags" [SE Tag] +tags = path "tags" <> parse (attoparsec items ".tags: ") + + +-- | +moderatorOnlyTags ∷ Request a "moderatorOnlyTags" [SE Tag] +moderatorOnlyTags = + path "tags/moderator-only" <> + parse (attoparsec items ".tags/moderator-only: ") + + +-- | +requiredTags ∷ Request a "requiredTags" [SE Tag] +requiredTags = + path "tags/required" <> parse (attoparsec items ".tags/required: ") + + +-- | +tagsByName ∷ [Text] → Request a "tagsByName" [SE Tag] +tagsByName (T.intercalate ";" → ts) = + path ("tags/" <> ts <> "/info") <> + parse (attoparsec items ".tags/{tags}/info: ") + + +-- | +relatedTags ∷ [Text] → Request a "relatedTags" [SE Tag] +relatedTags (T.intercalate ";" → ts) = + path ("tags/" <> ts <> "/related") <> + parse (attoparsec items ".tags/{tags}/related: ") + + +-- | +tagsOnUsers ∷ [Int] → Request a "tagsOnUsers" [SE Tag] +tagsOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/tags") <> + parse (attoparsec items ".users/{ids}/tags: ") + + +-- | +meTags ∷ Request RequireToken "meTags" [SE Tag] +meTags = path "me/tags" <> parse (attoparsec items ".me/tags: ") + + +-------------------------- +-- Tag Scores +-------------------------- + +-- | +topAnswerersOnTag ∷ Text → Text → Request a "topAnswerersOnTag" [SE TagScore] +topAnswerersOnTag t p = + path ("tags/" <> t <> "/top-answerers/" <> p) <> + parse (attoparsec items ".tags/{tag}/top-answerers/{period}: ") + + +-- | +topAskersOnTag ∷ Text → Text → Request a "topAskersOnTag" [SE TagScore] +topAskersOnTag t p = + path ("tags/" <> t <> "/top-askers/" <> p) <> + parse (attoparsec items ".tags/{tag}/top-askers/{period}: ") + + +-------------------------- +-- Tag Synonyms +-------------------------- + +-- | +tagSynonyms ∷ Request a "tagSynonyms" [SE TagSynonym] +tagSynonyms = + path "tags/synonyms" <> parse (attoparsec items ".tags/synonyms: ") + + +-- | +synonymsByTags ∷ [Text] → Request a "synonymsByTags" [SE TagSynonym] +synonymsByTags (T.intercalate ";" → ts) = + path ("tags/" <> ts <> "/synonyms") <> + parse (attoparsec items ".tags/{tags}/synonyms: ") + + +-------------------------- +-- Tag Wikis +-------------------------- + +-- | +wikisByTags ∷ [Text] → Request a "wikisByTags" [SE TagWiki] +wikisByTags (T.intercalate ";" → ts) = + path ("tags/" <> ts <> "/wikis") <> + parse (attoparsec items ".tags/{tags}/wikis: ") + + +-------------------------- +-- Top Tags +-------------------------- + +-- | +topAnswerTagsOnUsers ∷ Int → Request a "topAnswerTagsOnUsers" [SE TopTag] +topAnswerTagsOnUsers (toLazyText . decimal → i) = + path ("users/" <> i <> "/top-answer-tags") <> + parse (attoparsec items ".users/{id}/top-answer-tags: ") + + +-- | +meTopAnswerTags ∷ Request RequireToken "meTopAnswerTags" [SE TopTag] +meTopAnswerTags = path "me/top-answer-tags" <> parse (attoparsec items ".me/top-answer-tags: ") + + +-- | +topQuestionTagsOnUsers ∷ Int → Request a "topQuestionTagsOnUsers" [SE TopTag] +topQuestionTagsOnUsers (toLazyText . decimal → i) = + path ("users/" <> i <> "/top-question-tags") <> + parse (attoparsec items ".users/{id}/top-question-tags: ") + + +-- | +meTopQuestionTags ∷ Request RequireToken "meTopQuestionTags" [SE TopTag] +meTopQuestionTags = path "me/top-question-tags" <> parse (attoparsec items ".me/top-question-tags: ") + + +-------------------------- +-- Users +-------------------------- + +-- | +users ∷ Request a "users" [SE User] +users = path "users" <> parse (attoparsec items ".users: ") + + +-- | +usersByIds ∷ [Int] → Request a "usersByIds" [SE User] +usersByIds (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is) <> parse (attoparsec items ".users/{ids}: ") + + +-- | +me ∷ Request RequireToken "me" (SE User) +me = path "me" <> parse (head . attoparsec items ".me: ") + + +-- | +moderators ∷ Request a "moderators" [SE User] +moderators = + path "users/moderators" <> parse (attoparsec items ".users/moderators: ") + + +-- | +electedModerators ∷ Request a "electedModerators" [SE User] +electedModerators = + path "users/moderators/elected" <> + parse (attoparsec items ".users/moderators/elected: ") + + +-------------------------- +-- User Timeline +-------------------------- + +-- | +timelineOnUsers ∷ [Int] → Request a "timelineOnUsers" [SE UserTimeline] +timelineOnUsers (T.intercalate ";" . map (toLazyText . decimal) → is) = + path ("users/" <> is <> "/timeline") <> + parse (attoparsec items ".users/{ids}/timeline: ") + + +-- | +meTimeline ∷ Request RequireToken "meTimeline" [SE UserTimeline] +meTimeline = path "me/timeline" <> parse (attoparsec items ".me/timeline: ") + + +-------------------------- +-- Write Permissions +-------------------------- + +-- | +writePermissions ∷ Int → Request a "writePermissions" [SE WritePermission] +writePermissions (toLazyText . decimal → i) = + path ("users/" <> i <> "/write-permissions") <> + parse (attoparsec items ".users/{id}/write-permissions: ") + + +-- | +meWritePermissions ∷ Request RequireToken "meWritePermissions" [SE WritePermission] +meWritePermissions = path "me/write-permissions" <> parse (attoparsec items ".me/write-permissions: ") + + +attoparsec ∷ (Value → Maybe b) → String → ByteString → b +attoparsec f msg request = case AP.eitherResult $ AP.parse A.json request of + Right s → case f s of + Just b → b + Nothing → throw $ SEException request ("libstackexchange" ++ msg ++ "incorrect JSON content") + Left e → throw $ SEException request ("libstackexchange" ++ msg ++ e) + + +items ∷ (Functor m, Monad m) ⇒ Value → m [SE a] +items s = SE s ^! field "items" diff --git a/src/Network/StackExchange/Auth.hs b/src/Network/StackExchange/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/StackExchange/Auth.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UnicodeSyntax #-} +-- | StackExchange authentication helpers +module Network.StackExchange.Auth + ( -- * Authentication related routines + askPermission, accessToken + ) where + +import Control.Applicative ((<$>), (*>)) +import Control.Exception (throw) +import Data.Monoid ((<>), mconcat) + +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (decodeUtf8) +import qualified Data.Attoparsec.Text.Lazy as P + +import Network.StackExchange.Response +import Network.StackExchange.Request + + +-- | Construct URI at which user should approve app +askPermission ∷ Int → Text → Request a n r +askPermission c r = host "https://stackexchange.com/oauth" <> client c <> redirectURI r + + +-- | Request access_token from StackExchange +accessToken ∷ Int → Text → Text → Text → Request a n Text +accessToken c s c' r = mconcat + [ host "https://stackexchange.com/oauth/access_token" + , client c + , secret s + , code c' + , redirectURI r + , parse parseToken + , method "POST" + ] + where + parseToken bs = case P.eitherResult $ P.parse parser (decodeUtf8 bs) of + Right t → t + Left e → throw $ SEException bs ("libstackexchange.accessToken: " ++ show e) + + parser ∷ P.Parser Text + parser = P.string "access_token=" *> (T.pack <$> P.manyTill P.anyChar (P.char '&')) diff --git a/src/Network/StackExchange/Request.hs b/src/Network/StackExchange/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/StackExchange/Request.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} +-- | StackExchange API request manipulation routines +module Network.StackExchange.Request + ( -- * Type + Request(..), Auth(..), SE(..), Object(..) + -- * Constructing requests + , host, path, method, parse + , query, token, key, site, filter, state, Scope(..), scope + , client, redirectURI, secret, code + ) where + +import Data.Monoid (Monoid(..), (<>)) +import GHC.TypeLits +import Prelude hiding (filter) + +import Control.Lens hiding (query) +import Data.ByteString.Lazy (ByteString) +import Data.Aeson (FromJSON) +import Data.Aeson.Types (Value) +import Data.Default (Default(..)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int (decimal) + + +-- | Whether to use authentication at all. Currently isn't used +data Auth = RequireToken | Ready + + +-- | SE response type +data Object = + AccessToken -- ^ + | AccountMerge -- ^ + | Answer -- ^ + | Badge -- ^ + | Comment -- ^ + | Error -- ^ + | Event -- ^ + | Filter -- ^ + | InboxItem -- ^ + | Info -- ^ + | NetworkUser -- ^ + | Notification -- ^ + | Post -- ^ + | Privilege -- ^ + | Question -- ^ + | QuestionTimeline -- ^ + | Reputation -- ^ + | ReputationHistory -- ^ + | Revision -- ^ + | Site -- ^ + | SuggestedEdit -- ^ + | Tag -- ^ + | TagScore -- ^ + | TagSynonym -- ^ + | TagWiki -- ^ + | TopTag -- ^ + | User -- ^ + | UserTimeline -- ^ + | WritePermission -- ^ + + +-- | SE response value wrapper +newtype SE (a ∷ Object) = SE { unSE ∷ Value } deriving (Show, FromJSON) + + +-- | StackExchange API Request data type. +-- +-- @a@ is a phantom type showing whether authentication is enabled +-- +-- @n@ is a phantom type dissallowing combination of +-- different API calls in one request +-- +-- @r@ is a type of parsed API call result +data Request (a ∷ Auth) (n ∷ Symbol) r = Request + { _host ∷ Text -- ^ API host link + , _path ∷ Text -- ^ API call link + , _method ∷ Text -- ^ API call method (GET/POST) + , _query ∷ Map Text Text -- ^ API call query parameters + , _parse ∷ Maybe (ByteString → r) -- ^ API call result parsing function + } + + +makeLensesFor + [ ("_host", "__host") + , ("_path", "__path") + , ("_method", "__method") + , ("_query", "__query") + , ("_parse", "__parse") + ] + ''Request + + +-- | Subject to monoid and idempotent laws, they all are checked in request test suite +instance Monoid (Request a n r) where + mempty = Request + { _host = mempty + , _path = mempty + , _method = mempty + , _query = mempty + , _parse = Nothing + } + l `mappend` r = Request + { _host = _host $ if T.null $ _host r then l else r + , _path = _path $ if T.null $ _path r then l else r + , _method = _method $ if T.null $ _method r then l else r + , _query = _query r <> _query l + , _parse = _parse $ case _parse r of Just _ → r; Nothing → l + } + + +-- | Useful if what's needed is immediate result parse +instance Functor (Request a n) where + fmap f = over __parse (fmap (f .)) + {-# INLINE fmap #-} + + +-- | Default StackExchange API request, defines only host link +instance Default (Request a n r) where + def = mempty % __host .~ "https://api.stackexchange.com/2.1" % __method .~ "GET" + {-# INLINE def #-} + + +-- | Request defining only API call host +-- +-- Primarily used in Auth, not intended for usage by library user +host ∷ Text → Request a n r +host p = mempty % __host .~ p +{-# INLINE host #-} + + +-- | Request defining only API call path +-- +-- Primarily used in API call wrappers, not intended for usage by library user +path ∷ Text → Request a n r +path p = mempty % __path .~ p +{-# INLINE path #-} + + +-- | Request defining only call method +-- +-- Primarily used in API call wrappers, not intended for usage by library user +method ∷ Text → Request a n r +method m = mempty % __method .~ m +{-# INLINE method #-} + + +-- | Request defining only API call result parsing function +-- +-- Primarily used in API call wrappers, not intended for usage by library user +parse ∷ (ByteString → r) → Request a n r +parse f = mempty % __parse ?~ f +{-# INLINE parse #-} + + +-- | Request defining only API call query parameters +-- +-- Rather low level interface. For more specific usage 'site', +-- 'filter', etc calls may be more convenient +-- +-- +-- Takes a list of (key, value) parameters such as @[("order", "asc"), ("sort", "rank")]@ +query ∷ [(Text, Text)] → Request a n r +query q = mempty % __query .~ M.fromList q +{-# INLINE query #-} + + +-- | Convert token requiring Request into ready one +token ∷ Text → Request RequireToken n r → Request Ready n r +token t = over __query (M.insert "access_token" t) +{-# INLINE token #-} + + +-- | Request defining only App key +key ∷ Text → Request a n r +key s = mempty % __query .~ M.singleton "key" s +{-# INLINE key #-} + + +-- | Request defining only API call site query parameter +site ∷ Text → Request a n r +site s = mempty % __query .~ M.singleton "site" s +{-# INLINE site #-} + + +-- | Request defining only API call filter query parameter +filter ∷ Text → Request a n r +filter f = mempty % __query .~ M.singleton "filter" f +{-# INLINE filter #-} + + +-- | Request defining only API call state query parameter +state ∷ Text → Request a n r +state s = mempty % __query .~ M.singleton "state" s +{-# INLINE state #-} + + +-- | Scope defines permission granted for application by user +data Scope = ReadInbox | NoExpiry | WriteAccess | PrivateInfo + + +-- | Request defining only API call scope query parameter +scope ∷ [Scope] → Request a n r +scope ss = mempty % __query .~ (M.singleton "scope" $ scopie ss) + where + scopie xs = T.intercalate "," . flip map xs $ \case + ReadInbox → "read_inbox" + NoExpiry → "no_expiry" + WriteAccess → "write_access" + PrivateInfo → "private_info" + + +-- | Request defining only Authentication API call application id +-- +-- Primarily used in Authentication API call wrappers, not intended for usage by library user +client ∷ Int → Request a n r +client (toLazyText . decimal → c) = mempty % __query .~ M.singleton "client_id" c +{-# INLINE client #-} + + +-- | Request defining only Authentication API call redirect url +-- +-- Primarily used in Authentication API call wrappers, not intended for usage by library user +redirectURI ∷ Text → Request a n r +redirectURI r = mempty % __query .~ M.singleton "redirect_uri" r +{-# INLINE redirectURI #-} + + +-- | Request defining only Authentication API call application secret +-- +-- Primarily used in Authentication API call wrappers, not intended for usage by library user +secret ∷ Text → Request a n r +secret c = mempty % __query .~ M.singleton "client_secret" c +{-# INLINE secret #-} + + +-- | Request defining only Authentication API call code +-- +-- Primarily used in Authentication API call wrappers, not intended for usage by library user +code ∷ Text → Request a n r +code c = mempty % __query .~ M.singleton "code" c +{-# INLINE code #-} diff --git a/src/Network/StackExchange/Response.hs b/src/Network/StackExchange/Response.hs new file mode 100644 --- /dev/null +++ b/src/Network/StackExchange/Response.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} +-- | Get response from Request and retrieve data from it +module Network.StackExchange.Response + ( -- * Schedule request + SEException(..), askSE, render + -- * Generalized combinator + , aeson + -- * Convenience functions + , field, fields + ) where + +import Control.Applicative ((<$>)) +import Control.Exception (Exception, throwIO) +import Control.Category ((>>>)) +import Control.Monad ((<=<)) +import Data.Monoid (Monoid(..)) +import Data.Typeable (Typeable) + +import Data.ByteString.Lazy (ByteString, toStrict) +import Control.Lens +import Data.Aeson (FromJSON, Value, (.:), parseJSON) +import qualified Data.Aeson.Types as A +import Data.Default (Default(..)) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Network.HTTP.Conduit as C + +import Network.StackExchange.Request + + +-- | StackExchange invalid response exception +data SEException = SEException + { _data ∷ ByteString -- ^ Recieved data + , _error ∷ String -- ^ Parser/libstackexchange errors + } deriving (Show, Typeable) + + +instance Exception SEException + + +-- | Send Request and parse response +askSE ∷ Request Ready n r → IO r +askSE (mappend def → q@Request {_method, _parse}) = do + r ← C.withManager $ \m → C.parseUrl (render q) >>= \url → + C.responseBody <$> C.httpLbs (url {C.method = toStrict $ encodeUtf8 _method}) m + case _parse of + Just f → return $ f r + Nothing → throwIO $ + SEException r "libstackexchange.askSE: no parsing function registered" + + +-- | Render Request as string for networking +render ∷ Request a n r → String +render Request {_host, _path, _query} = T.unpack $ mconcat [_host, "/", _path, "?", argie _query] + where + argie = T.intercalate "&" . M.foldrWithKey (\k v m → T.concat [k, "=", v] : m) mempty + + +-- | Generalized combinator, useful if full power of Aeson is needed +aeson ∷ Monad m ⇒ (a → A.Parser b) → Action m a b +aeson p = act $ A.parse p >>> \case + A.Success v → return v + A.Error g → fail g +{-# INLINE aeson #-} + + +-- | Select specific field in JSON +field ∷ (Monad m, FromJSON a) ⇒ Text → Action m (SE x) a +field xs = aeson ((.: xs) <=< parseJSON . unSE) +{-# INLINE field #-} + + +-- | Select specific fields of an array in JSON +fields ∷ (Monad m, FromJSON a) ⇒ Text → Action m Value [a] +fields xs = aeson $ mapM (.: xs) <=< parseJSON +{-# INLINE fields #-} diff --git a/tests/aeson-lens/Main.hs b/tests/aeson-lens/Main.hs new file mode 100644 --- /dev/null +++ b/tests/aeson-lens/Main.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} +module Main (main) where + +import System.Exit (exitFailure, exitSuccess) + +import Data.ByteString.Lazy (ByteString) +import Control.Lens +import qualified Data.Aeson as A +import Network.StackExchange.Request +import Network.StackExchange.Response +import qualified Data.Attoparsec.Lazy as AP +import Test.HUnit + +import TH (string) + + +main ∷ IO () +main = do + let AP.Done _ parsed = AP.parse A.json json + Counts { errors, failures } ← runTestTT (tests $ SE parsed) + if errors + failures == 0 then exitSuccess else exitFailure + + +json ∷ ByteString +json = [string| + { "apples": 4 + , "bananas": + { "bananas": 7 + } + , "pinapples": [4, 7] + , "peaches": + [ { "peaches": [4, 7] } + , { "peaches": [4, 7] } + ] + } +|] + + +tests ∷ SE a → Test +tests = TestList . sequence + [ testKeyLookup + , testNestedKeyLookup + , testFailedKeyLookup + , testKeysLookup + , testNestedKeysLookup + ] + where + testKeyLookup parsed = TestCase . assertEqual "key lookup" (Just 4) $ + (parsed ^! field "apples" ∷ Maybe Int) + testNestedKeyLookup parsed = TestCase . assertEqual "nested key lookup" (Just 7) $ + (parsed ^! field "bananas" . field "bananas" ∷ Maybe Int) + testFailedKeyLookup parsed = TestCase . assertEqual "failed key lookup" Nothing $ + (parsed ^! field "oranges" ∷ Maybe Int) + testKeysLookup parsed = TestCase . assertEqual "keys lookup" (Just [4,7]) $ + (parsed ^! field "pinapples" ∷ Maybe [Int]) + testNestedKeysLookup parsed = TestCase . assertEqual "nested keys lookup" (Just [4,7,4,7]) $ + (parsed ^! field "peaches" . fields "peaches" . traverse ∷ Maybe [Int]) diff --git a/tests/aeson-lens/TH.hs b/tests/aeson-lens/TH.hs new file mode 100644 --- /dev/null +++ b/tests/aeson-lens/TH.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} +module TH(string) where + +import GHC.Exts(IsString(..)) +import Language.Haskell.TH.Quote + + +string ∷ QuasiQuoter +string = QuasiQuoter + ((\a → [|fromString a|]) . filter (/= '\r')) + (error "Cannot use q as a pattern") + (error "Cannot use q as a type") + (error "Cannot use q as a dec") diff --git a/tests/request/Main.hs b/tests/request/Main.hs new file mode 100644 --- /dev/null +++ b/tests/request/Main.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main (main) where + +import Control.Applicative ((<$>), (<*>), liftA2) +import Data.Monoid ((<>), mempty) +import System.Exit (exitFailure, exitSuccess) + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Network.StackExchange.Request +import Test.QuickCheck +import Test.QuickCheck.Function + + +instance Show (a → b) where + show = const "" + + +instance Eq (a → b) where + (==) = const . const True + + +deriving instance Show (Request a i r) + + +deriving instance Eq (Request a i r) + + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + + +instance (Ord k, Arbitrary k, Arbitrary v) ⇒ Arbitrary (Map k v) where + arbitrary = M.fromList <$> arbitrary + + +instance Arbitrary (Request a i r) where + arbitrary = + Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> return Nothing + + +prop_right_id ∷ Request a i r → Bool +prop_right_id r = r <> mempty == r + + +prop_left_id ∷ Request a i r → Bool +prop_left_id r = mempty <> r == r + + +prop_associative ∷ Request a i r → Request a i r → Request a i r → Bool +prop_associative x y z = (x <> y) <> z == x <> (y <> z) + + +prop_idempotent ∷ Request a i r → Bool +prop_idempotent x = x <> x == x + + +prop_functor_id ∷ Request a i r → Bool +prop_functor_id x = fmap id x == x + + +prop_functor_composition ∷ Fun Char Int → Fun Int Char → Request a i Char → Bool +prop_functor_composition (Fun _ f) (Fun _ g) = liftA2 (==) (fmap (g . f)) (fmap g . fmap f) + + +main ∷ IO () +main = (,,,,,) <$> + (check prop_right_id) <*> + (check prop_left_id) <*> + (check prop_associative) <*> + (check prop_idempotent) <*> + (check prop_functor_id) <*> + (check prop_functor_composition) >>= \case + (True,True,True,True,True,True) → exitSuccess + _ → exitFailure + where + check p = success <$> quickCheckResult p + + success (Success {}) = True + success _ = False