diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,24 @@ +## Changes for 0.25 + +- Add `executeRequestWithMgrAndRes` + [#421](https://github.com/phadej/github/pull/421) +- Add `limitsFromHttpResponse` + [#421](https://github.com/phadej/github/pull/421) +- Add label descriptions + [#418](https://github.com/phadej/github/pull/418) +- Add "draft" option to mergeable state + [#431](https://github.com/phadej/github/pull/431) +- Use IssueNumber in editIssueR and issueR + [#429](https://github.com/phadej/github/pull/429) +- Manage orgs in GitHub Enterprise + [#420](https://github.com/phadej/github/pull/420) +- Add support for collaborator permission endpoint + [#425](https://github.com/phadej/github/pull/425) +- Add support for the comment reply endpoint + [#424](https://github.com/phadej/github/pull/424) +- Organise exports in `GitHub` + [#430](https://github.com/phadej/github/pull/430) + ## Changes for 0.24 **Major change**: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,8 +3,6 @@ [![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)][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) The Github API v3 for Haskell. @@ -34,6 +32,8 @@ See the samples in the [samples/](https://github.com/fpco/github/tree/master/samples) directory. +Note: some samples might be outdated. + Documentation ============= @@ -68,7 +68,7 @@ main :: IO () main = do - possibleUsers <- github GitHub.usersFollowingR "phadej" + possibleUsers <- github' GitHub.usersFollowingR "phadej" T.putStrLn $ either (("Error: " <>) . pack . show) (foldMap ((<> "\n") . formatUser)) possibleUsers diff --git a/github.cabal b/github.cabal --- a/github.cabal +++ b/github.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: github -version: 0.24 +version: 0.25 synopsis: Access to the GitHub API, v3. category: Network description: @@ -90,6 +90,8 @@ GitHub.Data.DeployKeys GitHub.Data.Deployments GitHub.Data.Email + GitHub.Data.Enterprise + GitHub.Data.Enterprise.Organizations GitHub.Data.Events GitHub.Data.Gists GitHub.Data.GitData @@ -116,6 +118,7 @@ GitHub.Endpoints.Activity.Notifications GitHub.Endpoints.Activity.Starring GitHub.Endpoints.Activity.Watching + GitHub.Endpoints.Enterprise.Organizations GitHub.Endpoints.Gists GitHub.Endpoints.Gists.Comments GitHub.Endpoints.GitData.Blobs @@ -151,6 +154,7 @@ GitHub.Endpoints.Users.Emails GitHub.Endpoints.Users.Followers GitHub.Endpoints.Users.PublicSSHKeys + GitHub.Enterprise GitHub.Internal.Prelude GitHub.Request @@ -165,7 +169,7 @@ , deepseq >=1.3.0.2 && <1.5 , mtl >=2.1.3.1 && <2.2 || >=2.2.1 && <2.3 , text >=1.2.0.6 && <1.3 - , time >=1.4 && <1.10 + , time-compat >=1.9.2.2 && <1.10 , transformers >=0.3.0.0 && <0.6 -- other packages diff --git a/spec/GitHub/IssuesSpec.hs b/spec/GitHub/IssuesSpec.hs --- a/spec/GitHub/IssuesSpec.hs +++ b/spec/GitHub/IssuesSpec.hs @@ -38,6 +38,11 @@ cms <- GitHub.executeRequest auth $ GitHub.commentsR owner repo (GitHub.issueNumber i) 1 cms `shouldSatisfy` isRight + describe "issueR" $ do + it "fetches issue #428" $ withAuth $ \auth -> do + resIss <- GitHub.executeRequest auth $ + GitHub.issueR "phadej" "github" (GitHub.IssueNumber 428) + resIss `shouldSatisfy` isRight where repos = [ ("thoughtbot", "paperclip") diff --git a/src/GitHub.hs b/src/GitHub.hs --- a/src/GitHub.hs +++ b/src/GitHub.hs @@ -3,7 +3,7 @@ -- License : BSD-3-Clause -- Maintainer : Oleg Grenrus -- --- This module re-exports all request constructrors and data definitions from +-- This module re-exports all request constructors and data definitions from -- this package. -- -- See "GitHub.Request" module for executing 'Request', in short @@ -223,6 +223,7 @@ pullRequestCommentsR, pullRequestCommentR, createPullCommentR, + createPullCommentReplyR, -- ** Pull request reviews -- | See @@ -258,6 +259,7 @@ -- ** Collaborators -- | See collaboratorsOnR, + collaboratorPermissionOnR, isCollaboratorOnR, addCollaboratorR, @@ -280,6 +282,15 @@ commitR, diffR, + -- ** Contents + -- | See + contentsForR, + readmeForR, + archiveForR, + createFileR, + updateFileR, + deleteFileR, + -- ** Deploy Keys -- | See deployKeysForR, @@ -307,6 +318,12 @@ -- * Create a fork forksForR, + -- ** Statuses + -- | See + createStatusR, + statusesForR, + statusForR, + -- ** Webhooks -- | See webhooksForR, @@ -380,11 +397,13 @@ usersFollowingR, usersFollowedByR, - -- ** Statuses - -- | See - createStatusR, - statusesForR, - statusForR, + -- ** Git SSH Keys + -- | See + publicSSHKeysR, + publicSSHKeysForR, + publicSSHKeyR, + createUserPublicSSHKeyR, + deleteUserPublicSSHKeyR, -- ** Rate Limit -- | See @@ -423,6 +442,7 @@ import GitHub.Endpoints.Repos.Collaborators import GitHub.Endpoints.Repos.Comments import GitHub.Endpoints.Repos.Commits +import GitHub.Endpoints.Repos.Contents import GitHub.Endpoints.Repos.DeployKeys import GitHub.Endpoints.Repos.Deployments import GitHub.Endpoints.Repos.Forks @@ -434,4 +454,5 @@ import GitHub.Endpoints.Users import GitHub.Endpoints.Users.Emails import GitHub.Endpoints.Users.Followers +import GitHub.Endpoints.Users.PublicSSHKeys import GitHub.Request diff --git a/src/GitHub/Auth.hs b/src/GitHub/Auth.hs --- a/src/GitHub/Auth.hs +++ b/src/GitHub/Auth.hs @@ -30,11 +30,17 @@ instance Hashable Auth -- | A type class for different authentication methods +-- +-- Note the '()' intance, which doee nothing, i.e. is unauthenticated. class AuthMethod a where -- | Custom API endpoint without trailing slash endpoint :: a -> Maybe Text -- | A function which sets authorisation on an HTTP request setAuthRequest :: a -> HTTP.Request -> HTTP.Request + +instance AuthMethod () where + endpoint _ = Nothing + setAuthRequest _ = id instance AuthMethod Auth where endpoint (BasicAuth _ _) = Nothing diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs --- a/src/GitHub/Data.hs +++ b/src/GitHub/Data.hs @@ -59,7 +59,8 @@ module GitHub.Data.Statuses, module GitHub.Data.Teams, module GitHub.Data.URL, - module GitHub.Data.Webhooks + module GitHub.Data.Webhooks, + module GitHub.Data.Webhooks.Validate, ) where import GitHub.Internal.Prelude @@ -94,6 +95,7 @@ import GitHub.Data.Teams import GitHub.Data.URL import GitHub.Data.Webhooks +import GitHub.Data.Webhooks.Validate mkOwnerId :: Int -> Id Owner mkOwnerId = Id 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 @@ -83,3 +83,15 @@ , "path" .= path , "position" .= pos ] + +data PullCommentReply = PullCommentReply + { pullCommentReplyBody :: Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData PullCommentReply where rnf = genericRnf + +instance ToJSON PullCommentReply where + toJSON (PullCommentReply b) = + object [ "body" .= b + ] 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 @@ -268,6 +268,7 @@ { labelColor :: !Text , labelUrl :: !URL , labelName :: !(Name IssueLabel) + , labelDesc :: !(Maybe Text) } deriving (Show, Data, Typeable, Eq, Ord, Generic) @@ -279,3 +280,57 @@ <$> o .: "color" <*> o .:? "url" .!= URL "" -- in events there aren't URL <*> o .: "name" + <*> o .:? "description" + + +------------------------------------------------------------------------------- +-- NewIssueLabel +------------------------------------------------------------------------------- + +data NewIssueLabel = NewIssueLabel + { newLabelColor :: !Text + , newLabelName :: !(Name NewIssueLabel) + , newLabelDesc :: !(Maybe Text) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData NewIssueLabel where rnf = genericRnf +instance Binary NewIssueLabel + + +instance ToJSON NewIssueLabel where + toJSON (NewIssueLabel color lblName lblDesc) = object $ filter notNull + [ "name" .= lblName + , "color" .= color + , "description" .= lblDesc + ] + where + notNull (_, Null) = False + notNull (_, _) = True + + + +------------------------------------------------------------------------------- +-- UpdateIssueLabel +------------------------------------------------------------------------------- + +data UpdateIssueLabel = UpdateIssueLabel + { updateLabelColor :: !Text + , updateLabelName :: !(Name UpdateIssueLabel) + , updateLabelDesc :: !(Maybe Text) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData UpdateIssueLabel where rnf = genericRnf +instance Binary UpdateIssueLabel + + +instance ToJSON UpdateIssueLabel where + toJSON (UpdateIssueLabel color lblName lblDesc) = object $ filter notNull + [ "new_name" .= lblName + , "color" .= color + , "description" .= lblDesc + ] + where + notNull (_, Null) = False + notNull (_, _) = True diff --git a/src/GitHub/Data/Deployments.hs b/src/GitHub/Data/Deployments.hs --- a/src/GitHub/Data/Deployments.hs +++ b/src/GitHub/Data/Deployments.hs @@ -21,7 +21,6 @@ import Data.ByteString (ByteString) import Data.Maybe (catMaybes) import Data.Text (Text) -import Data.Time.Clock (UTCTime) import Data.Vector (Vector) import GitHub.Data.Definitions (SimpleUser) diff --git a/src/GitHub/Data/Enterprise.hs b/src/GitHub/Data/Enterprise.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Enterprise.hs @@ -0,0 +1,12 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- This module re-exports the @GitHub.Data.Enterprise.@ submodules. +module GitHub.Data.Enterprise ( + -- * Module re-exports + module GitHub.Data.Enterprise.Organizations, + ) where + +import GitHub.Data.Enterprise.Organizations diff --git a/src/GitHub/Data/Enterprise/Organizations.hs b/src/GitHub/Data/Enterprise/Organizations.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Enterprise/Organizations.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Enterprise.Organizations where + +import GitHub.Data.Definitions +import GitHub.Data.Name (Name) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data CreateOrganization = CreateOrganization + { createOrganizationLogin :: !(Name Organization) + , createOrganizationAdmin :: !(Name User) + , createOrganizationProfileName :: !(Maybe Text) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData CreateOrganization where rnf = genericRnf +instance Binary CreateOrganization + +data RenameOrganization = RenameOrganization + { renameOrganizationLogin :: !(Name Organization) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData RenameOrganization where rnf = genericRnf +instance Binary RenameOrganization + +data RenameOrganizationResponse = RenameOrganizationResponse + { renameOrganizationResponseMessage :: !Text + , renameOrganizationResponseUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData RenameOrganizationResponse where rnf = genericRnf +instance Binary RenameOrganizationResponse + +-- JSON Instances + +instance ToJSON CreateOrganization where + toJSON (CreateOrganization login admin profileName) = + object $ filter notNull + [ "login" .= login + , "admin" .= admin + , "profile_name" .= profileName + ] + where + notNull (_, Null) = False + notNull (_, _) = True + +instance ToJSON RenameOrganization where + toJSON (RenameOrganization login) = + object + [ "login" .= login + ] + +instance FromJSON RenameOrganizationResponse where + parseJSON = withObject "RenameOrganizationResponse" $ \o -> + RenameOrganizationResponse + <$> o .: "message" + <*> o .: "url" diff --git a/src/GitHub/Data/Options.hs b/src/GitHub/Data/Options.hs --- a/src/GitHub/Data/Options.hs +++ b/src/GitHub/Data/Options.hs @@ -98,6 +98,7 @@ | StateUnstable | StateBlocked | StateBehind + | StateDraft deriving (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) @@ -108,6 +109,7 @@ toJSON StateUnstable = String "unstable" toJSON StateBlocked = String "blocked" toJSON StateBehind = String "behind" + toJSON StateDraft = String "draft" instance FromJSON MergeableState where parseJSON = withText "MergeableState" $ \t -> case T.toLower t of @@ -117,6 +119,7 @@ "unstable" -> pure StateUnstable "blocked" -> pure StateBlocked "behind" -> pure StateBehind + "draft" -> pure StateDraft _ -> fail $ "Unknown MergeableState: " <> T.unpack t instance NFData MergeableState where rnf = genericRnf diff --git a/src/GitHub/Data/RateLimit.hs b/src/GitHub/Data/RateLimit.hs --- a/src/GitHub/Data/RateLimit.hs +++ b/src/GitHub/Data/RateLimit.hs @@ -8,12 +8,17 @@ import GitHub.Internal.Prelude import Prelude () +import Data.Time.Clock.System.Compat (SystemTime (..)) + +import qualified Data.ByteString.Char8 as BS8 +import qualified Network.HTTP.Client as HTTP + data Limits = Limits { limitsMax :: !Int , limitsRemaining :: !Int - , limitsReset :: !Int -- TODO: change to proper type + , limitsReset :: !SystemTime } - deriving (Show, Data, Typeable, Eq, Ord, Generic) + deriving (Show, {- Data, -} Typeable, Eq, Ord, Generic) instance NFData Limits where rnf = genericRnf instance Binary Limits @@ -22,14 +27,14 @@ parseJSON = withObject "Limits" $ \obj -> Limits <$> obj .: "limit" <*> obj .: "remaining" - <*> obj .: "reset" + <*> fmap (\t -> MkSystemTime t 0) (obj .: "reset") data RateLimit = RateLimit { rateLimitCore :: Limits , rateLimitSearch :: Limits , rateLimitGraphQL :: Limits } - deriving (Show, Data, Typeable, Eq, Ord, Generic) + deriving (Show, {- Data, -} Typeable, Eq, Ord, Generic) instance NFData RateLimit where rnf = genericRnf instance Binary RateLimit @@ -41,3 +46,21 @@ <$> resources .: "core" <*> resources .: "search" <*> resources .: "graphql" + +------------------------------------------------------------------------------- +-- Extras +------------------------------------------------------------------------------- + +-- | @since 0.24 +limitsFromHttpResponse :: HTTP.Response a -> Maybe Limits +limitsFromHttpResponse res = do + let hdrs = HTTP.responseHeaders res + m <- lookup "X-RateLimit-Limit" hdrs >>= readIntegral + r <- lookup "X-RateLimit-Remaining" hdrs >>= readIntegral + t <- lookup "X-RateLimit-Reset" hdrs >>= readIntegral + return (Limits m r (MkSystemTime t 0)) + where + readIntegral :: Num a => BS8.ByteString -> Maybe a + readIntegral bs = case BS8.readInt bs of + Just (n, bs') | BS8.null bs' -> Just (fromIntegral n) + _ -> Nothing 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 @@ -20,6 +20,7 @@ import Prelude () import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T #if MIN_VERSION_aeson(1,0,0) import Data.Aeson.Types (FromJSONKey (..), fromJSONKeyCoerce) #else @@ -158,6 +159,27 @@ contributorToSimpleUser (KnownContributor _contributions avatarUrl name url uid _gravatarid) = Just $ SimpleUser uid name avatarUrl url +-- | The permission of a collaborator on a repository. +-- See +data CollaboratorPermission + = CollaboratorPermissionAdmin + | CollaboratorPermissionWrite + | CollaboratorPermissionRead + | CollaboratorPermissionNone + deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) + +instance NFData CollaboratorPermission where rnf = genericRnf +instance Binary CollaboratorPermission + +-- | A collaborator and its permission on a repository. +-- See +data CollaboratorWithPermission + = CollaboratorWithPermission SimpleUser CollaboratorPermission + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData CollaboratorWithPermission where rnf = genericRnf +instance Binary CollaboratorWithPermission + -- JSON instances instance FromJSON Repo where @@ -303,3 +325,22 @@ toPathPart af = case af of ArchiveFormatTarball -> "tarball" ArchiveFormatZipball -> "zipball" + +instance FromJSON CollaboratorPermission where + parseJSON = withText "CollaboratorPermission" $ \t -> case T.toLower t of + "admin" -> pure CollaboratorPermissionAdmin + "write" -> pure CollaboratorPermissionWrite + "read" -> pure CollaboratorPermissionRead + "none" -> pure CollaboratorPermissionNone + _ -> fail $ "Unknown CollaboratorPermission: " <> T.unpack t + +instance ToJSON CollaboratorPermission where + toJSON CollaboratorPermissionAdmin = "admin" + toJSON CollaboratorPermissionWrite = "write" + toJSON CollaboratorPermissionRead = "read" + toJSON CollaboratorPermissionNone = "none" + +instance FromJSON CollaboratorWithPermission where + parseJSON = withObject "CollaboratorWithPermission" $ \o -> CollaboratorWithPermission + <$> o .: "user" + <*> o .: "permission" diff --git a/src/GitHub/Endpoints/Enterprise/Organizations.hs b/src/GitHub/Endpoints/Enterprise/Organizations.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Endpoints/Enterprise/Organizations.hs @@ -0,0 +1,28 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- The GitHub Enterprise orgs API as described on . +module GitHub.Endpoints.Enterprise.Organizations ( + createOrganizationR, + renameOrganizationR, + module GitHub.Data, + ) where + +import GitHub.Data +import GitHub.Data.Enterprise +import GitHub.Internal.Prelude +import Prelude () + +-- | Create an organization. +-- See +createOrganizationR :: CreateOrganization -> Request 'RW SimpleOrganization +createOrganizationR = + command Post ["admin", "organizations"] . encode + +-- | Rename an organization. +-- See +renameOrganizationR :: Name Organization -> RenameOrganization -> Request 'RW RenameOrganizationResponse +renameOrganizationR org = + command Patch ["admin", "organizations", toPathPart org] . encode 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 @@ -33,7 +33,7 @@ -- | Query a single issue. -- See -issueR :: Name Owner -> Name Repo -> Id Issue -> Request k Issue +issueR :: Name Owner -> Name Repo -> IssueNumber -> Request k Issue issueR user reqRepoName reqIssueNumber = query ["repos", toPathPart user, toPathPart reqRepoName, "issues", toPathPart reqIssueNumber] [] @@ -63,6 +63,6 @@ -- | Edit an issue. -- See -editIssueR :: Name Owner -> Name Repo -> Id Issue -> EditIssue -> Request 'RW Issue +editIssueR :: Name Owner -> Name Repo -> IssueNumber -> EditIssue -> Request 'RW Issue editIssueR user repo iss = command Patch ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iss] . encode 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 @@ -38,26 +38,19 @@ -- | Create a label. -- See -createLabelR :: Name Owner -> Name Repo -> Name IssueLabel -> String -> Request 'RW IssueLabel -createLabelR user repo lbl color = - command Post paths $ encode body - where - paths = ["repos", toPathPart user, toPathPart repo, "labels"] - body = object ["name" .= untagName lbl, "color" .= color] +createLabelR :: Name Owner -> Name Repo -> NewIssueLabel -> Request 'RW IssueLabel +createLabelR user repo = + command Post ["repos", toPathPart user, toPathPart repo, "labels"] . encode -- | Update a label. -- See updateLabelR :: Name Owner -> Name Repo -> Name IssueLabel -- ^ old label name - -> Name IssueLabel -- ^ new label name - -> String -- ^ new color + -> UpdateIssueLabel -- ^ new label -> Request 'RW IssueLabel -updateLabelR user repo oldLbl newLbl color = - command Patch paths (encode body) - where - paths = ["repos", toPathPart user, toPathPart repo, "labels", toPathPart oldLbl] - body = object ["name" .= untagName newLbl, "color" .= color] +updateLabelR user repo oldLbl = + command Patch ["repos", toPathPart user, toPathPart repo, "labels", toPathPart oldLbl] . encode -- | Delete a label. -- See diff --git a/src/GitHub/Endpoints/PullRequests/Comments.hs b/src/GitHub/Endpoints/PullRequests/Comments.hs --- a/src/GitHub/Endpoints/PullRequests/Comments.hs +++ b/src/GitHub/Endpoints/PullRequests/Comments.hs @@ -9,6 +9,7 @@ pullRequestCommentsR, pullRequestCommentR, createPullCommentR, + createPullCommentReplyR, module GitHub.Data, ) where @@ -36,3 +37,13 @@ command Post parts (encode $ NewPullComment commit path position body) where parts = ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart iss, "comments"] + +-- | Create a comment reply. +-- +-- See +createPullCommentReplyR :: Name Owner -> Name Repo -> IssueNumber -> Id Comment -> Text -> Request 'RW Comment +createPullCommentReplyR user repo iss cid body = + command Post parts (encode $ PullCommentReply body) + where + parts = ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart iss + , "comments", toPathPart cid, "replies"] 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 @@ -7,6 +7,7 @@ -- . module GitHub.Endpoints.Repos.Collaborators ( collaboratorsOnR, + collaboratorPermissionOnR, isCollaboratorOnR, addCollaboratorR, module GitHub.Data, @@ -21,6 +22,16 @@ collaboratorsOnR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector SimpleUser) collaboratorsOnR user repo = pagedQuery ["repos", toPathPart user, toPathPart repo, "collaborators"] [] + +-- | Review a user's permission level. +-- +collaboratorPermissionOnR + :: Name Owner -- ^ Repository owner + -> Name Repo -- ^ Repository name + -> Name User -- ^ Collaborator to check permissions of. + -> GenRequest 'MtJSON rw CollaboratorWithPermission +collaboratorPermissionOnR owner repo coll = + query ["repos", toPathPart owner, toPathPart repo, "collaborators", toPathPart coll, "permission"] [] -- | Check if a user is a collaborator. -- See diff --git a/src/GitHub/Enterprise.hs b/src/GitHub/Enterprise.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Enterprise.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- This module re-exports all request constructors and data definitions for +-- working with GitHub Enterprise. +-- +module GitHub.Enterprise ( + -- * Enterprise Admin + -- | See + + -- ** Organizations + -- | See + createOrganizationR, + renameOrganizationR, + + -- * Data definitions + module GitHub.Data.Enterprise, + ) where + +import GitHub.Data.Enterprise +import GitHub.Endpoints.Enterprise.Organizations diff --git a/src/GitHub/Internal/Prelude.hs b/src/GitHub/Internal/Prelude.hs --- a/src/GitHub/Internal/Prelude.hs +++ b/src/GitHub/Internal/Prelude.hs @@ -53,7 +53,7 @@ import Data.Semigroup (Semigroup (..)) import Data.String (IsString (..)) import Data.Text (Text, pack, unpack) -import Data.Time (UTCTime) +import Data.Time.Compat (UTCTime) import Data.Time.ISO8601 (formatISO8601) import Data.Vector (Vector) import Data.Vector.Instances () diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -46,6 +46,7 @@ -- * Request execution in IO executeRequest, executeRequestWithMgr, + executeRequestWithMgrAndRes, executeRequest', executeRequestWithMgr', executeRequestMaybe, @@ -62,6 +63,11 @@ -- ** Preview PreviewAccept (..), PreviewParseResponse (..), + -- * SSL + -- | This always exist, independently of @openssl@ configuration flag. + -- They change accordingly, to make use of the library simpler. + withOpenSSL, + tlsManagerSettings, ) where import GitHub.Internal.Prelude @@ -107,7 +113,7 @@ import qualified OpenSSL.X509.SystemStore as SSL #endif -import GitHub.Auth (Auth, AuthMethod, endpoint, setAuthRequest) +import GitHub.Auth (AuthMethod, endpoint, setAuthRequest) import GitHub.Data (Error (..)) import GitHub.Data.PullRequests (MergeResult (..)) import GitHub.Data.Request @@ -201,6 +207,7 @@ lessFetchCount _ FetchAll = True lessFetchCount i (FetchAtLeast j) = i < fromIntegral j + -- | Like 'executeRequest' but with provided 'Manager'. executeRequestWithMgr :: (AuthMethod am, ParseResponse mt a) @@ -208,26 +215,38 @@ -> am -> GenRequest mt rw a -> IO (Either Error a) -executeRequestWithMgr mgr auth req = runExceptT $ do +executeRequestWithMgr mgr auth req = + fmap (fmap responseBody) (executeRequestWithMgrAndRes mgr auth req) + +-- | Execute request and return the last received 'HTTP.Response'. +-- +-- @since 0.24 +executeRequestWithMgrAndRes + :: (AuthMethod am, ParseResponse mt a) + => Manager + -> am + -> GenRequest mt rw a + -> IO (Either Error (HTTP.Response a)) +executeRequestWithMgrAndRes mgr auth req = runExceptT $ do httpReq <- makeHttpRequest (Just auth) req performHttpReq httpReq req where - httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString) + httpLbs' :: HTTP.Request -> ExceptT Error IO (HTTP.Response LBS.ByteString) httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException - performHttpReq :: forall rw mt b. ParseResponse mt b => HTTP.Request -> GenRequest mt rw b -> ExceptT Error IO b + performHttpReq :: forall rw mt b. ParseResponse mt b => HTTP.Request -> GenRequest mt rw b -> ExceptT Error IO (HTTP.Response b) performHttpReq httpReq Query {} = do res <- httpLbs' httpReq - unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) + (<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) performHttpReq httpReq (PagedQuery _ _ l) = - unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO b)) + unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b))) where predicate v = lessFetchCount (V.length v) l performHttpReq httpReq (Command _ _ _) = do res <- httpLbs' httpReq - unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) + (<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) -- | Like 'executeRequest' but without authentication. executeRequest' :: ParseResponse mt a => GenRequest mt 'RO a -> IO (Either Error a) @@ -241,21 +260,7 @@ => Manager -> GenRequest mt 'RO a -> IO (Either Error a) -executeRequestWithMgr' mgr req = runExceptT $ do - httpReq <- makeHttpRequest (Nothing :: Maybe Auth) req - performHttpReq httpReq req - where - httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString) - httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException - - performHttpReq :: forall mt b. ParseResponse mt b => HTTP.Request -> GenRequest mt 'RO b -> ExceptT Error IO b - performHttpReq httpReq Query {} = do - res <- httpLbs' httpReq - unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) - performHttpReq httpReq (PagedQuery _ _ l) = - unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO b)) - where - predicate v = lessFetchCount (V.length v) l +executeRequestWithMgr' mgr = executeRequestWithMgr mgr () -- | Helper for picking between 'executeRequest' and 'executeRequest''. -- @@ -297,9 +302,9 @@ -- | Parse API response. -- -- @ --- parseResponse :: 'FromJSON' a => 'Response' 'LBS.ByteString' -> 'Either' 'Error' a +-- parseResponse :: 'FromJSON' a => 'HTTP.Response' 'LBS.ByteString' -> 'Either' 'Error' a -- @ -parseResponseJSON :: (FromJSON a, MonadError Error m) => Response LBS.ByteString -> m a +parseResponseJSON :: (FromJSON a, MonadError Error m) => HTTP.Response LBS.ByteString -> m a parseResponseJSON res = case eitherDecode (responseBody res) of Right x -> return x Left err -> throwError . ParseError . T.pack $ err @@ -344,9 +349,9 @@ -- | Helper for handling of 'RequestRedirect'. -- -- @ --- parseRedirect :: 'Response' 'LBS.ByteString' -> 'Either' 'Error' a +-- parseRedirect :: 'HTTP.Response' 'LBS.ByteString' -> 'Either' 'Error' a -- @ -parseRedirect :: MonadError Error m => URI -> Response LBS.ByteString -> m URI +parseRedirect :: MonadError Error m => URI -> HTTP.Response LBS.ByteString -> m URI parseRedirect originalUri rsp = do let status = responseStatus rsp when (statusCode status /= 302) $ @@ -496,7 +501,7 @@ setBody body req = req { requestBody = RequestBodyLBS body } -- | Query @Link@ header with @rel=next@ from the request headers. -getNextUrl :: Response a -> Maybe URI +getNextUrl :: HTTP.Response a -> Maybe URI getNextUrl req = do linkHeader <- lookup "Link" (responseHeaders req) links <- parseLinkHeaderBS linkHeader @@ -511,25 +516,27 @@ -- | Helper for making paginated requests. Responses, @a@ are combined monoidally. -- +-- The result is wrapped in the last received 'HTTP.Response'. +-- -- @ -- performPagedRequest :: ('FromJSON' a, 'Semigroup' a) --- => ('HTTP.Request' -> 'ExceptT' 'Error' 'IO' ('Response' 'LBS.ByteString')) +-- => ('HTTP.Request' -> 'ExceptT' 'Error' 'IO' ('HTTP.Response' 'LBS.ByteString')) -- -> (a -> 'Bool') -- -> 'HTTP.Request' --- -> 'ExceptT' 'Error' 'IO' a +-- -> 'ExceptT' 'Error' 'IO' ('HTTP.Response' a) -- @ performPagedRequest :: forall a m mt. (ParseResponse mt 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 - -> Tagged mt (m a) + => (HTTP.Request -> m (HTTP.Response LBS.ByteString)) -- ^ `httpLbs` analogue + -> (a -> Bool) -- ^ predicate to continue iteration + -> HTTP.Request -- ^ initial request + -> Tagged mt (m (HTTP.Response a)) performPagedRequest httpLbs' predicate initReq = Tagged $ do res <- httpLbs' initReq m <- unTagged (parseResponse initReq res :: Tagged mt (m a)) go m res initReq where - go :: a -> Response LBS.ByteString -> HTTP.Request -> m a + go :: a -> HTTP.Response LBS.ByteString -> HTTP.Request -> m (HTTP.Response a) go acc res req = case (predicate acc, getNextUrl res) of (True, Just uri) -> do @@ -537,7 +544,7 @@ res' <- httpLbs' req' m <- unTagged (parseResponse req' res' :: Tagged mt (m a)) go (acc <> m) res' req' - (_, _) -> return acc + (_, _) -> return (acc <$ res) ------------------------------------------------------------------------------- -- Internal