diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ ------ [![Build Status](https://travis-ci.org/phadej/github.svg?branch=master)](https://travis-ci.org/phadej/github) -[![Hackage](https://img.shields.io/hackage/v/github.svg)](http://hackage.haskell.org/package/github) +[![Hackage](https://img.shields.io/hackage/v/github.svg)][hackage] [![Stackage LTS 5](http://stackage.org/package/github/badge/lts-5)](http://stackage.org/lts-5/package/github) [![Stackage Nightly](http://stackage.org/package/github/badge/nightly)](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" diff --git a/fixtures/issue-search.json b/fixtures/issue-search.json --- a/fixtures/issue-search.json +++ b/fixtures/issue-search.json @@ -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", diff --git a/github.cabal b/github.cabal --- a/github.cabal +++ b/github.cabal @@ -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 diff --git a/spec/GitHub/ActivitySpec.hs b/spec/GitHub/ActivitySpec.hs --- a/spec/GitHub/ActivitySpec.hs +++ b/spec/GitHub/ActivitySpec.hs @@ -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) diff --git a/spec/GitHub/CommitsSpec.hs b/spec/GitHub/CommitsSpec.hs --- a/spec/GitHub/CommitsSpec.hs +++ b/spec/GitHub/CommitsSpec.hs @@ -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 diff --git a/spec/GitHub/IssuesSpec.hs b/spec/GitHub/IssuesSpec.hs new file mode 100644 --- /dev/null +++ b/spec/GitHub/IssuesSpec.hs @@ -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") + ] diff --git a/spec/GitHub/PullRequestsSpec.hs b/spec/GitHub/PullRequestsSpec.hs new file mode 100644 --- /dev/null +++ b/spec/GitHub/PullRequestsSpec.hs @@ -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 diff --git a/spec/GitHub/ReposSpec.hs b/spec/GitHub/ReposSpec.hs --- a/spec/GitHub/ReposSpec.hs +++ b/spec/GitHub/ReposSpec.hs @@ -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 diff --git a/spec/GitHub/SearchSpec.hs b/spec/GitHub/SearchSpec.hs --- a/spec/GitHub/SearchSpec.hs +++ b/spec/GitHub/SearchSpec.hs @@ -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" diff --git a/spec/GitHub/UsersSpec.hs b/spec/GitHub/UsersSpec.hs --- a/spec/GitHub/UsersSpec.hs +++ b/spec/GitHub/UsersSpec.hs @@ -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 diff --git a/src/GitHub.hs b/src/GitHub.hs --- a/src/GitHub.hs +++ b/src/GitHub.hs @@ -15,6 +15,10 @@ -- * Activity -- | See + -- ** Events + -- | See https://developer.github.com/v3/activity/events/#events + repositoryEventsR, + -- ** Starring -- | See -- @@ -26,6 +30,7 @@ stargazersForR, reposStarredByR, myStarredR, + myStarredAcceptStarR, -- ** Watching -- | See @@ -91,9 +96,8 @@ -- * Issues -- | See -- - -- 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 diff --git a/src/GitHub/Auth.hs b/src/GitHub/Auth.hs --- a/src/GitHub/Auth.hs +++ b/src/GitHub/Auth.hs @@ -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 diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs --- a/src/GitHub/Data.hs +++ b/src/GitHub/Data.hs @@ -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 diff --git a/src/GitHub/Data/Activities.hs b/src/GitHub/Data/Activities.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Activities.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +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" + diff --git a/src/GitHub/Data/Comments.hs b/src/GitHub/Data/Comments.hs --- a/src/GitHub/Data/Comments.hs +++ b/src/GitHub/Data/Comments.hs @@ -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 diff --git a/src/GitHub/Data/Content.hs b/src/GitHub/Data/Content.hs --- a/src/GitHub/Data/Content.hs +++ b/src/GitHub/Data/Content.hs @@ -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 -> diff --git a/src/GitHub/Data/Definitions.hs b/src/GitHub/Data/Definitions.hs --- a/src/GitHub/Data/Definitions.hs +++ b/src/GitHub/Data/Definitions.hs @@ -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" diff --git a/src/GitHub/Data/DeployKeys.hs b/src/GitHub/Data/DeployKeys.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/DeployKeys.hs @@ -0,0 +1,52 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Todd Mohney +-- +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" diff --git a/src/GitHub/Data/Events.hs b/src/GitHub/Data/Events.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Events.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +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" diff --git a/src/GitHub/Data/Gists.hs b/src/GitHub/Data/Gists.hs --- a/src/GitHub/Data/Gists.hs +++ b/src/GitHub/Data/Gists.hs @@ -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" diff --git a/src/GitHub/Data/GitData.hs b/src/GitHub/Data/GitData.hs --- a/src/GitHub/Data/GitData.hs +++ b/src/GitHub/Data/GitData.hs @@ -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" diff --git a/src/GitHub/Data/Id.hs b/src/GitHub/Data/Id.hs --- a/src/GitHub/Data/Id.hs +++ b/src/GitHub/Data/Id.hs @@ -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 diff --git a/src/GitHub/Data/Issues.hs b/src/GitHub/Data/Issues.hs --- a/src/GitHub/Data/Issues.hs +++ b/src/GitHub/Data/Issues.hs @@ -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 diff --git a/src/GitHub/Data/Milestone.hs b/src/GitHub/Data/Milestone.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Milestone.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +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" diff --git a/src/GitHub/Data/Name.hs b/src/GitHub/Data/Name.hs --- a/src/GitHub/Data/Name.hs +++ b/src/GitHub/Data/Name.hs @@ -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 diff --git a/src/GitHub/Data/Options.hs b/src/GitHub/Data/Options.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Options.hs @@ -0,0 +1,598 @@ +{-# LANGUAGE RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- 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 . +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 . +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 . +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 . +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 . +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 +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 } diff --git a/src/GitHub/Data/PullRequests.hs b/src/GitHub/Data/PullRequests.hs --- a/src/GitHub/Data/PullRequests.hs +++ b/src/GitHub/Data/PullRequests.hs @@ -1,97 +1,103 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause -- Maintainer : Oleg Grenrus -- -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) + ] diff --git a/src/GitHub/Data/Repos.hs b/src/GitHub/Data/Repos.hs --- a/src/GitHub/Data/Repos.hs +++ b/src/GitHub/Data/Repos.hs @@ -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 diff --git a/src/GitHub/Data/Request.hs b/src/GitHub/Data/Request.hs --- a/src/GitHub/Data/Request.hs +++ b/src/GitHub/Data/Request.hs @@ -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 -- 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 diff --git a/src/GitHub/Data/Search.hs b/src/GitHub/Data/Search.hs --- a/src/GitHub/Data/Search.hs +++ b/src/GitHub/Data/Search.hs @@ -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" diff --git a/src/GitHub/Data/Teams.hs b/src/GitHub/Data/Teams.hs --- a/src/GitHub/Data/Teams.hs +++ b/src/GitHub/Data/Teams.hs @@ -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 diff --git a/src/GitHub/Data/URL.hs b/src/GitHub/Data/URL.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/URL.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +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) diff --git a/src/GitHub/Data/Webhooks.hs b/src/GitHub/Data/Webhooks.hs --- a/src/GitHub/Data/Webhooks.hs +++ b/src/GitHub/Data/Webhooks.hs @@ -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" diff --git a/src/GitHub/Data/Webhooks/Validate.hs b/src/GitHub/Data/Webhooks/Validate.hs --- a/src/GitHub/Data/Webhooks/Validate.hs +++ b/src/GitHub/Data/Webhooks/Validate.hs @@ -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 diff --git a/src/GitHub/Endpoints/Activity/Events.hs b/src/GitHub/Endpoints/Activity/Events.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Endpoints/Activity/Events.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- The events API as described on . +module GitHub.Endpoints.Activity.Events ( + -- * Events + repositoryEventsR, + module GitHub.Data, + ) where + +import GitHub.Data +import GitHub.Internal.Prelude +import Prelude () + +-- | List repository events. +-- See +repositoryEventsR :: Name Owner -> Name Repo -> FetchCount -> Request 'RO (Vector Event) +repositoryEventsR user repo = + pagedQuery ["repos", toPathPart user, toPathPart repo, "events"] [] diff --git a/src/GitHub/Endpoints/Activity/Starring.hs b/src/GitHub/Endpoints/Activity/Starring.hs --- a/src/GitHub/Endpoints/Activity/Starring.hs +++ b/src/GitHub/Endpoints/Activity/Starring.hs @@ -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 -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 -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 +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 +myStarredAcceptStarR :: FetchCount -> Request 'RA (Vector RepoStarred) +myStarredAcceptStarR = HeaderQuery [("Accept", "application/vnd.github.v3.star+json")] . PagedQuery ["user", "starred"] [] diff --git a/src/GitHub/Endpoints/Activity/Watching.hs b/src/GitHub/Endpoints/Activity/Watching.hs --- a/src/GitHub/Endpoints/Activity/Watching.hs +++ b/src/GitHub/Endpoints/Activity/Watching.hs @@ -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 -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 -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"] [] diff --git a/src/GitHub/Endpoints/Gists.hs b/src/GitHub/Endpoints/Gists.hs --- a/src/GitHub/Endpoints/Gists.hs +++ b/src/GitHub/Endpoints/Gists.hs @@ -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 -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 -gistR :: Name Gist ->Request k Gist +gistR :: Name Gist -> Request k Gist gistR gid = - Query ["gists", toPathPart gid] [] + query ["gists", toPathPart gid] [] diff --git a/src/GitHub/Endpoints/Gists/Comments.hs b/src/GitHub/Endpoints/Gists/Comments.hs --- a/src/GitHub/Endpoints/Gists/Comments.hs +++ b/src/GitHub/Endpoints/Gists/Comments.hs @@ -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 -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 gistCommentR :: Id GistComment -> Request k GistComment gistCommentR cid = - Query ["gists", "comments", toPathPart cid] [] + query ["gists", "comments", toPathPart cid] [] diff --git a/src/GitHub/Endpoints/GitData/Blobs.hs b/src/GitHub/Endpoints/GitData/Blobs.hs --- a/src/GitHub/Endpoints/GitData/Blobs.hs +++ b/src/GitHub/Endpoints/GitData/Blobs.hs @@ -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 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] [] diff --git a/src/GitHub/Endpoints/GitData/Commits.hs b/src/GitHub/Endpoints/GitData/Commits.hs --- a/src/GitHub/Endpoints/GitData/Commits.hs +++ b/src/GitHub/Endpoints/GitData/Commits.hs @@ -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 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] [] diff --git a/src/GitHub/Endpoints/GitData/References.hs b/src/GitHub/Endpoints/GitData/References.hs --- a/src/GitHub/Endpoints/GitData/References.hs +++ b/src/GitHub/Endpoints/GitData/References.hs @@ -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 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 -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 -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 -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] [] diff --git a/src/GitHub/Endpoints/GitData/Trees.hs b/src/GitHub/Endpoints/GitData/Trees.hs --- a/src/GitHub/Endpoints/GitData/Trees.hs +++ b/src/GitHub/Endpoints/GitData/Trees.hs @@ -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 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 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")] diff --git a/src/GitHub/Endpoints/Issues.hs b/src/GitHub/Endpoints/Issues.hs --- a/src/GitHub/Endpoints/Issues.hs +++ b/src/GitHub/Endpoints/Issues.hs @@ -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 . 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 . +currentUserIssuesR :: IssueMod -> FetchCount -> Request 'RA (Vector Issue) +currentUserIssuesR opts = + pagedQuery ["user", "issues"] (issueModToQueryString opts) -import qualified Data.ByteString.Char8 as BS8 +-- | See . +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 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 -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 -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 -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 diff --git a/src/GitHub/Endpoints/Issues/Comments.hs b/src/GitHub/Endpoints/Issues/Comments.hs --- a/src/GitHub/Endpoints/Issues/Comments.hs +++ b/src/GitHub/Endpoints/Issues/Comments.hs @@ -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 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 -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 -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 -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] diff --git a/src/GitHub/Endpoints/Issues/Events.hs b/src/GitHub/Endpoints/Issues/Events.hs --- a/src/GitHub/Endpoints/Issues/Events.hs +++ b/src/GitHub/Endpoints/Issues/Events.hs @@ -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 -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 -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 -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] [] diff --git a/src/GitHub/Endpoints/Issues/Labels.hs b/src/GitHub/Endpoints/Issues/Labels.hs --- a/src/GitHub/Endpoints/Issues/Labels.hs +++ b/src/GitHub/Endpoints/Issues/Labels.hs @@ -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 -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 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 -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 -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 -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 -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 -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 -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"] [] diff --git a/src/GitHub/Endpoints/Issues/Milestones.hs b/src/GitHub/Endpoints/Issues/Milestones.hs --- a/src/GitHub/Endpoints/Issues/Milestones.hs +++ b/src/GitHub/Endpoints/Issues/Milestones.hs @@ -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 -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 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] [] diff --git a/src/GitHub/Endpoints/Organizations.hs b/src/GitHub/Endpoints/Organizations.hs --- a/src/GitHub/Endpoints/Organizations.hs +++ b/src/GitHub/Endpoints/Organizations.hs @@ -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 -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 publicOrganizationR :: Name Organization -> Request k Organization -publicOrganizationR reqOrganizationName = Query ["orgs", toPathPart reqOrganizationName] [] +publicOrganizationR reqOrganizationName = query ["orgs", toPathPart reqOrganizationName] [] diff --git a/src/GitHub/Endpoints/Organizations/Members.hs b/src/GitHub/Endpoints/Organizations/Members.hs --- a/src/GitHub/Endpoints/Organizations/Members.hs +++ b/src/GitHub/Endpoints/Organizations/Members.hs @@ -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 -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 -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" diff --git a/src/GitHub/Endpoints/Organizations/Teams.hs b/src/GitHub/Endpoints/Organizations/Teams.hs --- a/src/GitHub/Endpoints/Organizations/Teams.hs +++ b/src/GitHub/Endpoints/Organizations/Teams.hs @@ -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 -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 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 -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 -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 -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 -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 +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 +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 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 -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 -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 -listTeamsCurrentR :: Maybe Count -> Request 'True (Vector Team) -listTeamsCurrentR = PagedQuery ["user", "teams"] [] +listTeamsCurrentR :: FetchCount -> Request 'RA (Vector Team) +listTeamsCurrentR = + pagedQuery ["user", "teams"] [] diff --git a/src/GitHub/Endpoints/PullRequests.hs b/src/GitHub/Endpoints/PullRequests.hs --- a/src/GitHub/Endpoints/PullRequests.hs +++ b/src/GitHub/Endpoints/PullRequests.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause @@ -8,8 +6,6 @@ -- The pull requests API as documented at -- . 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 -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 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 -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 -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 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 [] diff --git a/src/GitHub/Endpoints/PullRequests/ReviewComments.hs b/src/GitHub/Endpoints/PullRequests/ReviewComments.hs --- a/src/GitHub/Endpoints/PullRequests/ReviewComments.hs +++ b/src/GitHub/Endpoints/PullRequests/ReviewComments.hs @@ -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 -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 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] [] diff --git a/src/GitHub/Endpoints/Repos.hs b/src/GitHub/Endpoints/Repos.hs --- a/src/GitHub/Endpoints/Repos.hs +++ b/src/GitHub/Endpoints/Repos.hs @@ -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 -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 -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 -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 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 -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 -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 -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 -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 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 -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 -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 diff --git a/src/GitHub/Endpoints/Repos/Collaborators.hs b/src/GitHub/Endpoints/Repos/Collaborators.hs --- a/src/GitHub/Endpoints/Repos/Collaborators.hs +++ b/src/GitHub/Endpoints/Repos/Collaborators.hs @@ -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 -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 -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] [] diff --git a/src/GitHub/Endpoints/Repos/Comments.hs b/src/GitHub/Endpoints/Repos/Comments.hs --- a/src/GitHub/Endpoints/Repos/Comments.hs +++ b/src/GitHub/Endpoints/Repos/Comments.hs @@ -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 -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 -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 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] [] diff --git a/src/GitHub/Endpoints/Repos/Commits.hs b/src/GitHub/Endpoints/Repos/Commits.hs --- a/src/GitHub/Endpoints/Repos/Commits.hs +++ b/src/GitHub/Endpoints/Repos/Commits.hs @@ -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 -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 -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 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 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] [] diff --git a/src/GitHub/Endpoints/Repos/DeployKeys.hs b/src/GitHub/Endpoints/Repos/DeployKeys.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Endpoints/Repos/DeployKeys.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Todd Mohney +-- +-- The deploy keys API, as described at +-- +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 +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 +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 . +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 +deleteRepoDeployKeyR :: Name Owner -> Name Repo -> Id RepoDeployKey -> Request 'RW () +deleteRepoDeployKeyR user repo keyId = + command Delete ["repos", toPathPart user, toPathPart repo, "keys", toPathPart keyId] mempty diff --git a/src/GitHub/Endpoints/Repos/Forks.hs b/src/GitHub/Endpoints/Repos/Forks.hs --- a/src/GitHub/Endpoints/Repos/Forks.hs +++ b/src/GitHub/Endpoints/Repos/Forks.hs @@ -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 -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"] [] diff --git a/src/GitHub/Endpoints/Repos/Webhooks.hs b/src/GitHub/Endpoints/Repos/Webhooks.hs --- a/src/GitHub/Endpoints/Repos/Webhooks.hs +++ b/src/GitHub/Endpoints/Repos/Webhooks.hs @@ -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 -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 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 -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 -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 -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 -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 -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] diff --git a/src/GitHub/Endpoints/Search.hs b/src/GitHub/Endpoints/Search.hs --- a/src/GitHub/Endpoints/Search.hs +++ b/src/GitHub/Endpoints/Search.hs @@ -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 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 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 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)] diff --git a/src/GitHub/Endpoints/Users.hs b/src/GitHub/Endpoints/Users.hs --- a/src/GitHub/Endpoints/Users.hs +++ b/src/GitHub/Endpoints/Users.hs @@ -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 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 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 -userInfoCurrentR :: Request 'True User -userInfoCurrentR = Query ["user"] [] +userInfoCurrentR :: Request 'RA User +userInfoCurrentR = query ["user"] [] diff --git a/src/GitHub/Endpoints/Users/Followers.hs b/src/GitHub/Endpoints/Users/Followers.hs --- a/src/GitHub/Endpoints/Users/Followers.hs +++ b/src/GitHub/Endpoints/Users/Followers.hs @@ -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 -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 -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"] [] diff --git a/src/GitHub/Internal/Prelude.hs b/src/GitHub/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Internal/Prelude.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- 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 diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -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