github 0.14.1 → 0.15.0
raw patch · 66 files changed
+3093/−1932 lines, 66 filesdep +tlsdep −attoparsecdep ~aesondep ~basedep ~base-compat
Dependencies added: tls
Dependencies removed: attoparsec
Dependency ranges changed: aeson, base, base-compat, http-client, http-client-tls, vector, vector-instances
Files
- CHANGELOG.md +22/−0
- README.md +19/−6
- fixtures/issue-search.json +2/−0
- github.cabal +36/−9
- spec/GitHub/ActivitySpec.hs +9/−1
- spec/GitHub/CommitsSpec.hs +4/−2
- spec/GitHub/IssuesSpec.hs +38/−0
- spec/GitHub/PullRequestsSpec.hs +39/−0
- spec/GitHub/ReposSpec.hs +15/−6
- spec/GitHub/SearchSpec.hs +3/−3
- spec/GitHub/UsersSpec.hs +4/−2
- src/GitHub.hs +9/−4
- src/GitHub/Auth.hs +4/−8
- src/GitHub/Data.hs +32/−8
- src/GitHub/Data/Activities.hs +26/−0
- src/GitHub/Data/Comments.hs +26/−36
- src/GitHub/Data/Content.hs +7/−21
- src/GitHub/Data/Definitions.hs +47/−33
- src/GitHub/Data/DeployKeys.hs +52/−0
- src/GitHub/Data/Events.hs +33/−0
- src/GitHub/Data/Gists.hs +62/−73
- src/GitHub/Data/GitData.hs +210/−206
- src/GitHub/Data/Id.hs +2/−8
- src/GitHub/Data/Issues.hs +159/−231
- src/GitHub/Data/Milestone.hs +42/−0
- src/GitHub/Data/Name.hs +18/−10
- src/GitHub/Data/Options.hs +598/−0
- src/GitHub/Data/PullRequests.hs +186/−172
- src/GitHub/Data/Repos.hs +117/−126
- src/GitHub/Data/Request.hs +150/−79
- src/GitHub/Data/Search.hs +30/−40
- src/GitHub/Data/Teams.hs +145/−148
- src/GitHub/Data/URL.hs +30/−0
- src/GitHub/Data/Webhooks.hs +129/−135
- src/GitHub/Data/Webhooks/Validate.hs +14/−16
- src/GitHub/Endpoints/Activity/Events.hs +21/−0
- src/GitHub/Endpoints/Activity/Starring.hs +25/−11
- src/GitHub/Endpoints/Activity/Watching.hs +8/−7
- src/GitHub/Endpoints/Gists.hs +7/−6
- src/GitHub/Endpoints/Gists/Comments.hs +6/−6
- src/GitHub/Endpoints/GitData/Blobs.hs +3/−1
- src/GitHub/Endpoints/GitData/Commits.hs +3/−1
- src/GitHub/Endpoints/GitData/References.hs +11/−13
- src/GitHub/Endpoints/GitData/Trees.hs +4/−3
- src/GitHub/Endpoints/Issues.hs +28/−40
- src/GitHub/Endpoints/Issues/Comments.hs +10/−13
- src/GitHub/Endpoints/Issues/Events.hs +16/−16
- src/GitHub/Endpoints/Issues/Labels.hs +26/−33
- src/GitHub/Endpoints/Issues/Milestones.hs +7/−6
- src/GitHub/Endpoints/Organizations.hs +6/−5
- src/GitHub/Endpoints/Organizations/Members.hs +9/−8
- src/GitHub/Endpoints/Organizations/Teams.hs +66/−32
- src/GitHub/Endpoints/PullRequests.hs +33/−56
- src/GitHub/Endpoints/PullRequests/ReviewComments.hs +6/−5
- src/GitHub/Endpoints/Repos.hs +68/−62
- src/GitHub/Endpoints/Repos/Collaborators.hs +17/−14
- src/GitHub/Endpoints/Repos/Comments.hs +9/−8
- src/GitHub/Endpoints/Repos/Commits.hs +15/−17
- src/GitHub/Endpoints/Repos/DeployKeys.hs +70/−0
- src/GitHub/Endpoints/Repos/Forks.hs +5/−4
- src/GitHub/Endpoints/Repos/Webhooks.hs +18/−23
- src/GitHub/Endpoints/Search.hs +10/−8
- src/GitHub/Endpoints/Users.hs +6/−5
- src/GitHub/Endpoints/Users/Followers.hs +10/−8
- src/GitHub/Internal/Prelude.hs +60/−0
- src/GitHub/Request.hs +191/−138
CHANGELOG.md view
@@ -1,3 +1,25 @@+Changes for 0.15.0++- Reworked `PullRequest` (notably `pullRequestsFor`)+- Reworked PR and Issue filtering+- GHC-8.0.1 support+- Change `repoMasterBranch` to `repoDefaultBranch` in `Repo`+- Add `listTeamReposR`+- Add `myStarredAcceptStarR`+- Add `HeaderQuery` to `Request`+- Add `Hashable Auth` instance+- Add `mkUserId`, `mkUserName`, `fromUserId`, `fromOrganizationId`+- Add 'userIssuesR'+- Add 'organizationIssuesR'+- Make `teamName :: Text` amnd `teamSlug :: Name Team` in both: `Team` and `SimpleTeam`+- Refactor 'Request' structure+- Added multiple issue assignees+- Preliminary support for repository events: `repositoryEventsR`+- Support for adding repository permissions to the team+- Remove 'simpleUserType', it was always the same.++See [git commit summary](https://github.com/phadej/github/compare/v0.14.1...v0.15.0)+ Changes for 0.14.1 - Add `membersOfWithR`, `listTeamMembersR`
README.md view
@@ -2,7 +2,7 @@ ------ [](https://travis-ci.org/phadej/github)-[](http://hackage.haskell.org/package/github)+[][hackage] [](http://stackage.org/lts-5/package/github) [](http://stackage.org/nightly/package/github) @@ -37,7 +37,7 @@ Documentation ============= -For details see the reference documentation on Hackage.+For details see the reference [documentation on Hackage][hackage]. Each module lines up with the hierarchy of [documentation from the Github API](http://developer.github.com/v3/).@@ -54,15 +54,26 @@ [`samples/`](https://github.com/phadej/github/tree/master/samples) directory. ```hs-import qualified GitHub.Endpoints.Users.Followers as Github+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} +import Prelude.Compat++import Data.Text (Text, pack)+import Data.Text.IO as T (putStrLn)+import Data.Monoid ((<>))++import qualified GitHub.Endpoints.Users.Followers as GitHub++main :: IO () main = do possibleUsers <- GitHub.usersFollowing "mike-burns"- T.putStrLn $ either (("Error: " <>) . T.pack . show)- (foldMap (formatUser . (<> "\n")))+ T.putStrLn $ either (("Error: " <>) . pack . show)+ (foldMap ((<> "\n") . formatUser)) possibleUsers -formatUser = GitHub.untagName . GitHub.githubOwnerLogin+formatUser :: GitHub.SimpleUser -> Text+formatUser = GitHub.untagName . GitHub.simpleUserLogin ``` Test setup@@ -90,3 +101,5 @@ Copyright 2016 Oleg Grenrus. Available under the BSD 3-clause license.++[hackage]: http://hackage.haskell.org/package/github "Hackage"
fixtures/issue-search.json view
@@ -36,6 +36,7 @@ "state": "closed", "locked": false, "assignee": null,+ "assignees": [], "milestone": null, "comments": 0, "created_at": "2015-12-25T21:37:39Z",@@ -84,6 +85,7 @@ "state": "open", "locked": false, "assignee": null,+ "assignees": [], "milestone": null, "comments": 2, "created_at": "2015-12-01T11:09:03Z",
github.cabal view
@@ -1,5 +1,5 @@ name: github-version: 0.14.1+version: 0.15.0 synopsis: Access to the GitHub API, v3. description: The GitHub API provides programmatic access to the full@@ -25,7 +25,7 @@ copyright: Copyright 2012-2013 Mike Burns, Copyright 2013-2015 John Wiegley, Copyright 2016 Oleg Grenrus category: Network build-type: Simple-tested-with: GHC==7.8.4, GHC==7.10.2+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1 cabal-version: >=1.10 extra-source-files: README.md,@@ -49,25 +49,46 @@ default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src+ default-extensions:+ DataKinds+ DeriveDataTypeable+ DeriveGeneric+ OverloadedStrings+ ScopedTypeVariables+ other-extensions:+ CPP+ FlexibleContexts+ FlexibleInstances+ GADTs+ KindSignatures+ StandaloneDeriving exposed-modules: GitHub+ GitHub.Internal.Prelude GitHub.Auth GitHub.Data+ GitHub.Data.Activities GitHub.Data.Comments GitHub.Data.Content GitHub.Data.Definitions+ GitHub.Data.DeployKeys+ GitHub.Data.Events GitHub.Data.Gists GitHub.Data.GitData GitHub.Data.Id GitHub.Data.Issues+ GitHub.Data.Milestone GitHub.Data.Name+ GitHub.Data.Options GitHub.Data.PullRequests GitHub.Data.Repos GitHub.Data.Request GitHub.Data.Search GitHub.Data.Teams+ GitHub.Data.URL GitHub.Data.Webhooks GitHub.Data.Webhooks.Validate+ GitHub.Endpoints.Activity.Events GitHub.Endpoints.Activity.Starring GitHub.Endpoints.Activity.Watching GitHub.Endpoints.Gists@@ -92,16 +113,16 @@ GitHub.Endpoints.Repos.Commits GitHub.Endpoints.Repos.Forks GitHub.Endpoints.Repos.Webhooks+ GitHub.Endpoints.Repos.DeployKeys GitHub.Endpoints.Search GitHub.Endpoints.Users GitHub.Endpoints.Users.Followers GitHub.Request -- Packages needed in order to build this package.- build-depends: base >= 4.7 && <4.9,- aeson >=0.7.0.6 && <0.11,- attoparsec >=0.11.3.4 && <0.14,- base-compat >=0.6.0 && <0.10,+ build-depends: base >=4.7 && <4.10,+ aeson >=0.7.0.6 && <1.1,+ base-compat >=0.9.1 && <0.10, base16-bytestring >=0.1.1.6 && <0.2, binary >=0.7.1.0 && <0.9, binary-orphans >=0.1.0.0 && <0.2,@@ -113,8 +134,8 @@ deepseq-generics >=0.1.1.2 && <0.3, exceptions >=0.8.0.2 && <0.9, hashable >=1.2.3.3 && <1.3,- http-client >=0.4.8.1 && <0.5,- http-client-tls >=0.2.2 && <0.3,+ http-client >=0.4.8.1 && <0.6,+ http-client-tls >=0.2.2 && <0.4, http-link-header >=1.0.1 && <1.1, http-types >=0.8.6 && <0.10, iso8601-time >=0.1.4 && <0.2,@@ -127,8 +148,10 @@ transformers-compat >=0.4.0.3 && <0.6, unordered-containers >=0.2 && <0.3, vector >=0.10.12.3 && <0.12,- vector-instances >=3.3.0.1 && <3.4+ vector-instances >=3.3.0.1 && <3.4, + tls >=1.3.5+ if flag(aeson-compat) build-depends: aeson-compat >=0.3.0.0 && <0.4 else@@ -138,10 +161,14 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: spec+ other-extensions:+ TemplateHaskell other-modules: GitHub.ActivitySpec GitHub.CommitsSpec GitHub.OrganizationsSpec+ GitHub.IssuesSpec+ GitHub.PullRequestsSpec GitHub.ReposSpec GitHub.SearchSpec GitHub.UsersSpec
spec/GitHub/ActivitySpec.hs view
@@ -2,7 +2,10 @@ {-# LANGUAGE TemplateHaskell #-} module GitHub.ActivitySpec where +import qualified GitHub+ import GitHub.Auth (Auth (..))+import GitHub.Endpoints.Activity.Starring (myStarredAcceptStarR) import GitHub.Endpoints.Activity.Watching (watchersForR) import GitHub.Request (executeRequest) @@ -28,6 +31,11 @@ spec = do describe "watchersForR" $ do it "works" $ withAuth $ \auth -> do- cs <- executeRequest auth $ watchersForR "phadej" "github" Nothing+ cs <- executeRequest auth $ watchersForR "phadej" "github" GitHub.FetchAll cs `shouldSatisfy` isRight V.length (fromRightS cs) `shouldSatisfy` (> 10)+ describe "myStarredR" $ do+ it "works" $ withAuth $ \auth -> do+ cs <- executeRequest auth $ myStarredAcceptStarR (GitHub.FetchAtLeast 31)+ cs `shouldSatisfy` isRight+ fromRightS cs `shouldSatisfy` (\xs -> V.length xs > 30)
spec/GitHub/CommitsSpec.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE TemplateHaskell #-} module GitHub.CommitsSpec where +import qualified GitHub+ import GitHub.Auth (Auth (..)) import GitHub.Endpoints.Repos.Commits (Commit, commitSha, commitsFor', commitsForR, diffR, mkName)@@ -39,7 +41,7 @@ -- Page size is 30, so we get 60 commits it "limits the response" $ withAuth $ \auth -> do- cs <- executeRequest auth $ commitsForR "phadej" "github" (Just 40)+ cs <- executeRequest auth $ commitsForR "phadej" "github" (GitHub.FetchAtLeast 40) cs `shouldSatisfy` isRight let cs' = fromRightS cs V.length cs' `shouldSatisfy` (< 70)@@ -48,7 +50,7 @@ describe "diff" $ do it "works" $ withAuth $ \auth -> do- cs <- executeRequest auth $ commitsForR "phadej" "github" (Just 30)+ cs <- executeRequest auth $ commitsForR "phadej" "github" (GitHub.FetchAtLeast 30) cs `shouldSatisfy` isRight let commits = take 10 . V.toList . fromRightS $ cs let pairs = zip commits $ drop 1 commits
+ spec/GitHub/IssuesSpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}+module GitHub.IssuesSpec where++import qualified GitHub++import Prelude ()+import Prelude.Compat++import Data.Either.Compat (isRight)+import Data.Foldable (for_)+import Data.String (fromString)+import System.Environment (lookupEnv)+import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy)++fromRightS :: Show a => Either a b -> b+fromRightS (Right b) = b+fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a++withAuth :: (GitHub.Auth -> IO ()) -> IO ()+withAuth action = do+ mtoken <- lookupEnv "GITHUB_TOKEN"+ case mtoken of+ Nothing -> pendingWith "no GITHUB_TOKEN"+ Just token -> action (GitHub.OAuth $ fromString token)++spec :: Spec+spec = do+ describe "issuesForRepoR" $ do+ it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do+ cs <- GitHub.executeRequest auth $+ GitHub.issuesForRepoR owner repo mempty GitHub.FetchAll + cs `shouldSatisfy` isRight+ where+ repos =+ [ ("thoughtbot", "paperclip")+ , ("phadej", "github")+ , ("haskell", "cabal")+ ]
+ spec/GitHub/PullRequestsSpec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+module GitHub.PullRequestsSpec where++import qualified GitHub++import Prelude ()+import Prelude.Compat++import Data.Either.Compat (isRight)+import Data.Foldable (for_)+import Data.String (fromString)+import System.Environment (lookupEnv)+import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy)++fromRightS :: Show a => Either a b -> b+fromRightS (Right b) = b+fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a++withAuth :: (GitHub.Auth -> IO ()) -> IO ()+withAuth action = do+ mtoken <- lookupEnv "GITHUB_TOKEN"+ case mtoken of+ Nothing -> pendingWith "no GITHUB_TOKEN"+ Just token -> action (GitHub.OAuth $ fromString token)++spec :: Spec+spec = do+ describe "pullRequestsForR" $ do+ it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do+ cs <- GitHub.executeRequest auth $+ GitHub.pullRequestsForR owner repo opts GitHub.FetchAll + cs `shouldSatisfy` isRight+ where+ repos =+ [ ("thoughtbot", "paperclip")+ , ("phadej", "github")+ , ("haskell", "cabal")+ ]+ opts = GitHub.stateClosed
spec/GitHub/ReposSpec.hs view
@@ -2,14 +2,15 @@ {-# LANGUAGE TemplateHaskell #-} module GitHub.ReposSpec where -import GitHub.Auth (Auth (..))-import GitHub.Endpoints.Repos (RepoPublicity (..), currentUserRepos,- languagesFor', userRepos')+import GitHub (Auth (..), Repo (..), RepoPublicity (..),+ executeRequest, repositoryR)+import GitHub.Endpoints.Repos (currentUserRepos, languagesFor', userRepos') import Data.Either.Compat (isRight) import Data.String (fromString) import System.Environment (lookupEnv)-import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy)+import Test.Hspec (Spec, describe, it, pendingWith, shouldBe,+ shouldSatisfy) import qualified Data.HashMap.Strict as HM @@ -26,14 +27,22 @@ spec :: Spec spec = do+ describe "repositoryR" $ do+ it "works" $ withAuth $ \auth -> do+ er <- executeRequest auth $ repositoryR "phadej" "github"+ er `shouldSatisfy` isRight+ let Right r = er+ -- https://github.com/phadej/github/pull/219+ repoDefaultBranch r `shouldBe` Just "master"+ describe "currentUserRepos" $ do it "works" $ withAuth $ \auth -> do- cs <- currentUserRepos auth RepoPublicityAll+ cs <- currentUserRepos auth RepoPublicityAll cs `shouldSatisfy` isRight describe "userRepos" $ do it "works" $ withAuth $ \auth -> do- cs <- userRepos' (Just auth) "phadej" RepoPublicityAll+ cs <- userRepos' (Just auth) "phadej" RepoPublicityAll cs `shouldSatisfy` isRight describe "languagesFor'" $ do
spec/GitHub/SearchSpec.hs view
@@ -14,7 +14,7 @@ import qualified Data.Vector as V -import GitHub.Data (Auth (..), Issue (..), mkId)+import GitHub.Data (Auth (..), Issue (..), mkId, IssueState (..)) import GitHub.Endpoints.Search (SearchResult (..), searchIssues') fromRightS :: Show a => Either a b -> b@@ -42,13 +42,13 @@ issueId issue1 `shouldBe` mkId (Proxy :: Proxy Issue) 123898390 issueNumber issue1 `shouldBe` 130 issueTitle issue1 `shouldBe` "Make test runner more robust"- issueState issue1 `shouldBe` "closed"+ issueState issue1 `shouldBe` StateClosed let issue2 = issues V.! 1 issueId issue2 `shouldBe` mkId (Proxy :: Proxy Issue) 119694665 issueNumber issue2 `shouldBe` 127 issueTitle issue2 `shouldBe` "Decouple request creation from execution"- issueState issue2 `shouldBe` "open"+ issueState issue2 `shouldBe` StateOpen it "performs an issue search via the API" $ withAuth $ \auth -> do let query = "Decouple in:title repo:phadej/github created:<=2015-12-01"
spec/GitHub/UsersSpec.hs view
@@ -10,6 +10,8 @@ import Test.Hspec (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) +import qualified GitHub+ import GitHub.Data (Auth (..), Organization (..), User (..), fromOwner) import GitHub.Endpoints.Users (ownerInfoForR, userInfoCurrent',@@ -67,10 +69,10 @@ describe "usersFollowing" $ do it "works" $ withAuth $ \auth -> do- us <- executeRequest auth $ usersFollowingR "phadej" (Just 10)+ us <- executeRequest auth $ usersFollowingR "phadej" (GitHub.FetchAtLeast 10) us `shouldSatisfy` isRight describe "usersFollowedBy" $ do it "works" $ withAuth $ \auth -> do- us <- executeRequest auth $ usersFollowedByR "phadej" (Just 10)+ us <- executeRequest auth $ usersFollowedByR "phadej" (GitHub.FetchAtLeast 10) us `shouldSatisfy` isRight
src/GitHub.hs view
@@ -15,6 +15,10 @@ -- * Activity -- | See <https://developer.github.com/v3/activity/> + -- ** Events+ -- | See https://developer.github.com/v3/activity/events/#events+ repositoryEventsR,+ -- ** Starring -- | See <https://developer.github.com/v3/activity/starring/> --@@ -26,6 +30,7 @@ stargazersForR, reposStarredByR, myStarredR,+ myStarredAcceptStarR, -- ** Watching -- | See <https://developer.github.com/v3/activity/>@@ -91,9 +96,8 @@ -- * Issues -- | See <https://developer.github.com/v3/issues/> --- -- Missing endpoints:- --- -- * List issues+ currentUserIssuesR,+ organizationIssuesR, issueR, issuesForRepoR, createIssueR,@@ -168,7 +172,6 @@ -- * Query team member (deprecated) -- * Add team member (deprecated) -- * Remove team member (deprecated)- -- * List team repos -- * Check if a team manages a repository -- * Add team repository -- * Remove team repository@@ -178,6 +181,7 @@ editTeamR, deleteTeamR, listTeamMembersR,+ listTeamReposR, teamMembershipInfoForR, addTeamMembershipForR, deleteTeamMembershipForR,@@ -306,6 +310,7 @@ ) where import GitHub.Data+import GitHub.Endpoints.Activity.Events import GitHub.Endpoints.Activity.Starring import GitHub.Endpoints.Activity.Watching import GitHub.Endpoints.Gists
src/GitHub/Auth.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -7,11 +5,8 @@ -- module GitHub.Auth where -import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Binary (Binary)-import Data.Data (Data, Typeable)-import GHC.Generics (Generic)+import GitHub.Internal.Prelude+import Prelude () import qualified Data.ByteString as BS @@ -21,10 +16,11 @@ data Auth = BasicAuth BS.ByteString BS.ByteString | OAuth Token -- ^ token- | EnterpriseOAuth String -- custom API endpoint without+ | EnterpriseOAuth Text -- custom API endpoint without -- trailing slash Token -- token deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Auth where rnf = genericRnf instance Binary Auth+instance Hashable Auth
src/GitHub/Data.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -14,6 +12,7 @@ mkName, untagName, mkOwnerName,+ mkUserName, mkTeamName, mkOrganizationName, mkRepoName,@@ -24,44 +23,57 @@ mkId, untagId, mkOwnerId,+ mkUserId, mkTeamId, mkOrganizationId, mkRepoId,+ fromUserId,+ fromOrganizationId, -- * Module re-exports module GitHub.Auth,+ module GitHub.Data.Activities, module GitHub.Data.Comments, module GitHub.Data.Content, module GitHub.Data.Definitions,+ module GitHub.Data.DeployKeys,+ module GitHub.Data.Events, module GitHub.Data.Gists, module GitHub.Data.GitData, module GitHub.Data.Issues,+ module GitHub.Data.Milestone,+ module GitHub.Data.Options, module GitHub.Data.PullRequests, module GitHub.Data.Repos, module GitHub.Data.Request, module GitHub.Data.Search, module GitHub.Data.Teams,- module GitHub.Data.Webhooks,+ module GitHub.Data.URL,+ module GitHub.Data.Webhooks ) where -import Prelude ()-import Prelude.Compat--import Data.Text (Text)+import GitHub.Internal.Prelude+import Prelude () import GitHub.Auth+import GitHub.Data.Activities import GitHub.Data.Comments import GitHub.Data.Content import GitHub.Data.Definitions+import GitHub.Data.DeployKeys+import GitHub.Data.Events import GitHub.Data.Gists import GitHub.Data.GitData import GitHub.Data.Id import GitHub.Data.Issues+import GitHub.Data.Milestone import GitHub.Data.Name+import GitHub.Data.Options import GitHub.Data.PullRequests import GitHub.Data.Repos import GitHub.Data.Request import GitHub.Data.Search import GitHub.Data.Teams+import GitHub.Data.URL import GitHub.Data.Webhooks mkOwnerId :: Int -> Id Owner@@ -70,6 +82,12 @@ mkOwnerName :: Text -> Name Owner mkOwnerName = N +mkUserId :: Int -> Id User+mkUserId = Id++mkUserName :: Text -> Name User+mkUserName = N+ mkTeamId :: Int -> Id Team mkTeamId = Id @@ -93,3 +111,9 @@ fromUserName :: Name User -> Name Owner fromUserName = N . untagName++fromOrganizationId :: Id Organization -> Id Owner+fromOrganizationId = Id . untagId++fromUserId :: Id User -> Id Owner+fromUserId = Id . untagId
+ src/GitHub/Data/Activities.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- License : BSD-3-Clause+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+module GitHub.Data.Activities where++import GitHub.Data.Repos (Repo)+import GitHub.Internal.Prelude+import Prelude ()++data RepoStarred = RepoStarred+ { repoStarredStarredAt :: !UTCTime+ , repoStarredRepo :: !Repo+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic)++instance NFData RepoStarred where rnf = genericRnf+instance Binary RepoStarred++-- JSON Instances+instance FromJSON RepoStarred where+ parseJSON = withObject "RepoStarred" $ \o -> RepoStarred+ <$> o .: "starred_at"+ <*> o .: "repo"+
src/GitHub/Data/Comments.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,35 +5,26 @@ -- module GitHub.Data.Comments where -import Prelude ()-import Prelude.Compat--import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), ToJSON (..), object, withObject,- (.:), (.:?), (.=))-import Data.Binary.Orphans (Binary)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import Data.Time (UTCTime)-import GHC.Generics (Generic)- import GitHub.Data.Definitions-import GitHub.Data.Id+import GitHub.Data.Id (Id)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude () -data Comment = Comment {- commentPosition :: !(Maybe Int)- ,commentLine :: !(Maybe Int)- ,commentBody :: !Text- ,commentCommitId :: !(Maybe Text)- ,commentUpdatedAt :: !UTCTime- ,commentHtmlUrl :: !(Maybe Text)- ,commentUrl :: !Text- ,commentCreatedAt :: !(Maybe UTCTime)- ,commentPath :: !(Maybe Text)- ,commentUser :: !SimpleUser- ,commentId :: !(Id Comment)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Comment = Comment+ { commentPosition :: !(Maybe Int)+ , commentLine :: !(Maybe Int)+ , commentBody :: !Text+ , commentCommitId :: !(Maybe Text)+ , commentUpdatedAt :: !UTCTime+ , commentHtmlUrl :: !(Maybe URL)+ , commentUrl :: !URL+ , commentCreatedAt :: !(Maybe UTCTime)+ , commentPath :: !(Maybe Text)+ , commentUser :: !SimpleUser+ , commentId :: !(Id Comment)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Comment where rnf = genericRnf instance Binary Comment@@ -55,9 +43,10 @@ <*> o .: "user" <*> o .: "id" -data NewComment = NewComment {- newCommentBody :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data NewComment = NewComment+ { newCommentBody :: !Text+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData NewComment where rnf = genericRnf instance Binary NewComment@@ -65,9 +54,10 @@ instance ToJSON NewComment where toJSON (NewComment b) = object [ "body" .= b ] -data EditComment = EditComment {- editCommentBody :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data EditComment = EditComment+ { editCommentBody :: !Text+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData EditComment where rnf = genericRnf instance Binary EditComment
src/GitHub/Data/Content.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,20 +5,9 @@ -- module GitHub.Data.Content where -import Prelude ()-import Prelude.Compat--import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), Value (..), withObject,- withText, (.:))-import Data.Binary.Orphans (Binary)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import Data.Vector (Vector)-import GHC.Generics (Generic)--import qualified Data.Text as T+import GitHub.Data.URL+import GitHub.Internal.Prelude+import Prelude () data Content = ContentFile !ContentFileData@@ -61,9 +47,9 @@ contentName :: !Text ,contentPath :: !Text ,contentSha :: !Text- ,contentUrl :: !Text- ,contentGitUrl :: !Text- ,contentHtmlUrl :: !Text+ ,contentUrl :: !URL+ ,contentGitUrl :: !URL+ ,contentHtmlUrl :: !URL } deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData ContentInfo where rnf = genericRnf@@ -91,7 +77,7 @@ case t of "file" -> return ItemFile "dir" -> return ItemDir- _ -> fail $ "Invalid ContentItemType: " ++ T.unpack t+ _ -> fail $ "Invalid ContentItemType: " ++ unpack t instance FromJSON ContentInfo where parseJSON = withObject "ContentInfo" $ \o ->
src/GitHub/Data/Definitions.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,27 +5,20 @@ -- module GitHub.Data.Definitions where -import Prelude ()-import Prelude.Compat+import GitHub.Internal.Prelude+import Prelude () -import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Control.Monad (mfilter)-import Data.Aeson.Compat (FromJSON (..), Object, withObject, withText,- (.:), (.:?))-import Data.Aeson.Types (Parser)-import Data.Binary.Orphans (Binary)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import Data.Time (UTCTime)-import GHC.Generics (Generic)-import Network.HTTP.Client (HttpException)+import Control.Monad (mfilter)+import Data.Aeson.Types (Parser)+import Network.HTTP.Client (HttpException) import qualified Control.Exception as E+import qualified Data.ByteString as BS import qualified Data.Text as T -import GitHub.Data.Id-import GitHub.Data.Name+import GitHub.Data.Id (Id)+import GitHub.Data.Name (Name)+import GitHub.Data.URL (URL) -- | Errors have been tagged according to their source, so you can more easily -- dispatch and handle them.@@ -51,9 +41,8 @@ data SimpleUser = SimpleUser { simpleUserId :: !(Id User) , simpleUserLogin :: !(Name User)- , simpleUserAvatarUrl :: !Text- , simpleUserUrl :: !Text- , simpleUserType :: !OwnerType -- ^ Should always be 'OwnerUser'+ , simpleUserAvatarUrl :: !URL+ , simpleUserUrl :: !URL } deriving (Show, Data, Typeable, Eq, Ord, Generic) @@ -63,8 +52,8 @@ data SimpleOrganization = SimpleOrganization { simpleOrganizationId :: !(Id Organization) , simpleOrganizationLogin :: !(Name Organization)- , simpleOrganizationUrl :: !Text- , simpleOrganizationAvatarUrl :: !Text+ , simpleOrganizationUrl :: !URL+ , simpleOrganizationAvatarUrl :: !URL } deriving (Show, Data, Typeable, Eq, Ord, Generic) @@ -75,8 +64,8 @@ data SimpleOwner = SimpleOwner { simpleOwnerId :: !(Id Owner) , simpleOwnerLogin :: !(Name Owner)- , simpleOwnerUrl :: !Text- , simpleOwnerAvatarUrl :: !Text+ , simpleOwnerUrl :: !URL+ , simpleOwnerAvatarUrl :: !URL , simpleOwnerType :: !OwnerType } deriving (Show, Data, Typeable, Eq, Ord, Generic)@@ -91,7 +80,7 @@ , userType :: !OwnerType -- ^ Should always be 'OwnerUser' , userCreatedAt :: !UTCTime , userPublicGists :: !Int- , userAvatarUrl :: !Text+ , userAvatarUrl :: !URL , userFollowers :: !Int , userFollowing :: !Int , userHireable :: !(Maybe Bool)@@ -101,8 +90,8 @@ , userLocation :: !(Maybe Text) , userCompany :: !(Maybe Text) , userEmail :: !(Maybe Text)- , userUrl :: !Text- , userHtmlUrl :: !Text+ , userUrl :: !URL+ , userHtmlUrl :: !URL } deriving (Show, Data, Typeable, Eq, Ord, Generic) @@ -118,13 +107,13 @@ , organizationLocation :: !(Maybe Text) , organizationFollowers :: !Int , organizationCompany :: !(Maybe Text)- , organizationAvatarUrl :: !Text+ , organizationAvatarUrl :: !URL , organizationPublicGists :: !Int- , organizationHtmlUrl :: !Text+ , organizationHtmlUrl :: !URL , organizationEmail :: !(Maybe Text) , organizationFollowing :: !Int , organizationPublicRepos :: !Int- , organizationUrl :: !Text+ , organizationUrl :: !URL , organizationCreatedAt :: !UTCTime } deriving (Show, Data, Typeable, Eq, Ord, Generic)@@ -158,7 +147,6 @@ <*> obj .: "login" <*> obj .: "avatar_url" <*> obj .: "url"- <*> obj .: "type" instance FromJSON SimpleOrganization where parseJSON = withObject "SimpleOrganization" $ \obj ->@@ -242,3 +230,29 @@ | OrgMemberRoleAdmin -- ^ Organization owners. | OrgMemberRoleMember -- ^ Non-owner organization members. deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic)++-- | Request query string+type QueryString = [(BS.ByteString, Maybe BS.ByteString)]++-- | Count of elements+type Count = Int++-------------------------------------------------------------------------------+-- IssueLabel+-------------------------------------------------------------------------------++data IssueLabel = IssueLabel+ { labelColor :: !Text+ , labelUrl :: !URL+ , labelName :: !(Name IssueLabel)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic)++instance NFData IssueLabel where rnf = genericRnf+instance Binary IssueLabel++instance FromJSON IssueLabel where+ parseJSON = withObject "IssueLabel" $ \o -> IssueLabel+ <$> o .: "color"+ <*> o .: "url"+ <*> o .: "name"
+ src/GitHub/Data/DeployKeys.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- License : BSD-3-Clause+-- Maintainer : Todd Mohney <toddmohney@gmail.com>+--+module GitHub.Data.DeployKeys where++import GitHub.Data.Id (Id)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude ()++data RepoDeployKey = RepoDeployKey+ { repoDeployKeyId :: !(Id RepoDeployKey)+ , repoDeployKeyKey :: !Text+ , repoDeployKeyUrl :: !URL+ , repoDeployKeyTitle :: !Text+ , repoDeployKeyVerified :: !Bool+ , repoDeployKeyCreatedAt :: !UTCTime+ , repoDeployKeyReadOnly :: !Bool+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic)++instance FromJSON RepoDeployKey where+ parseJSON = withObject "RepoDeployKey" $ \o -> RepoDeployKey+ <$> o .: "id"+ <*> o .: "key"+ <*> o .: "url"+ <*> o .: "title"+ <*> o .: "verified"+ <*> o .: "created_at"+ <*> o .: "read_only"++data NewRepoDeployKey = NewRepoDeployKey+ { newRepoDeployKeyKey :: !Text+ , newRepoDeployKeyTitle :: !Text+ , newRepoDeployKeyReadOnly :: !Bool+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic)++instance ToJSON NewRepoDeployKey where+ toJSON (NewRepoDeployKey key title readOnly) = object+ [ "key" .= key+ , "title" .= title+ , "read_only" .= readOnly+ ]++instance FromJSON NewRepoDeployKey where+ parseJSON = withObject "RepoDeployKey" $ \o -> NewRepoDeployKey+ <$> o .: "key"+ <*> o .: "title"+ <*> o .: "read_only"
+ src/GitHub/Data/Events.hs view
@@ -0,0 +1,33 @@+-----------------------------------------------------------------------------+-- |+-- License : BSD-3-Clause+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+module GitHub.Data.Events where++import GitHub.Data.Definitions+import GitHub.Internal.Prelude+import Prelude ()++-- | Events.+--+-- /TODO:/+--+-- * missing repo, org, payload, id+data Event = Event+ -- { eventId :: !(Id Event) -- id can be encoded as string.+ { eventActor :: !SimpleUser+ , eventCreatedAt :: !UTCTime+ , eventPublic :: !Bool+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic)++instance NFData Event where rnf = genericRnf+instance Binary Event ++instance FromJSON Event where+ parseJSON = withObject "Event" $ \obj -> Event + -- <$> obj .: "id"+ <$> obj .: "actor"+ <*> obj .: "created_at"+ <*> obj .: "public"
src/GitHub/Data/Gists.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,95 +5,87 @@ -- module GitHub.Data.Gists where -import Prelude ()-import Prelude.Compat- import GitHub.Data.Definitions import GitHub.Data.Id (Id) import GitHub.Data.Name (Name) import GitHub.Data.Repos (Language)--import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), withObject, (.:), (.:?))-import Data.Binary (Binary)-import Data.Data (Data, Typeable)-import Data.HashMap.Strict (HashMap)-import Data.Text (Text)-import Data.Time (UTCTime)-import GHC.Generics (Generic)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude () -data Gist = Gist {- gistUser :: !SimpleUser- ,gistGitPushUrl :: !Text- ,gistUrl :: !Text- ,gistDescription :: !(Maybe Text)- ,gistCreatedAt :: !UTCTime- ,gistPublic :: !Bool- ,gistComments :: !Int- ,gistUpdatedAt :: !UTCTime- ,gistHtmlUrl :: !Text- ,gistId :: !(Name Gist)- ,gistFiles :: !(HashMap Text GistFile)- ,gistGitPullUrl :: !Text-} deriving (Show, Data, Typeable, Eq, Generic)+data Gist = Gist+ { gistUser :: !SimpleUser+ , gistGitPushUrl :: !URL+ , gistUrl :: !URL+ , gistDescription :: !(Maybe Text)+ , gistCreatedAt :: !UTCTime+ , gistPublic :: !Bool+ , gistComments :: !Int+ , gistUpdatedAt :: !UTCTime+ , gistHtmlUrl :: !URL+ , gistId :: !(Name Gist)+ , gistFiles :: !(HashMap Text GistFile)+ , gistGitPullUrl :: !URL+ } deriving (Show, Data, Typeable, Eq, Generic) instance NFData Gist where rnf = genericRnf instance Binary Gist instance FromJSON Gist where- parseJSON = withObject "Gist" $ \o ->- Gist <$> o .: "owner"- <*> o .: "git_push_url"- <*> o .: "url"- <*> o .:? "description"- <*> o .: "created_at"- <*> o .: "public"- <*> o .: "comments"- <*> o .: "updated_at"- <*> o .: "html_url"- <*> o .: "id"- <*> o .: "files"- <*> o .: "git_push_url"+ parseJSON = withObject "Gist" $ \o -> Gist+ <$> o .: "owner"+ <*> o .: "git_push_url"+ <*> o .: "url"+ <*> o .:? "description"+ <*> o .: "created_at"+ <*> o .: "public"+ <*> o .: "comments"+ <*> o .: "updated_at"+ <*> o .: "html_url"+ <*> o .: "id"+ <*> o .: "files"+ <*> o .: "git_push_url" -data GistFile = GistFile {- gistFileType :: !Text- ,gistFileRawUrl :: !Text- ,gistFileSize :: !Int- ,gistFileLanguage :: !(Maybe Language)- ,gistFileFilename :: !Text- ,gistFileContent :: !(Maybe Text)-} deriving (Show, Data, Typeable, Eq, Generic)+data GistFile = GistFile+ { gistFileType :: !Text+ , gistFileRawUrl :: !URL+ , gistFileSize :: !Int+ , gistFileLanguage :: !(Maybe Language)+ , gistFileFilename :: !Text+ , gistFileContent :: !(Maybe Text)+ }+ deriving (Show, Data, Typeable, Eq, Generic) instance NFData GistFile where rnf = genericRnf instance Binary GistFile instance FromJSON GistFile where- parseJSON = withObject "GistFile" $ \o ->- GistFile <$> o .: "type"- <*> o .: "raw_url"- <*> o .: "size"- <*> o .:? "language"- <*> o .: "filename"- <*> o .:? "content"+ parseJSON = withObject "GistFile" $ \o -> GistFile+ <$> o .: "type"+ <*> o .: "raw_url"+ <*> o .: "size"+ <*> o .:? "language"+ <*> o .: "filename"+ <*> o .:? "content" -data GistComment = GistComment {- gistCommentUser :: !SimpleUser- ,gistCommentUrl :: !Text- ,gistCommentCreatedAt :: !UTCTime- ,gistCommentBody :: !Text- ,gistCommentUpdatedAt :: !UTCTime- ,gistCommentId :: !(Id GistComment)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data GistComment = GistComment+ { gistCommentUser :: !SimpleUser+ , gistCommentUrl :: !URL+ , gistCommentCreatedAt :: !UTCTime+ , gistCommentBody :: !Text+ , gistCommentUpdatedAt :: !UTCTime+ , gistCommentId :: !(Id GistComment)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData GistComment where rnf = genericRnf instance Binary GistComment instance FromJSON GistComment where- parseJSON = withObject "GistComment" $ \o ->- GistComment <$> o .: "user"- <*> o .: "url"- <*> o .: "created_at"- <*> o .: "body"- <*> o .: "updated_at"- <*> o .: "id"+ parseJSON = withObject "GistComment" $ \o -> GistComment+ <$> o .: "user"+ <*> o .: "url"+ <*> o .: "created_at"+ <*> o .: "body"+ <*> o .: "updated_at"+ <*> o .: "id"
src/GitHub/Data/GitData.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,191 +5,196 @@ -- module GitHub.Data.GitData where -import Prelude ()-import Prelude.Compat- import GitHub.Data.Definitions import GitHub.Data.Name (Name)--import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), ToJSON (..), object, withObject,- (.!=), (.:), (.:?), (.=))-import Data.Binary (Binary)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import Data.Time (UTCTime)-import Data.Vector (Vector)-import GHC.Generics (Generic)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude () import qualified Data.Vector as V -- | The options for querying commits.-data CommitQueryOption = CommitQuerySha !Text- | CommitQueryPath !Text- | CommitQueryAuthor !Text- | CommitQuerySince !UTCTime- | CommitQueryUntil !UTCTime- deriving (Show, Eq, Ord, Generic, Typeable, Data)+data CommitQueryOption+ = CommitQuerySha !Text+ | CommitQueryPath !Text+ | CommitQueryAuthor !Text+ | CommitQuerySince !UTCTime+ | CommitQueryUntil !UTCTime+ deriving (Show, Eq, Ord, Generic, Typeable, Data) -data Stats = Stats {- statsAdditions :: !Int- ,statsTotal :: !Int- ,statsDeletions :: !Int-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Stats = Stats+ { statsAdditions :: !Int+ , statsTotal :: !Int+ , statsDeletions :: !Int+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Stats where rnf = genericRnf instance Binary Stats -data Commit = Commit {- commitSha :: !(Name Commit)- ,commitParents :: !(Vector Tree)- ,commitUrl :: !Text- ,commitGitCommit :: !GitCommit- ,commitCommitter :: !(Maybe SimpleUser)- ,commitAuthor :: !(Maybe SimpleUser)- ,commitFiles :: !(Vector File)- ,commitStats :: !(Maybe Stats)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Commit = Commit+ { commitSha :: !(Name Commit)+ , commitParents :: !(Vector Tree)+ , commitUrl :: !URL+ , commitGitCommit :: !GitCommit+ , commitCommitter :: !(Maybe SimpleUser)+ , commitAuthor :: !(Maybe SimpleUser)+ , commitFiles :: !(Vector File)+ , commitStats :: !(Maybe Stats)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Commit where rnf = genericRnf instance Binary Commit -data Tree = Tree {- treeSha :: !(Name Tree)- ,treeUrl :: !Text- ,treeGitTrees :: !(Vector GitTree)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Tree = Tree+ { treeSha :: !(Name Tree)+ , treeUrl :: !URL+ , treeGitTrees :: !(Vector GitTree)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Tree where rnf = genericRnf instance Binary Tree -data GitTree = GitTree {- gitTreeType :: !Text- ,gitTreeSha :: !(Name GitTree)- -- Can be empty for submodule- ,gitTreeUrl :: !(Maybe Text)- ,gitTreeSize :: !(Maybe Int)- ,gitTreePath :: !Text- ,gitTreeMode :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data GitTree = GitTree+ { gitTreeType :: !Text+ , gitTreeSha :: !(Name GitTree)+ -- Can be empty for submodule+ , gitTreeUrl :: !(Maybe URL)+ , gitTreeSize :: !(Maybe Int)+ , gitTreePath :: !Text+ , gitTreeMode :: !Text+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData GitTree where rnf = genericRnf instance Binary GitTree -data GitCommit = GitCommit {- gitCommitMessage :: !Text- ,gitCommitUrl :: !Text- ,gitCommitCommitter :: !GitUser- ,gitCommitAuthor :: !GitUser- ,gitCommitTree :: !Tree- ,gitCommitSha :: !(Maybe (Name GitCommit))- ,gitCommitParents :: !(Vector Tree)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data GitCommit = GitCommit+ { gitCommitMessage :: !Text+ , gitCommitUrl :: !URL+ , gitCommitCommitter :: !GitUser+ , gitCommitAuthor :: !GitUser+ , gitCommitTree :: !Tree+ , gitCommitSha :: !(Maybe (Name GitCommit))+ , gitCommitParents :: !(Vector Tree)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData GitCommit where rnf = genericRnf instance Binary GitCommit -data Blob = Blob {- blobUrl :: !Text- ,blobEncoding :: !Text- ,blobContent :: !Text- ,blobSha :: !(Name Blob)- ,blobSize :: !Int-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Blob = Blob+ { blobUrl :: !URL+ , blobEncoding :: !Text+ , blobContent :: !Text+ , blobSha :: !(Name Blob)+ , blobSize :: !Int+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Blob where rnf = genericRnf instance Binary Blob -data Tag = Tag {- tagName :: !Text- ,tagZipballUrl :: !Text- ,tagTarballUrl :: !Text- ,tagCommit :: !BranchCommit-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Tag = Tag+ { tagName :: !Text+ , tagZipballUrl :: !URL+ , tagTarballUrl :: !URL+ , tagCommit :: !BranchCommit+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Tag where rnf = genericRnf instance Binary Tag -data Branch = Branch {- branchName :: !Text- ,branchCommit :: !BranchCommit-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Branch = Branch+ { branchName :: !Text+ , branchCommit :: !BranchCommit+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Branch where rnf = genericRnf -data BranchCommit = BranchCommit {- branchCommitSha :: !Text- ,branchCommitUrl :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data BranchCommit = BranchCommit+ { branchCommitSha :: !Text+ , branchCommitUrl :: !URL+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData BranchCommit where rnf = genericRnf instance Binary BranchCommit -data Diff = Diff {- diffStatus :: !Text- ,diffBehindBy :: !Int- ,diffPatchUrl :: !Text- ,diffUrl :: !Text- ,diffBaseCommit :: !Commit- ,diffCommits :: !(Vector Commit)- ,diffTotalCommits :: !Int- ,diffHtmlUrl :: !Text- ,diffFiles :: !(Vector File)- ,diffAheadBy :: !Int- ,diffDiffUrl :: !Text- ,diffPermalinkUrl :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Diff = Diff+ { diffStatus :: !Text+ , diffBehindBy :: !Int+ , diffPatchUrl :: !URL+ , diffUrl :: !URL+ , diffBaseCommit :: !Commit+ , diffCommits :: !(Vector Commit)+ , diffTotalCommits :: !Int+ , diffHtmlUrl :: !URL+ , diffFiles :: !(Vector File)+ , diffAheadBy :: !Int+ , diffDiffUrl :: !URL+ , diffPermalinkUrl :: !URL+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Diff where rnf = genericRnf instance Binary Diff -data NewGitReference = NewGitReference {- newGitReferenceRef :: !Text- ,newGitReferenceSha :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data NewGitReference = NewGitReference+ { newGitReferenceRef :: !Text+ , newGitReferenceSha :: !Text+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData NewGitReference where rnf = genericRnf instance Binary NewGitReference -data GitReference = GitReference {- gitReferenceObject :: !GitObject- ,gitReferenceUrl :: !Text- ,gitReferenceRef :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data GitReference = GitReference+ { gitReferenceObject :: !GitObject+ , gitReferenceUrl :: !URL+ , gitReferenceRef :: !Text+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData GitReference where rnf = genericRnf instance Binary GitReference -data GitObject = GitObject {- gitObjectType :: !Text- ,gitObjectSha :: !Text- ,gitObjectUrl :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data GitObject = GitObject+ { gitObjectType :: !Text+ , gitObjectSha :: !Text+ , gitObjectUrl :: !URL+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData GitObject where rnf = genericRnf instance Binary GitObject -data GitUser = GitUser {- gitUserName :: !Text- ,gitUserEmail :: !Text- ,gitUserDate :: !UTCTime-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data GitUser = GitUser+ { gitUserName :: !Text+ , gitUserEmail :: !Text+ , gitUserDate :: !UTCTime+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData GitUser where rnf = genericRnf instance Binary GitUser -data File = File {- fileBlobUrl :: !Text- ,fileStatus :: !Text- ,fileRawUrl :: !Text- ,fileAdditions :: !Int- ,fileSha :: !Text- ,fileChanges :: !Int- ,filePatch :: !(Maybe Text)- ,fileFilename :: !Text- ,fileDeletions :: !Int-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data File = File+ { fileBlobUrl :: !URL+ , fileStatus :: !Text+ , fileRawUrl :: !URL+ , fileAdditions :: !Int+ , fileSha :: !Text+ , fileChanges :: !Int+ , filePatch :: !(Maybe Text)+ , fileFilename :: !Text+ , fileDeletions :: !Int+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData File where rnf = genericRnf instance Binary File@@ -200,114 +202,116 @@ -- JSON instances instance FromJSON Stats where- parseJSON = withObject "Stats" $ \o ->- Stats <$> o .: "additions"- <*> o .: "total"- <*> o .: "deletions"+ parseJSON = withObject "Stats" $ \o -> Stats+ <$> o .: "additions"+ <*> o .: "total"+ <*> o .: "deletions" instance FromJSON Commit where- parseJSON = withObject "Commit" $ \o ->- Commit <$> o .: "sha"- <*> o .: "parents"- <*> o .: "url"- <*> o .: "commit"- <*> o .:? "committer"- <*> o .:? "author"- <*> o .:? "files" .!= V.empty- <*> o .:? "stats"+ parseJSON = withObject "Commit" $ \o -> Commit+ <$> o .: "sha"+ <*> o .: "parents"+ <*> o .: "url"+ <*> o .: "commit"+ <*> o .:? "committer"+ <*> o .:? "author"+ <*> o .:? "files" .!= V.empty+ <*> o .:? "stats" instance FromJSON Tree where- parseJSON = withObject "Tree" $ \o ->- Tree <$> o .: "sha"- <*> o .: "url"- <*> o .:? "tree" .!= V.empty+ parseJSON = withObject "Tree" $ \o -> Tree+ <$> o .: "sha"+ <*> o .: "url"+ <*> o .:? "tree" .!= V.empty instance FromJSON GitTree where- parseJSON = withObject "GitTree" $ \o ->- GitTree <$> o .: "type"- <*> o .: "sha"- <*> o .:? "url"- <*> o .:? "size"- <*> o .: "path"- <*> o .: "mode"+ parseJSON = withObject "GitTree" $ \o -> GitTree+ <$> o .: "type"+ <*> o .: "sha"+ <*> o .:? "url"+ <*> o .:? "size"+ <*> o .: "path"+ <*> o .: "mode" instance FromJSON GitCommit where- parseJSON = withObject "GitCommit" $ \o ->- GitCommit <$> o .: "message"- <*> o .: "url"- <*> o .: "committer"- <*> o .: "author"- <*> o .: "tree"- <*> o .:? "sha"- <*> o .:? "parents" .!= V.empty+ parseJSON = withObject "GitCommit" $ \o -> GitCommit+ <$> o .: "message"+ <*> o .: "url"+ <*> o .: "committer"+ <*> o .: "author"+ <*> o .: "tree"+ <*> o .:? "sha"+ <*> o .:? "parents" .!= V.empty instance FromJSON GitUser where- parseJSON = withObject "GitUser" $ \o ->- GitUser <$> o .: "name"- <*> o .: "email"- <*> o .: "date"+ parseJSON = withObject "GitUser" $ \o -> GitUser+ <$> o .: "name"+ <*> o .: "email"+ <*> o .: "date" instance FromJSON File where- parseJSON = withObject "File" $ \o ->- File <$> o .: "blob_url"- <*> o .: "status"- <*> o .: "raw_url"- <*> o .: "additions"- <*> o .: "sha"- <*> o .: "changes"- <*> o .:? "patch"- <*> o .: "filename"- <*> o .: "deletions"+ parseJSON = withObject "File" $ \o -> File+ <$> o .: "blob_url"+ <*> o .: "status"+ <*> o .: "raw_url"+ <*> o .: "additions"+ <*> o .: "sha"+ <*> o .: "changes"+ <*> o .:? "patch"+ <*> o .: "filename"+ <*> o .: "deletions" instance ToJSON NewGitReference where- toJSON (NewGitReference r s) = object [ "ref" .= r, "sha" .= s ]+ toJSON (NewGitReference r s) = object [ "ref" .= r, "sha" .= s ] instance FromJSON GitReference where- parseJSON = withObject "GitReference" $ \o ->- GitReference <$> o .: "object"- <*> o .: "url"- <*> o .: "ref"+ parseJSON = withObject "GitReference" $ \o -> GitReference+ <$> o .: "object"+ <*> o .: "url"+ <*> o .: "ref" instance FromJSON GitObject where- parseJSON = withObject "GitObject" $ \o ->- GitObject <$> o .: "type"- <*> o .: "sha"- <*> o .: "url"+ parseJSON = withObject "GitObject" $ \o -> GitObject+ <$> o .: "type"+ <*> o .: "sha"+ <*> o .: "url" instance FromJSON Diff where- parseJSON = withObject "Diff" $ \o ->- Diff <$> o .: "status"- <*> o .: "behind_by"- <*> o .: "patch_url"- <*> o .: "url"- <*> o .: "base_commit"- <*> o .:? "commits" .!= V.empty- <*> o .: "total_commits"- <*> o .: "html_url"- <*> o .:? "files" .!= V.empty- <*> o .: "ahead_by"- <*> o .: "diff_url"- <*> o .: "permalink_url"+ parseJSON = withObject "Diff" $ \o -> Diff+ <$> o .: "status"+ <*> o .: "behind_by"+ <*> o .: "patch_url"+ <*> o .: "url"+ <*> o .: "base_commit"+ <*> o .:? "commits" .!= V.empty+ <*> o .: "total_commits"+ <*> o .: "html_url"+ <*> o .:? "files" .!= V.empty+ <*> o .: "ahead_by"+ <*> o .: "diff_url"+ <*> o .: "permalink_url" instance FromJSON Blob where- parseJSON = withObject "Blob" $ \o ->- Blob <$> o .: "url"- <*> o .: "encoding"- <*> o .: "content"- <*> o .: "sha"- <*> o .: "size"+ parseJSON = withObject "Blob" $ \o -> Blob+ <$> o .: "url"+ <*> o .: "encoding"+ <*> o .: "content"+ <*> o .: "sha"+ <*> o .: "size" instance FromJSON Tag where- parseJSON = withObject "Tag" $ \o ->- Tag <$> o .: "name"+ parseJSON = withObject "Tag" $ \o -> Tag+ <$> o .: "name" <*> o .: "zipball_url" <*> o .: "tarball_url" <*> o .: "commit" instance FromJSON Branch where- parseJSON = withObject "Branch" $ \o ->- Branch <$> o .: "name" <*> o .: "commit"+ parseJSON = withObject "Branch" $ \o -> Branch+ <$> o .: "name"+ <*> o .: "commit" instance FromJSON BranchCommit where- parseJSON = withObject "BranchCommit" $ \o ->- BranchCommit <$> o .: "sha" <*> o .: "url"+ parseJSON = withObject "BranchCommit" $ \o -> BranchCommit+ <$> o .: "sha"+ <*> o .: "url"
src/GitHub/Data/Id.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -11,12 +9,8 @@ untagId, ) where -import Control.DeepSeq (NFData (..))-import Data.Aeson.Compat (FromJSON (..), ToJSON (..))-import Data.Binary (Binary)-import Data.Data (Data, Typeable)-import Data.Hashable (Hashable)-import GHC.Generics (Generic)+import GitHub.Internal.Prelude+import Prelude () -- | Numeric identifier. newtype Id entity = Id Int
src/GitHub/Data/Issues.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,268 +5,199 @@ -- module GitHub.Data.Issues where -import Prelude ()-import Prelude.Compat- import GitHub.Data.Definitions import GitHub.Data.Id (Id)+import GitHub.Data.Milestone (Milestone)+import GitHub.Data.Name (Name)+import GitHub.Data.Options (IssueState) import GitHub.Data.PullRequests--import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), ToJSON (..), Value (..), object,- withObject, (.:), (.:?), (.=))-import Data.Binary (Binary)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import Data.Time (UTCTime)-import Data.Vector (Vector)-import GHC.Generics (Generic)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude () -data Issue = Issue {- issueClosedAt :: Maybe UTCTime- ,issueUpdatedAt :: UTCTime- ,issueEventsUrl :: Text- ,issueHtmlUrl :: Maybe Text- ,issueClosedBy :: Maybe SimpleUser- ,issueLabels :: (Vector IssueLabel)- ,issueNumber :: Int- ,issueAssignee :: Maybe SimpleUser- ,issueUser :: SimpleUser- ,issueTitle :: Text- ,issuePullRequest :: Maybe PullRequestReference- ,issueUrl :: Text- ,issueCreatedAt :: UTCTime- ,issueBody :: Maybe Text- ,issueState :: Text- ,issueId :: Id Issue- ,issueComments :: Int- ,issueMilestone :: Maybe Milestone-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Issue = Issue+ { issueClosedAt :: !(Maybe UTCTime)+ , issueUpdatedAt :: !UTCTime+ , issueEventsUrl :: !URL+ , issueHtmlUrl :: !(Maybe URL)+ , issueClosedBy :: !(Maybe SimpleUser)+ , issueLabels :: (Vector IssueLabel)+ , issueNumber :: !Int+ , issueAssignees :: !(Vector SimpleUser)+ , issueUser :: !SimpleUser+ , issueTitle :: !Text+ , issuePullRequest :: !(Maybe PullRequestReference)+ , issueUrl :: !URL+ , issueCreatedAt :: !UTCTime+ , issueBody :: !(Maybe Text)+ , issueState :: !IssueState+ , issueId :: !(Id Issue)+ , issueComments :: !Int+ , issueMilestone :: !(Maybe Milestone)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Issue where rnf = genericRnf instance Binary Issue -data NewIssue = NewIssue {- newIssueTitle :: Text-, newIssueBody :: Maybe Text-, newIssueAssignee :: Maybe Text-, newIssueMilestone :: Maybe Int-, newIssueLabels :: Maybe (Vector Text)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data NewIssue = NewIssue+ { newIssueTitle :: !Text+ , newIssueBody :: !(Maybe Text)+ , newIssueAssignee :: !(Maybe Text)+ , newIssueMilestone :: !(Maybe (Id Milestone))+ , newIssueLabels :: !(Maybe (Vector (Name IssueLabel)))+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData NewIssue where rnf = genericRnf instance Binary NewIssue -data EditIssue = EditIssue {- editIssueTitle :: Maybe Text-, editIssueBody :: Maybe Text-, editIssueAssignee :: Maybe Text-, editIssueState :: Maybe Text-, editIssueMilestone :: Maybe Int-, editIssueLabels :: Maybe (Vector Text)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data EditIssue = EditIssue+ { editIssueTitle :: !(Maybe Text)+ , editIssueBody :: !(Maybe Text)+ , editIssueAssignee :: !(Maybe (Name User))+ , editIssueState :: !(Maybe IssueState)+ , editIssueMilestone :: !(Maybe (Id Milestone))+ , editIssueLabels :: !(Maybe (Vector (Name IssueLabel)))+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData EditIssue where rnf = genericRnf instance Binary EditIssue -data Milestone = Milestone {- milestoneCreator :: SimpleUser- ,milestoneDueOn :: Maybe UTCTime- ,milestoneOpenIssues :: Int- ,milestoneNumber :: Int- ,milestoneClosedIssues :: Int- ,milestoneDescription :: Maybe Text- ,milestoneTitle :: Text- ,milestoneUrl :: Text- ,milestoneCreatedAt :: UTCTime- ,milestoneState :: Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)--instance NFData Milestone where rnf = genericRnf-instance Binary Milestone--data IssueLabel = IssueLabel {- labelColor :: Text- ,labelUrl :: Text- ,labelName :: Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)--instance NFData IssueLabel where rnf = genericRnf-instance Binary IssueLabel--data IssueComment = IssueComment {- issueCommentUpdatedAt :: UTCTime- ,issueCommentUser :: SimpleUser- ,issueCommentUrl :: Text- ,issueCommentHtmlUrl :: Text- ,issueCommentCreatedAt :: UTCTime- ,issueCommentBody :: Text- ,issueCommentId :: Int-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data IssueComment = IssueComment+ { issueCommentUpdatedAt :: !UTCTime+ , issueCommentUser :: !SimpleUser+ , issueCommentUrl :: !URL+ , issueCommentHtmlUrl :: !URL+ , issueCommentCreatedAt :: !UTCTime+ , issueCommentBody :: !Text+ , issueCommentId :: !Int+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData IssueComment where rnf = genericRnf instance Binary IssueComment -data EventType =- Mentioned -- ^ The actor was @mentioned in an issue body.- | Subscribed -- ^ The actor subscribed to receive notifications for an issue.- | Unsubscribed -- ^ The issue was unsubscribed from by the actor.- | Referenced -- ^ The issue was referenced from a commit message. The commit_id attribute is the commit SHA1 of where that happened.- | Merged -- ^ The issue was merged by the actor. The commit_id attribute is the SHA1 of the HEAD commit that was merged.- | Assigned -- ^ The issue was assigned to the actor.- | Closed -- ^ The issue was closed by the actor. When the commit_id is present, it identifies the commit that closed the issue using “closes / fixes #NN” syntax.- | Reopened -- ^ The issue was reopened by the actor.- | ActorUnassigned -- ^ The issue was unassigned to the actor- | Labeled -- ^ A label was added to the issue.- | Unlabeled -- ^ A label was removed from the issue.- | Milestoned -- ^ The issue was added to a milestone.- | Demilestoned -- ^ The issue was removed from a milestone.- | Renamed -- ^ The issue title was changed.- | Locked -- ^ The issue was locked by the actor.- | Unlocked -- ^ The issue was unlocked by the actor.- | HeadRefDeleted -- ^ The pull request’s branch was deleted.- | HeadRefRestored -- ^ The pull request’s branch was restored.- deriving (Show, Data, Typeable, Eq, Ord, Generic)+data EventType+ = Mentioned -- ^ The actor was @mentioned in an issue body.+ | Subscribed -- ^ The actor subscribed to receive notifications for an issue.+ | Unsubscribed -- ^ The issue was unsubscribed from by the actor.+ | Referenced -- ^ The issue was referenced from a commit message. The commit_id attribute is the commit SHA1 of where that happened.+ | Merged -- ^ The issue was merged by the actor. The commit_id attribute is the SHA1 of the HEAD commit that was merged.+ | Assigned -- ^ The issue was assigned to the actor.+ | Closed -- ^ The issue was closed by the actor. When the commit_id is present, it identifies the commit that closed the issue using “closes / fixes #NN” syntax.+ | Reopened -- ^ The issue was reopened by the actor.+ | ActorUnassigned -- ^ The issue was unassigned to the actor+ | Labeled -- ^ A label was added to the issue.+ | Unlabeled -- ^ A label was removed from the issue.+ | Milestoned -- ^ The issue was added to a milestone.+ | Demilestoned -- ^ The issue was removed from a milestone.+ | Renamed -- ^ The issue title was changed.+ | Locked -- ^ The issue was locked by the actor.+ | Unlocked -- ^ The issue was unlocked by the actor.+ | HeadRefDeleted -- ^ The pull request’s branch was deleted.+ | HeadRefRestored -- ^ The pull request’s branch was restored.+ deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) instance NFData EventType where rnf = genericRnf instance Binary EventType -- | Issue event-data Event = Event {- eventActor :: !SimpleUser- ,eventType :: !EventType- ,eventCommitId :: !(Maybe Text)- ,eventUrl :: !Text- ,eventCreatedAt :: !UTCTime- ,eventId :: !Int- ,eventIssue :: !(Maybe Issue)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)--instance NFData Event where rnf = genericRnf-instance Binary Event---- | A data structure for describing how to filter issues. This is used by--- @issuesForRepo@.-data IssueLimitation =- AnyMilestone -- ^ Issues appearing in any milestone. [default]- | NoMilestone -- ^ Issues without a milestone.- | MilestoneId Int -- ^ Only issues that are in the milestone with the given id.- | Open -- ^ Only open issues. [default]- | OnlyClosed -- ^ Only closed issues.- | Unassigned -- ^ Issues to which no one has been assigned ownership.- | AnyAssignment -- ^ All issues regardless of assignment. [default]- | AssignedTo String -- ^ Only issues assigned to the user with the given login.- | Mentions String -- ^ Issues which mention the given string, taken to be a user's login.- | Labels [String] -- ^ A list of labels to filter by.- | Ascending -- ^ Sort ascending.- | Descending -- ^ Sort descending. [default]- | Since UTCTime -- ^ Only issues created since the specified date and time.- | PerPage Int -- ^ Download this many issues per query- deriving (Eq, Ord, Show, Typeable, Data, Generic)--instance NFData IssueLimitation where rnf = genericRnf-instance Binary IssueLimitation+data IssueEvent = IssueEvent+ { issueEventActor :: !SimpleUser+ , issueEventType :: !EventType+ , issueEventCommitId :: !(Maybe Text)+ , issueEventUrl :: !URL+ , issueEventCreatedAt :: !UTCTime+ , issueEventId :: !Int+ , issueEventIssue :: !(Maybe Issue)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) --- JSON instances+instance NFData IssueEvent where rnf = genericRnf+instance Binary IssueEvent -instance FromJSON Event where- parseJSON = withObject "Event" $ \o ->- Event <$> o .: "actor"- <*> o .: "event"- <*> o .:? "commit_id"- <*> o .: "url"- <*> o .: "created_at"- <*> o .: "id"- <*> o .:? "issue"+instance FromJSON IssueEvent where+ parseJSON = withObject "Event" $ \o -> IssueEvent+ <$> o .: "actor"+ <*> o .: "event"+ <*> o .:? "commit_id"+ <*> o .: "url"+ <*> o .: "created_at"+ <*> o .: "id"+ <*> o .:? "issue" instance FromJSON EventType where- parseJSON (String "closed") = pure Closed- parseJSON (String "reopened") = pure Reopened- parseJSON (String "subscribed") = pure Subscribed- parseJSON (String "merged") = pure Merged- parseJSON (String "referenced") = pure Referenced- parseJSON (String "mentioned") = pure Mentioned- parseJSON (String "assigned") = pure Assigned- parseJSON (String "unsubscribed") = pure Unsubscribed- parseJSON (String "unassigned") = pure ActorUnassigned- parseJSON (String "labeled") = pure Labeled- parseJSON (String "unlabeled") = pure Unlabeled- parseJSON (String "milestoned") = pure Milestoned- parseJSON (String "demilestoned") = pure Demilestoned- parseJSON (String "renamed") = pure Renamed- parseJSON (String "locked") = pure Locked- parseJSON (String "unlocked") = pure Unlocked- parseJSON (String "head_ref_deleted") = pure HeadRefDeleted- parseJSON (String "head_ref_restored") = pure HeadRefRestored- parseJSON _ = fail "Could not build an EventType"--instance FromJSON IssueLabel where- parseJSON = withObject "IssueLabel" $ \o ->- IssueLabel <$> o .: "color"- <*> o .: "url"- <*> o .: "name"+ parseJSON (String "closed") = pure Closed+ parseJSON (String "reopened") = pure Reopened+ parseJSON (String "subscribed") = pure Subscribed+ parseJSON (String "merged") = pure Merged+ parseJSON (String "referenced") = pure Referenced+ parseJSON (String "mentioned") = pure Mentioned+ parseJSON (String "assigned") = pure Assigned+ parseJSON (String "unsubscribed") = pure Unsubscribed+ parseJSON (String "unassigned") = pure ActorUnassigned+ parseJSON (String "labeled") = pure Labeled+ parseJSON (String "unlabeled") = pure Unlabeled+ parseJSON (String "milestoned") = pure Milestoned+ parseJSON (String "demilestoned") = pure Demilestoned+ parseJSON (String "renamed") = pure Renamed+ parseJSON (String "locked") = pure Locked+ parseJSON (String "unlocked") = pure Unlocked+ parseJSON (String "head_ref_deleted") = pure HeadRefDeleted+ parseJSON (String "head_ref_restored") = pure HeadRefRestored+ parseJSON _ = fail "Could not build an EventType" instance FromJSON IssueComment where- parseJSON = withObject "IssueComment" $ \o ->- IssueComment <$> o .: "updated_at"- <*> o .: "user"- <*> o .: "url"- <*> o .: "html_url"- <*> o .: "created_at"- <*> o .: "body"- <*> o .: "id"+ parseJSON = withObject "IssueComment" $ \o -> IssueComment+ <$> o .: "updated_at"+ <*> o .: "user"+ <*> o .: "url"+ <*> o .: "html_url"+ <*> o .: "created_at"+ <*> o .: "body"+ <*> o .: "id" instance FromJSON Issue where- parseJSON = withObject "Issue" $ \o ->- Issue <$> o .:? "closed_at"- <*> o .: "updated_at"- <*> o .: "events_url"- <*> o .: "html_url"- <*> o .:? "closed_by"- <*> o .: "labels"- <*> o .: "number"- <*> o .:? "assignee"- <*> o .: "user"- <*> o .: "title"- <*> o .:? "pull_request"- <*> o .: "url"- <*> o .: "created_at"- <*> o .: "body"- <*> o .: "state"- <*> o .: "id"- <*> o .: "comments"- <*> o .:? "milestone"+ parseJSON = withObject "Issue" $ \o -> Issue+ <$> o .:? "closed_at"+ <*> o .: "updated_at"+ <*> o .: "events_url"+ <*> o .: "html_url"+ <*> o .:? "closed_by"+ <*> o .: "labels"+ <*> o .: "number"+ <*> o .: "assignees"+ <*> o .: "user"+ <*> o .: "title"+ <*> o .:? "pull_request"+ <*> o .: "url"+ <*> o .: "created_at"+ <*> o .: "body"+ <*> o .: "state"+ <*> o .: "id"+ <*> o .: "comments"+ <*> o .:? "milestone" instance ToJSON NewIssue where- toJSON (NewIssue t b a m ls) =- object- [ "title" .= t- , "body" .= b- , "assignee" .= a- , "milestone" .= m- , "labels" .= ls ]+ toJSON (NewIssue t b a m ls) = object+ [ "title" .= t+ , "body" .= b+ , "assignee" .= a+ , "milestone" .= m+ , "labels" .= ls+ ] instance ToJSON EditIssue where- toJSON (EditIssue t b a s m ls) =- object $ filter notNull $ [ "title" .= t- , "body" .= b- , "assignee" .= a- , "state" .= s- , "milestone" .= m- , "labels" .= ls ]- where notNull (_, Null) = False- notNull (_, _) = True--instance FromJSON Milestone where- parseJSON = withObject "Milestone" $ \o ->- Milestone <$> o .: "creator"- <*> o .: "due_on"- <*> o .: "open_issues"- <*> o .: "number"- <*> o .: "closed_issues"- <*> o .: "description"- <*> o .: "title"- <*> o .: "url"- <*> o .: "created_at"- <*> o .: "state"+ toJSON (EditIssue t b a s m ls) = object $ filter notNull $+ [ "title" .= t+ , "body" .= b+ , "assignee" .= a+ , "state" .= s+ , "milestone" .= m+ , "labels" .= ls+ ]+ where+ notNull (_, Null) = False+ notNull (_, _) = True
+ src/GitHub/Data/Milestone.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- License : BSD-3-Clause+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+module GitHub.Data.Milestone where++import GitHub.Data.Definitions+import GitHub.Data.Id (Id)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude ()++data Milestone = Milestone+ { milestoneCreator :: !SimpleUser+ , milestoneDueOn :: !(Maybe UTCTime)+ , milestoneOpenIssues :: !Int+ , milestoneNumber :: !(Id Milestone)+ , milestoneClosedIssues :: !Int+ , milestoneDescription :: !(Maybe Text)+ , milestoneTitle :: !Text+ , milestoneUrl :: !URL+ , milestoneCreatedAt :: !UTCTime+ , milestoneState :: !Text+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic)++instance NFData Milestone where rnf = genericRnf+instance Binary Milestone++instance FromJSON Milestone where+ parseJSON = withObject "Milestone" $ \o -> Milestone+ <$> o .: "creator"+ <*> o .: "due_on"+ <*> o .: "open_issues"+ <*> o .: "number"+ <*> o .: "closed_issues"+ <*> o .: "description"+ <*> o .: "title"+ <*> o .: "url"+ <*> o .: "created_at"+ <*> o .: "state"
src/GitHub/Data/Name.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -11,15 +10,14 @@ untagName, ) where -import Control.DeepSeq (NFData (..))-import Data.Aeson.Compat (FromJSON (..), ToJSON (..))-import Data.Binary.Orphans (Binary)-import Data.Data (Data, Typeable)-import Data.Hashable (Hashable)-import Data.String (IsString (..))-import Data.Text (Text)-import GHC.Generics (Generic)+import Prelude ()+import GitHub.Internal.Prelude +#if MIN_VERSION_aeson(1,0,0)+import Data.Aeson.Types+ (FromJSONKey (..), ToJSONKey (..), fromJSONKeyCoerce, toJSONKeyText)+#endif+ newtype Name entity = N Text deriving (Eq, Ord, Show, Generic, Typeable, Data) @@ -44,3 +42,13 @@ instance IsString (Name entity) where fromString = N . fromString++#if MIN_VERSION_aeson(1,0,0)+-- | @since 0.15.0.0+instance ToJSONKey (Name entity) where+ toJSONKey = toJSONKeyText untagName++-- | @since 0.15.0.0+instance FromJSONKey (Name entity) where+ fromJSONKey = fromJSONKeyCoerce+#endif
+ src/GitHub/Data/Options.hs view
@@ -0,0 +1,598 @@+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- License : BSD-3-Clause+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- Module with modifiers for pull requests' and issues' listings.+module GitHub.Data.Options (+ -- * Common modifiers+ stateOpen,+ stateClosed,+ stateAll,+ sortAscending,+ sortDescending,+ sortByCreated,+ sortByUpdated,+ -- * Pull Requests+ PullRequestMod,+ prModToQueryString,+ optionsBase,+ optionsNoBase,+ optionsHead,+ optionsNoHead,+ sortByPopularity,+ sortByLongRunning,+ -- * Issues+ IssueMod,+ issueModToQueryString,+ sortByComments,+ optionsLabels,+ optionsSince,+ optionsSinceAll,+ optionsAssignedIssues,+ optionsCreatedIssues,+ optionsMentionedIssues,+ optionsSubscribedIssues,+ optionsAllIssues,+ -- * Repo issues+ IssueRepoMod,+ issueRepoModToQueryString,+ optionsIrrelevantMilestone,+ optionsAnyMilestone,+ optionsNoMilestone,+ optionsIrrelevantAssignee,+ optionsAnyAssignee,+ optionsNoAssignee,+ -- * Data+ IssueState (..),+ MergeableState (..),+ -- * Internal+ HasState,+ HasDirection,+ HasCreatedUpdated,+ HasComments,+ HasLabels,+ HasSince,+ ) where++import GitHub.Data.Definitions+import GitHub.Data.Id (Id, untagId)+import GitHub.Data.Milestone (Milestone)+import GitHub.Data.Name (Name, untagName)+import GitHub.Internal.Prelude+import Prelude ()++import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++-------------------------------------------------------------------------------+-- Data+-------------------------------------------------------------------------------++-- | 'GitHub.Data.Issues.Issue' or 'GitHub.Data.PullRequests.PullRequest' state+data IssueState+ = StateOpen+ | StateClosed+ deriving+ (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)++instance ToJSON IssueState where+ toJSON StateOpen = String "open"+ toJSON StateClosed = String "closed"++instance FromJSON IssueState where+ parseJSON (String "open") = pure StateOpen+ parseJSON (String "closed") = pure StateClosed+ parseJSON v = typeMismatch "IssueState" v++instance NFData IssueState where rnf = genericRnf+instance Binary IssueState++-- | 'GitHub.Data.PullRequests.PullRequest' mergeable_state+data MergeableState+ = StateUnknown+ | StateClean+ | StateDirty+ | StateUnstable+ deriving+ (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)++instance ToJSON MergeableState where+ toJSON StateUnknown = String "unknown"+ toJSON StateClean = String "clean"+ toJSON StateDirty = String "dirty"+ toJSON StateUnstable = String "unstable"++instance FromJSON MergeableState where+ parseJSON (String "unknown") = pure StateUnknown+ parseJSON (String "clean") = pure StateClean+ parseJSON (String "dirty") = pure StateDirty+ parseJSON (String "unstable") = pure StateUnstable+ parseJSON v = typeMismatch "MergeableState" v++instance NFData MergeableState where rnf = genericRnf+instance Binary MergeableState++data SortDirection+ = SortAscending+ | SortDescending+ deriving+ (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)++instance NFData SortDirection where rnf = genericRnf+instance Binary SortDirection++-- PR++data SortPR+ = SortPRCreated+ | SortPRUpdated+ | SortPRPopularity+ | SortPRLongRunning+ deriving+ (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)++instance NFData SortPR where rnf = genericRnf+instance Binary SortPR++-- Issue+data IssueFilter+ = IssueFilterAssigned+ | IssueFilterCreated+ | IssueFilterMentioned+ | IssueFilterSubscribed+ | IssueFilterAll+ deriving+ (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)++instance NFData IssueFilter where rnf = genericRnf+instance Binary IssueFilter++data SortIssue+ = SortIssueCreated+ | SortIssueUpdated+ | SortIssueComments+ deriving+ (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)++instance NFData SortIssue where rnf = genericRnf+instance Binary SortIssue++data FilterBy a+ = FilterAny+ | FilterNone+ | FilterBy a+ | FilterNotSpecified+ -- ^ e.g. for milestones "any" means "any milestone".+ -- I.e. won't show issues without mileston specified+ deriving+ (Eq, Ord, Show, Generic, Typeable, Data)++-------------------------------------------------------------------------------+-- Classes+-------------------------------------------------------------------------------++class HasState mod where+ state :: Maybe IssueState -> mod++stateOpen :: HasState mod => mod+stateOpen = state (Just StateOpen)++stateClosed :: HasState mod => mod+stateClosed = state (Just StateClosed)++stateAll :: HasState mod => mod+stateAll = state Nothing++instance HasState PullRequestMod where+ state s = PRMod $ \opts ->+ opts { pullRequestOptionsState = s }++instance HasState IssueMod where+ state s = IssueMod $ \opts ->+ opts { issueOptionsState = s }++instance HasState IssueRepoMod where+ state s = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsState = s }+++class HasDirection mod where+ sortDir :: SortDirection -> mod++sortAscending :: HasDirection mod => mod+sortAscending = sortDir SortAscending++sortDescending :: HasDirection mod => mod+sortDescending = sortDir SortDescending++instance HasDirection PullRequestMod where+ sortDir x = PRMod $ \opts ->+ opts { pullRequestOptionsDirection = x }++instance HasDirection IssueMod where+ sortDir x = IssueMod $ \opts ->+ opts { issueOptionsDirection = x }++instance HasDirection IssueRepoMod where+ sortDir x = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsDirection = x }+++class HasCreatedUpdated mod where+ sortByCreated :: mod+ sortByUpdated :: mod++instance HasCreatedUpdated PullRequestMod where+ sortByCreated = PRMod $ \opts ->+ opts { pullRequestOptionsSort = SortPRCreated }+ sortByUpdated = PRMod $ \opts ->+ opts { pullRequestOptionsSort = SortPRUpdated }++instance HasCreatedUpdated IssueMod where+ sortByCreated = IssueMod $ \opts ->+ opts { issueOptionsSort = SortIssueCreated }+ sortByUpdated = IssueMod $ \opts ->+ opts { issueOptionsSort = SortIssueUpdated }++instance HasCreatedUpdated IssueRepoMod where+ sortByCreated = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsSort = SortIssueCreated }+ sortByUpdated = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsSort = SortIssueUpdated }++-------------------------------------------------------------------------------+-- Pull Request+-------------------------------------------------------------------------------++-- | See <https://developer.github.com/v3/pulls/#parameters>.+data PullRequestOptions = PullRequestOptions+ { pullRequestOptionsState :: !(Maybe IssueState)+ , pullRequestOptionsHead :: !(Maybe Text)+ , pullRequestOptionsBase :: !(Maybe Text)+ , pullRequestOptionsSort :: !SortPR+ , pullRequestOptionsDirection :: !SortDirection+ }+ deriving+ (Eq, Ord, Show, Generic, Typeable, Data)++defaultPullRequestOptions :: PullRequestOptions+defaultPullRequestOptions = PullRequestOptions+ { pullRequestOptionsState = Just StateOpen+ , pullRequestOptionsHead = Nothing+ , pullRequestOptionsBase = Nothing+ , pullRequestOptionsSort = SortPRCreated+ , pullRequestOptionsDirection = SortDescending+ }++-- | See <https://developer.github.com/v3/pulls/#parameters>.+newtype PullRequestMod = PRMod (PullRequestOptions -> PullRequestOptions)++instance Semigroup PullRequestMod where+ PRMod f <> PRMod g = PRMod (g . f)++instance Monoid PullRequestMod where+ mempty = PRMod id+ mappend = (<>)++toPullRequestOptions :: PullRequestMod -> PullRequestOptions+toPullRequestOptions (PRMod f) = f defaultPullRequestOptions++prModToQueryString :: PullRequestMod -> QueryString+prModToQueryString = pullRequestOptionsToQueryString . toPullRequestOptions++pullRequestOptionsToQueryString :: PullRequestOptions -> QueryString+pullRequestOptionsToQueryString (PullRequestOptions st head_ base sort dir) =+ [ mk "state" state'+ , mk "sort" sort'+ , mk "direction" direction'+ ] ++ catMaybes+ [ mk "head" <$> head'+ , mk "base" <$> base'+ ]+ where+ mk k v = (k, Just v)+ state' = case st of+ Nothing -> "all"+ Just StateOpen -> "open"+ Just StateClosed -> "closed"+ sort' = case sort of+ SortPRCreated -> "created"+ SortPRUpdated -> "updated"+ SortPRPopularity -> "popularity"+ SortPRLongRunning -> "long-running"+ direction' = case dir of+ SortDescending -> "desc"+ SortAscending -> "asc"+ head' = fmap TE.encodeUtf8 head_+ base' = fmap TE.encodeUtf8 base++-------------------------------------------------------------------------------+-- Pull request modifiers+-------------------------------------------------------------------------------++optionsBase :: Text -> PullRequestMod+optionsBase x = PRMod $ \opts ->+ opts { pullRequestOptionsBase = Just x }++optionsNoBase :: PullRequestMod+optionsNoBase = PRMod $ \opts ->+ opts { pullRequestOptionsBase = Nothing }++optionsHead :: Text -> PullRequestMod+optionsHead x = PRMod $ \opts ->+ opts { pullRequestOptionsHead = Just x }++optionsNoHead :: PullRequestMod+optionsNoHead = PRMod $ \opts ->+ opts { pullRequestOptionsHead = Nothing }++sortByPopularity :: PullRequestMod+sortByPopularity = PRMod $ \opts ->+ opts { pullRequestOptionsSort = SortPRPopularity }++sortByLongRunning :: PullRequestMod+sortByLongRunning = PRMod $ \opts ->+ opts { pullRequestOptionsSort = SortPRLongRunning }++-------------------------------------------------------------------------------+-- Issues+-------------------------------------------------------------------------------++-- | See <https://developer.github.com/v3/issues/#parameters>.+data IssueOptions = IssueOptions+ { issueOptionsFilter :: !IssueFilter+ , issueOptionsState :: !(Maybe IssueState)+ , issueOptionsLabels :: ![Name IssueLabel] -- TODO: change to newtype+ , issueOptionsSort :: !SortIssue+ , issueOptionsDirection :: !SortDirection+ , issueOptionsSince :: !(Maybe UTCTime)+ }+ deriving+ (Eq, Ord, Show, Generic, Typeable, Data)++defaultIssueOptions :: IssueOptions+defaultIssueOptions = IssueOptions+ { issueOptionsFilter = IssueFilterAssigned+ , issueOptionsState = Just StateOpen+ , issueOptionsLabels = []+ , issueOptionsSort = SortIssueCreated+ , issueOptionsDirection = SortDescending+ , issueOptionsSince = Nothing+ }++-- | See <https://developer.github.com/v3/issues/#parameters>.+newtype IssueMod = IssueMod (IssueOptions -> IssueOptions)++instance Semigroup IssueMod where+ IssueMod f <> IssueMod g = IssueMod (g . f)++instance Monoid IssueMod where+ mempty = IssueMod id+ mappend = (<>)++toIssueOptions :: IssueMod -> IssueOptions+toIssueOptions (IssueMod f) = f defaultIssueOptions++issueModToQueryString :: IssueMod -> QueryString+issueModToQueryString = issueOptionsToQueryString . toIssueOptions++issueOptionsToQueryString :: IssueOptions -> QueryString+issueOptionsToQueryString (IssueOptions filt st labels sort dir since) =+ [ mk "state" state'+ , mk "sort" sort'+ , mk "direction" direction'+ , mk "filter" filt'+ ] ++ catMaybes+ [ mk "labels" <$> labels'+ , mk "since" <$> since'+ ]+ where+ mk k v = (k, Just v)+ filt' = case filt of+ IssueFilterAssigned -> "assigned"+ IssueFilterCreated -> "created"+ IssueFilterMentioned -> "mentioned"+ IssueFilterSubscribed -> "subscribed"+ IssueFilterAll -> "all"+ state' = case st of+ Nothing -> "all"+ Just StateOpen -> "open"+ Just StateClosed -> "closed"+ sort' = case sort of+ SortIssueCreated -> "created"+ SortIssueUpdated -> "updated"+ SortIssueComments -> "comments"+ direction' = case dir of+ SortDescending -> "desc"+ SortAscending -> "asc"++ since' = fmap (TE.encodeUtf8 . T.pack . show) since+ labels' = TE.encodeUtf8 . T.intercalate "," . fmap untagName <$> nullToNothing labels++nullToNothing :: Foldable f => f a -> Maybe (f a)+nullToNothing xs+ | null xs = Nothing+ | otherwise = Just xs++-------------------------------------------------------------------------------+-- Issues modifiers+-------------------------------------------------------------------------------++class HasComments mod where+ sortByComments :: mod++instance HasComments IssueMod where+ sortByComments = IssueMod $ \opts ->+ opts { issueOptionsSort = SortIssueComments }++instance HasComments IssueRepoMod where+ sortByComments = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsSort = SortIssueComments }+++class HasLabels mod where+ optionsLabels :: Foldable f => f (Name IssueLabel) -> mod++instance HasLabels IssueMod where+ optionsLabels lbls = IssueMod $ \opts ->+ opts { issueOptionsLabels = toList lbls }++instance HasLabels IssueRepoMod where+ optionsLabels lbls = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsLabels = toList lbls }+++class HasSince mod where+ optionsSince :: UTCTime -> mod+ optionsSinceAll :: mod++instance HasSince IssueMod where+ optionsSince since = IssueMod $ \opts ->+ opts { issueOptionsSince = Just since }+ optionsSinceAll = IssueMod $ \opts ->+ opts { issueOptionsSince = Nothing }++instance HasSince IssueRepoMod where+ optionsSince since = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsSince = Just since }+ optionsSinceAll = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsSince = Nothing }++-------------------------------------------------------------------------------+-- Only issues modifiers+-------------------------------------------------------------------------------++optionsAssignedIssues, optionsCreatedIssues, optionsMentionedIssues,+ optionsSubscribedIssues, optionsAllIssues :: IssueMod+optionsAssignedIssues = issueFilter IssueFilterAssigned+optionsCreatedIssues = issueFilter IssueFilterCreated+optionsMentionedIssues = issueFilter IssueFilterMentioned+optionsSubscribedIssues = issueFilter IssueFilterSubscribed+optionsAllIssues = issueFilter IssueFilterAll++issueFilter :: IssueFilter -> IssueMod+issueFilter f = IssueMod $ \opts ->+ opts { issueOptionsFilter = f }++-------------------------------------------------------------------------------+-- Issues repo+-------------------------------------------------------------------------------++data IssueRepoOptions = IssueRepoOptions+ { issueRepoOptionsMilestone :: !(FilterBy (Id Milestone))+ , issueRepoOptionsState :: !(Maybe IssueState)+ , issueRepoOptionsAssignee :: !(FilterBy (Name User))+ , issueRepoOptionsCreator :: !(Maybe (Name User))+ , issueRepoOptionsMentioned :: !(Maybe (Name User))+ , issueRepoOptionsLabels :: ![Name IssueLabel]+ , issueRepoOptionsSort :: !SortIssue+ , issueRepoOptionsDirection :: !SortDirection+ , issueRepoOptionsSince :: !(Maybe UTCTime)+ }+ deriving+ (Eq, Ord, Show, Generic, Typeable, Data)++defaultIssueRepoOptions :: IssueRepoOptions+defaultIssueRepoOptions = IssueRepoOptions+ { issueRepoOptionsMilestone = FilterNotSpecified+ , issueRepoOptionsState = (Just StateOpen)+ , issueRepoOptionsAssignee = FilterNotSpecified+ , issueRepoOptionsCreator = Nothing+ , issueRepoOptionsMentioned = Nothing+ , issueRepoOptionsLabels = []+ , issueRepoOptionsSort = SortIssueCreated+ , issueRepoOptionsDirection = SortDescending+ , issueRepoOptionsSince = Nothing+ }++-- | See <https://developer.github.com/v3/issues/#parameters-1>.+newtype IssueRepoMod = IssueRepoMod (IssueRepoOptions -> IssueRepoOptions)++instance Semigroup IssueRepoMod where+ IssueRepoMod f <> IssueRepoMod g = IssueRepoMod (g . f)++instance Monoid IssueRepoMod where+ mempty = IssueRepoMod id+ mappend = (<>)++toIssueRepoOptions :: IssueRepoMod -> IssueRepoOptions+toIssueRepoOptions (IssueRepoMod f) = f defaultIssueRepoOptions++issueRepoModToQueryString :: IssueRepoMod -> QueryString+issueRepoModToQueryString = issueRepoOptionsToQueryString . toIssueRepoOptions++issueRepoOptionsToQueryString :: IssueRepoOptions -> QueryString+issueRepoOptionsToQueryString IssueRepoOptions {..} =+ [ mk "state" state'+ , mk "sort" sort'+ , mk "direction" direction'+ ] ++ catMaybes+ [ mk "milestone" <$> milestone'+ , mk "assignee" <$> assignee'+ , mk "labels" <$> labels'+ , mk "since" <$> since'+ , mk "creator" <$> creator'+ , mk "mentioned" <$> mentioned'+ ]+ where+ mk k v = (k, Just v)+ filt f x = case x of+ FilterAny -> Just "*"+ FilterNone -> Just "none"+ FilterBy x' -> Just $ TE.encodeUtf8 $ f x'+ FilterNotSpecified -> Nothing++ milestone' = filt (T.pack . show . untagId) issueRepoOptionsMilestone+ assignee' = filt untagName issueRepoOptionsAssignee++ state' = case issueRepoOptionsState of+ Nothing -> "all"+ Just StateOpen -> "open"+ Just StateClosed -> "closed"+ sort' = case issueRepoOptionsSort of+ SortIssueCreated -> "created"+ SortIssueUpdated -> "updated"+ SortIssueComments -> "comments"+ direction' = case issueRepoOptionsDirection of+ SortDescending -> "desc"+ SortAscending -> "asc"++ since' = TE.encodeUtf8 . T.pack . show <$> issueRepoOptionsSince+ labels' = TE.encodeUtf8 . T.intercalate "," . fmap untagName <$> nullToNothing issueRepoOptionsLabels+ creator' = TE.encodeUtf8 . untagName <$> issueRepoOptionsCreator+ mentioned' = TE.encodeUtf8 . untagName <$> issueRepoOptionsMentioned++-------------------------------------------------------------------------------+-- Issues repo modifiers+-------------------------------------------------------------------------------++-- | Don't care about milestones.+--+-- 'optionsAnyMilestone' means there should be some milestone, but it can be any.+--+-- See <https://developer.github.com/v3/issues/#list-issues-for-a-repository>+optionsIrrelevantMilestone :: IssueRepoMod+optionsIrrelevantMilestone = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsMilestone = FilterNotSpecified }++optionsAnyMilestone :: IssueRepoMod+optionsAnyMilestone = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsMilestone = FilterAny }++optionsNoMilestone :: IssueRepoMod+optionsNoMilestone = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsMilestone = FilterNone }++optionsIrrelevantAssignee :: IssueRepoMod+optionsIrrelevantAssignee = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsAssignee = FilterNotSpecified }++optionsAnyAssignee :: IssueRepoMod+optionsAnyAssignee = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsAssignee = FilterAny }++optionsNoAssignee :: IssueRepoMod+optionsNoAssignee = IssueRepoMod $ \opts ->+ opts { issueRepoOptionsAssignee = FilterNone }
src/GitHub/Data/PullRequests.hs view
@@ -1,97 +1,103 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause -- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi> ---module GitHub.Data.PullRequests where--import Prelude ()-import Prelude.Compat+module GitHub.Data.PullRequests (+ SimplePullRequest(..),+ PullRequest(..),+ EditPullRequest(..),+ CreatePullRequest(..),+ PullRequestLinks(..),+ PullRequestCommit(..),+ PullRequestEvent(..),+ PullRequestEventType(..),+ PullRequestReference(..),+ MergeResult(..),+ statusMerge,+ ) where import GitHub.Data.Definitions+import GitHub.Data.Id (Id)+import GitHub.Data.Options (IssueState (..), MergeableState (..)) import GitHub.Data.Repos (Repo)--import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), ToJSON (..), Value (..), object,- withObject, (.:), (.:?), (.=))-import Data.Aeson.Types (Object, Parser)-import Data.Binary.Orphans (Binary)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import Data.Time (UTCTime)-import GHC.Generics (Generic)+import GitHub.Data.Request (StatusMap)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude () -data SimplePullRequest = SimplePullRequest {- simplePullRequestClosedAt :: !(Maybe UTCTime)- ,simplePullRequestCreatedAt :: !UTCTime- ,simplePullRequestUser :: !SimpleUser- ,simplePullRequestPatchUrl :: !Text- ,simplePullRequestState :: !Text- ,simplePullRequestNumber :: !Int- ,simplePullRequestHtmlUrl :: !Text- ,simplePullRequestUpdatedAt :: !UTCTime- ,simplePullRequestBody :: !Text- ,simplePullRequestIssueUrl :: !Text- ,simplePullRequestDiffUrl :: !Text- ,simplePullRequestUrl :: !Text- ,simplePullRequestLinks :: !PullRequestLinks- ,simplePullRequestMergedAt :: !(Maybe UTCTime)- ,simplePullRequestTitle :: !Text- ,simplePullRequestId :: !Int-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data SimplePullRequest = SimplePullRequest+ { simplePullRequestClosedAt :: !(Maybe UTCTime)+ , simplePullRequestCreatedAt :: !UTCTime+ , simplePullRequestUser :: !SimpleUser+ , simplePullRequestPatchUrl :: !URL+ , simplePullRequestState :: !IssueState+ , simplePullRequestNumber :: !Int+ , simplePullRequestHtmlUrl :: !URL+ , simplePullRequestUpdatedAt :: !UTCTime+ , simplePullRequestBody :: !(Maybe Text)+ , simplePullRequestAssignees :: (Vector SimpleUser)+ , simplePullRequestIssueUrl :: !URL+ , simplePullRequestDiffUrl :: !URL+ , simplePullRequestUrl :: !URL+ , simplePullRequestLinks :: !PullRequestLinks+ , simplePullRequestMergedAt :: !(Maybe UTCTime)+ , simplePullRequestTitle :: !Text+ , simplePullRequestId :: !(Id PullRequest)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData SimplePullRequest where rnf = genericRnf instance Binary SimplePullRequest -data PullRequest = PullRequest {- -- this is a duplication of a PullRequest- pullRequestClosedAt :: !(Maybe UTCTime)- ,pullRequestCreatedAt :: !UTCTime- ,pullRequestUser :: !SimpleUser- ,pullRequestPatchUrl :: !Text- ,pullRequestState :: !Text- ,pullRequestNumber :: !Int- ,pullRequestHtmlUrl :: !Text- ,pullRequestUpdatedAt :: !UTCTime- ,pullRequestBody :: !Text- ,pullRequestIssueUrl :: !Text- ,pullRequestDiffUrl :: !Text- ,pullRequestUrl :: !Text- ,pullRequestLinks :: !PullRequestLinks- ,pullRequestMergedAt :: !(Maybe UTCTime)- ,pullRequestTitle :: !Text- ,pullRequestId :: !Int- ,pullRequestMergedBy :: !(Maybe SimpleUser)- ,pullRequestChangedFiles :: !Int- ,pullRequestHead :: !PullRequestCommit- ,pullRequestComments :: !Int- ,pullRequestDeletions :: !Int- ,pullRequestAdditions :: !Int- ,pullRequestReviewComments :: !Int- ,pullRequestBase :: !PullRequestCommit- ,pullRequestCommits :: !Int- ,pullRequestMerged :: !Bool- ,pullRequestMergeable :: !(Maybe Bool)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data PullRequest = PullRequest+ { pullRequestClosedAt :: !(Maybe UTCTime)+ , pullRequestCreatedAt :: !UTCTime+ , pullRequestUser :: !SimpleUser+ , pullRequestPatchUrl :: !URL+ , pullRequestState :: !IssueState+ , pullRequestNumber :: !Int+ , pullRequestHtmlUrl :: !URL+ , pullRequestUpdatedAt :: !UTCTime+ , pullRequestBody :: !(Maybe Text)+ , pullRequestAssignees :: (Vector SimpleUser)+ , pullRequestIssueUrl :: !URL+ , pullRequestDiffUrl :: !URL+ , pullRequestUrl :: !URL+ , pullRequestLinks :: !PullRequestLinks+ , pullRequestMergedAt :: !(Maybe UTCTime)+ , pullRequestTitle :: !Text+ , pullRequestId :: !(Id PullRequest)+ , pullRequestMergedBy :: !(Maybe SimpleUser)+ , pullRequestChangedFiles :: !Int+ , pullRequestHead :: !PullRequestCommit+ , pullRequestComments :: !Count+ , pullRequestDeletions :: !Count+ , pullRequestAdditions :: !Count+ , pullRequestReviewComments :: !Count+ , pullRequestBase :: !PullRequestCommit+ , pullRequestCommits :: !Count+ , pullRequestMerged :: !Bool+ , pullRequestMergeable :: !(Maybe Bool)+ , pullRequestMergeableState :: !MergeableState+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData PullRequest where rnf = genericRnf instance Binary PullRequest -data EditPullRequest = EditPullRequest {- editPullRequestTitle :: !(Maybe Text)- ,editPullRequestBody :: !(Maybe Text)- ,editPullRequestState :: !(Maybe EditPullRequestState)-} deriving (Show, Generic)+data EditPullRequest = EditPullRequest+ { editPullRequestTitle :: !(Maybe Text)+ , editPullRequestBody :: !(Maybe Text)+ , editPullRequestState :: !(Maybe IssueState)+ }+ deriving (Show, Generic) instance NFData EditPullRequest where rnf = genericRnf instance Binary EditPullRequest -data CreatePullRequest =- CreatePullRequest+data CreatePullRequest+ = CreatePullRequest { createPullRequestTitle :: !Text , createPullRequestBody :: !Text , createPullRequestHead :: !Text@@ -102,80 +108,77 @@ , createPullRequestHead :: !Text , createPullRequestBase :: !Text }- deriving (Show, Generic)+ deriving (Show, Generic) instance NFData CreatePullRequest where rnf = genericRnf instance Binary CreatePullRequest -data PullRequestLinks = PullRequestLinks {- pullRequestLinksReviewComments :: !Text- ,pullRequestLinksComments :: !Text- ,pullRequestLinksHtml :: !Text- ,pullRequestLinksSelf :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data PullRequestLinks = PullRequestLinks+ { pullRequestLinksReviewComments :: !URL+ , pullRequestLinksComments :: !URL+ , pullRequestLinksHtml :: !URL+ , pullRequestLinksSelf :: !URL+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData PullRequestLinks where rnf = genericRnf instance Binary PullRequestLinks -data PullRequestCommit = PullRequestCommit {- pullRequestCommitLabel :: !Text- ,pullRequestCommitRef :: !Text- ,pullRequestCommitSha :: !Text- ,pullRequestCommitUser :: !SimpleUser- ,pullRequestCommitRepo :: !Repo-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data PullRequestCommit = PullRequestCommit+ { pullRequestCommitLabel :: !Text+ , pullRequestCommitRef :: !Text+ , pullRequestCommitSha :: !Text+ , pullRequestCommitUser :: !SimpleUser+ , pullRequestCommitRepo :: !Repo+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData PullRequestCommit where rnf = genericRnf instance Binary PullRequestCommit -data PullRequestEvent = PullRequestEvent {- pullRequestEventAction :: !PullRequestEventType- ,pullRequestEventNumber :: !Int- ,pullRequestEventPullRequest :: !PullRequest- ,pullRequestRepository :: !Repo- ,pullRequestSender :: !SimpleUser-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data PullRequestEvent = PullRequestEvent+ { pullRequestEventAction :: !PullRequestEventType+ , pullRequestEventNumber :: !Int+ , pullRequestEventPullRequest :: !PullRequest+ , pullRequestRepository :: !Repo+ , pullRequestSender :: !SimpleUser+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData PullRequestEvent where rnf = genericRnf instance Binary PullRequestEvent -data PullRequestEventType =- PullRequestOpened- | PullRequestClosed- | PullRequestSynchronized- | PullRequestReopened- | PullRequestAssigned- | PullRequestUnassigned- | PullRequestLabeled- | PullRequestUnlabeled- deriving (Show, Data, Typeable, Eq, Ord, Generic)+data PullRequestEventType+ = PullRequestOpened+ | PullRequestClosed+ | PullRequestSynchronized+ | PullRequestReopened+ | PullRequestAssigned+ | PullRequestUnassigned+ | PullRequestLabeled+ | PullRequestUnlabeled+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData PullRequestEventType where rnf = genericRnf instance Binary PullRequestEventType -data PullRequestReference = PullRequestReference {- pullRequestReferenceHtmlUrl :: !(Maybe Text)- ,pullRequestReferencePatchUrl :: !(Maybe Text)- ,pullRequestReferenceDiffUrl :: !(Maybe Text)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data PullRequestReference = PullRequestReference+ { pullRequestReferenceHtmlUrl :: !(Maybe URL)+ , pullRequestReferencePatchUrl :: !(Maybe URL)+ , pullRequestReferenceDiffUrl :: !(Maybe URL)+ }+ deriving (Eq, Ord, Show, Generic, Typeable, Data) instance NFData PullRequestReference where rnf = genericRnf instance Binary PullRequestReference -data EditPullRequestState =- EditPullRequestStateOpen- | EditPullRequestStateClosed- deriving (Show, Generic) -instance NFData EditPullRequestState where rnf = genericRnf-instance Binary EditPullRequestState-+------------------------------------------------------------------------------- -- JSON instances-+------------------------------------------------------------------------------- instance FromJSON SimplePullRequest where- parseJSON = withObject "SimplePullRequest" $ \o ->- SimplePullRequest+ parseJSON = withObject "SimplePullRequest" $ \o -> SimplePullRequest <$> o .:? "closed_at" <*> o .: "created_at" <*> o .: "user"@@ -184,7 +187,8 @@ <*> o .: "number" <*> o .: "html_url" <*> o .: "updated_at"- <*> o .: "body"+ <*> o .:? "body"+ <*> o .: "assignees" <*> o .: "issue_url" <*> o .: "diff_url" <*> o .: "url"@@ -193,25 +197,21 @@ <*> o .: "title" <*> o .: "id" -instance ToJSON EditPullRequestState where- toJSON (EditPullRequestStateOpen) = String "open"- toJSON (EditPullRequestStateClosed) = String "closed"- instance ToJSON EditPullRequest where- toJSON (EditPullRequest t b s) =- object $ filter notNull [ "title" .= t, "body" .= b, "state" .= s ]- where notNull (_, Null) = False- notNull (_, _) = True+ toJSON (EditPullRequest t b s) =+ object $ filter notNull [ "title" .= t, "body" .= b, "state" .= s ]+ where+ notNull (_, Null) = False+ notNull (_, _) = True instance ToJSON CreatePullRequest where- toJSON (CreatePullRequest t b headPR basePR) =- object [ "title" .= t, "body" .= b, "head" .= headPR, "base" .= basePR ]- toJSON (CreatePullRequestIssue issueNum headPR basePR) =- object [ "issue" .= issueNum, "head" .= headPR, "base" .= basePR]+ toJSON (CreatePullRequest t b headPR basePR) =+ object [ "title" .= t, "body" .= b, "head" .= headPR, "base" .= basePR ]+ toJSON (CreatePullRequestIssue issueNum headPR basePR) =+ object [ "issue" .= issueNum, "head" .= headPR, "base" .= basePR] instance FromJSON PullRequest where- parseJSON = withObject "PullRequest" $ \o ->- PullRequest+ parseJSON = withObject "PullRequest" $ \o -> PullRequest <$> o .:? "closed_at" <*> o .: "created_at" <*> o .: "user"@@ -220,7 +220,8 @@ <*> o .: "number" <*> o .: "html_url" <*> o .: "updated_at"- <*> o .: "body"+ <*> o .:? "body"+ <*> o .: "assignees" <*> o .: "issue_url" <*> o .: "diff_url" <*> o .: "url"@@ -239,53 +240,66 @@ <*> o .: "commits" <*> o .: "merged" <*> o .:? "mergeable"+ <*> o .: "mergeable_state" instance FromJSON PullRequestLinks where- parseJSON = withObject "PullRequestLinks" $ \o ->- PullRequestLinks <$> o <.:> ["review_comments", "href"]- <*> o <.:> ["comments", "href"]- <*> o <.:> ["html", "href"]- <*> o <.:> ["self", "href"]+ parseJSON = withObject "PullRequestLinks" $ \o -> PullRequestLinks+ <$> fmap getHref (o .: "review_comments")+ <*> fmap getHref (o .: "comments")+ <*> fmap getHref (o .: "html")+ <*> fmap getHref (o .: "self") instance FromJSON PullRequestCommit where- parseJSON = withObject "PullRequestCommit" $ \o ->- PullRequestCommit <$> o .: "label"- <*> o .: "ref"- <*> o .: "sha"- <*> o .: "user"- <*> o .: "repo"+ parseJSON = withObject "PullRequestCommit" $ \o -> PullRequestCommit+ <$> o .: "label"+ <*> o .: "ref"+ <*> o .: "sha"+ <*> o .: "user"+ <*> o .: "repo" instance FromJSON PullRequestEvent where- parseJSON = withObject "PullRequestEvent" $ \o ->- PullRequestEvent <$> o .: "action"- <*> o .: "number"- <*> o .: "pull_request"- <*> o .: "repository"- <*> o .: "sender"+ parseJSON = withObject "PullRequestEvent" $ \o -> PullRequestEvent+ <$> o .: "action"+ <*> o .: "number"+ <*> o .: "pull_request"+ <*> o .: "repository"+ <*> o .: "sender" instance FromJSON PullRequestEventType where- parseJSON (String "opened") = pure PullRequestOpened- parseJSON (String "closed") = pure PullRequestClosed- parseJSON (String "synchronize") = pure PullRequestSynchronized- parseJSON (String "reopened") = pure PullRequestReopened- parseJSON (String "assigned") = pure PullRequestAssigned- parseJSON (String "unassigned") = pure PullRequestUnassigned- parseJSON (String "labeled") = pure PullRequestLabeled- parseJSON (String "unlabeled") = pure PullRequestUnlabeled- parseJSON _ = fail "Could not build a PullRequestEventType"+ parseJSON (String "opened") = pure PullRequestOpened+ parseJSON (String "closed") = pure PullRequestClosed+ parseJSON (String "synchronize") = pure PullRequestSynchronized+ parseJSON (String "reopened") = pure PullRequestReopened+ parseJSON (String "assigned") = pure PullRequestAssigned+ parseJSON (String "unassigned") = pure PullRequestUnassigned+ parseJSON (String "labeled") = pure PullRequestLabeled+ parseJSON (String "unlabeled") = pure PullRequestUnlabeled+ parseJSON v = typeMismatch "Could not build a PullRequestEventType" v instance FromJSON PullRequestReference where- parseJSON = withObject "PullRequestReference" $ \o ->- PullRequestReference <$> o .:? "html_url"- <*> o .:? "patch_url"- <*> o .:? "diff_url"+ parseJSON = withObject "PullRequestReference" $ \o -> PullRequestReference+ <$> o .:? "html_url"+ <*> o .:? "patch_url"+ <*> o .:? "diff_url" -- Helpers --- | Produce the value for the last key by traversing.-(<.:>) :: FromJSON v => Object -> [Text] -> Parser v-obj <.:> [key] = obj .: key-obj <.:> (key:keys) = do- obj' <- obj .: key- obj' <.:> keys-_obj <.:> [] = fail "<.:> never happens - empty path"+newtype Href a = Href { getHref :: a }++instance FromJSON a => FromJSON (Href a) where+ parseJSON = withObject "href object" $+ \obj -> Href <$> obj .: "href"++-- | Pull request merge results+data MergeResult+ = MergeSuccessful+ | MergeCannotPerform+ | MergeConflict+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)++statusMerge :: StatusMap MergeResult+statusMerge =+ [ (204, MergeSuccessful)+ , (405, MergeCannotPerform)+ , (409, MergeConflict)+ ]
src/GitHub/Data/Repos.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} #define UNSAFE 1 ----------------------------------------------------------------------------- -- |@@ -11,66 +8,57 @@ -- -- This module also exports -- @'FromJSON' a => 'FromJSON' ('HM.HashMap' 'Language' a)@--- orphan-ish instance.+-- orphan-ish instance for @aeson < 1@ module GitHub.Data.Repos where -import Prelude ()-import Prelude.Compat- import GitHub.Data.Definitions import GitHub.Data.Id (Id) import GitHub.Data.Name (Name)----import Control.Arrow (first) -- Data.Bifunctor would be better-import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), ToJSON (..), object, withObject,- withText, (.:), (.:?), (.=))-import Data.Binary (Binary)-import Data.Data (Data, Typeable)-import Data.Hashable (Hashable (..))-import Data.String (IsString (..))-import Data.Text (Text)-import Data.Time (UTCTime)-import GHC.Generics (Generic)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude () import qualified Data.HashMap.Strict as HM--#if UNSAFE+#if MIN_VERSION_aeson(1,0,0)+import Data.Aeson.Types (FromJSONKey (..), fromJSONKeyCoerce)+#else+#ifdef UNSAFE import Unsafe.Coerce (unsafeCoerce) #endif+#endif -data Repo = Repo {- repoSshUrl :: !(Maybe Text)- ,repoDescription :: !(Maybe Text)- ,repoCreatedAt :: !(Maybe UTCTime)- ,repoHtmlUrl :: !Text- ,repoSvnUrl :: !(Maybe Text)- ,repoForks :: !(Maybe Int)- ,repoHomepage :: !(Maybe Text)- ,repoFork :: !(Maybe Bool)- ,repoGitUrl :: !(Maybe Text)- ,repoPrivate :: !Bool- ,repoCloneUrl :: !(Maybe Text)- ,repoSize :: !(Maybe Int)- ,repoUpdatedAt :: !(Maybe UTCTime)- ,repoWatchers :: !(Maybe Int)- ,repoOwner :: !SimpleOwner- ,repoName :: !(Name Repo)- ,repoLanguage :: !(Maybe Language)- ,repoMasterBranch :: !(Maybe Text)- ,repoPushedAt :: !(Maybe UTCTime) -- ^ this is Nothing for new repositories- ,repoId :: !(Id Repo)- ,repoUrl :: !Text- ,repoOpenIssues :: !(Maybe Int)- ,repoHasWiki :: !(Maybe Bool)- ,repoHasIssues :: !(Maybe Bool)- ,repoHasDownloads :: !(Maybe Bool)- ,repoParent :: !(Maybe RepoRef)- ,repoSource :: !(Maybe RepoRef)- ,repoHooksUrl :: !Text- ,repoStargazersCount :: !Int-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Repo = Repo+ { repoSshUrl :: !(Maybe URL)+ , repoDescription :: !(Maybe Text)+ , repoCreatedAt :: !(Maybe UTCTime)+ , repoHtmlUrl :: !URL+ , repoSvnUrl :: !(Maybe URL)+ , repoForks :: !(Maybe Int)+ , repoHomepage :: !(Maybe Text)+ , repoFork :: !(Maybe Bool)+ , repoGitUrl :: !(Maybe URL)+ , repoPrivate :: !Bool+ , repoCloneUrl :: !(Maybe URL)+ , repoSize :: !(Maybe Int)+ , repoUpdatedAt :: !(Maybe UTCTime)+ , repoWatchers :: !(Maybe Int)+ , repoOwner :: !SimpleOwner+ , repoName :: !(Name Repo)+ , repoLanguage :: !(Maybe Language)+ , repoDefaultBranch :: !(Maybe Text)+ , repoPushedAt :: !(Maybe UTCTime) -- ^ this is Nothing for new repositories+ , repoId :: !(Id Repo)+ , repoUrl :: !URL+ , repoOpenIssues :: !(Maybe Int)+ , repoHasWiki :: !(Maybe Bool)+ , repoHasIssues :: !(Maybe Bool)+ , repoHasDownloads :: !(Maybe Bool)+ , repoParent :: !(Maybe RepoRef)+ , repoSource :: !(Maybe RepoRef)+ , repoHooksUrl :: !URL+ , repoStargazersCount :: !Int+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Repo where rnf = genericRnf instance Binary Repo@@ -84,15 +72,15 @@ instance NFData RepoRef where rnf = genericRnf instance Binary RepoRef -data NewRepo = NewRepo {- newRepoName :: !(Name Repo)-, newRepoDescription :: !(Maybe Text)-, newRepoHomepage :: !(Maybe Text)-, newRepoPrivate :: !(Maybe Bool)-, newRepoHasIssues :: !(Maybe Bool)-, newRepoHasWiki :: !(Maybe Bool)-, newRepoAutoInit :: !(Maybe Bool)-} deriving (Eq, Ord, Show, Data, Typeable, Generic)+data NewRepo = NewRepo+ { newRepoName :: !(Name Repo)+ , newRepoDescription :: !(Maybe Text)+ , newRepoHomepage :: !(Maybe Text)+ , newRepoPrivate :: !(Maybe Bool)+ , newRepoHasIssues :: !(Maybe Bool)+ , newRepoHasWiki :: !(Maybe Bool)+ , newRepoAutoInit :: !(Maybe Bool)+ } deriving (Eq, Ord, Show, Data, Typeable, Generic) instance NFData NewRepo where rnf = genericRnf instance Binary NewRepo@@ -100,15 +88,16 @@ newRepo :: Name Repo -> NewRepo newRepo name = NewRepo name Nothing Nothing Nothing Nothing Nothing Nothing -data EditRepo = EditRepo {- editName :: !(Maybe (Name Repo))-, editDescription :: !(Maybe Text)-, editHomepage :: !(Maybe Text)-, editPublic :: !(Maybe Bool)-, editHasIssues :: !(Maybe Bool)-, editHasWiki :: !(Maybe Bool)-, editHasDownloads :: !(Maybe Bool)-} deriving (Eq, Ord, Show, Data, Typeable, Generic)+data EditRepo = EditRepo+ { editName :: !(Maybe (Name Repo))+ , editDescription :: !(Maybe Text)+ , editHomepage :: !(Maybe Text)+ , editPublic :: !(Maybe Bool)+ , editHasIssues :: !(Maybe Bool)+ , editHasWiki :: !(Maybe Bool)+ , editHasDownloads :: !(Maybe Bool)+ }+ deriving (Eq, Ord, Show, Data, Typeable, Generic) instance NFData EditRepo where rnf = genericRnf instance Binary EditRepo@@ -140,12 +129,12 @@ fromString = Language . fromString data Contributor- -- | An existing Github user, with their number of contributions, avatar- -- URL, login, URL, ID, and Gravatar ID.- = KnownContributor !Int !Text !(Name User) !Text !(Id User) !Text- -- | An unknown Github user with their number of contributions and recorded name.- | AnonymousContributor !Int !Text- deriving (Show, Data, Typeable, Eq, Ord, Generic)+ -- | An existing Github user, with their number of contributions, avatar+ -- URL, login, URL, ID, and Gravatar ID.+ = KnownContributor !Int !URL !(Name User) !URL !(Id User) !Text+ -- | An unknown Github user with their number of contributions and recorded name.+ | AnonymousContributor !Int !Text+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Contributor where rnf = genericRnf instance Binary Contributor@@ -153,41 +142,40 @@ contributorToSimpleUser :: Contributor -> Maybe SimpleUser contributorToSimpleUser (AnonymousContributor _ _) = Nothing contributorToSimpleUser (KnownContributor _contributions avatarUrl name url uid _gravatarid) =- Just $ SimpleUser uid name avatarUrl url OwnerUser+ Just $ SimpleUser uid name avatarUrl url -- JSON instances instance FromJSON Repo where- parseJSON = withObject "Repo" $ \o ->- Repo <$> o .:? "ssh_url"- <*> o .: "description"- <*> o .:? "created_at"- <*> o .: "html_url"- <*> o .:? "svn_url"- <*> o .:? "forks"- <*> o .:? "homepage"- <*> o .: "fork"- <*> o .:? "git_url"- <*> o .: "private"- <*> o .:? "clone_url"- <*> o .:? "size"- <*> o .:? "updated_at"- <*> o .:? "watchers"- <*> o .: "owner"- <*> o .: "name"- <*> o .:? "language"- <*> o .:? "master_branch"- <*> o .:? "pushed_at"- <*> o .: "id"- <*> o .: "url"- <*> o .:? "open_issues"- <*> o .:? "has_wiki"- <*> o .:? "has_issues"- <*> o .:? "has_downloads"- <*> o .:? "parent"- <*> o .:? "source"- <*> o .: "hooks_url"- <*> o .: "stargazers_count"+ parseJSON = withObject "Repo" $ \o -> Repo <$> o .:? "ssh_url"+ <*> o .: "description"+ <*> o .:? "created_at"+ <*> o .: "html_url"+ <*> o .:? "svn_url"+ <*> o .:? "forks"+ <*> o .:? "homepage"+ <*> o .: "fork"+ <*> o .:? "git_url"+ <*> o .: "private"+ <*> o .:? "clone_url"+ <*> o .:? "size"+ <*> o .:? "updated_at"+ <*> o .:? "watchers"+ <*> o .: "owner"+ <*> o .: "name"+ <*> o .:? "language"+ <*> o .:? "default_branch"+ <*> o .:? "pushed_at"+ <*> o .: "id"+ <*> o .: "url"+ <*> o .:? "open_issues"+ <*> o .:? "has_wiki"+ <*> o .:? "has_issues"+ <*> o .:? "has_downloads"+ <*> o .:? "parent"+ <*> o .:? "source"+ <*> o .: "hooks_url"+ <*> o .: "stargazers_count" instance ToJSON NewRepo where toJSON (NewRepo { newRepoName = name@@ -226,26 +214,24 @@ ] instance FromJSON RepoRef where- parseJSON = withObject "RepoRef" $ \o ->- RepoRef <$> o .: "owner"- <*> o .: "name"+ parseJSON = withObject "RepoRef" $ \o -> RepoRef+ <$> o .: "owner"+ <*> o .: "name" instance FromJSON Contributor where parseJSON = withObject "Contributor" $ \o -> do t <- o .: "type"- case t of- _ | t == ("Anonymous" :: Text) ->- AnonymousContributor- <$> o .: "contributions"- <*> o .: "name"- _ | otherwise ->- KnownContributor- <$> o .: "contributions"- <*> o .: "avatar_url"- <*> o .: "login"- <*> o .: "url"- <*> o .: "id"- <*> o .: "gravatar_id"+ case (t :: Text) of+ "Anonymous" -> AnonymousContributor+ <$> o .: "contributions"+ <*> o .: "name"+ _ -> KnownContributor+ <$> o .: "contributions"+ <*> o .: "avatar_url"+ <*> o .: "login"+ <*> o .: "url"+ <*> o .: "id"+ <*> o .: "gravatar_id" instance FromJSON Language where parseJSON = withText "Language" (pure . Language)@@ -253,6 +239,10 @@ instance ToJSON Language where toJSON = toJSON . getLanguage +#if MIN_VERSION_aeson(1,0,0)+instance FromJSONKey Language where+ fromJSONKey = fromJSONKeyCoerce+#else instance FromJSON a => FromJSON (HM.HashMap Language a) where parseJSON = fmap mapKeyLanguage . parseJSON where@@ -263,4 +253,5 @@ mapKeyLanguage = mapKey Language mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> HM.HashMap k1 a -> HM.HashMap k2 a mapKey f = HM.fromList . map (first f) . HM.toList+#endif #endif
src/GitHub/Data/Request.hs view
@@ -1,11 +1,7 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- |@@ -13,53 +9,54 @@ -- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi> -- module GitHub.Data.Request (- Request(..),+ -- * Request+ Request (..),+ SimpleRequest (..),+ -- * Smart constructors+ query, pagedQuery, command,+ -- * Auxiliary types+ RW(..),+ StatusMap,+ statusOnlyOk, CommandMethod(..), toMethod,- StatusMap(..),- MergeResult(..),+ FetchCount(..), Paths, IsPathPart(..), QueryString, Count, ) where -import Data.Aeson.Compat (FromJSON)-import Data.Hashable (Hashable (..))-import Data.Typeable (Typeable)-import Data.Vector (Vector)-import GHC.Generics (Generic)+import GitHub.Data.Definitions (Count, QueryString)+import GitHub.Data.Id (Id, untagId)+import GitHub.Data.Name (Name, untagName)+import GitHub.Internal.Prelude -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T+import qualified Network.HTTP.Types as Types import qualified Network.HTTP.Types.Method as Method--import GitHub.Data.Id (Id, untagId)-import GitHub.Data.Name (Name, untagName)- ------------------------------------------------------------------------------ -- Auxillary types ------------------------------------------------------------------------------ -type Paths = [String]-type QueryString = [(BS.ByteString, Maybe BS.ByteString)]-type Count = Int+type Paths = [Text] class IsPathPart a where- toPathPart :: a -> String+ toPathPart :: a -> Text instance IsPathPart (Name a) where- toPathPart = T.unpack . untagName+ toPathPart = untagName instance IsPathPart (Id a) where- toPathPart = show . untagId+ toPathPart = T.pack . show . untagId -- | Http method of requests with body. data CommandMethod a where Post :: CommandMethod a Patch :: CommandMethod a Put :: CommandMethod a+ Put' :: CommandMethod () Delete :: CommandMethod () deriving (Typeable) @@ -69,93 +66,158 @@ showsPrec _ Post = showString "Post" showsPrec _ Patch = showString "Patch" showsPrec _ Put = showString "Put"+ showsPrec _ Put' = showString "Put'" showsPrec _ Delete = showString "Delete" instance Hashable (CommandMethod a) where hashWithSalt salt Post = hashWithSalt salt (0 :: Int) hashWithSalt salt Patch = hashWithSalt salt (1 :: Int) hashWithSalt salt Put = hashWithSalt salt (2 :: Int)- hashWithSalt salt Delete = hashWithSalt salt (3 :: Int)+ hashWithSalt salt Put' = hashWithSalt salt (3 :: Int)+ hashWithSalt salt Delete = hashWithSalt salt (4 :: Int) toMethod :: CommandMethod a -> Method.Method toMethod Post = Method.methodPost toMethod Patch = Method.methodPatch toMethod Put = Method.methodPut+toMethod Put' = Method.methodPut toMethod Delete = Method.methodDelete --- | Result of merge operation-data MergeResult = MergeSuccessful- | MergeCannotPerform- | MergeConflict- deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)+-- | 'PagedQuery' returns just some results, using this data we can specify how+-- many pages we want to fetch.+data FetchCount = FetchAtLeast !Word | FetchAll+ deriving (Eq, Ord, Read, Show, Generic, Typeable) -instance Hashable MergeResult --- | Status code transform-data StatusMap a where- StatusOnlyOk :: StatusMap Bool- StatusMerge :: StatusMap MergeResult- deriving (Typeable)+-- | This instance is there mostly for 'fromInteger'.+instance Num FetchCount where+ fromInteger = FetchAtLeast . fromInteger -deriving instance Eq (StatusMap a)+ FetchAtLeast a + FetchAtLeast b = FetchAtLeast (a * b)+ _ + _ = FetchAll -instance Show (StatusMap a) where- showsPrec _ StatusOnlyOk = showString "StatusOnlyOK"- showsPrec _ StatusMerge = showString "StatusMerge"+ FetchAtLeast a * FetchAtLeast b = FetchAtLeast (a * b)+ _ * _ = FetchAll -instance Hashable (StatusMap a) where- hashWithSalt salt StatusOnlyOk = hashWithSalt salt (0 :: Int)- hashWithSalt salt StatusMerge = hashWithSalt salt (1 :: Int)+ abs = error "abs @FetchCount: not implemented"+ signum = error "signum @FetchCount: not implemented"+ negate = error "negate @FetchCount: not implemented" +instance Hashable FetchCount+instance Binary FetchCount+instance NFData FetchCount where rnf = genericRnf+ ------------------------------------------------------------------------------ -- Github request ------------------------------------------------------------------------------ +-- | Type used as with @DataKinds@ to tag whether requests need authentication+-- or aren't read-only.+data RW+ = RO -- ^ /Read-only/, doesn't necessarily requires authentication+ | RA -- ^ /Read autenticated/+ | RW -- ^ /Read-write/, requires authentication+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic)++{-+data SRO (rw :: RW) where+ ROO :: SRO 'RO+ ROA :: SRO 'RA++-- | This class is used to describe read-only (but pontentially+class IReadOnly (rw :: RW) where iro :: SRO rw+instance IReadOnly 'RO where iro = ROO+instance IReadOnly 'RA where iro = ROA+-}+ -- | Github request data type. -- -- * @k@ describes whether authentication is required. It's required for non-@GET@ requests. -- * @a@ is the result type -- -- /Note:/ 'Request' is not 'Functor' on purpose.-data Request (k :: Bool) a where- Query :: FromJSON a => Paths -> QueryString -> Request k a- PagedQuery :: FromJSON (Vector a) => Paths -> QueryString -> Maybe Count -> Request k (Vector a)- Command :: FromJSON a => CommandMethod a -> Paths -> LBS.ByteString -> Request 'True a- StatusQuery :: StatusMap a -> Request k () -> Request k a- deriving (Typeable)+data Request (k :: RW) a where+ SimpleQuery :: FromJSON a => SimpleRequest k a -> Request k a+ StatusQuery :: StatusMap a -> SimpleRequest k () -> Request k a+ HeaderQuery :: FromJSON a => Types.RequestHeaders -> SimpleRequest k a -> Request k a+ deriving (Typeable) -deriving instance Eq (Request k a)+data SimpleRequest (k :: RW) a where+ Query :: Paths -> QueryString -> SimpleRequest k a+ PagedQuery :: Paths -> QueryString -> FetchCount -> SimpleRequest k (Vector a)+ Command :: CommandMethod a -> Paths -> LBS.ByteString -> SimpleRequest 'RW a+ deriving (Typeable) +-------------------------------------------------------------------------------+-- Status Map+-------------------------------------------------------------------------------++-- TODO: Change to 'Map' ?+type StatusMap a = [(Int, a)]++statusOnlyOk :: StatusMap Bool+statusOnlyOk =+ [ (202, True)+ , (404, False)+ ]++-------------------------------------------------------------------------------+-- Smart constructors+-------------------------------------------------------------------------------++query :: FromJSON a => Paths -> QueryString -> Request k a+query ps qs = SimpleQuery (Query ps qs)++pagedQuery :: FromJSON a => Paths -> QueryString -> FetchCount -> Request k (Vector a)+pagedQuery ps qs fc = SimpleQuery (PagedQuery ps qs fc)++command :: FromJSON a => CommandMethod a -> Paths -> LBS.ByteString -> Request 'RW a+command m ps body = SimpleQuery (Command m ps body)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++deriving instance Eq a => Eq (Request k a)+deriving instance Eq a => Eq (SimpleRequest k a)++instance Show (SimpleRequest k a) where+ showsPrec d r = showParen (d > appPrec) $ case r of+ Query ps qs -> showString "Query "+ . showsPrec (appPrec + 1) ps+ . showString " "+ . showsPrec (appPrec + 1) qs+ PagedQuery ps qs l -> showString "PagedQuery "+ . showsPrec (appPrec + 1) ps+ . showString " "+ . showsPrec (appPrec + 1) qs+ . showString " "+ . showsPrec (appPrec + 1) l+ Command m ps body -> showString "Command "+ . showsPrec (appPrec + 1) m+ . showString " "+ . showsPrec (appPrec + 1) ps+ . showString " "+ . showsPrec (appPrec + 1) body+ where+ appPrec = 10 :: Int+ instance Show (Request k a) where- showsPrec d r =- case r of- Query ps qs -> showParen (d > appPrec) $- showString "Query "- . showsPrec (appPrec + 1) ps- . showString " "- . showsPrec (appPrec + 1) qs- PagedQuery ps qs l -> showParen (d > appPrec) $- showString "PagedQuery "- . showsPrec (appPrec + 1) ps- . showString " "- . showsPrec (appPrec + 1) qs- . showString " "- . showsPrec (appPrec + 1) l- Command m ps body -> showParen (d > appPrec) $- showString "Command "- . showsPrec (appPrec + 1) m- . showString " "- . showsPrec (appPrec + 1) ps- . showString " "- . showsPrec (appPrec + 1) body- StatusQuery m req -> showParen (d > appPrec) $- showString "Status "- . showsPrec (appPrec + 1) m- . showString " "- . showsPrec (appPrec + 1) req- where appPrec = 10 :: Int+ showsPrec d r = showParen (d > appPrec) $ case r of+ SimpleQuery req -> showString "SimpleQuery "+ . showsPrec (appPrec + 1) req+ StatusQuery m req -> showString "Status "+ . showsPrec (appPrec + 1) (map fst m) -- !!! printing only keys+ . showString " "+ . showsPrec (appPrec + 1) req+ HeaderQuery m req -> showString "Header "+ . showsPrec (appPrec + 1) m+ . showString " "+ . showsPrec (appPrec + 1) req+ where+ appPrec = 10 :: Int -instance Hashable (Request k a) where+instance Hashable (SimpleRequest k a) where hashWithSalt salt (Query ps qs) = salt `hashWithSalt` (0 :: Int) `hashWithSalt` ps@@ -170,7 +232,16 @@ `hashWithSalt` m `hashWithSalt` ps `hashWithSalt` body++instance Hashable (Request k a) where+ hashWithSalt salt (SimpleQuery req) =+ salt `hashWithSalt` (0 :: Int)+ `hashWithSalt` req hashWithSalt salt (StatusQuery sm req) =- salt `hashWithSalt` (3 :: Int)- `hashWithSalt` sm+ salt `hashWithSalt` (1 :: Int)+ `hashWithSalt` map fst sm+ `hashWithSalt` req+ hashWithSalt salt (HeaderQuery h req) =+ salt `hashWithSalt` (2 :: Int)+ `hashWithSalt` h `hashWithSalt` req
src/GitHub/Data/Search.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,54 +5,47 @@ -- module GitHub.Data.Search where -import Prelude ()-import Prelude.Compat--import GitHub.Data.Repos (Repo)--import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), withObject, (.!=), (.:), (.:?))-import Data.Binary (Binary)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import Data.Vector (Vector)-import GHC.Generics (Generic)+import GitHub.Data.Repos (Repo)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude () import qualified Data.Vector as V -data SearchResult entity = SearchResult {- searchResultTotalCount :: !Int- ,searchResultResults :: !(Vector entity)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data SearchResult entity = SearchResult+ { searchResultTotalCount :: !Int+ , searchResultResults :: !(Vector entity)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData entity => NFData (SearchResult entity) where rnf = genericRnf instance Binary entity => Binary (SearchResult entity) instance FromJSON entity => FromJSON (SearchResult entity) where- parseJSON = withObject "SearchResult" $ \o ->- SearchResult <$> o .: "total_count"- <*> o .:? "items" .!= V.empty+ parseJSON = withObject "SearchResult" $ \o -> SearchResult+ <$> o .: "total_count"+ <*> o .:? "items" .!= V.empty -data Code = Code {- codeName :: !Text- ,codePath :: !Text- ,codeSha :: !Text- ,codeUrl :: !Text- ,codeGitUrl :: !Text- ,codeHtmlUrl :: !Text- ,codeRepo :: !Repo-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Code = Code+ { codeName :: !Text+ , codePath :: !Text+ , codeSha :: !Text+ , codeUrl :: !URL+ , codeGitUrl :: !URL+ , codeHtmlUrl :: !URL+ , codeRepo :: !Repo+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Code where rnf = genericRnf instance Binary Code instance FromJSON Code where- parseJSON = withObject "Code" $ \o ->- Code <$> o .: "name"- <*> o .: "path"- <*> o .: "sha"- <*> o .: "url"- <*> o .: "git_url"- <*> o .: "html_url"- <*> o .: "repository"+ parseJSON = withObject "Code" $ \o -> Code+ <$> o .: "name"+ <*> o .: "path"+ <*> o .: "sha"+ <*> o .: "url"+ <*> o .: "git_url"+ <*> o .: "html_url"+ <*> o .: "repository"
src/GitHub/Data/Teams.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- |@@ -8,117 +9,119 @@ -- module GitHub.Data.Teams where -import Prelude ()-import Prelude.Compat- import GitHub.Data.Definitions--import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), ToJSON (..), Value (..), object,- withObject, (.!=), (.:), (.:?), (.=))-import Data.Binary (Binary)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import Data.Vector (Vector)-import GHC.Generics (Generic)--import GitHub.Data.Id (Id)-import GitHub.Data.Name (Name)-import GitHub.Data.Repos (Repo)+import GitHub.Data.Id (Id)+import GitHub.Data.Name (Name)+import GitHub.Data.Repos (Repo)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude () -data Privacy =- PrivacyClosed- | PrivacySecret- deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic)+data Privacy+ = PrivacyClosed+ | PrivacySecret+ deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) instance NFData Privacy where rnf = genericRnf instance Binary Privacy -data Permission =- PermissionPull- | PermissionPush- | PermissionAdmin- deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic)+data Permission+ = PermissionPull+ | PermissionPush+ | PermissionAdmin+ deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) instance NFData Permission where rnf = genericRnf instance Binary Permission -data SimpleTeam = SimpleTeam {- simpleTeamId :: !(Id Team)- ,simpleTeamUrl :: !Text- ,simpleTeamName :: !Text -- TODO (0.15.0): unify this and 'simpleTeamSlug' as in 'Team'.- ,simpleTeamSlug :: !(Name Team)- ,simpleTeamDescription :: !(Maybe Text)- ,simpleTeamPrivacy :: !(Maybe Privacy)- ,simpleTeamPermission :: !Permission- ,simpleTeamMembersUrl :: !Text- ,simpleTeamRepositoriesUrl :: !Text-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data AddTeamRepoPermission = AddTeamRepoPermission+ { addTeamRepoPermission :: !Permission+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) +instance NFData AddTeamRepoPermission where rnf = genericRnf+instance Binary AddTeamRepoPermission++data SimpleTeam = SimpleTeam+ { simpleTeamId :: !(Id Team)+ , simpleTeamUrl :: !URL+ , simpleTeamName :: !Text -- TODO (0.15.0): unify this and 'simpleTeamSlug' as in 'Team'.+ , simpleTeamSlug :: !(Name Team)+ , simpleTeamDescription :: !(Maybe Text)+ , simpleTeamPrivacy :: !(Maybe Privacy)+ , simpleTeamPermission :: !Permission+ , simpleTeamMembersUrl :: !URL+ , simpleTeamRepositoriesUrl :: !URL+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic)+ instance NFData SimpleTeam where rnf = genericRnf instance Binary SimpleTeam -data Team = Team {- teamId :: !(Id Team)- ,teamUrl :: !Text- ,teamName :: !(Name Team)- ,teamSlug :: !Text- ,teamDescription :: !(Maybe Text)- ,teamPrivacy :: !(Maybe Privacy)- ,teamPermission :: !Permission- ,teamMembersUrl :: !Text- ,teamRepositoriesUrl :: !Text- ,teamMembersCount :: !Int- ,teamReposCount :: !Int- ,teamOrganization :: !SimpleOrganization-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Team = Team+ { teamId :: !(Id Team)+ , teamUrl :: !URL+ , teamName :: !Text+ , teamSlug :: !(Name Team)+ , teamDescription :: !(Maybe Text)+ , teamPrivacy :: !(Maybe Privacy)+ , teamPermission :: !Permission+ , teamMembersUrl :: !URL+ , teamRepositoriesUrl :: !URL+ , teamMembersCount :: !Int+ , teamReposCount :: !Int+ , teamOrganization :: !SimpleOrganization+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Team where rnf = genericRnf instance Binary Team -data CreateTeam = CreateTeam {- createTeamName :: !(Name Team)- ,createTeamDescription :: !(Maybe Text)- ,createTeamRepoNames :: !(Vector (Name Repo))- {-,createTeamPrivacy :: Privacy-}- ,createTeamPermission :: Permission-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data CreateTeam = CreateTeam+ { createTeamName :: !(Name Team)+ , createTeamDescription :: !(Maybe Text)+ , createTeamRepoNames :: !(Vector (Name Repo))+ -- , createTeamPrivacy :: Privacy+ , createTeamPermission :: Permission+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData CreateTeam where rnf = genericRnf instance Binary CreateTeam -data EditTeam = EditTeam {- editTeamName :: !(Name Team)- ,editTeamDescription :: !(Maybe Text)- {-,editTeamPrivacy :: Privacy-}- ,editTeamPermission :: !Permission-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data EditTeam = EditTeam+ { editTeamName :: !(Name Team)+ , editTeamDescription :: !(Maybe Text)+ -- , editTeamPrivacy :: Privacy+ , editTeamPermission :: !Permission+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData EditTeam where rnf = genericRnf instance Binary EditTeam -data Role =- RoleMaintainer- | RoleMember- deriving (Show, Data, Typeable, Eq, Ord, Generic)+data Role+ = RoleMaintainer+ | RoleMember+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Role instance Binary Role -data ReqState =- StatePending- | StateActive- deriving (Show, Data, Typeable, Eq, Ord, Generic)+data ReqState+ = StatePending+ | StateActive+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData ReqState where rnf = genericRnf instance Binary ReqState -data TeamMembership = TeamMembership {- teamMembershipUrl :: !Text,- teamMembershipRole :: !Role,- teamMembershipReqState :: !ReqState-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data TeamMembership = TeamMembership+ { teamMembershipUrl :: !URL+ , teamMembershipRole :: !Role+ , teamMembershipReqState :: !ReqState+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData TeamMembership where rnf = genericRnf instance Binary TeamMembership@@ -133,31 +136,31 @@ -- JSON Instances instance FromJSON SimpleTeam where- parseJSON = withObject "SimpleTeam" $ \o ->- SimpleTeam <$> o .: "id"- <*> o .: "url"- <*> o .: "name"- <*> o .: "slug"- <*> o .:?"description" .!= Nothing- <*> o .:?"privacy" .!= Nothing- <*> o .: "permission"- <*> o .: "members_url"- <*> o .: "repositories_url"+ parseJSON = withObject "SimpleTeam" $ \o -> SimpleTeam+ <$> o .: "id"+ <*> o .: "url"+ <*> o .: "name"+ <*> o .: "slug"+ <*> o .:?"description" .!= Nothing+ <*> o .:?"privacy" .!= Nothing+ <*> o .: "permission"+ <*> o .: "members_url"+ <*> o .: "repositories_url" instance FromJSON Team where- parseJSON = withObject "Team" $ \o ->- Team <$> o .: "id"- <*> o .: "url"- <*> o .: "name"- <*> o .: "slug"- <*> o .:?"description" .!= Nothing- <*> o .:?"privacy" .!= Nothing- <*> o .: "permission"- <*> o .: "members_url"- <*> o .: "repositories_url"- <*> o .: "members_count"- <*> o .: "repos_count"- <*> o .: "organization"+ parseJSON = withObject "Team" $ \o -> Team+ <$> o .: "id"+ <*> o .: "url"+ <*> o .: "name"+ <*> o .: "slug"+ <*> o .:?"description" .!= Nothing+ <*> o .:?"privacy" .!= Nothing+ <*> o .: "permission"+ <*> o .: "members_url"+ <*> o .: "repositories_url"+ <*> o .: "members_count"+ <*> o .: "repos_count"+ <*> o .: "organization" instance ToJSON CreateTeam where toJSON (CreateTeam name desc repo_names {-privacy-} permissions) =@@ -175,74 +178,68 @@ , "permissions" .= permissions ] instance FromJSON TeamMembership where- parseJSON = withObject "TeamMembership" $ \o ->- TeamMembership <$> o .: "url"- <*> o .: "role"- <*> o .: "state"+ parseJSON = withObject "TeamMembership" $ \o -> TeamMembership+ <$> o .: "url"+ <*> o .: "role"+ <*> o .: "state" instance FromJSON CreateTeamMembership where- parseJSON = withObject "CreateTeamMembership" $ \o ->- CreateTeamMembership <$> o .: "role"+ parseJSON = withObject "CreateTeamMembership" $ \o -> CreateTeamMembership+ <$> o .: "role" instance ToJSON CreateTeamMembership where- toJSON (CreateTeamMembership { createTeamMembershipRole = role }) =- object [ "role" .= role ]+ toJSON (CreateTeamMembership { createTeamMembershipRole = role }) =+ object [ "role" .= role ] +instance FromJSON AddTeamRepoPermission where+ parseJSON = withObject "AddTeamRepoPermission" $ \o -> AddTeamRepoPermission+ <$> o .: "permission"++instance ToJSON AddTeamRepoPermission where+ toJSON (AddTeamRepoPermission { addTeamRepoPermission = permission}) =+ object [ "permission" .= permission ]+ instance FromJSON Role where- parseJSON (String attr) =- case attr of- "maintainer" -> return RoleMaintainer- "member" -> return RoleMember- _ -> fail "Unknown Role"- parseJSON _ = fail "Could not build Role"+ parseJSON = withText "Attribute" $ \attr -> case attr of+ "maintainer" -> return RoleMaintainer+ "member" -> return RoleMember+ _ -> fail $ "Unknown Role: " ++ show attr instance ToJSON Role where- toJSON RoleMaintainer = String "maintainer"- toJSON RoleMember = String "member"+ toJSON RoleMaintainer = String "maintainer"+ toJSON RoleMember = String "member" instance ToJSON Permission where- toJSON attr =- String $- case attr of- PermissionPull -> "pull"- PermissionPush -> "push"- PermissionAdmin -> "admin"+ toJSON PermissionPull = "pull"+ toJSON PermissionPush = "push"+ toJSON PermissionAdmin = "admin" instance FromJSON Permission where- parseJSON (String attr) =- case attr of- "pull" -> return PermissionPull- "push" -> return PermissionPush- "admin" -> return PermissionAdmin- _ -> fail "Unknown Permission Attribute"- parseJSON _ = fail "Could not build Permission"+ parseJSON = withText "Permission Attribute" $ \attr -> case attr of + "pull" -> return PermissionPull+ "push" -> return PermissionPush+ "admin" -> return PermissionAdmin+ _ -> fail $ "Unknown Permission Attribute: " ++ show attr instance FromJSON Privacy where- parseJSON (String attr) =- case attr of- "secret" -> return PrivacySecret- "closed" -> return PrivacyClosed- _ -> fail "Unknown Privacy Attribute"- parseJSON _ = fail "Could not build Privacy"+ parseJSON = withText "Privacy Attribute" $ \attr -> case attr of+ "secret" -> return PrivacySecret+ "closed" -> return PrivacyClosed+ _ -> fail $ "Unknown Privacy Attribute: " ++ show attr instance ToJSON Privacy where- toJSON attr =- String $- case attr of- PrivacySecret -> "secret"- PrivacyClosed -> "closed"+ toJSON PrivacySecret = String "secret"+ toJSON PrivacyClosed = String "closed" instance FromJSON ReqState where- parseJSON (String attr) =- case attr of- "active" -> return StateActive- "pending" -> return StatePending- _ -> fail "Unknown ReqState"- parseJSON _ = fail "Could not build ReqState"+ parseJSON = withText "ReqState" $ \attr -> case attr of+ "active" -> return StateActive+ "pending" -> return StatePending+ _ -> fail $ "Unknown ReqState: " ++ show attr instance ToJSON ReqState where- toJSON StateActive = String "active"- toJSON StatePending = String "pending"+ toJSON StateActive = String "active"+ toJSON StatePending = String "pending" -- | Filters members returned by their role in the team. data TeamMemberRole
+ src/GitHub/Data/URL.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- License : BSD-3-Clause+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+module GitHub.Data.URL (+ URL(..),+ getUrl,+ ) where++import GitHub.Internal.Prelude+import Prelude ()++-- | Data representing URLs in responses.+--+-- /N.B./ syntactical validity is not verified.+newtype URL = URL Text+ deriving (Eq, Ord, Show, Generic, Typeable, Data)++getUrl :: URL -> Text+getUrl (URL url) = url++instance NFData URL where rnf = genericRnf+instance Binary URL++instance ToJSON URL where+ toJSON (URL url) = toJSON url++instance FromJSON URL where+ parseJSON = withText "URL" (pure . URL)
src/GitHub/Data/Webhooks.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,101 +5,96 @@ -- module GitHub.Data.Webhooks where -import Prelude ()-import Prelude.Compat--import GitHub.Data.Id (Id)--import Control.DeepSeq (NFData (..))-import Control.DeepSeq.Generics (genericRnf)-import Data.Aeson.Compat (FromJSON (..), ToJSON (..), Value (..), object,- withObject, (.:), (.=))-import Data.Binary.Orphans (Binary)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import Data.Time (UTCTime)-import Data.Vector (Vector)-import GHC.Generics (Generic)+import GitHub.Data.Id (Id)+import GitHub.Data.URL (URL)+import GitHub.Internal.Prelude+import Prelude () import qualified Data.Map as M -data RepoWebhook = RepoWebhook {- repoWebhookUrl :: !Text- ,repoWebhookTestUrl :: !Text- ,repoWebhookId :: !(Id RepoWebhook)- ,repoWebhookName :: !Text- ,repoWebhookActive :: !Bool- ,repoWebhookEvents :: !(Vector RepoWebhookEvent)- ,repoWebhookConfig :: !(M.Map Text Text)- ,repoWebhookLastResponse :: !RepoWebhookResponse- ,repoWebhookUpdatedAt :: !UTCTime- ,repoWebhookCreatedAt :: !UTCTime-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data RepoWebhook = RepoWebhook+ { repoWebhookUrl :: !URL+ , repoWebhookTestUrl :: !URL+ , repoWebhookId :: !(Id RepoWebhook)+ , repoWebhookName :: !Text+ , repoWebhookActive :: !Bool+ , repoWebhookEvents :: !(Vector RepoWebhookEvent)+ , repoWebhookConfig :: !(M.Map Text Text)+ , repoWebhookLastResponse :: !RepoWebhookResponse+ , repoWebhookUpdatedAt :: !UTCTime+ , repoWebhookCreatedAt :: !UTCTime+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData RepoWebhook where rnf = genericRnf instance Binary RepoWebhook -data RepoWebhookEvent =- WebhookWildcardEvent- | WebhookCommitCommentEvent- | WebhookCreateEvent- | WebhookDeleteEvent- | WebhookDeploymentEvent- | WebhookDeploymentStatusEvent- | WebhookForkEvent- | WebhookGollumEvent- | WebhookIssueCommentEvent- | WebhookIssuesEvent- | WebhookMemberEvent- | WebhookPageBuildEvent- | WebhookPublicEvent- | WebhookPullRequestReviewCommentEvent- | WebhookPullRequestEvent- | WebhookPushEvent- | WebhookReleaseEvent- | WebhookStatusEvent- | WebhookTeamAddEvent- | WebhookWatchEvent- deriving (Show, Data, Typeable, Eq, Ord, Generic)+data RepoWebhookEvent+ = WebhookWildcardEvent+ | WebhookCommitCommentEvent+ | WebhookCreateEvent+ | WebhookDeleteEvent+ | WebhookDeploymentEvent+ | WebhookDeploymentStatusEvent+ | WebhookForkEvent+ | WebhookGollumEvent+ | WebhookIssueCommentEvent+ | WebhookIssuesEvent+ | WebhookMemberEvent+ | WebhookPageBuildEvent+ | WebhookPingEvent+ | WebhookPublicEvent+ | WebhookPullRequestReviewCommentEvent+ | WebhookPullRequestEvent+ | WebhookPushEvent+ | WebhookReleaseEvent+ | WebhookStatusEvent+ | WebhookTeamAddEvent+ | WebhookWatchEvent+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData RepoWebhookEvent where rnf = genericRnf instance Binary RepoWebhookEvent -data RepoWebhookResponse = RepoWebhookResponse {- repoWebhookResponseCode :: !(Maybe Int)- ,repoWebhookResponseStatus :: !Text- ,repoWebhookResponseMessage :: !(Maybe Text)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data RepoWebhookResponse = RepoWebhookResponse+ { repoWebhookResponseCode :: !(Maybe Int)+ , repoWebhookResponseStatus :: !Text+ , repoWebhookResponseMessage :: !(Maybe Text)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData RepoWebhookResponse where rnf = genericRnf instance Binary RepoWebhookResponse -data PingEvent = PingEvent {- pingEventZen :: !Text- ,pingEventHook :: !RepoWebhook- ,pingEventHookId :: !(Id RepoWebhook)-} deriving (Show, Data, Typeable, Eq, Ord, Generic)+data PingEvent = PingEvent+ { pingEventZen :: !Text+ , pingEventHook :: !RepoWebhook+ , pingEventHookId :: !(Id RepoWebhook)+ }+ deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData PingEvent where rnf = genericRnf instance Binary PingEvent -data NewRepoWebhook = NewRepoWebhook {- newRepoWebhookName :: !Text- ,newRepoWebhookConfig :: !(M.Map Text Text)- ,newRepoWebhookEvents :: !(Maybe (Vector RepoWebhookEvent))- ,newRepoWebhookActive :: !(Maybe Bool)-} deriving (Eq, Ord, Show, Typeable, Data, Generic)+data NewRepoWebhook = NewRepoWebhook+ { newRepoWebhookName :: !Text+ , newRepoWebhookConfig :: !(M.Map Text Text)+ , newRepoWebhookEvents :: !(Maybe (Vector RepoWebhookEvent))+ , newRepoWebhookActive :: !(Maybe Bool)+ }+ deriving (Eq, Ord, Show, Typeable, Data, Generic) instance NFData NewRepoWebhook where rnf = genericRnf instance Binary NewRepoWebhook -data EditRepoWebhook = EditRepoWebhook {- editRepoWebhookConfig :: !(Maybe (M.Map Text Text))- ,editRepoWebhookEvents :: !(Maybe (Vector RepoWebhookEvent))- ,editRepoWebhookAddEvents :: !(Maybe (Vector RepoWebhookEvent))- ,editRepoWebhookRemoveEvents :: !(Maybe (Vector RepoWebhookEvent))- ,editRepoWebhookActive :: !(Maybe Bool)-} deriving (Eq, Ord, Show, Typeable, Data, Generic)+data EditRepoWebhook = EditRepoWebhook+ { editRepoWebhookConfig :: !(Maybe (M.Map Text Text))+ , editRepoWebhookEvents :: !(Maybe (Vector RepoWebhookEvent))+ , editRepoWebhookAddEvents :: !(Maybe (Vector RepoWebhookEvent))+ , editRepoWebhookRemoveEvents :: !(Maybe (Vector RepoWebhookEvent))+ , editRepoWebhookActive :: !(Maybe Bool)+ }+ deriving (Eq, Ord, Show, Typeable, Data, Generic) instance NFData EditRepoWebhook where rnf = genericRnf instance Binary EditRepoWebhook@@ -110,68 +102,70 @@ -- JSON instances instance FromJSON RepoWebhookEvent where- parseJSON (String "*") = pure WebhookWildcardEvent- parseJSON (String "commit_comment") = pure WebhookCommitCommentEvent- parseJSON (String "create") = pure WebhookCreateEvent- parseJSON (String "delete") = pure WebhookDeleteEvent- parseJSON (String "deployment") = pure WebhookDeploymentEvent- parseJSON (String "deployment_status") = pure WebhookDeploymentStatusEvent- parseJSON (String "fork") = pure WebhookForkEvent- parseJSON (String "gollum") = pure WebhookGollumEvent- parseJSON (String "issue_comment") = pure WebhookIssueCommentEvent- parseJSON (String "issues") = pure WebhookIssuesEvent- parseJSON (String "member") = pure WebhookMemberEvent- parseJSON (String "page_build") = pure WebhookPageBuildEvent- parseJSON (String "public") = pure WebhookPublicEvent- parseJSON (String "pull_request_review_comment") = pure WebhookPullRequestReviewCommentEvent- parseJSON (String "pull_request") = pure WebhookPullRequestEvent- parseJSON (String "push") = pure WebhookPushEvent- parseJSON (String "release") = pure WebhookReleaseEvent- parseJSON (String "status") = pure WebhookStatusEvent- parseJSON (String "team_add") = pure WebhookTeamAddEvent- parseJSON (String "watch") = pure WebhookWatchEvent- parseJSON _ = fail "Could not build a Webhook event"+ parseJSON (String "*") = pure WebhookWildcardEvent+ parseJSON (String "commit_comment") = pure WebhookCommitCommentEvent+ parseJSON (String "create") = pure WebhookCreateEvent+ parseJSON (String "delete") = pure WebhookDeleteEvent+ parseJSON (String "deployment") = pure WebhookDeploymentEvent+ parseJSON (String "deployment_status") = pure WebhookDeploymentStatusEvent+ parseJSON (String "fork") = pure WebhookForkEvent+ parseJSON (String "gollum") = pure WebhookGollumEvent+ parseJSON (String "issue_comment") = pure WebhookIssueCommentEvent+ parseJSON (String "issues") = pure WebhookIssuesEvent+ parseJSON (String "member") = pure WebhookMemberEvent+ parseJSON (String "page_build") = pure WebhookPageBuildEvent+ parseJSON (String "ping") = pure WebhookPingEvent+ parseJSON (String "public") = pure WebhookPublicEvent+ parseJSON (String "pull_request_review_comment") = pure WebhookPullRequestReviewCommentEvent+ parseJSON (String "pull_request") = pure WebhookPullRequestEvent+ parseJSON (String "push") = pure WebhookPushEvent+ parseJSON (String "release") = pure WebhookReleaseEvent+ parseJSON (String "status") = pure WebhookStatusEvent+ parseJSON (String "team_add") = pure WebhookTeamAddEvent+ parseJSON (String "watch") = pure WebhookWatchEvent+ parseJSON _ = fail "Could not build a Webhook event" instance ToJSON RepoWebhookEvent where- toJSON (WebhookWildcardEvent) = String "*"- toJSON (WebhookCommitCommentEvent) = String "commit_comment"- toJSON (WebhookCreateEvent) = String "create"- toJSON (WebhookDeleteEvent) = String "delete"- toJSON (WebhookDeploymentEvent) = String "deployment"- toJSON (WebhookDeploymentStatusEvent) = String "deployment_status"- toJSON (WebhookForkEvent) = String "fork"- toJSON (WebhookGollumEvent) = String "gollum"- toJSON (WebhookIssueCommentEvent) = String "issue_comment"- toJSON (WebhookIssuesEvent) = String "issues"- toJSON (WebhookMemberEvent) = String "member"- toJSON (WebhookPageBuildEvent) = String "page_build"- toJSON (WebhookPublicEvent) = String "public"- toJSON (WebhookPullRequestReviewCommentEvent) = String "pull_request_review_comment"- toJSON (WebhookPullRequestEvent) = String "pull_request"- toJSON (WebhookPushEvent) = String "push"- toJSON (WebhookReleaseEvent) = String "release"- toJSON (WebhookStatusEvent) = String "status"- toJSON (WebhookTeamAddEvent) = String "team_add"- toJSON (WebhookWatchEvent) = String "watch"+ toJSON WebhookWildcardEvent = String "*"+ toJSON WebhookCommitCommentEvent = String "commit_comment"+ toJSON WebhookCreateEvent = String "create"+ toJSON WebhookDeleteEvent = String "delete"+ toJSON WebhookDeploymentEvent = String "deployment"+ toJSON WebhookDeploymentStatusEvent = String "deployment_status"+ toJSON WebhookForkEvent = String "fork"+ toJSON WebhookGollumEvent = String "gollum"+ toJSON WebhookIssueCommentEvent = String "issue_comment"+ toJSON WebhookIssuesEvent = String "issues"+ toJSON WebhookMemberEvent = String "member"+ toJSON WebhookPageBuildEvent = String "page_build"+ toJSON WebhookPingEvent = String "ping"+ toJSON WebhookPublicEvent = String "public"+ toJSON WebhookPullRequestReviewCommentEvent = String "pull_request_review_comment"+ toJSON WebhookPullRequestEvent = String "pull_request"+ toJSON WebhookPushEvent = String "push"+ toJSON WebhookReleaseEvent = String "release"+ toJSON WebhookStatusEvent = String "status"+ toJSON WebhookTeamAddEvent = String "team_add"+ toJSON WebhookWatchEvent = String "watch" instance FromJSON RepoWebhook where- parseJSON = withObject "RepoWebhook" $ \o ->- RepoWebhook <$> o .: "url"- <*> o .: "test_url"- <*> o .: "id"- <*> o .: "name"- <*> o .: "active"- <*> o .: "events"- <*> o .: "config"- <*> o .: "last_response"- <*> o .: "updated_at"- <*> o .: "created_at"+ parseJSON = withObject "RepoWebhook" $ \o -> RepoWebhook+ <$> o .: "url"+ <*> o .: "test_url"+ <*> o .: "id"+ <*> o .: "name"+ <*> o .: "active"+ <*> o .: "events"+ <*> o .: "config"+ <*> o .: "last_response"+ <*> o .: "updated_at"+ <*> o .: "created_at" instance FromJSON RepoWebhookResponse where- parseJSON = withObject "RepoWebhookResponse" $ \o ->- RepoWebhookResponse <$> o .: "code"- <*> o .: "status"- <*> o .: "message"+ parseJSON = withObject "RepoWebhookResponse" $ \o -> RepoWebhookResponse+ <$> o .: "code"+ <*> o .: "status"+ <*> o .: "message" instance ToJSON NewRepoWebhook where toJSON (NewRepoWebhook { newRepoWebhookName = name@@ -201,7 +195,7 @@ ] instance FromJSON PingEvent where- parseJSON = withObject "PingEvent" $ \o ->- PingEvent <$> o .: "zen"- <*> o .: "hook"- <*> o .: "hook_id"+ parseJSON = withObject "PingEvent" $ \o -> PingEvent+ <$> o .: "zen"+ <*> o .: "hook"+ <*> o .: "hook_id"
src/GitHub/Data/Webhooks/Validate.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -11,31 +9,31 @@ isValidPayload ) where -import Prelude ()-import Prelude.Compat+import GitHub.Internal.Prelude+import Prelude () -import Crypto.Hash-import Data.Byteable (constEqBytes, toBytes)-import qualified Data.ByteString.Base16 as Hex-import qualified Data.ByteString.Char8 as BS-import Data.Monoid+import Crypto.Hash (HMAC, SHA1, hmac, hmacGetDigest)+import Data.Byteable (constEqBytes, toBytes)+import Data.ByteString (ByteString) +import qualified Data.ByteString.Base16 as Hex+import qualified Data.Text.Encoding as TE -- | Validates a given payload against a given HMAC hexdigest using a given -- secret. -- Returns 'True' iff the given hash is non-empty and it's a valid signature of -- the payload. isValidPayload- :: String -- ^ the secret- -> Maybe String -- ^ the hash provided by the remote party- -- in @X-Hub-Signature@ (if any),- -- including the 'sha1=...' prefix- -> BS.ByteString -- ^ the body+ :: Text -- ^ the secret+ -> Maybe Text -- ^ the hash provided by the remote party+ -- in @X-Hub-Signature@ (if any),+ -- including the 'sha1=...' prefix+ -> ByteString -- ^ the body -> Bool isValidPayload secret shaOpt payload = maybe False (constEqBytes sign) shaOptBS where- shaOptBS = BS.pack <$> shaOpt+ shaOptBS = TE.encodeUtf8 <$> shaOpt hexDigest = Hex.encode . toBytes . hmacGetDigest - hm = hmac (BS.pack secret) payload :: HMAC SHA1+ hm = hmac (TE.encodeUtf8 secret) payload :: HMAC SHA1 sign = "sha1=" <> hexDigest hm
+ src/GitHub/Endpoints/Activity/Events.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- License : BSD-3-Clause+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- The events API as described on <https://developer.github.com/v3/activity/events/>.+module GitHub.Endpoints.Activity.Events (+ -- * Events+ repositoryEventsR,+ module GitHub.Data,+ ) where++import GitHub.Data+import GitHub.Internal.Prelude+import Prelude ()++-- | List repository events.+-- See <https://developer.github.com/v3/activity/events/#list-repository-events>+repositoryEventsR :: Name Owner -> Name Repo -> FetchCount -> Request 'RO (Vector Event)+repositoryEventsR user repo =+ pagedQuery ["repos", toPathPart user, toPathPart repo, "events"] []
src/GitHub/Endpoints/Activity/Starring.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -13,45 +12,60 @@ reposStarredByR, myStarred, myStarredR,+ myStarredAcceptStar,+ myStarredAcceptStarR, module GitHub.Data, ) where -import Data.Vector (Vector) import GitHub.Auth import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | The list of users that have starred the specified Github repo. -- -- > userInfoFor' Nothing "mike-burns" stargazersFor :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector SimpleUser)) stargazersFor auth user repo =- executeRequestMaybe auth $ stargazersForR user repo Nothing+ executeRequestMaybe auth $ stargazersForR user repo FetchAll -- | List Stargazers. -- See <https://developer.github.com/v3/activity/starring/#list-stargazers>-stargazersForR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector SimpleUser)+stargazersForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector SimpleUser) stargazersForR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "stargazers"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "stargazers"] [] -- | All the public repos starred by the specified user. -- -- > reposStarredBy Nothing "croaky" reposStarredBy :: Maybe Auth -> Name Owner -> IO (Either Error (Vector Repo)) reposStarredBy auth user =- executeRequestMaybe auth $ reposStarredByR user Nothing+ executeRequestMaybe auth $ reposStarredByR user FetchAll -- | List repositories being starred. -- See <https://developer.github.com/v3/activity/starring/#list-repositories-being-starred>-reposStarredByR :: Name Owner -> Maybe Count -> Request k (Vector Repo)+reposStarredByR :: Name Owner -> FetchCount -> Request k (Vector Repo) reposStarredByR user =- PagedQuery ["users", toPathPart user, "starred"] []+ pagedQuery ["users", toPathPart user, "starred"] [] -- | All the repos starred by the authenticated user. myStarred :: Auth -> IO (Either Error (Vector Repo)) myStarred auth =- executeRequest auth $ myStarredR Nothing+ executeRequest auth $ myStarredR FetchAll -- | All the repos starred by the authenticated user.-myStarredR :: Maybe Count -> Request 'True (Vector Repo)-myStarredR = PagedQuery ["user", "starred"] []+-- See <https://developer.github.com/v3/activity/starring/#list-repositories-being-starred>+myStarredR :: FetchCount -> Request 'RA (Vector Repo)+myStarredR = pagedQuery ["user", "starred"] []+++-- | All the repos starred by the authenticated user.+myStarredAcceptStar :: Auth -> IO (Either Error (Vector RepoStarred))+myStarredAcceptStar auth =+ executeRequest auth $ myStarredAcceptStarR FetchAll++-- | All the repos starred by the authenticated user.+-- See <https://developer.github.com/v3/activity/starring/#alternative-response-with-star-creation-timestamps-1>+myStarredAcceptStarR :: FetchCount -> Request 'RA (Vector RepoStarred)+myStarredAcceptStarR = HeaderQuery [("Accept", "application/vnd.github.v3.star+json")] . PagedQuery ["user", "starred"] []
src/GitHub/Endpoints/Activity/Watching.hs view
@@ -15,10 +15,11 @@ module GitHub.Data, ) where -import Data.Vector (Vector) import GitHub.Auth import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | The list of users that are watching the specified Github repo. --@@ -32,13 +33,13 @@ -- > watchersFor' (Just (User (user, password))) "thoughtbot" "paperclip" watchersFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector SimpleUser)) watchersFor' auth user repo =- executeRequestMaybe auth $ watchersForR user repo Nothing+ executeRequestMaybe auth $ watchersForR user repo FetchAll -- | List watchers. -- See <https://developer.github.com/v3/activity/watching/#list-watchers>-watchersForR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector SimpleUser)+watchersForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector SimpleUser) watchersForR user repo limit =- PagedQuery ["repos", toPathPart user, toPathPart repo, "watchers"] [] limit+ pagedQuery ["repos", toPathPart user, toPathPart repo, "watchers"] [] limit -- | All the public repos watched by the specified user. --@@ -52,10 +53,10 @@ -- > reposWatchedBy' (Just (User (user, password))) "croaky" reposWatchedBy' :: Maybe Auth -> Name Owner -> IO (Either Error (Vector Repo)) reposWatchedBy' auth user =- executeRequestMaybe auth $ reposWatchedByR user Nothing+ executeRequestMaybe auth $ reposWatchedByR user FetchAll -- | List repositories being watched. -- See <https://developer.github.com/v3/activity/watching/#list-repositories-being-watched>-reposWatchedByR :: Name Owner -> Maybe Count -> Request k (Vector Repo)+reposWatchedByR :: Name Owner -> FetchCount -> Request k (Vector Repo) reposWatchedByR user =- PagedQuery ["users", toPathPart user, "subscriptions"] []+ pagedQuery ["users", toPathPart user, "subscriptions"] []
src/GitHub/Endpoints/Gists.hs view
@@ -14,16 +14,17 @@ module GitHub.Data, ) where -import Data.Vector (Vector) import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | The list of all gists created by the user -- -- > gists' (Just ("github-username", "github-password")) "mike-burns" gists' :: Maybe Auth -> Name Owner -> IO (Either Error (Vector Gist)) gists' auth user =- executeRequestMaybe auth $ gistsR user Nothing+ executeRequestMaybe auth $ gistsR user FetchAll -- | The list of all public gists created by the user. --@@ -33,8 +34,8 @@ -- | List gists. -- See <https://developer.github.com/v3/gists/#list-gists>-gistsR :: Name Owner -> Maybe Count -> Request k (Vector Gist)-gistsR user = PagedQuery ["users", toPathPart user, "gists"] []+gistsR :: Name Owner -> FetchCount -> Request k (Vector Gist)+gistsR user = pagedQuery ["users", toPathPart user, "gists"] [] -- | A specific gist, given its id, with authentication credentials --@@ -51,6 +52,6 @@ -- | Query a single gist. -- See <https://developer.github.com/v3/gists/#get-a-single-gist>-gistR :: Name Gist ->Request k Gist+gistR :: Name Gist -> Request k Gist gistR gid =- Query ["gists", toPathPart gid] []+ query ["gists", toPathPart gid] []
src/GitHub/Endpoints/Gists/Comments.hs view
@@ -13,23 +13,23 @@ module GitHub.Data, ) where -import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All the comments on a Gist, given the Gist ID. -- -- > commentsOn "1174060" commentsOn :: Name Gist -> IO (Either Error (Vector GistComment)) commentsOn gid =- executeRequest' $ commentsOnR gid Nothing+ executeRequest' $ commentsOnR gid FetchAll -- | List comments on a gist. -- See <https://developer.github.com/v3/gists/comments/#list-comments-on-a-gist>-commentsOnR :: Name Gist -> Maybe Count -> Request k (Vector GistComment)+commentsOnR :: Name Gist -> FetchCount -> Request k (Vector GistComment) commentsOnR gid =- PagedQuery ["gists", toPathPart gid, "comments"] []+ pagedQuery ["gists", toPathPart gid, "comments"] [] -- | A specific comment, by the comment ID. --@@ -42,4 +42,4 @@ -- See <https://developer.github.com/v3/gists/comments/#get-a-single-comment> gistCommentR :: Id GistComment -> Request k GistComment gistCommentR cid =- Query ["gists", "comments", toPathPart cid] []+ query ["gists", "comments", toPathPart cid] []
src/GitHub/Endpoints/GitData/Blobs.hs view
@@ -13,7 +13,9 @@ ) where import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | Query a blob by SHA1. --@@ -32,4 +34,4 @@ -- See <https://developer.github.com/v3/git/blobs/#get-a-blob> blobR :: Name Owner -> Name Repo -> Name Blob -> Request k Blob blobR user repo sha =- Query ["repos", toPathPart user, toPathPart repo, "git", "blobs", toPathPart sha] []+ query ["repos", toPathPart user, toPathPart repo, "git", "blobs", toPathPart sha] []
src/GitHub/Endpoints/GitData/Commits.hs view
@@ -12,7 +12,9 @@ ) where import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | A single commit, by SHA1. --@@ -25,4 +27,4 @@ -- See <https://developer.github.com/v3/git/commits/#get-a-commit> gitCommitR :: Name Owner -> Name Repo -> Name GitCommit -> Request k GitCommit gitCommitR user repo sha =- Query ["repos", toPathPart user, toPathPart repo, "git", "commits", toPathPart sha] []+ query ["repos", toPathPart user, toPathPart repo, "git", "commits", toPathPart sha] []
src/GitHub/Endpoints/GitData/References.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -20,11 +19,10 @@ module GitHub.Data, ) where -import Data.Aeson.Compat (encode)-import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | A single reference by the ref name. --@@ -43,14 +41,14 @@ -- See <https://developer.github.com/v3/git/refs/#get-a-reference> referenceR :: Name Owner -> Name Repo -> Name GitReference -> Request k GitReference referenceR user repo ref =- Query ["repos", toPathPart user, toPathPart repo, "git", "refs", toPathPart ref] []+ query ["repos", toPathPart user, toPathPart repo, "git", "refs", toPathPart ref] [] -- | The history of references for a repo. -- -- > references "mike-burns" "github" references' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector GitReference)) references' auth user repo =- executeRequestMaybe auth $ referencesR user repo Nothing+ executeRequestMaybe auth $ referencesR user repo FetchAll -- | The history of references for a repo. --@@ -60,9 +58,9 @@ -- | Query all References. -- See <https://developer.github.com/v3/git/refs/#get-all-references>-referencesR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector GitReference)+referencesR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector GitReference) referencesR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "git", "refs"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "git", "refs"] [] -- | Create a reference. createReference :: Auth -> Name Owner -> Name Repo -> NewGitReference -> IO (Either Error GitReference)@@ -71,19 +69,19 @@ -- | Create a reference. -- See <https://developer.github.com/v3/git/refs/#create-a-reference>-createReferenceR :: Name Owner -> Name Repo -> NewGitReference -> Request 'True GitReference+createReferenceR :: Name Owner -> Name Repo -> NewGitReference -> Request 'RW GitReference createReferenceR user repo newRef =- Command Post ["repos", toPathPart user, toPathPart repo , "git", "refs"] (encode newRef)+ command Post ["repos", toPathPart user, toPathPart repo , "git", "refs"] (encode newRef) -- | Limited references by a namespace. -- -- > namespacedReferences "thoughtbot" "paperclip" "tags"-namespacedReferences :: Name Owner -> Name Repo -> String -> IO (Either Error [GitReference])+namespacedReferences :: Name Owner -> Name Repo -> Text -> IO (Either Error [GitReference]) namespacedReferences user repo namespace = executeRequest' $ namespacedReferencesR user repo namespace -- | Query namespaced references. -- See <https://developer.github.com/v3/git/refs/#get-all-references>-namespacedReferencesR :: Name Owner -> Name Repo -> String -> Request k [GitReference]+namespacedReferencesR :: Name Owner -> Name Repo -> Text -> Request k [GitReference] namespacedReferencesR user repo namespace =- Query ["repos", toPathPart user, toPathPart repo, "git", "refs", namespace] []+ query ["repos", toPathPart user, toPathPart repo, "git", "refs", namespace] []
src/GitHub/Endpoints/GitData/Trees.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -17,7 +16,9 @@ ) where import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | A tree for a SHA1. --@@ -36,7 +37,7 @@ -- See <https://developer.github.com/v3/git/trees/#get-a-tree> treeR :: Name Owner -> Name Repo -> Name Tree -> Request k Tree treeR user repo sha =- Query ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha] []+ query ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha] [] -- | A recursively-nested tree for a SHA1. --@@ -55,4 +56,4 @@ -- See <https://developer.github.com/v3/git/trees/#get-a-tree-recursively> nestedTreeR :: Name Owner -> Name Repo -> Name Tree -> Request k Tree nestedTreeR user repo sha =- Query ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha] [("recursive", Just "1")]+ query ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha] [("recursive", Just "1")]
src/GitHub/Endpoints/Issues.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,13 +6,14 @@ -- -- The issues API as described on <http://developer.github.com/v3/issues/>. module GitHub.Endpoints.Issues (+ currentUserIssuesR,+ organizationIssuesR, issue, issue', issueR, issuesForRepo, issuesForRepo', issuesForRepoR,- IssueLimitation(..), createIssue, createIssueR, newIssue,@@ -25,15 +24,19 @@ ) where import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -import Data.Aeson.Compat (encode)-import Data.List (intercalate)-import Data.Text (Text)-import Data.Time.ISO8601 (formatISO8601)-import Data.Vector (Vector)+-- | See <https://developer.github.com/v3/issues/#list-issues>.+currentUserIssuesR :: IssueMod -> FetchCount -> Request 'RA (Vector Issue)+currentUserIssuesR opts =+ pagedQuery ["user", "issues"] (issueModToQueryString opts) -import qualified Data.ByteString.Char8 as BS8+-- | See <https://developer.github.com/v3/issues/#list-issues>.+organizationIssuesR :: Name Organization -> IssueMod -> FetchCount -> Request k (Vector Issue)+organizationIssuesR org opts =+ pagedQuery ["orgs", toPathPart org, "issues"] (issueModToQueryString opts) -- | Details on a specific issue, given the repo owner and name, and the issue -- number.'@@ -54,45 +57,30 @@ -- See <https://developer.github.com/v3/issues/#get-a-single-issue> issueR :: Name Owner -> Name Repo -> Id Issue -> Request k Issue issueR user reqRepoName reqIssueNumber =- Query ["repos", toPathPart user, toPathPart reqRepoName, "issues", toPathPart reqIssueNumber] []+ query ["repos", toPathPart user, toPathPart reqRepoName, "issues", toPathPart reqIssueNumber] [] -- | All issues for a repo (given the repo owner and name), with optional--- restrictions as described in the @IssueLimitation@ data type.+-- restrictions as described in the 'IssueRepoMod' data type. -- -- > issuesForRepo' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" [NoMilestone, OnlyClosed, Mentions "jyurek", Ascending]-issuesForRepo' :: Maybe Auth -> Name Owner -> Name Repo -> [IssueLimitation] -> IO (Either Error (Vector Issue))-issuesForRepo' auth user reqRepoName issueLimitations =- executeRequestMaybe auth $ issuesForRepoR user reqRepoName issueLimitations Nothing+issuesForRepo' :: Maybe Auth -> Name Owner -> Name Repo -> IssueRepoMod -> IO (Either Error (Vector Issue))+issuesForRepo' auth user reqRepoName opts =+ executeRequestMaybe auth $ issuesForRepoR user reqRepoName opts FetchAll -- | All issues for a repo (given the repo owner and name), with optional--- restrictions as described in the @IssueLimitation@ data type.+-- restrictions as described in the 'IssueRepoMod' data type. -- -- > issuesForRepo "thoughtbot" "paperclip" [NoMilestone, OnlyClosed, Mentions "jyurek", Ascending]-issuesForRepo :: Name Owner -> Name Repo -> [IssueLimitation] -> IO (Either Error (Vector Issue))+issuesForRepo :: Name Owner -> Name Repo -> IssueRepoMod -> IO (Either Error (Vector Issue)) issuesForRepo = issuesForRepo' Nothing -- | List issues for a repository. -- See <https://developer.github.com/v3/issues/#list-issues-for-a-repository>-issuesForRepoR :: Name Owner -> Name Repo -> [IssueLimitation] -> Maybe Count -> Request k (Vector Issue)-issuesForRepoR user reqRepoName issueLimitations =- PagedQuery ["repos", toPathPart user, toPathPart reqRepoName, "issues"] qs+issuesForRepoR :: Name Owner -> Name Repo -> IssueRepoMod -> FetchCount -> Request k (Vector Issue)+issuesForRepoR user reqRepoName opts =+ pagedQuery ["repos", toPathPart user, toPathPart reqRepoName, "issues"] qs where- qs = map convert issueLimitations-- convert AnyMilestone = ("milestone", Just "*")- convert NoMilestone = ("milestone", Just "none")- convert (MilestoneId n) = ("milestone", Just . BS8.pack $ show n)- convert Open = ("state", Just "open")- convert OnlyClosed = ("state", Just "closed")- convert Unassigned = ("assignee", Just "none")- convert AnyAssignment = ("assignee", Just "")- convert (AssignedTo u) = ("assignee", Just $ BS8.pack u)- convert (Mentions u) = ("mentioned", Just $ BS8.pack u)- convert (Labels l) = ("labels", Just . BS8.pack $ intercalate "," l)- convert Ascending = ("direction", Just "asc")- convert Descending = ("direction", Just "desc")- convert (PerPage n) = ("per_page", Just . BS8.pack $ show n)- convert (Since t) = ("since", Just . BS8.pack $ formatISO8601 t)+ qs = issueRepoModToQueryString opts -- Creating new issues. @@ -111,9 +99,9 @@ -- | Create an issue. -- See <https://developer.github.com/v3/issues/#create-an-issue>-createIssueR :: Name Owner -> Name Repo -> NewIssue -> Request 'True Issue+createIssueR :: Name Owner -> Name Repo -> NewIssue -> Request 'RW Issue createIssueR user repo =- Command Post ["repos", toPathPart user, toPathPart repo, "issues"] . encode+ command Post ["repos", toPathPart user, toPathPart repo, "issues"] . encode -- Editing issues. @@ -131,6 +119,6 @@ -- | Edit an issue. -- See <https://developer.github.com/v3/issues/#edit-an-issue>-editIssueR :: Name Owner -> Name Repo -> Id Issue -> EditIssue -> Request 'True Issue+editIssueR :: Name Owner -> Name Repo -> Id Issue -> EditIssue -> Request 'RW Issue editIssueR user repo iss =- Command Patch ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iss] . encode+ command Patch ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iss] . encode
src/GitHub/Endpoints/Issues/Comments.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -19,12 +18,10 @@ module GitHub.Data, ) where -import Data.Aeson.Compat (encode)-import Data.Text (Text)-import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | A specific comment, by ID. --@@ -37,7 +34,7 @@ -- See <https://developer.github.com/v3/issues/comments/#get-a-single-comment> commentR :: Name Owner -> Name Repo -> Id Comment -> Request k IssueComment commentR user repo cid =- Query ["repos", toPathPart user, toPathPart repo, "issues", "comments", toPathPart cid] []+ query ["repos", toPathPart user, toPathPart repo, "issues", "comments", toPathPart cid] [] -- | All comments on an issue, by the issue's number. --@@ -50,13 +47,13 @@ -- > comments' (User (user, password)) "thoughtbot" "paperclip" 635 comments' :: Maybe Auth -> Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector IssueComment)) comments' auth user repo iid =- executeRequestMaybe auth $ commentsR user repo iid Nothing+ executeRequestMaybe auth $ commentsR user repo iid FetchAll -- | List comments on an issue. -- See <https://developer.github.com/v3/issues/comments/#list-comments-on-an-issue>-commentsR :: Name Owner -> Name Repo -> Id Issue -> Maybe Count -> Request k (Vector IssueComment)+commentsR :: Name Owner -> Name Repo -> Id Issue -> FetchCount -> Request k (Vector IssueComment) commentsR user repo iid =- PagedQuery ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "comments"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "comments"] [] -- | Create a new comment. --@@ -69,9 +66,9 @@ -- | Create a comment. -- See <https://developer.github.com/v3/issues/comments/#create-a-comment>-createCommentR :: Name Owner -> Name Repo -> Id Issue -> Text -> Request 'True Comment+createCommentR :: Name Owner -> Name Repo -> Id Issue -> Text -> Request 'RW Comment createCommentR user repo iss body =- Command Post parts (encode $ NewComment body)+ command Post parts (encode $ NewComment body) where parts = ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iss, "comments"] @@ -86,8 +83,8 @@ -- | Edit a comment. -- See <https://developer.github.com/v3/issues/comments/#edit-a-comment>-editCommentR :: Name Owner -> Name Repo -> Id Comment -> Text -> Request 'True Comment+editCommentR :: Name Owner -> Name Repo -> Id Comment -> Text -> Request 'RW Comment editCommentR user repo commid body =- Command Patch parts (encode $ EditComment body)+ command Patch parts (encode $ EditComment body) where parts = ["repos", toPathPart user, toPathPart repo, "issues", "comments", toPathPart commid]
src/GitHub/Endpoints/Issues/Events.hs view
@@ -18,64 +18,64 @@ module GitHub.Data, ) where -import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All events that have happened on an issue. -- -- > eventsForIssue "thoughtbot" "paperclip" 49-eventsForIssue :: Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector Event))+eventsForIssue :: Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector IssueEvent)) eventsForIssue = eventsForIssue' Nothing -- | All events that have happened on an issue, using authentication. -- -- > eventsForIssue' (User (user, password)) "thoughtbot" "paperclip" 49-eventsForIssue' :: Maybe Auth -> Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector Event))+eventsForIssue' :: Maybe Auth -> Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector IssueEvent)) eventsForIssue' auth user repo iid =- executeRequestMaybe auth $ eventsForIssueR user repo iid Nothing+ executeRequestMaybe auth $ eventsForIssueR user repo iid FetchAll -- | List events for an issue. -- See <https://developer.github.com/v3/issues/events/#list-events-for-an-issue>-eventsForIssueR :: Name Owner -> Name Repo -> Id Issue -> Maybe Count -> Request k (Vector Event)+eventsForIssueR :: Name Owner -> Name Repo -> Id Issue -> FetchCount -> Request k (Vector IssueEvent) eventsForIssueR user repo iid =- PagedQuery ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "events"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "events"] [] -- | All the events for all issues in a repo. -- -- > eventsForRepo "thoughtbot" "paperclip"-eventsForRepo :: Name Owner -> Name Repo -> IO (Either Error (Vector Event))+eventsForRepo :: Name Owner -> Name Repo -> IO (Either Error (Vector IssueEvent)) eventsForRepo = eventsForRepo' Nothing -- | All the events for all issues in a repo, using authentication. -- -- > eventsForRepo' (User (user, password)) "thoughtbot" "paperclip"-eventsForRepo' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Event))+eventsForRepo' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector IssueEvent)) eventsForRepo' auth user repo =- executeRequestMaybe auth $ eventsForRepoR user repo Nothing+ executeRequestMaybe auth $ eventsForRepoR user repo FetchAll -- | List events for a repository. -- See <https://developer.github.com/v3/issues/events/#list-events-for-a-repository>-eventsForRepoR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector Event)+eventsForRepoR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector IssueEvent) eventsForRepoR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "issues", "events"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "issues", "events"] [] -- | Details on a specific event, by the event's ID. -- -- > event "thoughtbot" "paperclip" 5335772-event :: Name Owner -> Name Repo -> Id Event -> IO (Either Error Event)+event :: Name Owner -> Name Repo -> Id IssueEvent -> IO (Either Error IssueEvent) event = event' Nothing -- | Details on a specific event, by the event's ID, using authentication. -- -- > event' (User (user, password)) "thoughtbot" "paperclip" 5335772-event' :: Maybe Auth -> Name Owner -> Name Repo -> Id Event -> IO (Either Error Event)+event' :: Maybe Auth -> Name Owner -> Name Repo -> Id IssueEvent -> IO (Either Error IssueEvent) event' auth user repo eid = executeRequestMaybe auth $ eventR user repo eid -- | Query a single event. -- See <https://developer.github.com/v3/issues/events/#get-a-single-event>-eventR :: Name Owner -> Name Repo -> Id Event -> Request k Event+eventR :: Name Owner -> Name Repo -> Id IssueEvent -> Request k IssueEvent eventR user repo eid =- Query ["repos", toPathPart user, toPathPart repo, "issues", "events", show eid] []+ query ["repos", toPathPart user, toPathPart repo, "issues", "events", toPathPart eid] []
src/GitHub/Endpoints/Issues/Labels.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -37,15 +35,10 @@ module GitHub.Data, ) where -import Prelude ()-import Prelude.Compat--import Data.Aeson.Compat (encode, object, (.=))-import Data.Foldable (toList)-import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All the labels available to use on any issue in the repo. --@@ -58,13 +51,13 @@ -- > labelsOnRepo' (Just (User (user password))) "thoughtbot" "paperclip" labelsOnRepo' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector IssueLabel)) labelsOnRepo' auth user repo =- executeRequestMaybe auth $ labelsOnRepoR user repo Nothing+ executeRequestMaybe auth $ labelsOnRepoR user repo FetchAll -- | List all labels for this repository. -- See <https://developer.github.com/v3/issues/labels/#list-all-labels-for-this-repository>-labelsOnRepoR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector IssueLabel)+labelsOnRepoR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector IssueLabel) labelsOnRepoR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "labels"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "labels"] [] -- | A label by name. --@@ -83,7 +76,7 @@ -- See <https://developer.github.com/v3/issues/labels/#get-a-single-label> labelR :: Name Owner -> Name Repo -> Name IssueLabel -> Request k IssueLabel labelR user repo lbl =- Query ["repos", toPathPart user, toPathPart repo, "labels", toPathPart lbl] []+ query ["repos", toPathPart user, toPathPart repo, "labels", toPathPart lbl] [] -- | Create a label --@@ -94,9 +87,9 @@ -- | Create a label. -- See <https://developer.github.com/v3/issues/labels/#create-a-label>-createLabelR :: Name Owner -> Name Repo -> Name IssueLabel -> String -> Request 'True IssueLabel+createLabelR :: Name Owner -> Name Repo -> Name IssueLabel -> String -> Request 'RW IssueLabel createLabelR user repo lbl color =- Command Post paths $ encode body+ command Post paths $ encode body where paths = ["repos", toPathPart user, toPathPart repo, "labels"] body = object ["name" .= untagName lbl, "color" .= color]@@ -121,9 +114,9 @@ -> Name IssueLabel -- ^ old label name -> Name IssueLabel -- ^ new label name -> String -- ^ new color- -> Request 'True IssueLabel+ -> Request 'RW IssueLabel updateLabelR user repo oldLbl newLbl color =- Command Patch paths (encode body)+ command Patch paths (encode body) where paths = ["repos", toPathPart user, toPathPart repo, "labels", toPathPart oldLbl] body = object ["name" .= untagName newLbl, "color" .= color]@@ -137,9 +130,9 @@ -- | Delete a label. -- See <https://developer.github.com/v3/issues/labels/#delete-a-label>-deleteLabelR :: Name Owner -> Name Repo -> Name IssueLabel -> Request 'True ()+deleteLabelR :: Name Owner -> Name Repo -> Name IssueLabel -> Request 'RW () deleteLabelR user repo lbl =- Command Delete ["repos", toPathPart user, toPathPart repo, "labels", toPathPart lbl] mempty+ command Delete ["repos", toPathPart user, toPathPart repo, "labels", toPathPart lbl] mempty -- | The labels on an issue in a repo. --@@ -152,13 +145,13 @@ -- > labelsOnIssue' (Just (User (user password))) "thoughtbot" "paperclip" (Id 585) labelsOnIssue' :: Maybe Auth -> Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector IssueLabel)) labelsOnIssue' auth user repo iid =- executeRequestMaybe auth $ labelsOnIssueR user repo iid Nothing+ executeRequestMaybe auth $ labelsOnIssueR user repo iid FetchAll -- | List labels on an issue. -- See <https://developer.github.com/v3/issues/labels/#list-labels-on-an-issue>-labelsOnIssueR :: Name Owner -> Name Repo -> Id Issue -> Maybe Count -> Request k (Vector IssueLabel)+labelsOnIssueR :: Name Owner -> Name Repo -> Id Issue -> FetchCount -> Request k (Vector IssueLabel) labelsOnIssueR user repo iid =- PagedQuery ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels"] [] -- | Add labels to an issue. --@@ -180,9 +173,9 @@ -> Name Repo -> Id Issue -> f (Name IssueLabel)- -> Request 'True (Vector IssueLabel)+ -> Request 'RW (Vector IssueLabel) addLabelsToIssueR user repo iid lbls =- Command Post paths (encode $ toList lbls)+ command Post paths (encode $ toList lbls) where paths = ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels"] @@ -195,9 +188,9 @@ -- | Remove a label from an issue. -- See <https://developer.github.com/v3/issues/labels/#remove-a-label-from-an-issue>-removeLabelFromIssueR :: Name Owner -> Name Repo -> Id Issue -> Name IssueLabel -> Request 'True ()+removeLabelFromIssueR :: Name Owner -> Name Repo -> Id Issue -> Name IssueLabel -> Request 'RW () removeLabelFromIssueR user repo iid lbl =- Command Delete ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels", toPathPart lbl] mempty+ command Delete ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels", toPathPart lbl] mempty -- | Replace all labels on an issue. Sending an empty list will remove all labels from the issue. --@@ -221,9 +214,9 @@ -> Name Repo -> Id Issue -> f (Name IssueLabel)- -> Request 'True (Vector IssueLabel)+ -> Request 'RW (Vector IssueLabel) replaceAllLabelsForIssueR user repo iid lbls =- Command Put paths (encode $ toList lbls)+ command Put paths (encode $ toList lbls) where paths = ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels"] @@ -236,9 +229,9 @@ -- | Remove all labels from an issue. -- See <https://developer.github.com/v3/issues/labels/#remove-all-labels-from-an-issue>-removeAllLabelsFromIssueR :: Name Owner -> Name Repo -> Id Issue -> Request 'True ()+removeAllLabelsFromIssueR :: Name Owner -> Name Repo -> Id Issue -> Request 'RW () removeAllLabelsFromIssueR user repo iid =- Command Delete ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels"] mempty+ command Delete ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels"] mempty -- | All the labels on a repo's milestone given the milestone ID. --@@ -251,10 +244,10 @@ -- > labelsOnMilestone' (Just (User (user password))) "thoughtbot" "paperclip" (Id 2) labelsOnMilestone' :: Maybe Auth -> Name Owner -> Name Repo -> Id Milestone -> IO (Either Error (Vector IssueLabel)) labelsOnMilestone' auth user repo mid =- executeRequestMaybe auth $ labelsOnMilestoneR user repo mid Nothing+ executeRequestMaybe auth $ labelsOnMilestoneR user repo mid FetchAll -- | Query labels for every issue in a milestone. -- See <https://developer.github.com/v3/issues/labels/#get-labels-for-every-issue-in-a-milestone>-labelsOnMilestoneR :: Name Owner -> Name Repo -> Id Milestone -> Maybe Count -> Request k (Vector IssueLabel)+labelsOnMilestoneR :: Name Owner -> Name Repo -> Id Milestone -> FetchCount -> Request k (Vector IssueLabel) labelsOnMilestoneR user repo mid =- PagedQuery ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid, "labels"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid, "labels"] []
src/GitHub/Endpoints/Issues/Milestones.hs view
@@ -14,10 +14,10 @@ module GitHub.Data, ) where -import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All milestones in the repo. --@@ -30,12 +30,13 @@ -- > milestones' (User (user, passwordG) "thoughtbot" "paperclip" milestones' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Milestone)) milestones' auth user repo =- executeRequestMaybe auth $ milestonesR user repo Nothing+ executeRequestMaybe auth $ milestonesR user repo FetchAll -- | List milestones for a repository. -- See <https://developer.github.com/v3/issues/milestones/#list-milestones-for-a-repository>-milestonesR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector Milestone)-milestonesR user repo = PagedQuery ["repos", toPathPart user, toPathPart repo, "milestones"] []+milestonesR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Milestone)+milestonesR user repo =+ pagedQuery ["repos", toPathPart user, toPathPart repo, "milestones"] [] -- | Details on a specific milestone, given it's milestone number. --@@ -48,4 +49,4 @@ -- See <https://developer.github.com/v3/issues/milestones/#get-a-single-milestone> milestoneR :: Name Owner -> Name Repo -> Id Milestone -> Request k Milestone milestoneR user repo mid =- Query ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid] []+ query ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid] []
src/GitHub/Endpoints/Organizations.hs view
@@ -14,16 +14,17 @@ module GitHub.Data, ) where -import Data.Vector (Vector) import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | The public organizations for a user, given the user's login, with authorization -- -- > publicOrganizationsFor' (Just ("github-username", "github-password")) "mike-burns" publicOrganizationsFor' :: Maybe Auth -> Name User -> IO (Either Error (Vector SimpleOrganization)) publicOrganizationsFor' auth org =- executeRequestMaybe auth $ publicOrganizationsForR org Nothing+ executeRequestMaybe auth $ publicOrganizationsForR org FetchAll -- | List user organizations. The public organizations for a user, given the user's login. --@@ -33,8 +34,8 @@ -- | List user organizations. -- See <https://developer.github.com/v3/orgs/#list-user-organizations>-publicOrganizationsForR :: Name User -> Maybe Count -> Request k (Vector SimpleOrganization)-publicOrganizationsForR user = PagedQuery ["users", toPathPart user, "orgs"] []+publicOrganizationsForR :: Name User -> FetchCount -> Request k (Vector SimpleOrganization)+publicOrganizationsForR user = pagedQuery ["users", toPathPart user, "orgs"] [] -- | Details on a public organization. Takes the organization's login. --@@ -51,4 +52,4 @@ -- | Query an organization. -- See <https://developer.github.com/v3/orgs/#get-an-organization> publicOrganizationR :: Name Organization -> Request k Organization-publicOrganizationR reqOrganizationName = Query ["orgs", toPathPart reqOrganizationName] []+publicOrganizationR reqOrganizationName = query ["orgs", toPathPart reqOrganizationName] []
src/GitHub/Endpoints/Organizations/Members.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -14,10 +13,10 @@ module GitHub.Data, ) where -import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All the users who are members of the specified organization, -- | with or without authentication.@@ -25,7 +24,7 @@ -- > membersOf' (Just $ OAuth "token") "thoughtbot" membersOf' :: Maybe Auth -> Name Organization -> IO (Either Error (Vector SimpleUser)) membersOf' auth org =- executeRequestMaybe auth $ membersOfR org Nothing+ executeRequestMaybe auth $ membersOfR org FetchAll -- | All the users who are members of the specified organization, -- | without authentication.@@ -37,14 +36,16 @@ -- | All the users who are members of the specified organization. -- -- See <https://developer.github.com/v3/orgs/members/#members-list>-membersOfR :: Name Organization -> Maybe Count -> Request k (Vector SimpleUser)-membersOfR organization = PagedQuery ["orgs", toPathPart organization, "members"] []+membersOfR :: Name Organization -> FetchCount -> Request k (Vector SimpleUser)+membersOfR organization =+ pagedQuery ["orgs", toPathPart organization, "members"] [] -- | 'membersOfR' with filters. -- -- See <https://developer.github.com/v3/orgs/members/#members-list>-membersOfWithR :: Name Organization -> OrgMemberFilter -> OrgMemberRole -> Maybe Count -> Request k (Vector SimpleUser)-membersOfWithR org f r = PagedQuery ["orgs", toPathPart org, "members"] [("filter", Just f'), ("role", Just r')]+membersOfWithR :: Name Organization -> OrgMemberFilter -> OrgMemberRole -> FetchCount -> Request k (Vector SimpleUser)+membersOfWithR org f r =+ pagedQuery ["orgs", toPathPart org, "members"] [("filter", Just f'), ("role", Just r')] where f' = case f of OrgMemberFilter2faDisabled -> "2fa_disabled"
src/GitHub/Endpoints/Organizations/Teams.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -21,6 +19,11 @@ deleteTeam', deleteTeamR, listTeamMembersR,+ listTeamRepos,+ listTeamRepos',+ listTeamReposR,+ addOrUpdateTeamRepo',+ addOrUpdateTeamRepoR, teamMembershipInfoFor, teamMembershipInfoFor', teamMembershipInfoForR,@@ -33,14 +36,10 @@ module GitHub.Data, ) where -import Prelude ()-import Prelude.Compat--import Data.Aeson.Compat (encode)-import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | List teams. List the teams of an Owner. -- When authenticated, lists private teams visible to the authenticated user.@@ -49,7 +48,7 @@ -- > teamsOf' (Just $ OAuth "token") "thoughtbot" teamsOf' :: Maybe Auth -> Name Organization -> IO (Either Error (Vector SimpleTeam)) teamsOf' auth org =- executeRequestMaybe auth $ teamsOfR org Nothing+ executeRequestMaybe auth $ teamsOfR org FetchAll -- | List the public teams of an Owner. --@@ -59,11 +58,12 @@ -- | List teams. -- See <https://developer.github.com/v3/orgs/teams/#list-teams>-teamsOfR :: Name Organization -> Maybe Count -> Request k (Vector SimpleTeam)-teamsOfR org = PagedQuery ["orgs", toPathPart org, "teams"] []+teamsOfR :: Name Organization -> FetchCount -> Request k (Vector SimpleTeam)+teamsOfR org =+ pagedQuery ["orgs", toPathPart org, "teams"] [] -- | The information for a single team, by team id.--- | With authentication+-- With authentication -- -- > teamInfoFor' (Just $ OAuth "token") 1010101 teamInfoFor' :: Maybe Auth -> Id Team -> IO (Either Error Team)@@ -80,7 +80,7 @@ -- See <https://developer.github.com/v3/orgs/teams/#get-team> teamInfoForR :: Id Team -> Request k Team teamInfoForR tid =- Query ["teams", toPathPart tid] []+ query ["teams", toPathPart tid] [] -- | Create a team under an Owner --@@ -94,9 +94,9 @@ -- | Create team. -- See <https://developer.github.com/v3/orgs/teams/#create-team>-createTeamForR :: Name Organization -> CreateTeam -> Request 'True Team+createTeamForR :: Name Organization -> CreateTeam -> Request 'RW Team createTeamForR org cteam =- Command Post ["orgs", toPathPart org, "teams"] (encode cteam)+ command Post ["orgs", toPathPart org, "teams"] (encode cteam) -- | Edit a team, by id. --@@ -110,9 +110,9 @@ -- | Edit team. -- See <https://developer.github.com/v3/orgs/teams/#edit-team>-editTeamR :: Id Team -> EditTeam -> Request 'True Team+editTeamR :: Id Team -> EditTeam -> Request 'RW Team editTeamR tid eteam =- Command Patch ["teams", toPathPart tid] (encode eteam)+ command Patch ["teams", toPathPart tid] (encode eteam) -- | Delete a team, by id. --@@ -124,23 +124,56 @@ -- | Delete team. -- -- See <https://developer.github.com/v3/orgs/teams/#delete-team>-deleteTeamR :: Id Team -> Request 'True ()+deleteTeamR :: Id Team -> Request 'RW () deleteTeamR tid =- Command Delete ["teams", toPathPart tid] mempty+ command Delete ["teams", toPathPart tid] mempty --- List team members.+-- | List team members. -- -- See <https://developer.github.com/v3/orgs/teams/#list-team-members>-listTeamMembersR :: Id Team -> TeamMemberRole -> Maybe Count -> Request 'True (Vector SimpleUser)-listTeamMembersR tid r = PagedQuery ["teams", toPathPart tid, "members"] [("role", Just r')]+listTeamMembersR :: Id Team -> TeamMemberRole -> FetchCount -> Request 'RA (Vector SimpleUser)+listTeamMembersR tid r =+ pagedQuery ["teams", toPathPart tid, "members"] [("role", Just r')] where r' = case r of TeamMemberRoleAll -> "all" TeamMemberRoleMaintainer -> "maintainer" TeamMemberRoleMember -> "member" +-- | The repositories of a single team, by team id.+-- With authentication+--+-- > listTeamRepos' (Just $ GitHub.OAuth token) (GitHub.mkTeamId team_id)+listTeamRepos' :: Maybe Auth -> Id Team -> IO (Either Error (Vector Repo))+listTeamRepos' auth tid = executeRequestMaybe auth $ listTeamReposR tid FetchAll++-- | Query team repositories.+-- See <https://developer.github.com/v3/orgs/teams/#list-team-repos>+listTeamReposR :: Id Team -> FetchCount -> Request k (Vector Repo)+listTeamReposR tid =+ pagedQuery ["teams", toPathPart tid, "repos"] []++-- | Retrieve repositories for a team.+--+-- > listTeamRepos (GitHub.mkTeamId team_id)+listTeamRepos :: Id Team -> IO (Either Error (Vector Repo))+listTeamRepos = listTeamRepos' Nothing++-- | Add a repository to a team or update the permission on the repository.+--+-- > addOrUpdateTeamRepo' (OAuth "token") 1010101 "mburns" (Just PermissionPull)+addOrUpdateTeamRepo' :: Auth -> Id Team -> Name Organization -> Name Repo -> Permission -> IO (Either Error ())+addOrUpdateTeamRepo' auth tid org repo permission =+ executeRequest auth $ addOrUpdateTeamRepoR tid org repo permission++-- | Add or update a team repository.+-- See <https://developer.github.com/v3/orgs/teams/#add-or-update-team-repository>+addOrUpdateTeamRepoR :: Id Team -> Name Organization -> Name Repo -> Permission -> Request 'RW ()+addOrUpdateTeamRepoR tid org repo permission =+ command Put' ["teams", toPathPart tid, "repos", toPathPart org, toPathPart repo] (encode $ AddTeamRepoPermission permission)+ -- | Retrieve team mebership information for a user.--- | With authentication+-- With authentication -- -- > teamMembershipInfoFor' (Just $ OAuth "token") 1010101 "mburns" teamMembershipInfoFor' :: Maybe Auth -> Id Team -> Name Owner -> IO (Either Error TeamMembership)@@ -151,7 +184,7 @@ -- See <https://developer.github.com/v3/orgs/teams/#get-team-membership teamMembershipInfoForR :: Id Team -> Name Owner -> Request k TeamMembership teamMembershipInfoForR tid user =- Query ["teams", toPathPart tid, "memberships", toPathPart user] []+ query ["teams", toPathPart tid, "memberships", toPathPart user] [] -- | Retrieve team mebership information for a user. --@@ -162,15 +195,15 @@ -- | Add (or invite) a member to a team. -- -- > addTeamMembershipFor' (OAuth "token") 1010101 "mburns" RoleMember-addTeamMembershipFor' :: Auth -> Id Team -> Name Owner -> Role-> IO (Either Error TeamMembership)+addTeamMembershipFor' :: Auth -> Id Team -> Name Owner -> Role -> IO (Either Error TeamMembership) addTeamMembershipFor' auth tid user role = executeRequest auth $ addTeamMembershipForR tid user role -- | Add team membership. -- See <https://developer.github.com/v3/orgs/teams/#add-team-membership>-addTeamMembershipForR :: Id Team -> Name Owner -> Role -> Request 'True TeamMembership+addTeamMembershipForR :: Id Team -> Name Owner -> Role -> Request 'RW TeamMembership addTeamMembershipForR tid user role =- Command Put ["teams", toPathPart tid, "memberships", toPathPart user] (encode $ CreateTeamMembership role)+ command Put ["teams", toPathPart tid, "memberships", toPathPart user] (encode $ CreateTeamMembership role) -- | Delete a member of a team. --@@ -181,17 +214,18 @@ -- | Remove team membership. -- See <https://developer.github.com/v3/orgs/teams/#remove-team-membership>-deleteTeamMembershipForR :: Id Team -> Name Owner -> Request 'True ()+deleteTeamMembershipForR :: Id Team -> Name Owner -> Request 'RW () deleteTeamMembershipForR tid user =- Command Delete ["teams", toPathPart tid, "memberships", toPathPart user] mempty+ command Delete ["teams", toPathPart tid, "memberships", toPathPart user] mempty -- | List teams for current authenticated user -- -- > listTeamsCurrent' (OAuth "token") listTeamsCurrent' :: Auth -> IO (Either Error (Vector Team))-listTeamsCurrent' auth = executeRequest auth $ listTeamsCurrentR Nothing+listTeamsCurrent' auth = executeRequest auth $ listTeamsCurrentR FetchAll -- | List user teams. -- See <https://developer.github.com/v3/orgs/teams/#list-user-teams>-listTeamsCurrentR :: Maybe Count -> Request 'True (Vector Team)-listTeamsCurrentR = PagedQuery ["user", "teams"] []+listTeamsCurrentR :: FetchCount -> Request 'RA (Vector Team)+listTeamsCurrentR =+ pagedQuery ["user", "teams"] []
src/GitHub/Endpoints/PullRequests.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -8,8 +6,6 @@ -- The pull requests API as documented at -- <http://developer.github.com/v3/pulls/>. module GitHub.Endpoints.PullRequests (- pullRequestsFor'',- pullRequestsFor', pullRequestsFor, pullRequestsForR, pullRequest',@@ -33,51 +29,32 @@ ) where import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request--import Data.Aeson.Compat (Value, encode, object, (.=))-import Data.Vector (Vector)--import qualified Data.ByteString.Char8 as BS8---- | All pull requests for the repo, by owner, repo name, and pull request state.--- | With authentification------ > pullRequestsFor' (Just ("github-username", "github-password")) (Just "open") "rails" "rails"------ State can be one of @all@, @open@, or @closed@. Default is @open@.----pullRequestsFor'' :: Maybe Auth -> Maybe String -> Name Owner -> Name Repo -> IO (Either Error (Vector SimplePullRequest))-pullRequestsFor'' auth state user repo =- executeRequestMaybe auth $ pullRequestsForR user repo state Nothing---- | All pull requests for the repo, by owner and repo name.--- | With authentification------ > pullRequestsFor' (Just ("github-username", "github-password")) "rails" "rails"-pullRequestsFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector SimplePullRequest))-pullRequestsFor' auth = pullRequestsFor'' auth Nothing+import Prelude () --- | All pull requests for the repo, by owner and repo name.+-- | All open pull requests for the repo, by owner and repo name. -- -- > pullRequestsFor "rails" "rails" pullRequestsFor :: Name Owner -> Name Repo -> IO (Either Error (Vector SimplePullRequest))-pullRequestsFor = pullRequestsFor'' Nothing Nothing+pullRequestsFor user repo =+ executeRequest' $ pullRequestsForR user repo mempty FetchAll -- | List pull requests. -- See <https://developer.github.com/v3/pulls/#list-pull-requests>-pullRequestsForR :: Name Owner -> Name Repo- -> Maybe String -- ^ State- -> Maybe Count- -> Request k (Vector SimplePullRequest)-pullRequestsForR user repo state =- PagedQuery ["repos", toPathPart user, toPathPart repo, "pulls"] qs- where- qs = maybe [] (\s -> [("state", Just . BS8.pack $ s)]) state+pullRequestsForR+ :: Name Owner+ -> Name Repo+ -> PullRequestMod+ -> FetchCount+ -> Request k (Vector SimplePullRequest)+pullRequestsForR user repo opts = pagedQuery+ ["repos", toPathPart user, toPathPart repo, "pulls"]+ (prModToQueryString opts) -- | A detailed pull request, which has much more information. This takes the -- repo owner and name along with the number assigned to the pull request.--- | With authentification+-- With authentification. -- -- > pullRequest' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 562 pullRequest' :: Maybe Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error PullRequest)@@ -95,7 +72,7 @@ -- See <https://developer.github.com/v3/pulls/#get-a-single-pull-request> pullRequestR :: Name Owner -> Name Repo -> Id PullRequest -> Request k PullRequest pullRequestR user repo prid =- Query ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid] []+ query ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid] [] createPullRequest :: Auth -> Name Owner@@ -110,9 +87,9 @@ createPullRequestR :: Name Owner -> Name Repo -> CreatePullRequest- -> Request 'True PullRequest+ -> Request 'RW PullRequest createPullRequestR user repo cpr =- Command Post ["repos", toPathPart user, toPathPart repo, "pulls"] (encode cpr)+ command Post ["repos", toPathPart user, toPathPart repo, "pulls"] (encode cpr) -- | Update a pull request updatePullRequest :: Auth -> Name Owner -> Name Repo -> Id PullRequest -> EditPullRequest -> IO (Either Error PullRequest)@@ -125,18 +102,18 @@ -> Name Repo -> Id PullRequest -> EditPullRequest- -> Request 'True PullRequest+ -> Request 'RW PullRequest updatePullRequestR user repo prid epr =- Command Patch ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid] (encode epr)+ command Patch ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid] (encode epr) -- | All the commits on a pull request, given the repo owner, repo name, and -- the number of the pull request.--- | With authentification+-- With authentification. -- -- > pullRequestCommits' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 pullRequestCommits' :: Maybe Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error (Vector Commit)) pullRequestCommits' auth user repo prid =- executeRequestMaybe auth $ pullRequestCommitsR user repo prid Nothing+ executeRequestMaybe auth $ pullRequestCommitsR user repo prid FetchAll -- | All the commits on a pull request, given the repo owner, repo name, and -- the number of the pull request.@@ -147,18 +124,18 @@ -- | List commits on a pull request. -- See <https://developer.github.com/v3/pulls/#list-commits-on-a-pull-request>-pullRequestCommitsR :: Name Owner -> Name Repo -> Id PullRequest -> Maybe Count -> Request k (Vector Commit)+pullRequestCommitsR :: Name Owner -> Name Repo -> Id PullRequest -> FetchCount -> Request k (Vector Commit) pullRequestCommitsR user repo prid =- PagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "commits"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "commits"] [] -- | The individual files that a pull request patches. Takes the repo owner and -- name, plus the number assigned to the pull request.--- | With authentification+-- With authentification. -- -- > pullRequestFiles' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 pullRequestFiles' :: Maybe Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error (Vector File)) pullRequestFiles' auth user repo prid =- executeRequestMaybe auth $ pullRequestFilesR user repo prid Nothing+ executeRequestMaybe auth $ pullRequestFilesR user repo prid FetchAll -- | The individual files that a pull request patches. Takes the repo owner and -- name, plus the number assigned to the pull request.@@ -169,9 +146,9 @@ -- | List pull requests files. -- See <https://developer.github.com/v3/pulls/#list-pull-requests-files>-pullRequestFilesR :: Name Owner -> Name Repo -> Id PullRequest -> Maybe Count -> Request k (Vector File)+pullRequestFilesR :: Name Owner -> Name Repo -> Id PullRequest -> FetchCount -> Request k (Vector File) pullRequestFilesR user repo prid =- PagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "files"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "files"] [] -- | Check if pull request has been merged. isPullRequestMerged :: Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error Bool)@@ -181,23 +158,23 @@ -- | Query if a pull request has been merged. -- See <https://developer.github.com/v3/pulls/#get-if-a-pull-request-has-been-merged> isPullRequestMergedR :: Name Owner -> Name Repo -> Id PullRequest -> Request k Bool-isPullRequestMergedR user repo prid = StatusQuery StatusOnlyOk $+isPullRequestMergedR user repo prid = StatusQuery statusOnlyOk $ Query ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "merge"] [] -- | Merge a pull request.-mergePullRequest :: Auth -> Name Owner -> Name Repo -> Id PullRequest -> Maybe String -> IO (Either Error MergeResult)+mergePullRequest :: Auth -> Name Owner -> Name Repo -> Id PullRequest -> Maybe Text -> IO (Either Error MergeResult) mergePullRequest auth user repo prid commitMessage = executeRequest auth $ mergePullRequestR user repo prid commitMessage -- | Merge a pull request (Merge Button). -- https://developer.github.com/v3/pulls/#merge-a-pull-request-merge-button-mergePullRequestR :: Name Owner -> Name Repo -> Id PullRequest -> Maybe String -> Request 'True MergeResult-mergePullRequestR user repo prid commitMessage = StatusQuery StatusMerge $+mergePullRequestR :: Name Owner -> Name Repo -> Id PullRequest -> Maybe Text -> Request 'RW MergeResult+mergePullRequestR user repo prid commitMessage = StatusQuery statusMerge $ Command Put paths (encode $ buildCommitMessageMap commitMessage) where paths = ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "merge"] - buildCommitMessageMap :: Maybe String -> Value+ buildCommitMessageMap :: Maybe Text -> Value buildCommitMessageMap (Just msg) = object ["commit_message" .= msg ] buildCommitMessageMap Nothing = object []
src/GitHub/Endpoints/PullRequests/ReviewComments.hs view
@@ -13,22 +13,23 @@ module GitHub.Data, ) where -import Data.Vector (Vector) import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All the comments on a pull request with the given ID. -- -- > pullRequestReviewComments "thoughtbot" "factory_girl" (Id 256) pullRequestReviewCommentsIO :: Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error (Vector Comment)) pullRequestReviewCommentsIO user repo prid =- executeRequest' $ pullRequestReviewCommentsR user repo prid Nothing+ executeRequest' $ pullRequestReviewCommentsR user repo prid FetchAll -- | List comments on a pull request. -- See <https://developer.github.com/v3/pulls/comments/#list-comments-on-a-pull-request>-pullRequestReviewCommentsR :: Name Owner -> Name Repo -> Id PullRequest -> Maybe Count -> Request k (Vector Comment)+pullRequestReviewCommentsR :: Name Owner -> Name Repo -> Id PullRequest -> FetchCount -> Request k (Vector Comment) pullRequestReviewCommentsR user repo prid =- PagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "comments"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "comments"] [] -- | One comment on a pull request, by the comment's ID. --@@ -41,4 +42,4 @@ -- See <https://developer.github.com/v3/pulls/comments/#get-a-single-comment> pullRequestReviewCommentR :: Name Owner -> Name Repo -> Id Comment -> Request k Comment pullRequestReviewCommentR user repo cid =- Query ["repos", toPathPart user, toPathPart repo, "pulls", "comments", toPathPart cid] []+ query ["repos", toPathPart user, toPathPart repo, "pulls", "comments", toPathPart cid] []
src/GitHub/Endpoints/Repos.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -59,17 +55,12 @@ module GitHub.Data, ) where -import Prelude ()-import Prelude.Compat--import Control.Applicative ((<|>))-import Data.Aeson.Compat (encode)-import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -import qualified Data.ByteString.Char8 as BS8+import qualified Data.Text.Encoding as TE repoPublicityQueryString :: RepoPublicity -> QueryString repoPublicityQueryString RepoPublicityAll = [("type", Just "all")]@@ -81,13 +72,13 @@ -- | List your repositories. currentUserRepos :: Auth -> RepoPublicity -> IO (Either Error (Vector Repo)) currentUserRepos auth publicity =- executeRequest auth $ currentUserReposR publicity Nothing+ executeRequest auth $ currentUserReposR publicity FetchAll -- | List your repositories. -- See <https://developer.github.com/v3/repos/#list-your-repositories>-currentUserReposR :: RepoPublicity -> Maybe Count -> Request k(Vector Repo)+currentUserReposR :: RepoPublicity -> FetchCount -> Request k (Vector Repo) currentUserReposR publicity =- PagedQuery ["user", "repos"] qs+ pagedQuery ["user", "repos"] qs where qs = repoPublicityQueryString publicity @@ -102,15 +93,19 @@ -- With authentication. -- -- > userRepos' (Just (BasicAuth (user, password))) "mike-burns" All-userRepos' :: Maybe Auth -> Name Owner -> RepoPublicity -> IO (Either Error (Vector Repo))+userRepos'+ :: Maybe Auth+ -> Name Owner+ -> RepoPublicity+ -> IO (Either Error (Vector Repo)) userRepos' auth user publicity =- executeRequestMaybe auth $ userReposR user publicity Nothing+ executeRequestMaybe auth $ userReposR user publicity FetchAll -- | List user repositories. -- See <https://developer.github.com/v3/repos/#list-user-repositories>-userReposR :: Name Owner -> RepoPublicity -> Maybe Count -> Request k(Vector Repo)+userReposR :: Name Owner -> RepoPublicity -> FetchCount -> Request k(Vector Repo) userReposR user publicity =- PagedQuery ["users", toPathPart user, "repos"] qs+ pagedQuery ["users", toPathPart user, "repos"] qs where qs = repoPublicityQueryString publicity @@ -124,15 +119,23 @@ -- With authentication. -- -- > organizationRepos (Just (BasicAuth (user, password))) "thoughtbot" All-organizationRepos' :: Maybe Auth -> Name Organization -> RepoPublicity -> IO (Either Error (Vector Repo))+organizationRepos'+ :: Maybe Auth+ -> Name Organization+ -> RepoPublicity+ -> IO (Either Error (Vector Repo)) organizationRepos' auth org publicity =- executeRequestMaybe auth $ organizationReposR org publicity Nothing+ executeRequestMaybe auth $ organizationReposR org publicity FetchAll -- | List organization repositories. -- See <https://developer.github.com/v3/repos/#list-organization-repositories>-organizationReposR :: Name Organization -> RepoPublicity -> Maybe Count -> Request k (Vector Repo)+organizationReposR+ :: Name Organization+ -> RepoPublicity+ -> FetchCount+ -> Request k (Vector Repo) organizationReposR org publicity =- PagedQuery ["orgs", toPathPart org, "repos"] qs+ pagedQuery ["orgs", toPathPart org, "repos"] qs where qs = repoPublicityQueryString publicity @@ -154,7 +157,7 @@ -- See <https://developer.github.com/v3/repos/#get> repositoryR :: Name Owner -> Name Repo -> Request k Repo repositoryR user repo =- Query ["repos", toPathPart user, toPathPart repo] []+ query ["repos", toPathPart user, toPathPart repo] [] -- | Create a new repository. --@@ -165,9 +168,9 @@ -- | Create a new repository. -- See <https://developer.github.com/v3/repos/#create>-createRepoR :: NewRepo -> Request 'True Repo+createRepoR :: NewRepo -> Request 'RW Repo createRepoR nrepo =- Command Post ["user", "repos"] (encode nrepo)+ command Post ["user", "repos"] (encode nrepo) -- | Create a new repository for an organization. --@@ -178,27 +181,28 @@ -- | Create a new repository for an organization. -- See <https://developer.github.com/v3/repos/#create>-createOrganizationRepoR :: Name Organization -> NewRepo -> Request 'True Repo+createOrganizationRepoR :: Name Organization -> NewRepo -> Request 'RW Repo createOrganizationRepoR org nrepo =- Command Post ["orgs", toPathPart org, "repos"] (encode nrepo)+ command Post ["orgs", toPathPart org, "repos"] (encode nrepo) -- | Edit an existing repository. -- -- > editRepo (BasicAuth (user, password)) "some_user" "some_repo" def {editDescription = Just "some description"}-editRepo :: Auth- -> Name Owner -- ^ owner- -> Name Repo -- ^ repository name- -> EditRepo- -> IO (Either Error Repo)+editRepo+ :: Auth+ -> Name Owner -- ^ owner+ -> Name Repo -- ^ repository name+ -> EditRepo+ -> IO (Either Error Repo) editRepo auth user repo body = executeRequest auth $ editRepoR user repo body -- | Edit an existing repository. -- See <https://developer.github.com/v3/repos/#edit>-editRepoR :: Name Owner -> Name Repo -> EditRepo -> Request 'True Repo+editRepoR :: Name Owner -> Name Repo -> EditRepo -> Request 'RW Repo editRepoR user repo body =- Command Patch ["repos", toPathPart user, toPathPart repo] (encode b)+ command Patch ["repos", toPathPart user, toPathPart repo] (encode b) where -- if no name is given, use curent name b = body {editName = editName body <|> Just repo}@@ -215,17 +219,18 @@ -- > contributors' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" contributors' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Contributor)) contributors' auth user repo =- executeRequestMaybe auth $ contributorsR user repo False Nothing+ executeRequestMaybe auth $ contributorsR user repo False FetchAll -- | List contributors. -- See <https://developer.github.com/v3/repos/#list-contributors>-contributorsR :: Name Owner- -> Name Repo- -> Bool -- ^ Include anonymous- -> Maybe Count- -> Request k (Vector Contributor)+contributorsR+ :: Name Owner+ -> Name Repo+ -> Bool -- ^ Include anonymous+ -> FetchCount+ -> Request k (Vector Contributor) contributorsR user repo anon =- PagedQuery ["repos", toPathPart user, toPathPart repo, "contributors"] qs+ pagedQuery ["repos", toPathPart user, toPathPart repo, "contributors"] qs where qs | anon = [("anon", Just "true")] | otherwise = []@@ -246,7 +251,7 @@ -- > contributorsWithAnonymous' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" contributorsWithAnonymous' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Contributor)) contributorsWithAnonymous' auth user repo =- executeRequestMaybe auth $ contributorsR user repo True Nothing+ executeRequestMaybe auth $ contributorsR user repo True FetchAll -- | The programming languages used in a repo along with the number of -- characters written in that language. Takes the repo owner and name.@@ -268,7 +273,7 @@ -- See <https://developer.github.com/v3/repos/#list-languages> languagesForR :: Name Owner -> Name Repo -> Request k Languages languagesForR user repo =- Query ["repos", toPathPart user, toPathPart repo, "languages"] []+ query ["repos", toPathPart user, toPathPart repo, "languages"] [] -- | The git tags on a repo, given the repo owner and name. --@@ -282,13 +287,13 @@ -- > tagsFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" tagsFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Tag)) tagsFor' auth user repo =- executeRequestMaybe auth $ tagsForR user repo Nothing+ executeRequestMaybe auth $ tagsForR user repo FetchAll -- | List tags. -- See <https://developer.github.com/v3/repos/#list-tags>-tagsForR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector Tag)+tagsForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Tag) tagsForR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "tags"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "tags"] [] -- | The git branches on a repo, given the repo owner and name. --@@ -302,37 +307,38 @@ -- > branchesFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" branchesFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Branch)) branchesFor' auth user repo =- executeRequestMaybe auth $ branchesForR user repo Nothing+ executeRequestMaybe auth $ branchesForR user repo FetchAll -- | List branches. -- See <https://developer.github.com/v3/repos/#list-branches>-branchesForR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector Branch)+branchesForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Branch) branchesForR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "branches"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "branches"] [] -- | The contents of a file or directory in a repo, given the repo owner, name, and path to the file -- -- > contentsFor "thoughtbot" "paperclip" "README.md"-contentsFor :: Name Owner -> Name Repo -> String -> Maybe String -> IO (Either Error Content)+contentsFor :: Name Owner -> Name Repo -> Text -> Maybe Text -> IO (Either Error Content) contentsFor = contentsFor' Nothing -- | The contents of a file or directory in a repo, given the repo owner, name, and path to the file -- With Authentication -- -- > contentsFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" "README.md" Nothing-contentsFor' :: Maybe Auth -> Name Owner -> Name Repo -> String -> Maybe String -> IO (Either Error Content)+contentsFor' :: Maybe Auth -> Name Owner -> Name Repo -> Text -> Maybe Text -> IO (Either Error Content) contentsFor' auth user repo path ref = executeRequestMaybe auth $ contentsForR user repo path ref -contentsForR :: Name Owner- -> Name Repo- -> String -- ^ file or directory- -> Maybe String -- ^ Git commit- -> Request k Content+contentsForR+ :: Name Owner+ -> Name Repo+ -> Text -- ^ file or directory+ -> Maybe Text -- ^ Git commit+ -> Request k Content contentsForR user repo path ref =- Query ["repos", toPathPart user, toPathPart repo, "contents", path] qs+ query ["repos", toPathPart user, toPathPart repo, "contents", path] qs where- qs = maybe [] (\r -> [("ref", Just . BS8.pack $ r)]) ref+ qs = maybe [] (\r -> [("ref", Just . TE.encodeUtf8 $ r)]) ref -- | The contents of a README file in a repo, given the repo owner and name --@@ -350,7 +356,7 @@ readmeForR :: Name Owner -> Name Repo -> Request k Content readmeForR user repo =- Query ["repos", toPathPart user, toPathPart repo, "readme"] []+ query ["repos", toPathPart user, toPathPart repo, "readme"] [] -- | Delete an existing repository. --@@ -359,6 +365,6 @@ deleteRepo auth user repo = executeRequest auth $ deleteRepoR user repo -deleteRepoR :: Name Owner -> Name Repo -> Request 'True ()+deleteRepoR :: Name Owner -> Name Repo -> Request 'RW () deleteRepoR user repo =- Command Delete ["repos", toPathPart user, toPathPart repo] mempty+ command Delete ["repos", toPathPart user, toPathPart repo] mempty
src/GitHub/Endpoints/Repos/Collaborators.hs view
@@ -14,9 +14,10 @@ module GitHub.Data, ) where -import Data.Vector (Vector) import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All the users who have collaborated on a repo. --@@ -28,32 +29,34 @@ -- With authentication. collaboratorsOn' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector SimpleUser)) collaboratorsOn' auth user repo =- executeRequestMaybe auth $ collaboratorsOnR user repo Nothing+ executeRequestMaybe auth $ collaboratorsOnR user repo FetchAll -- | List collaborators. -- See <https://developer.github.com/v3/repos/collaborators/#list-collaborators>-collaboratorsOnR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector SimpleUser)+collaboratorsOnR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector SimpleUser) collaboratorsOnR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "collaborators"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "collaborators"] [] -- | Whether the user is collaborating on a repo. Takes the user in question, -- the user who owns the repo, and the repo name. -- -- > isCollaboratorOn Nothing "mike-burns" "thoughtbot" "paperclip" -- > isCollaboratorOn Nothing "johnson" "thoughtbot" "paperclip"-isCollaboratorOn :: Maybe Auth- -> Name Owner -- ^ Repository owner- -> Name Repo -- ^ Repository name- -> Name User -- ^ Collaborator?- -> IO (Either Error Bool)+isCollaboratorOn+ :: Maybe Auth+ -> Name Owner -- ^ Repository owner+ -> Name Repo -- ^ Repository name+ -> Name User -- ^ Collaborator?+ -> IO (Either Error Bool) isCollaboratorOn auth user repo coll = executeRequestMaybe auth $ isCollaboratorOnR user repo coll -- | Check if a user is a collaborator. -- See <https://developer.github.com/v3/repos/collaborators/#check-if-a-user-is-a-collaborator>-isCollaboratorOnR :: Name Owner -- ^ Repository owner- -> Name Repo -- ^ Repository name- -> Name User -- ^ Collaborator?- -> Request k Bool-isCollaboratorOnR user repo coll = StatusQuery StatusOnlyOk $+isCollaboratorOnR+ :: Name Owner -- ^ Repository owner+ -> Name Repo -- ^ Repository name+ -> Name User -- ^ Collaborator?+ -> Request k Bool+isCollaboratorOnR user repo coll = StatusQuery statusOnlyOk $ Query ["repos", toPathPart user, toPathPart repo, "collaborators", toPathPart coll] []
src/GitHub/Endpoints/Repos/Comments.hs view
@@ -19,9 +19,10 @@ module GitHub.Data, ) where -import Data.Vector (Vector) import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All the comments on a Github repo. --@@ -35,13 +36,13 @@ -- > commentsFor "thoughtbot" "paperclip" commentsFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Comment)) commentsFor' auth user repo =- executeRequestMaybe auth $ commentsForR user repo Nothing+ executeRequestMaybe auth $ commentsForR user repo FetchAll -- | List commit comments for a repository. -- See <https://developer.github.com/v3/repos/comments/#list-commit-comments-for-a-repository>-commentsForR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector Comment)+commentsForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Comment) commentsForR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "comments"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "comments"] [] -- | Just the comments on a specific SHA for a given Github repo. --@@ -55,13 +56,13 @@ -- > commitCommentsFor "thoughtbot" "paperclip" "41f685f6e01396936bb8cd98e7cca517e2c7d96b" commitCommentsFor' :: Maybe Auth -> Name Owner -> Name Repo -> Name Commit -> IO (Either Error (Vector Comment)) commitCommentsFor' auth user repo sha =- executeRequestMaybe auth $ commitCommentsForR user repo sha Nothing+ executeRequestMaybe auth $ commitCommentsForR user repo sha FetchAll -- | List comments for a single commit. -- See <https://developer.github.com/v3/repos/comments/#list-comments-for-a-single-commit>-commitCommentsForR :: Name Owner -> Name Repo -> Name Commit -> Maybe Count -> Request k (Vector Comment)+commitCommentsForR :: Name Owner -> Name Repo -> Name Commit -> FetchCount -> Request k (Vector Comment) commitCommentsForR user repo sha =- PagedQuery ["repos", toPathPart user, toPathPart repo, "commits", toPathPart sha, "comments"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "commits", toPathPart sha, "comments"] [] -- | A comment, by its ID, relative to the Github repo. --@@ -80,4 +81,4 @@ -- See <https://developer.github.com/v3/repos/comments/#get-a-single-commit-comment> commitCommentForR :: Name Owner -> Name Repo -> Id Comment -> Request k Comment commitCommentForR user repo cid =- Query ["repos", toPathPart user, toPathPart repo, "comments", toPathPart cid] []+ query ["repos", toPathPart user, toPathPart repo, "comments", toPathPart cid] []
src/GitHub/Endpoints/Repos/Commits.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -24,22 +23,21 @@ module GitHub.Data, ) where -import Data.Time.ISO8601 (formatISO8601)-import Data.Vector (Vector)--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import qualified Data.Text.Encoding as TE- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () +import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+ renderCommitQueryOption :: CommitQueryOption -> (BS.ByteString, Maybe BS.ByteString) renderCommitQueryOption (CommitQuerySha sha) = ("sha", Just $ TE.encodeUtf8 sha) renderCommitQueryOption (CommitQueryPath path) = ("path", Just $ TE.encodeUtf8 path) renderCommitQueryOption (CommitQueryAuthor author) = ("author", Just $ TE.encodeUtf8 author)-renderCommitQueryOption (CommitQuerySince date) = ("since", Just $ BS8.pack $ formatISO8601 date)-renderCommitQueryOption (CommitQueryUntil date) = ("until", Just $ BS8.pack $ formatISO8601 date)+renderCommitQueryOption (CommitQuerySince date) = ("since", Just $ TE.encodeUtf8 . T.pack $ formatISO8601 date)+renderCommitQueryOption (CommitQueryUntil date) = ("until", Just $ TE.encodeUtf8 . T.pack $ formatISO8601 date) -- | The commit history for a repo. --@@ -57,7 +55,7 @@ -- | List commits on a repository. -- See <https://developer.github.com/v3/repos/commits/#list-commits-on-a-repository>-commitsForR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector Commit)+commitsForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Commit) commitsForR user repo limit = commitsWithOptionsForR user repo limit [] commitsWithOptionsFor :: Name Owner -> Name Repo -> [CommitQueryOption] -> IO (Either Error (Vector Commit))@@ -70,13 +68,13 @@ -- > commitsWithOptionsFor' (Just (BasicAuth (user, password))) "mike-burns" "github" [CommitQueryAuthor "djeik"] commitsWithOptionsFor' :: Maybe Auth -> Name Owner -> Name Repo -> [CommitQueryOption] -> IO (Either Error (Vector Commit)) commitsWithOptionsFor' auth user repo opts =- executeRequestMaybe auth $ commitsWithOptionsForR user repo Nothing opts+ executeRequestMaybe auth $ commitsWithOptionsForR user repo FetchAll opts -- | List commits on a repository. -- See <https://developer.github.com/v3/repos/commits/#list-commits-on-a-repository>-commitsWithOptionsForR :: Name Owner -> Name Repo -> Maybe Count -> [CommitQueryOption] -> Request k (Vector Commit)+commitsWithOptionsForR :: Name Owner -> Name Repo -> FetchCount -> [CommitQueryOption] -> Request k (Vector Commit) commitsWithOptionsForR user repo limit opts =- PagedQuery ["repos", toPathPart user, toPathPart repo, "commits"] qs limit+ pagedQuery ["repos", toPathPart user, toPathPart repo, "commits"] qs limit where qs = map renderCommitQueryOption opts @@ -99,7 +97,7 @@ -- See <https://developer.github.com/v3/repos/commits/#get-a-single-commit> commitR :: Name Owner -> Name Repo -> Name Commit -> Request k Commit commitR user repo sha =- Query ["repos", toPathPart user, toPathPart repo, "commits", toPathPart sha] []+ query ["repos", toPathPart user, toPathPart repo, "commits", toPathPart sha] [] -- | The diff between two treeishes on a repo. --@@ -118,4 +116,4 @@ -- See <https://developer.github.com/v3/repos/commits/#compare-two-commits> diffR :: Name Owner -> Name Repo -> Name Commit -> Name Commit -> Request k Diff diffR user repo base headref =- Query ["repos", toPathPart user, toPathPart repo, "compare", toPathPart base ++ "..." ++ toPathPart headref] []+ query ["repos", toPathPart user, toPathPart repo, "compare", toPathPart base <> "..." <> toPathPart headref] []
+ src/GitHub/Endpoints/Repos/DeployKeys.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- License : BSD-3-Clause+-- Maintainer : Todd Mohney <toddmohney@gmail.com>+--+-- The deploy keys API, as described at+-- <https://developer.github.com/v3/repos/keys>+module GitHub.Endpoints.Repos.DeployKeys (+ -- * Querying deploy keys+ deployKeysFor',+ deployKeysForR,+ deployKeyFor',+ deployKeyForR,++ -- ** Create+ createRepoDeployKey',+ createRepoDeployKeyR,++ -- ** Delete+ deleteRepoDeployKey',+ deleteRepoDeployKeyR,+) where++import GitHub.Data+import GitHub.Internal.Prelude+import GitHub.Request+import Prelude ()++-- | Querying deploy keys.+deployKeysFor' :: Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector RepoDeployKey))+deployKeysFor' auth user repo =+ executeRequest auth $ deployKeysForR user repo FetchAll++-- | Querying deploy keys.+-- See <https://developer.github.com/v3/repos/keys/#list-deploy-keys>+deployKeysForR :: Name Owner -> Name Repo -> FetchCount -> Request 'RA (Vector RepoDeployKey)+deployKeysForR user repo =+ pagedQuery ["repos", toPathPart user, toPathPart repo, "keys"] []++-- | Querying a deploy key+deployKeyFor' :: Auth -> Name Owner -> Name Repo -> Id RepoDeployKey -> IO (Either Error RepoDeployKey)+deployKeyFor' auth user repo keyId =+ executeRequest auth $ deployKeyForR user repo keyId++-- | Querying a deploy key.+-- See <https://developer.github.com/v3/repos/keys/#get-a-deploy-key>+deployKeyForR :: Name Owner -> Name Repo -> Id RepoDeployKey -> Request 'RA RepoDeployKey+deployKeyForR user repo keyId =+ query ["repos", toPathPart user, toPathPart repo, "keys", toPathPart keyId] []++-- | Create a deploy key+createRepoDeployKey' :: Auth -> Name Owner -> Name Repo -> NewRepoDeployKey -> IO (Either Error RepoDeployKey)+createRepoDeployKey' auth user repo key =+ executeRequest auth $ createRepoDeployKeyR user repo key++-- | Create a deploy key.+-- See <https://developer.github.com/v3/repos/keys/#add-a-new-deploy-key>.+createRepoDeployKeyR :: Name Owner -> Name Repo -> NewRepoDeployKey -> Request 'RW RepoDeployKey+createRepoDeployKeyR user repo key =+ command Post ["repos", toPathPart user, toPathPart repo, "keys"] (encode key)++deleteRepoDeployKey' :: Auth -> Name Owner -> Name Repo -> Id RepoDeployKey -> IO (Either Error ())+deleteRepoDeployKey' auth user repo keyId =+ executeRequest auth $ deleteRepoDeployKeyR user repo keyId++-- | Delete a deploy key.+-- See <https://developer.github.com/v3/repos/keys/#remove-a-deploy-key>+deleteRepoDeployKeyR :: Name Owner -> Name Repo -> Id RepoDeployKey -> Request 'RW ()+deleteRepoDeployKeyR user repo keyId =+ command Delete ["repos", toPathPart user, toPathPart repo, "keys", toPathPart keyId] mempty
src/GitHub/Endpoints/Repos/Forks.hs view
@@ -12,9 +12,10 @@ module GitHub.Data, ) where -import Data.Vector (Vector) import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All the repos that are forked off the given repo. --@@ -28,10 +29,10 @@ -- > forksFor' (Just (User (user, password))) "thoughtbot" "paperclip" forksFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Repo)) forksFor' auth user repo =- executeRequestMaybe auth $ forksForR user repo Nothing+ executeRequestMaybe auth $ forksForR user repo FetchAll -- | List forks. -- See <https://developer.github.com/v3/repos/forks/#list-forks>-forksForR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector Repo)+forksForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Repo) forksForR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "forks"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "forks"] []
src/GitHub/Endpoints/Repos/Webhooks.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -33,24 +32,20 @@ deleteRepoWebhookR, ) where -import Prelude ()-import Prelude.Compat--import Data.Aeson.Compat (encode)-import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () webhooksFor' :: Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector RepoWebhook)) webhooksFor' auth user repo =- executeRequest auth $ webhooksForR user repo Nothing+ executeRequest auth $ webhooksForR user repo FetchAll -- | List hooks. -- See <https://developer.github.com/v3/repos/hooks/#list-hooks>-webhooksForR :: Name Owner -> Name Repo -> Maybe Count -> Request k (Vector RepoWebhook)+webhooksForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector RepoWebhook) webhooksForR user repo =- PagedQuery ["repos", toPathPart user, toPathPart repo, "hooks"] []+ pagedQuery ["repos", toPathPart user, toPathPart repo, "hooks"] [] webhookFor' :: Auth -> Name Owner -> Name Repo -> Id RepoWebhook -> IO (Either Error RepoWebhook) webhookFor' auth user repo hookId =@@ -60,7 +55,7 @@ -- See <https://developer.github.com/v3/repos/hooks/#get-single-hook> webhookForR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request k RepoWebhook webhookForR user repo hookId =- Query ["repos", toPathPart user, toPathPart repo, "hooks", toPathPart hookId] []+ query ["repos", toPathPart user, toPathPart repo, "hooks", toPathPart hookId] [] createRepoWebhook' :: Auth -> Name Owner -> Name Repo -> NewRepoWebhook -> IO (Either Error RepoWebhook) createRepoWebhook' auth user repo hook =@@ -68,9 +63,9 @@ -- | Create a hook. -- See <https://developer.github.com/v3/repos/hooks/#create-a-hook>-createRepoWebhookR :: Name Owner -> Name Repo -> NewRepoWebhook -> Request 'True RepoWebhook+createRepoWebhookR :: Name Owner -> Name Repo -> NewRepoWebhook -> Request 'RW RepoWebhook createRepoWebhookR user repo hook =- Command Post ["repos", toPathPart user, toPathPart repo, "hooks"] (encode hook)+ command Post ["repos", toPathPart user, toPathPart repo, "hooks"] (encode hook) editRepoWebhook' :: Auth -> Name Owner -> Name Repo -> Id RepoWebhook -> EditRepoWebhook -> IO (Either Error RepoWebhook) editRepoWebhook' auth user repo hookId hookEdit =@@ -78,9 +73,9 @@ -- | Edit a hook. -- See <https://developer.github.com/v3/repos/hooks/#edit-a-hook>-editRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> EditRepoWebhook -> Request 'True RepoWebhook+editRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> EditRepoWebhook -> Request 'RW RepoWebhook editRepoWebhookR user repo hookId hookEdit =- Command Patch ["repos", toPathPart user, toPathPart repo, "hooks", toPathPart hookId] (encode hookEdit)+ command Patch ["repos", toPathPart user, toPathPart repo, "hooks", toPathPart hookId] (encode hookEdit) testPushRepoWebhook' :: Auth -> Name Owner -> Name Repo -> Id RepoWebhook -> IO (Either Error Bool) testPushRepoWebhook' auth user repo hookId =@@ -88,8 +83,8 @@ -- | Test a push hook. -- See <https://developer.github.com/v3/repos/hooks/#test-a-push-hook>-testPushRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request 'True Bool-testPushRepoWebhookR user repo hookId = StatusQuery StatusOnlyOk $+testPushRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request 'RW Bool+testPushRepoWebhookR user repo hookId = StatusQuery statusOnlyOk $ Command Post (createWebhookOpPath user repo hookId $ Just "tests") (encode ()) pingRepoWebhook' :: Auth -> Name Owner -> Name Repo -> Id RepoWebhook -> IO (Either Error Bool)@@ -98,8 +93,8 @@ -- | Ping a hook. -- See <https://developer.github.com/v3/repos/hooks/#ping-a-hook>-pingRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request 'True Bool-pingRepoWebhookR user repo hookId = StatusQuery StatusOnlyOk $+pingRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request 'RW Bool+pingRepoWebhookR user repo hookId = StatusQuery statusOnlyOk $ Command Post (createWebhookOpPath user repo hookId $ Just "pings") (encode ()) deleteRepoWebhook' :: Auth -> Name Owner -> Name Repo -> Id RepoWebhook -> IO (Either Error ())@@ -108,14 +103,14 @@ -- | Delete a hook. -- See <https://developer.github.com/v3/repos/hooks/#delete-a-hook>-deleteRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request 'True ()+deleteRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request 'RW () deleteRepoWebhookR user repo hookId =- Command Delete (createWebhookOpPath user repo hookId Nothing) mempty+ command Delete (createWebhookOpPath user repo hookId Nothing) mempty -createBaseWebhookPath :: Name Owner -> Name Repo -> Id RepoWebhook -> [String]+createBaseWebhookPath :: Name Owner -> Name Repo -> Id RepoWebhook -> Paths createBaseWebhookPath user repo hookId = ["repos", toPathPart user, toPathPart repo, "hooks", toPathPart hookId] -createWebhookOpPath :: Name Owner -> Name Repo -> Id RepoWebhook -> Maybe String -> [String]+createWebhookOpPath :: Name Owner -> Name Repo -> Id RepoWebhook -> Maybe Text -> Paths createWebhookOpPath owner reqName webhookId Nothing = createBaseWebhookPath owner reqName webhookId createWebhookOpPath owner reqName webhookId (Just operation) = createBaseWebhookPath owner reqName webhookId ++ [operation]
src/GitHub/Endpoints/Search.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -19,13 +18,13 @@ module GitHub.Data, ) where -import Data.Text (Text)--import qualified Data.Text.Encoding as TE- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () +import qualified Data.Text.Encoding as TE+ -- | Perform a repository search. -- With authentication. --@@ -43,7 +42,8 @@ -- | Search repositories. -- See <https://developer.github.com/v3/search/#search-repositories> searchReposR :: Text -> Request k (SearchResult Repo)-searchReposR searchString = Query ["search", "repositories"] [("q", Just $ TE.encodeUtf8 searchString)]+searchReposR searchString =+ query ["search", "repositories"] [("q", Just $ TE.encodeUtf8 searchString)] -- | Perform a code search. -- With authentication.@@ -62,7 +62,8 @@ -- | Search code. -- See <https://developer.github.com/v3/search/#search-code> searchCodeR :: Text -> Request k (SearchResult Code)-searchCodeR searchString = Query ["search", "code"] [("q", Just $ TE.encodeUtf8 searchString)]+searchCodeR searchString =+ query ["search", "code"] [("q", Just $ TE.encodeUtf8 searchString)] -- | Perform an issue search. -- With authentication.@@ -81,4 +82,5 @@ -- | Search issues. -- See <https://developer.github.com/v3/search/#search-issues> searchIssuesR :: Text -> Request k (SearchResult Issue)-searchIssuesR searchString = Query ["search", "issues"] [("q", Just $ TE.encodeUtf8 searchString)]+searchIssuesR searchString =+ query ["search", "issues"] [("q", Just $ TE.encodeUtf8 searchString)]
src/GitHub/Endpoints/Users.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -17,7 +16,9 @@ ) where import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | The information for a single user, by login name. -- With authentification@@ -35,12 +36,12 @@ -- | Query a single user. -- See <https://developer.github.com/v3/users/#get-a-single-user> userInfoForR :: Name User -> Request k User-userInfoForR user = Query ["users", toPathPart user] []+userInfoForR user = query ["users", toPathPart user] [] -- | Query a single user or an organization. -- See <https://developer.github.com/v3/users/#get-a-single-user> ownerInfoForR :: Name Owner -> Request k Owner-ownerInfoForR owner = Query ["users", toPathPart owner] []+ownerInfoForR owner = query ["users", toPathPart owner] [] -- | Retrieve information about the user associated with the supplied authentication. --@@ -51,5 +52,5 @@ -- | Query the authenticated user. -- See <https://developer.github.com/v3/users/#get-the-authenticated-user>-userInfoCurrentR :: Request 'True User-userInfoCurrentR = Query ["user"] []+userInfoCurrentR :: Request 'RA User+userInfoCurrentR = query ["user"] []
src/GitHub/Endpoints/Users/Followers.hs view
@@ -13,31 +13,33 @@ module GitHub.Data, ) where -import Data.Vector (Vector)- import GitHub.Data+import GitHub.Internal.Prelude import GitHub.Request+import Prelude () -- | All the users following the given user. -- -- > usersFollowing "mike-burns" usersFollowing :: Name User -> IO (Either Error (Vector SimpleUser)) usersFollowing user =- executeRequest' $ usersFollowingR user Nothing+ executeRequest' $ usersFollowingR user FetchAll -- | List followers of a user. -- See <https://developer.github.com/v3/users/followers/#list-followers-of-a-user>-usersFollowingR :: Name User -> Maybe Count -> Request k (Vector SimpleUser)-usersFollowingR user = PagedQuery ["users", toPathPart user, "followers"] []+usersFollowingR :: Name User -> FetchCount -> Request k (Vector SimpleUser)+usersFollowingR user =+ pagedQuery ["users", toPathPart user, "followers"] [] -- | All the users that the given user follows. -- -- > usersFollowedBy "mike-burns" usersFollowedBy :: Name User -> IO (Either Error (Vector SimpleUser)) usersFollowedBy user =- executeRequest' $ usersFollowedByR user Nothing+ executeRequest' $ usersFollowedByR user FetchAll -- | List users followed by another user. -- See <https://developer.github.com/v3/users/followers/#list-users-followed-by-another-user>-usersFollowedByR :: Name User -> Maybe Count -> Request k (Vector SimpleUser)-usersFollowedByR user = PagedQuery ["users", toPathPart user, "following"] []+usersFollowedByR :: Name User -> FetchCount -> Request k (Vector SimpleUser)+usersFollowedByR user =+ pagedQuery ["users", toPathPart user, "following"] []
+ src/GitHub/Internal/Prelude.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE NoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- License : BSD-3-Clause+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- This module may change between minor releases. Do not rely on it contents.+module GitHub.Internal.Prelude (+ module Prelude.Compat,+ -- * Commonly used types+ UTCTime,+ HashMap,+ Text, pack, unpack,+ Vector,+ -- * Commonly used typeclasses+ Binary,+ Data, Typeable,+ Generic,+ Hashable(..),+ IsString(..),+ NFData(..), genericRnf,+ Semigroup(..),+ -- * Aeson+ FromJSON(..), ToJSON(..), Value(..), Object,+ encode,+ withText, withObject, (.:), (.:?), (.!=), (.=), object, typeMismatch,+ -- * Control.Applicative+ (<|>),+ -- * Data.Maybe+ catMaybes,+ -- * Data.List+ intercalate, toList,+ -- * Data.Time.ISO8601+ formatISO8601,+ ) where++import Control.Applicative ((<|>))+import Control.DeepSeq (NFData (..))+import Control.DeepSeq.Generics (genericRnf)+import Data.Aeson.Compat+ (FromJSON (..), Object, ToJSON (..), Value (..), encode, object,+ withObject, withText, (.!=), (.:), (.:?), (.=))+import Data.Aeson.Types (typeMismatch)+import Data.Binary (Binary)+import Data.Binary.Orphans ()+import Data.Data (Data, Typeable)+import Data.Foldable (toList)+import Data.Hashable (Hashable (..))+import Data.HashMap.Strict (HashMap)+import Data.List (intercalate)+import Data.Maybe (catMaybes)+import Data.Semigroup (Semigroup (..))+import Data.String (IsString (..))+import Data.Text (Text, pack, unpack)+import Data.Time (UTCTime)+import Data.Time.ISO8601 (formatISO8601)+import Data.Vector (Vector)+import Data.Vector.Instances ()+import GHC.Generics (Generic)+import Prelude.Compat
src/GitHub/Request.hs view
@@ -1,13 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause@@ -48,14 +43,15 @@ unsafeDropAuthRequirements, -- * Helpers makeHttpRequest,+ makeHttpSimpleRequest, parseResponse, parseStatus, getNextUrl, performPagedRequest, ) where -import Prelude ()-import Prelude.Compat+import GitHub.Internal.Prelude+import Prelude () #if MIN_VERSION_mtl(2,2,0) import Control.Monad.Except (MonadError (..))@@ -66,32 +62,30 @@ import Control.Monad.Catch (MonadCatch (..), MonadThrow) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT (..), runExceptT)-import Data.Aeson.Compat (FromJSON, eitherDecode)-import Data.List (find, intercalate)-import Data.Semigroup (Semigroup (..))-import Data.Text (Text)-import Data.Vector.Instances ()+import Data.Aeson.Compat (eitherDecode)+import Data.List (find) -import Network.HTTP.Client (CookieJar, HttpException (..), Manager,- RequestBody (..), Response (..),- applyBasicAuth, checkStatus, httpLbs,- method, newManager, parseUrl, requestBody,- requestHeaders, setQueryString)-import Network.HTTP.Client.Internal (setUri)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import Network.HTTP.Link.Parser (parseLinkHeaderBS)-import Network.HTTP.Link.Types (Link (..), LinkParam (..), href,- linkParams)-import Network.HTTP.Types (Method, RequestHeaders, ResponseHeaders,- Status (..))-import Network.URI (URI)+import Network.HTTP.Client+ (HttpException (..), Manager, RequestBody (..), Response (..),+ applyBasicAuth, httpLbs, method, newManager, requestBody,+ requestHeaders, setQueryString)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Link.Parser (parseLinkHeaderBS)+import Network.HTTP.Link.Types (Link (..), LinkParam (..), href, linkParams)+import Network.HTTP.Types (Method, RequestHeaders, Status (..))+import Network.URI (URI) -import qualified Control.Exception as E-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Text as T-import qualified Data.Vector as V-import qualified Network.HTTP.Client as HTTP+#if !MIN_VERSION_http_client(0,5,0)+import qualified Control.Exception as E+import Network.HTTP.Types (ResponseHeaders)+#endif +import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.Internal as HTTP+ import GitHub.Auth (Auth (..)) import GitHub.Data (Error (..)) import GitHub.Data.Request@@ -106,38 +100,50 @@ #endif pure x +lessFetchCount :: Int -> FetchCount -> Bool+lessFetchCount _ FetchAll = True+lessFetchCount i (FetchAtLeast j) = i < fromIntegral j+ -- | Like 'executeRequest' but with provided 'Manager'.-executeRequestWithMgr :: Manager- -> Auth- -> Request k a- -> IO (Either Error a)-executeRequestWithMgr mgr auth req = runExceptT $- case req of- Query {} -> do- httpReq <- makeHttpRequest (Just auth) req- res <- httpLbs' httpReq- parseResponse res- PagedQuery _ _ l -> do- httpReq <- makeHttpRequest (Just auth) req- performPagedRequest httpLbs' predicate httpReq- where- predicate = maybe (const True) (\l' -> (< l') . V.length ) l- Command m _ _ -> do- httpReq <- makeHttpRequest (Just auth) req- res <- httpLbs' httpReq- case m of- Delete -> pure ()- _ -> parseResponse res- StatusQuery sm _ -> do- httpReq <- makeHttpRequest (Just auth) req- res <- httpLbs' httpReq- parseStatus sm . responseStatus $ res+executeRequestWithMgr+ :: Manager+ -> Auth+ -> Request k a+ -> IO (Either Error a)+executeRequestWithMgr mgr auth req = runExceptT $ do+ httpReq <- makeHttpRequest (Just auth) req+ performHttpReq httpReq req where httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString) httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException + performHttpReq :: HTTP.Request -> Request k b -> ExceptT Error IO b+ performHttpReq httpReq (SimpleQuery sreq) =+ performHttpReq' httpReq sreq+ performHttpReq httpReq (HeaderQuery _ sreq) =+ performHttpReq' httpReq sreq+ performHttpReq httpReq (StatusQuery sm _) = do+ res <- httpLbs' httpReq+ parseStatus sm . responseStatus $ res++ performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest k b -> ExceptT Error IO b+ performHttpReq' httpReq Query {} = do+ res <- httpLbs' httpReq+ parseResponse res+ performHttpReq' httpReq (PagedQuery _ _ l) =+ performPagedRequest httpLbs' predicate httpReq+ where+ predicate v = lessFetchCount (V.length v) l+ performHttpReq' httpReq (Command m _ _) = do+ res <- httpLbs' httpReq+ case m of+ Delete -> pure ()+ Put' -> pure ()+ _ -> parseResponse res++ -- | Like 'executeRequest' but without authentication.-executeRequest' :: Request 'False a -> IO (Either Error a)+executeRequest' ::Request 'RO a -> IO (Either Error a) executeRequest' req = do manager <- newManager tlsManagerSettings x <- executeRequestWithMgr' manager req@@ -147,38 +153,45 @@ pure x -- | Like 'executeRequestWithMgr' but without authentication.-executeRequestWithMgr' :: Manager- -> Request 'False a- -> IO (Either Error a)-executeRequestWithMgr' mgr req = runExceptT $- case req of- Query {} -> do- httpReq <- makeHttpRequest Nothing req- res <- httpLbs' httpReq- parseResponse res- PagedQuery _ _ l -> do- httpReq <- makeHttpRequest Nothing req- performPagedRequest httpLbs' predicate httpReq- where- predicate = maybe (const True) (\l' -> (< l') . V.length) l- StatusQuery sm _ -> do- httpReq <- makeHttpRequest Nothing req- res <- httpLbs' httpReq- parseStatus sm . responseStatus $ res+executeRequestWithMgr'+ :: Manager+ -> Request 'RO a+ -> IO (Either Error a)+executeRequestWithMgr' mgr req = runExceptT $ do+ httpReq <- makeHttpRequest Nothing req+ performHttpReq httpReq req where httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString) httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException + performHttpReq :: HTTP.Request -> Request 'RO b -> ExceptT Error IO b+ performHttpReq httpReq (SimpleQuery sreq) =+ performHttpReq' httpReq sreq+ performHttpReq httpReq (HeaderQuery _ sreq) =+ performHttpReq' httpReq sreq+ performHttpReq httpReq (StatusQuery sm _) = do+ res <- httpLbs' httpReq+ parseStatus sm . responseStatus $ res++ performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest 'RO b -> ExceptT Error IO b+ performHttpReq' httpReq Query {} = do+ res <- httpLbs' httpReq+ parseResponse res+ performHttpReq' httpReq (PagedQuery _ _ l) =+ performPagedRequest httpLbs' predicate httpReq+ where+ predicate v = lessFetchCount (V.length v) l+ -- | Helper for picking between 'executeRequest' and 'executeRequest''. -- -- The use is discouraged.-executeRequestMaybe :: Maybe Auth -> Request 'False a- -> IO (Either Error a)+executeRequestMaybe :: Maybe Auth -> Request 'RO a -> IO (Either Error a) executeRequestMaybe = maybe executeRequest' executeRequest -- | Partial function to drop authentication need.-unsafeDropAuthRequirements :: Request 'True a -> Request k a-unsafeDropAuthRequirements (Query ps qs) = Query ps qs+unsafeDropAuthRequirements :: Request k' a -> Request k a+unsafeDropAuthRequirements (SimpleQuery (Query ps qs)) =+ SimpleQuery (Query ps qs) unsafeDropAuthRequirements r = error $ "Trying to drop authenatication from" ++ show r @@ -195,41 +208,64 @@ -- @ -- parseResponse :: 'Maybe' 'Auth' -> 'Request' k a -> 'Maybe' 'Request' -- @-makeHttpRequest :: MonadThrow m- => Maybe Auth- -> Request k a- -> m HTTP.Request+makeHttpRequest+ :: MonadThrow m+ => Maybe Auth+ -> Request k a+ -> m HTTP.Request makeHttpRequest auth r = case r of+ SimpleQuery req ->+ makeHttpSimpleRequest auth req StatusQuery sm req -> do- req' <- makeHttpRequest auth req+ req' <- makeHttpSimpleRequest auth req return $ setCheckStatus (Just sm) req'+ HeaderQuery h req -> do+ req' <- makeHttpSimpleRequest auth req+ return $ req' { requestHeaders = h <> requestHeaders req' }++makeHttpSimpleRequest+ :: MonadThrow m+ => Maybe Auth+ -> SimpleRequest k a+ -> m HTTP.Request+makeHttpSimpleRequest auth r = case r of Query paths qs -> do- req <- parseUrl $ url paths- return $ setReqHeaders- . setCheckStatus Nothing- . setAuthRequest auth- . setQueryString qs- $ req+ req <- parseUrl' $ url paths+ return+ $ setReqHeaders+ . setCheckStatus Nothing+ . setAuthRequest auth+ . setQueryString qs+ $ req PagedQuery paths qs _ -> do- req <- parseUrl $ url paths- return $ setReqHeaders- . setCheckStatus Nothing- . setAuthRequest auth- . setQueryString qs- $ req+ req <- parseUrl' $ url paths+ return+ $ setReqHeaders+ . setCheckStatus Nothing+ . setAuthRequest auth+ . setQueryString qs+ $ req Command m paths body -> do- req <- parseUrl $ url paths- return $ setReqHeaders- . setCheckStatus Nothing- . setAuthRequest auth- . setBody body- . setMethod (toMethod m)- $ req+ req <- parseUrl' $ url paths+ return+ $ setReqHeaders+ . setCheckStatus Nothing+ . setAuthRequest auth+ . setBody body+ . setMethod (toMethod m)+ $ req where- url :: Paths -> String- url paths = baseUrl ++ '/' : intercalate "/" paths+ parseUrl' :: MonadThrow m => Text -> m HTTP.Request+#if MIN_VERSION_http_client(0,4,30)+ parseUrl' = HTTP.parseRequest . T.unpack+#else+ parseUrl' = HTTP.parseUrl . T.unpack+#endif - baseUrl :: String+ url :: Paths -> Text+ url paths = baseUrl <> "/" <> T.intercalate "/" paths++ baseUrl :: Text baseUrl = case auth of Just (EnterpriseOAuth endpoint _) -> endpoint _ -> "https://api.github.com"@@ -237,9 +273,6 @@ setReqHeaders :: HTTP.Request -> HTTP.Request setReqHeaders req = req { requestHeaders = reqHeaders <> requestHeaders req } - setCheckStatus :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Request- setCheckStatus sm req = req { checkStatus = successOrMissing sm }- setMethod :: Method -> HTTP.Request -> HTTP.Request setMethod m req = req { method = m } @@ -260,16 +293,6 @@ getOAuthHeader (EnterpriseOAuth _ token) = [("Authorization", "token " <> token)] getOAuthHeader _ = [] - successOrMissing :: Maybe (StatusMap a) -> Status -> ResponseHeaders -> CookieJar -> Maybe E.SomeException- successOrMissing sm s@(Status sci _) hs cookiejar- | check = Nothing- | otherwise = Just $ E.toException $ StatusCodeException s hs cookiejar- where- check = case sm of- Nothing -> 200 <= sci && sci < 300- Just StatusOnlyOk -> sci == 204 || sci == 404- Just StatusMerge -> sci `elem` [204, 405, 409]- -- | Query @Link@ header with @rel=next@ from the request headers. getNextUrl :: Response a -> Maybe URI getNextUrl req = do@@ -300,15 +323,10 @@ -- parseStatus :: 'StatusMap' a -> 'Status' -> 'Either' 'Error' a -- @ parseStatus :: MonadError Error m => StatusMap a -> Status -> m a-parseStatus StatusOnlyOk (Status sci _)- | sci == 204 = return True- | sci == 404 = return False- | otherwise = throwError $ JsonError $ "invalid status: " <> T.pack (show sci)-parseStatus StatusMerge (Status sci _)- | sci == 204 = return MergeSuccessful- | sci == 405 = return MergeCannotPerform- | sci == 409 = return MergeConflict- | otherwise = throwError $ JsonError $ "invalid status: " <> T.pack (show sci)+parseStatus m (Status sci _) =+ maybe err return $ lookup sci m+ where+ err = throwError $ JsonError $ "invalid status: " <> T.pack (show sci) -- | Helper for making paginated requests. Responses, @a@ are combined monoidally. --@@ -319,11 +337,12 @@ -- -> 'HTTP.Request' -- -> 'ExceptT' 'Error' 'IO' a -- @-performPagedRequest :: forall a m. (FromJSON a, Semigroup a, MonadCatch m, MonadError Error m)- => (HTTP.Request -> m (Response LBS.ByteString)) -- ^ `httpLbs` analogue- -> (a -> Bool) -- ^ predicate to continue iteration- -> HTTP.Request -- ^ initial request- -> m a+performPagedRequest+ :: forall a m. (FromJSON a, Semigroup a, MonadCatch m, MonadError Error m)+ => (HTTP.Request -> m (Response LBS.ByteString)) -- ^ `httpLbs` analogue+ -> (a -> Bool) -- ^ predicate to continue iteration+ -> HTTP.Request -- ^ initial request+ -> m a performPagedRequest httpLbs' predicate initReq = do res <- httpLbs' initReq m <- parseResponse res@@ -333,11 +352,45 @@ go acc res req = case (predicate acc, getNextUrl res) of (True, Just uri) -> do- req' <- setUri req uri+ req' <- HTTP.setUri req uri res' <- httpLbs' req' m <- parseResponse res' go (acc <> m) res' req' (_, _) -> return acc++-------------------------------------------------------------------------------+-- Internal+-------------------------------------------------------------------------------+++setCheckStatus :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Request+#if MIN_VERSION_http_client(0,5,0)+setCheckStatus sm req = req { HTTP.checkResponse = successOrMissing sm }+#else+setCheckStatus sm req = req { HTTP.checkStatus = successOrMissing sm }+#endif+++#if MIN_VERSION_http_client(0,5,0)+successOrMissing :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO ()+successOrMissing sm _req res+ | check = pure ()+ | otherwise = do+ chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024+ let res' = fmap (const ()) res+ HTTP.throwHttp $ HTTP.StatusCodeException res' (LBS.toStrict chunk)+ where+ Status sci _ = HTTP.responseStatus res+#else+successOrMissing :: Maybe (StatusMap a) -> Status -> ResponseHeaders -> HTTP.CookieJar -> Maybe E.SomeException+successOrMissing sm s@(Status sci _) hs cookiejar+ | check = Nothing+ | otherwise = Just $ E.toException $ StatusCodeException s hs cookiejar+ where+#endif+ check = case sm of+ Nothing -> 200 <= sci && sci < 300+ Just sm' -> sci `elem` map fst sm' onHttpException :: MonadError Error m => HttpException -> m a onHttpException = throwError . HTTPError