diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # A Haskell library for the GitLab web API -This library interacts with a GitLab server's API. It supports queries -about and updates to: +This library lifts the GitLab REST API into Haskell. It supports +queries about and updates to: * Branches * Commits @@ -29,7 +29,6 @@ searchUser :: Text -> GitLab (Maybe User) userProjects :: User -> GitLab (Maybe [Project]) - projectCommits :: Project -> GitLab [Commit] ## Example @@ -40,7 +39,8 @@ -> GitLab a -> IO a -For example: +For example the following project finds all GitLab projects for the +user "joe". myProjects <- runGitLab @@ -66,5 +66,5 @@ For the complete `gitlab-haskell` API, see the [hackage documentation](https://hackage.haskell.org/package/gitlab-haskell). -The `gitlab-tools` command line tool for bulk GitLab transactions uses -this library [link](https://gitlab.com/robstewart57/gitlab-tools). +An example of an application using this library is `gitlab-tools`, +which is a command line tool for bulk GitLab transactions [link](https://gitlab.com/robstewart57/gitlab-tools). diff --git a/data/system-hooks/merge-request-old.json b/data/system-hooks/merge-request-old.json deleted file mode 100644 --- a/data/system-hooks/merge-request-old.json +++ /dev/null @@ -1,125 +0,0 @@ -{"object_kind":"merge_request", - "event_type":"merge_request", - "user": - {"name":"Rob", "username":"abc123", - "avatar_url":"", - "email":"" - }, - "project": {"id":8879, - "name":"", - "description":"", - "web_url":"", - "avatar_url":null,"git_ssh_url":"", - "git_http_url":"", - "namespace":"", - "visibility_level":0,"path_with_namespace":"", - "default_branch":"master", "ci_config_path":null, - "homepage":"", - "url":"", - "ssh_url":"", - "http_url":"" - }, - "object_attributes":{"assignee_id":null, - "author_id":5, - "created_at":"2020-12-21 22:56:31 UTC", - "description":"", - "head_pipeline_id":null, - "id":1567, - "iid":7, - "last_edited_at":null, - "last_edited_by_id":null, - "merge_commit_sha":null, - "merge_error":null, - "merge_params":{}, - "merge_status":"unchecked", - "merge_user_id":null, - "merge_when_pipeline_succeeds":false, - "milestone_id":null, - "source_branch":"master", - "source_project_id":8987, - "state_id":1, - "target_branch":"master", - "target_project_id":8879, - "time_estimate":0, - "title":"Master", - "updated_at":"2020-12-21 22:56:31 UTC", - "updated_by_id":null, - "url":"", - "source":{"id":8987, "name":"", - "description":"", - "web_url":"", - "avatar_url":null, - "git_ssh_url":"", - "git_http_url":"", - "namespace":"Rob", "visibility_level":0, - "path_with_namespace":"", - "default_branch":"master", "ci_config_path":null, - "homepage":"", - "url":"", - "ssh_url":"", - "http_url":"" - }, - "target":{"id":8879, "name":"", - "description":"", - "web_url":"", - "avatar_url":null, - "git_ssh_url":"", - "git_http_url":"", - "namespace":"", "visibility_level":0, - "path_with_namespace":"", - "default_branch":"master", "ci_config_path":null, - "homepage":"", - "url":"", - "ssh_url":"", - "http_url":"" - }, - "last_commit":{"id":"", - "message":"", - "title":"", - "timestamp":"2020-09-28T16:13:42+01:00", - "url":"", - "author":{ - "name":"Rob", - "email":"" - } - }, - "work_in_progress":false, - "total_time_spent":0, - "human_total_time_spent":null, - "human_time_estimate":null, - "assignee_ids":[], - "state":"opened", - "action":"open" - }, - "labels":[], - "changes":{"author_id": - {"previous":null, - "current":5 - }, - "created_at": - {"previous":null, - "current":"2020-12-21 22:56:31 UTC" - }, - "description": - {"previous":null, - "current":"" - }, - "id": - {"previous":null, - "current":1567 - }, - "iid":{"previous":null, "current":7}, - "source_branch":{"previous":null, "current":"master"}, - "source_project_id":{"previous":null, "current":8987}, - "target_branch":{"previous":null, "current":"master"}, - "target_project_id":{"previous":null, "current":8879}, - "title":{"previous":null, "current":"Master"}, - "updated_at":{"previous":null, "current":"2020-12-21 22:56:31 UTC"} - }, - "repository": { "name":"", - "url":"", - "description":"", - "homepage":"" - } - -} diff --git a/gitlab-haskell.cabal b/gitlab-haskell.cabal --- a/gitlab-haskell.cabal +++ b/gitlab-haskell.cabal @@ -1,12 +1,12 @@ cabal-version: 2.4 name: gitlab-haskell category: Git -version: 0.3.2.0 +version: 1.0.0.0 synopsis: A Haskell library for the GitLab web API description: - This Haskell library queries and updates the database of a GitLab instance using the GitLab web API: + This library lifts the GitLab REST API into Haskell: . - It also features an API for writing Gitlab file hook applications + It also features an event driven reactive API for writing Gitlab file hook applications . Run all GitLab actions with `runGitLab`: . @@ -27,9 +27,8 @@ . > searchUser :: Text -> GitLab (Maybe User) > userProjects :: User -> GitLab (Maybe [Project]) - > projectCommits :: Project -> GitLab [Commit] . - This library can also be used to develop rule based GitLab file hooks that react in real time to GitLab events with: + This is the API to develop event driven rule based GitLab file hooks that fire in real-time on events on a GitLab server: . > receive :: [Rule] -> GitLab () . @@ -46,7 +45,7 @@ bug-reports: https://gitlab.com/robstewart57/gitlab-haskell/issues author: Rob Stewart maintainer: robstewart57@gmail.com -copyright: 2021 Rob Stewart, Heriot-Watt University +copyright: 2022 Rob Stewart, Heriot-Watt University license: BSD-3-Clause license-file: LICENSE data-files: data/system-hooks/*.json @@ -141,3 +140,9 @@ , gitlab-haskell , bytestring , aeson + , tree-diff + , ansi-wl-pprint + , vector + , unordered-containers + ghc-options: -Wall + diff --git a/src/GitLab/API/Boards.hs b/src/GitLab/API/Boards.hs --- a/src/GitLab/API/Boards.hs +++ b/src/GitLab/API/Boards.hs @@ -8,29 +8,41 @@ -- Maintainer : robstewart57@gmail.com -- Stability : stable module GitLab.API.Boards - ( projectIssueBoards, - projectIssueBoards', + ( -- * List project issue boards + projectIssueBoards, + + -- * Show a single issue board projectIssueBoard, - projectIssueBoard', + + -- * Create an issue board createIssueBoard, - createIssueBoard', - updateIssueBoard', + + -- * Update an issue board + updateIssueBoard, + + -- * Delete an issue board deleteIssueBoard, - deleteIssueBoard', + + -- * List board lists in a project issue board projectBoardLists, - projectBoardLists', + + -- * Show a single board list boardList, - boardList', + + -- * Create a board list createBoardList, - createBoardList', + + -- * Reorder a list in a board reorderBoardList, - reorderBoardList', + + -- * Update an issue board deleteBoardList, - deleteBoardList', + + -- * Board attributes UpdateBoardAttrs (..), defaultUpdateBoardAttrs, - defaultCreateBoardAttrs, CreateBoardAttrs (..), + defaultCreateBoardAttrs, ) where @@ -66,7 +78,7 @@ boardsAddr projId = "/projects/" <> T.pack (show projId) <> "/boards" --- | returns all issue boards for a project. +-- | returns a single project issue board. projectIssueBoard :: -- | the project Project -> @@ -76,7 +88,7 @@ projectIssueBoard project = do projectIssueBoard' (project_id project) --- | returns all issue boards for a project. +-- | returns a single project issue board. projectIssueBoard' :: -- | the project ID Int -> @@ -116,21 +128,21 @@ "/projects/" <> T.pack (show projectId) <> "/boards" -- | Updates a project issue board. -updateIssueBoard' :: - -- | the project ID - Int -> +updateIssueBoard :: + -- | project + Project -> -- | the board ID Int -> -- | attributes for updating boards UpdateBoardAttrs -> GitLab (Either (Response BSL.ByteString) (Maybe IssueBoard)) -updateIssueBoard' projectId boardId attrs = do +updateIssueBoard prj boardId attrs = do gitlabPut boardAddr (updateBoardAttrs attrs) where boardAddr :: Text boardAddr = "/projects/" - <> T.pack (show projectId) + <> T.pack (show (project_id prj)) <> "/boards/" <> T.pack (show boardId) @@ -152,7 +164,7 @@ Int -> GitLab (Either (Response BSL.ByteString) (Maybe ())) deleteIssueBoard' projectId boardId = do - gitlabDelete boardAddr + gitlabDelete boardAddr [] where boardAddr :: Text boardAddr = @@ -187,7 +199,7 @@ boardsAddr = "/projects/" <> T.pack (show projectId) <> "/boards/" <> T.pack (show boardId) <> "/lists" --- | Get a list of the board’s lists. Does not include open and closed lists. +-- | Get a single board list. Does not include open and closed lists. boardList :: -- | the project Project -> @@ -201,7 +213,7 @@ -- return an empty list if the repository could not be found. return (fromRight Nothing result) --- | Get a list of the board’s lists. Does not include open and closed lists. +-- | Get a single board list. Does not include open and closed lists. boardList' :: -- | project ID Int -> @@ -310,7 +322,7 @@ Int -> GitLab (Either (Response BSL.ByteString) (Maybe ())) deleteBoardList' projectId boardId listId = - gitlabDelete boardsAddr + gitlabDelete boardsAddr [] where boardsAddr :: Text boardsAddr = diff --git a/src/GitLab/API/Branches.hs b/src/GitLab/API/Branches.hs --- a/src/GitLab/API/Branches.hs +++ b/src/GitLab/API/Branches.hs @@ -7,13 +7,36 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Branches where +module GitLab.API.Branches + ( -- * List repository branches + branches, + -- * Get single repository branch + branch, + + -- * Create repository branch + createRepositoryBranch, + + -- * Delete repository branch + deleteRepositoryBranch, + + -- * Delete merged branches + deleteMergedBranches, + ) +where + import qualified Data.ByteString.Lazy as BSL import Data.Either +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls + ( gitlabDelete, + gitlabGetMany, + gitlabGetOne, + gitlabPost, + ) import Network.HTTP.Client -- | Get a list of repository branches from a project, sorted by name @@ -25,7 +48,10 @@ -- | Get a list of repository branches from a project given its -- project ID, sorted by name alphabetically. -branches' :: Int -> GitLab (Either (Response BSL.ByteString) [Branch]) +branches' :: + -- | project ID + Int -> + GitLab (Either (Response BSL.ByteString) [Branch]) branches' projectId = gitlabGetMany addr [] where @@ -34,3 +60,115 @@ <> T.pack (show projectId) <> "/repository" <> "/branches" + +-- | Get a single project repository branch. +branch :: + -- | the project + Project -> + -- | the branch name + Text -> + GitLab (Maybe Branch) +branch project branchName = do + result <- branch' (project_id project) branchName + return (fromRight (error "branch error") result) + +-- | Get a single project repository branch. +branch' :: + -- | the project ID + Int -> + -- | name of the branch + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Branch)) +branch' projectId branchName = + gitlabGetOne addr [] + where + addr = + "/projects/" + <> T.pack (show projectId) + <> "/repository" + <> "/branches/" + <> branchName + +-- | Create a new branch in the repository. +createRepositoryBranch :: + -- | the project + Project -> + -- | branch name + Text -> + -- | Branch name or commit SHA to create branch from + Text -> + GitLab (Maybe Branch) +createRepositoryBranch project branchName branchFrom = do + result <- createRepositoryBranch' (project_id project) branchName branchFrom + -- return an empty list if the repository could not be found. + return (fromRight Nothing result) + +-- | Create a new branch in the repository. +createRepositoryBranch' :: + -- | project ID + Int -> + -- | branch name + Text -> + -- | Branch name or commit SHA to create branch from + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Branch)) +createRepositoryBranch' projectId branchName branchFrom = + gitlabPost newBranchAddr [("branch", Just (T.encodeUtf8 branchName)), ("ref", Just (T.encodeUtf8 branchFrom))] + where + newBranchAddr :: Text + newBranchAddr = + "/projects/" + <> T.pack (show projectId) + <> "/repository" + <> "/branches" + +-- | Delete a branch from the repository. +deleteRepositoryBranch :: + -- | project + Project -> + -- | branch name + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteRepositoryBranch project = + deleteRepositoryBranch' (project_id project) + +-- | Delete a branch from the repository. +deleteRepositoryBranch' :: + -- | project ID + Int -> + -- | branch name + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteRepositoryBranch' projectId branchName = + gitlabDelete branchAddr [] + where + branchAddr :: Text + branchAddr = + "/projects/" + <> T.pack (show projectId) + <> "/repository" + <> "/branches/" + <> branchName + +-- | Deletes all branches that are merged into the project’s default branch. +deleteMergedBranches :: + -- | project + Project -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteMergedBranches project = + deleteMergedBranches' (project_id project) + +-- | Deletes all branches that are merged into the project’s default branch. +deleteMergedBranches' :: + -- | project ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteMergedBranches' projectId = + gitlabDelete branchAddr [] + where + branchAddr :: Text + branchAddr = + "/projects/" + <> T.pack (show projectId) + <> "/repository" + <> "/merged_branches" diff --git a/src/GitLab/API/Commits.hs b/src/GitLab/API/Commits.hs --- a/src/GitLab/API/Commits.hs +++ b/src/GitLab/API/Commits.hs @@ -7,8 +7,55 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Commits where +module GitLab.API.Commits + ( -- * List repository commits + repoCommits, + -- * Create a commit with multiple files and actions + createCommitMultipleFilesActions, + + -- * Get a single commit + singleCommit, + + -- * Get references a commit is pushed to + + -- * Cherry-pick a commit + cheryPickCommit, + + -- * Revert a commit + revertCommit, + + -- * Get the diff of a commit + commitDiff, + + -- * Get the comments of a commit + commitComments, + + -- * Post comment to commit + postCommitComment, + + -- * Get the discussions of a commit + commitDiscussions, + -- -- * Commit status + + -- -- * List the statuses of a commit + + -- -- * Post the build status to a commit + + -- * List merge requests associated with a commit + commitMergeRequests, + -- -- * Get GPG signature of a commit + + -- * Commits on specific branch + branchCommits, + + -- * Types + CommitAction (..), + ContentEncoding (..), + Action (..), + ) +where + import qualified Data.ByteString.Lazy as BSL import Data.Either import Data.Text (Text) @@ -18,83 +65,305 @@ import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client --- | returns all commits for a project. -projectCommits :: +-- | Get a list of repository commits in a project. +repoCommits :: -- | the project Project -> GitLab [Commit] -projectCommits project = do - result <- projectCommits' (project_id project) +repoCommits prj = do -- return an empty list if the repository could not be found. + result <- gitlabGetMany (commitsAddr (project_id prj)) [("with_stats", Just "true")] return (fromRight [] result) - --- | returns all commits for a project given its project ID. -projectCommits' :: - -- | project ID - Int -> - GitLab (Either (Response BSL.ByteString) [Commit]) -projectCommits' projectId = - gitlabGetMany (commitsAddr projectId) [("with_stats", Just "true")] where commitsAddr :: Int -> Text commitsAddr projId = - "/projects/" <> T.pack (show projId) <> "/repository" <> "/commits" + "/projects/" + <> T.pack (show projId) + <> "/repository" + <> "/commits" --- | returns all commits of a branch from a project given the branch --- name. -branchCommits :: - -- | project +-- | Get a list of repository commits in a project. +createCommitMultipleFilesActions :: + -- | the project Project -> - -- | branch name + -- | Name of the branch to commit into. Text -> - GitLab [Commit] -branchCommits project branchName = do - result <- branchCommits' (project_id project) branchName - return (fromRight [] result) + -- | Commit message + Text -> + [CommitAction] -> + GitLab (Maybe Commit) +createCommitMultipleFilesActions prj branchName commitMsg actions = do + -- return an empty list if the repository could not be found. + result <- + gitlabPost + (commitsAddr (project_id prj)) + [ ("branch", Just (T.encodeUtf8 branchName)), + ("commit_message", Just (T.encodeUtf8 commitMsg)), + ("actions", Just (T.encodeUtf8 (T.pack (show actions)))) + ] + case result of + Left resp -> error ("createCommitMultipleFilesActions: " <> show resp) + Right x -> return x + where + commitsAddr :: Int -> Text + commitsAddr projId = + "/projects/" + <> T.pack (show projId) + <> "/repository" + <> "/commits" +-- | A commit action. +data CommitAction = CommitAction + { commit_action_action :: Action, + -- | Full path to the file. + commit_action_file_path :: FilePath, + -- | Original full path to the file being + -- moved. Ex. lib/class1.rb. Only considered for move action. + commit_action_previous_path :: Maybe Text, + -- | File content, required for all except delete, chmod, and + -- move. Move actions that do not specify content preserve the + -- existing file content, and any other value of content overwrites + -- the file content. + commit_action_content :: Maybe Text, + -- | text or base64. text is default. + commit_action_encoding :: Maybe ContentEncoding, + -- | Last known file commit ID. Only considered in update, move, and + -- delete actions. + commit_action_last_commit_id :: Maybe Text, + -- | When true/false enables/disables the execute flag on the + -- file. Only considered for chmod action. + commit_action_execute_filemode :: Maybe Bool + } + deriving (Show, Eq) + +-- | The actual action within a commit action. +data Action + = ActionCreate + | ActionDelete + | ActionMove + | ActionUpdate + | ActionChmod + deriving (Eq) + +instance Show Action where + show ActionCreate = "create" + show ActionDelete = "delete" + show ActionMove = "move" + show ActionUpdate = "update" + show ActionChmod = "chmod" + +-- | Whether the content is text or base 64. +data ContentEncoding + = EncodingText + | EncodingBase64 + deriving (Eq) + +instance Show ContentEncoding where + show EncodingText = "text" + show EncodingBase64 = "base64" + -- | returns all commits of a branch from a project -- given its project ID and the branch name. -branchCommits' :: - -- | project ID - Int -> +branchCommits :: + -- | project + Project -> -- | branch name Text -> GitLab (Either (Response BSL.ByteString) [Commit]) -branchCommits' projectId branchName = do - gitlabGetMany (commitsAddr projectId) [("ref_name", Just (T.encodeUtf8 branchName))] +branchCommits prj branchName = do + gitlabGetMany (commitsAddr (project_id prj)) [("ref_name", Just (T.encodeUtf8 branchName))] where commitsAddr :: Int -> Text commitsAddr projId = "/projects/" <> T.pack (show projId) <> "/repository" <> "/commits" --- | returns a commit for the given project and commit hash, if such --- a commit exists. -commitDetails :: +-- | Get a specific commit identified by the commit hash or name of a +-- branch or tag. +singleCommit :: -- | the project Project -> -- | the commit hash Text -> GitLab (Maybe Commit) -commitDetails project theHash = do - result <- commitDetails' (project_id project) theHash +singleCommit project theHash = do + result <- gitlabGetOne (commitsAddr (project_id project)) [] return (fromRight Nothing result) + where + commitsAddr :: Int -> Text + commitsAddr projId = + "/projects/" + <> T.pack (show projId) + <> "/repository" + <> "/commits" + <> "/" + <> theHash --- | returns a commit for the given project ID and commit hash, if --- such a commit exists. -commitDetails' :: - -- | project ID - Int -> +-- | Cherry-picks a commit to a given branch. +cheryPickCommit :: + -- | the project + Project -> -- | the commit hash Text -> - GitLab (Either (Response BSL.ByteString) (Maybe Commit)) -commitDetails' projectId hash = - gitlabGetOne (commitsAddr projectId) [] + -- | The name of the branch + Text -> + GitLab (Maybe Commit) +cheryPickCommit project theHash branchName = do + result <- + gitlabPost + commitsAddr + [ ("branch", Just (T.encodeUtf8 branchName)) + ] + case result of + Left _ -> return Nothing + Right x -> return x where + commitsAddr :: Text + commitsAddr = + "/projects/" + <> T.pack (show (project_id project)) + <> "/repository" + <> "/commits/" + <> theHash + <> "/cherry_pick" + +-- | Reverts a commit in a given branch. +revertCommit :: + -- | the project + Project -> + -- | the commit hash + Text -> + -- | target branch name + Text -> + GitLab (Maybe Commit) +revertCommit project theHash branchName = do + result <- + gitlabPost + commitsAddr + [ ("branch", Just (T.encodeUtf8 branchName)) + ] + case result of + Left _ -> return Nothing + Right x -> return x + where + commitsAddr :: Text + commitsAddr = + "/projects/" + <> T.pack (show (project_id project)) + <> "/repository" + <> "/commits/" + <> theHash + <> "/revert" + +-- | Get the diff of a commit in a project. +commitDiff :: + -- | project + Project -> + -- | The commit hash or name of a repository branch or tag + Text -> + GitLab (Either (Response BSL.ByteString) [Diff]) +commitDiff project sha = do + gitlabGetMany (commitsAddr (project_id project)) [] + where commitsAddr :: Int -> Text commitsAddr projId = "/projects/" <> T.pack (show projId) <> "/repository" - <> "/commits" - <> "/" - <> hash + <> "/commits/" + <> T.pack (show sha) + <> "/diff" + +-- | Get the diff of a commit in a project. +commitComments :: + -- | project + Project -> + -- | The commit hash or name of a repository branch or tag + Text -> + GitLab (Either (Response BSL.ByteString) [CommitNote]) +commitComments project sha = do + gitlabGetMany (commitsAddr (project_id project)) [] + where + commitsAddr :: Int -> Text + commitsAddr projId = + "/projects/" + <> T.pack (show projId) + <> "/repository" + <> "/commits/" + <> T.pack (show sha) + <> "/comments" + +-- | Adds a comment to a commit. +postCommitComment :: + -- | project + Project -> + -- | The commit hash or name of a repository branch or tag + Text -> + -- | The text of the comment + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe CommitNote)) +postCommitComment project sha note = do + gitlabPost + (commitsAddr (project_id project)) + [("note", Just (T.encodeUtf8 note))] + where + commitsAddr :: Int -> Text + commitsAddr projId = + "/projects/" + <> T.pack (show projId) + <> "/repository" + <> "/commits/" + <> T.pack (show sha) + <> "/comments" + +-- | Get the discussions of a commit in a project. +commitDiscussions :: + -- | project + Project -> + -- | The commit hash or name of a repository branch or tag + Text -> + GitLab (Either (Response BSL.ByteString) [Discussion]) +commitDiscussions project sha = do + gitlabGetMany (commitsAddr (project_id project)) [] + where + commitsAddr :: Int -> Text + commitsAddr projId = + "/projects/" + <> T.pack (show projId) + <> "/repository" + <> "/commits/" + <> T.pack (show sha) + <> "/discussions" + +-- | Get the discussions of a commit in a project. +commitMergeRequests :: + -- | project + Project -> + -- | The commit SHA + Text -> + GitLab (Either (Response BSL.ByteString) [MergeRequest]) +commitMergeRequests project sha = do + gitlabGetMany (commitsAddr (project_id project)) [] + where + commitsAddr :: Int -> Text + commitsAddr projId = + "/projects/" + <> T.pack (show projId) + <> "/repository" + <> "/commits/" + <> T.pack (show sha) + <> "/merge_requests" + +------------- +-- candidates for deletion + +-- -- | returns all commits of a branch from a project given the branch +-- -- name. +-- branchCommits :: +-- -- | project +-- Project -> +-- -- | branch name +-- Text -> +-- GitLab [Commit] +-- branchCommits project branchName = do +-- result <- branchCommits' (project_id project) branchName +-- return (fromRight [] result) diff --git a/src/GitLab/API/Discussions.hs b/src/GitLab/API/Discussions.hs --- a/src/GitLab/API/Discussions.hs +++ b/src/GitLab/API/Discussions.hs @@ -8,38 +8,791 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Discussions where +module GitLab.API.Discussions + ( -- * Issues + -- ** List project issue discussion items + projectIssueDiscussions, + + -- ** Get single issue discussion item + issueDiscussion, + + -- ** Create new issue thread + createIssueThread, + + -- ** Add note to existing issue thread + addNoteToIssueThread, + + -- ** Modify existing issue thread note + modifyThreadNoteIssue, + + -- ** Delete an issue thread note + deleteIssueThreadNote, + + -- * Snippets + + -- ** List project snippet discussion items + snippetDiscussionItems, + + -- ** Get single snippet discussion item + snippetDiscussionItem, + + -- ** Create new snippet thread + createSnippetThread, + + -- ** Add note to existing snippet thread + addNoteToSnippetThread, + + -- ** Modify existing snippet thread note + modifySnippetThreadNote, + + -- ** Delete a snippet thread note + deleteSnippetThreadNote, + -- -- * Epics + + -- -- ** List group epic discussion items + + -- -- ** Get single epic discussion item + + -- -- ** Create new epic thread + + -- -- ** Add note to existing epic thread + + -- -- ** Modify existing epic thread note + + -- -- ** Delete an epic thread note + + -- * Merge requests + + -- ** List project merge request discussion items + projectMergeRequestDiscussionItems, + + -- ** Get single merge request discussion item + mergeRequestDiscussionItems, + + -- ** Create new merge request thread + createMergeRequestThread, + -- -- ** Create a new thread on the overview page + + -- -- ** Create a new thread in the merge request diff + + -- -- ** Parameters for multiline comments + + -- * Line code + + -- ** Resolve a merge request thread + resolveMergeRequestThread, + + -- ** Add note to existing merge request thread + addNoteToMergeRequestThread, + + -- ** Modify an existing merge request thread note + modifyMergeRequestThreadNote, + + -- ** Delete a merge request thread note + deleteMergeRequestThreadNote, + + -- * Commits + + -- ** List project commit discussion items + projectCommitDiscussionItems, + + -- ** Get single commit discussion item + projectCommitDiscussionItem, + + -- ** Create new commit thread + createCommitThread, + + -- ** Add note to existing commit thread + addNoteToCommitThread, + + -- ** Modify an existing commit thread note + modifyCommityThreadNote, + + -- ** Delete a commit thread note + deleteCommitThreadNote, + + -- * Types + PositionReference (..), + ) +where + import qualified Data.ByteString.Lazy as BSL +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client --- | gets all discussion for a commit for a project. -commitDiscussions :: - -- | the project +-- | Gets a list of all discussion items for a single issue. +projectIssueDiscussions :: + -- | project Project -> - -- | commit hash - Text -> - GitLab (Either (Response BSL.ByteString) [Discussion]) -commitDiscussions proj = commitDiscussions' (project_id proj) - --- | gets all discussion for a commit for a project given its project ID. -commitDiscussions' :: - -- | the project ID + -- | The IID of an issue Int -> - -- | commit hash - Text -> GitLab (Either (Response BSL.ByteString) [Discussion]) -commitDiscussions' projId commitHash = do +projectIssueDiscussions prj issueIid = do let urlPath = T.pack $ "/projects/" - <> show projId - <> "/repository" - <> "/commits/" - <> T.unpack commitHash + <> show (project_id prj) + <> "/issues/" + <> show issueIid <> "/discussions" gitlabGetMany urlPath [] + +-- | Returns a single discussion item for a specific project issue. +issueDiscussion :: + -- | project + Project -> + -- | The IID of an issue + Int -> + -- | The ID of a discussion item + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +issueDiscussion prj issueIid discussionId = do + let urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/issues/" + <> show issueIid + <> "/discussions/" + <> show discussionId + gitlabGetOne urlPath [] + +-- | Creates a new thread to a single project issue. This is similar +-- to creating a note but other comments (replies) can be added to it +-- later. +createIssueThread :: + -- | project + Project -> + -- | The IID of an issue + Int -> + -- | The content of the thread + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +createIssueThread prj issueIid threadContent = do + gitlabPost discussionAddr [("body", Just (T.encodeUtf8 threadContent))] + where + discussionAddr :: Text + discussionAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueIid) + <> "/discussions" + +-- | Adds a new note to the thread. This can also create a thread from +-- a single comment. Notes can be added to other items than comments, +-- such as system notes, making them threads. +addNoteToIssueThread :: + -- | project + Project -> + -- | The IID of an issue + Int -> + -- | The ID of a thread + Int -> + -- -- | The ID of a thread note + -- Int -> + + -- | The content of the note/reply + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +addNoteToIssueThread prj issueIid discussionId content = do + gitlabPost discussionAddr [("body", Just (T.encodeUtf8 content))] + where + discussionAddr :: Text + discussionAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueIid) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes" + +-- <> "/notes/" +-- <> T.pack (show noteId) + +-- | Modify existing thread note of an issue. +modifyThreadNoteIssue :: + -- | project + Project -> + -- | The IID of an issue + Int -> + -- | The ID of a thread + Int -> + -- | The ID of a thread note + Int -> + -- | The content of the note/reply + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +modifyThreadNoteIssue prj issueIid discussionId noteId content = do + gitlabPut noteAddr [("body", Just (T.encodeUtf8 content))] + where + noteAddr :: Text + noteAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueIid) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes/" + <> T.pack (show noteId) + +-- | Deletes an existing thread note of an issue. +deleteIssueThreadNote :: + -- | project + Project -> + -- | The IID of an issue + Int -> + -- | The ID of a discussion + Int -> + -- | The ID of a discussion note + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteIssueThreadNote prj issueIid discussionId noteId = do + gitlabDelete noteAddr [] + where + noteAddr :: Text + noteAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueIid) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes/" + <> T.pack (show noteId) + +-- | Gets a list of all discussion items for a single snippet. +snippetDiscussionItems :: + -- | project + Project -> + -- | snippet ID + Int -> + GitLab (Either (Response BSL.ByteString) [Discussion]) +snippetDiscussionItems prj snippetId = + gitlabGetMany urlPath [] + where + urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/snippets/" + <> show snippetId + <> "/discussions" + +-- | Returns a single discussion item for a specific project snippet. +snippetDiscussionItem :: + -- | project + Project -> + -- | snippet ID + Int -> + -- | discussion ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +snippetDiscussionItem prj snippetId discussionId = + gitlabGetOne urlPath [] + where + urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/snippets/" + <> show snippetId + <> "/discussions/" + <> show discussionId + +-- | Creates a new thread to a single project snippet. This is similar +-- to creating a note but other comments (replies) can be added to it +-- later. +createSnippetThread :: + -- | project + Project -> + -- | snippet ID + Int -> + -- | The content of a discussion + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +createSnippetThread prj snippetId content = do + gitlabPost discussionAddr [("body", Just (T.encodeUtf8 content))] + where + discussionAddr :: Text + discussionAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/snippets/" + <> T.pack (show snippetId) + <> "/discussions" + +-- | Adds a new note to the thread. +addNoteToSnippetThread :: + -- | project + Project -> + -- | snippet ID + Int -> + -- | discussion ID + Int -> + -- -- | note ID + -- Int -> + + -- | The content of the note/reply + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +addNoteToSnippetThread prj snippetId discussionId content = + gitlabPost discussionAddr [("body", Just (T.encodeUtf8 content))] + where + discussionAddr :: Text + discussionAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/snippets/" + <> T.pack (show snippetId) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes" + +-- <> "/notes/" +-- <> T.pack (show noteId) + +-- | Modify existing thread note of a snippet. +modifySnippetThreadNote :: + -- | project + Project -> + -- | snippet ID + Int -> + -- | discussion ID + Int -> + -- | note ID + Int -> + -- | The content of the note/reply + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +modifySnippetThreadNote prj snippetId discussionId noteId content = + gitlabPut noteAddr [("body", Just (T.encodeUtf8 content))] + where + noteAddr :: Text + noteAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/snippets/" + <> T.pack (show snippetId) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes/" + <> T.pack (show noteId) + +-- | Deletes an existing thread note of an issue. +deleteSnippetThreadNote :: + -- | Project + Project -> + -- | snippet ID + Int -> + -- | discussion ID + Int -> + -- | note ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteSnippetThreadNote prj snippetId discussionId noteId = do + gitlabDelete noteAddr [] + where + noteAddr :: Text + noteAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/snippets/" + <> T.pack (show snippetId) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes/" + <> T.pack (show noteId) + +-- | Gets a list of all discussion items for a single merge request. +projectMergeRequestDiscussionItems :: + -- | project + Project -> + -- | Merge request IID + Int -> + GitLab (Either (Response BSL.ByteString) [Discussion]) +projectMergeRequestDiscussionItems prj mergeRequestIid = do + gitlabGetMany urlPath [] + where + urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/merge_requests/" + <> show mergeRequestIid + <> "/discussions" + +-- | Gets a list of all discussion items for a single merge request. +mergeRequestDiscussionItems :: + -- | project + Project -> + -- | Merge request IID + Int -> + -- | discussion ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +mergeRequestDiscussionItems prj mergeRequestIid discussionId = do + gitlabGetOne urlPath [] + where + urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/merge_requests/" + <> show mergeRequestIid + <> "/discussions/" + <> show discussionId + +-- | Position reference for an entry in a discussion. +data PositionReference = TextPos | ImagePos + +instance Show PositionReference where + show TextPos = "text" + show ImagePos = "image" + +-- | Creates a new thread to a single project merge request. This is +-- similar to creating a note but other comments (replies) can be +-- added to it later. See the GitLab document: +-- https://docs.gitlab.com/ee/api/discussions.html#create-new-merge-request-thread +createMergeRequestThread :: + -- | project + Project -> + -- | merge request ID + Int -> + -- | The content of the thread + Text -> + -- | Base commit SHA in the source branch + Text -> + -- | SHA referencing commit in target branch + Text -> + -- | SHA referencing HEAD of this merge request + Text -> + -- | Type of the position reference + PositionReference -> + -- | File path after change + Text -> + -- | File path before change + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +createMergeRequestThread prj mergeRequestIid content baseCommitShaSource shaCommitTarget shaHeadMR typePosRef filePathAfter filePathBefore = + gitlabPost + discussionAddr + [ ("body", Just (T.encodeUtf8 content)), + ("position[base_sha]", Just (T.encodeUtf8 baseCommitShaSource)), + ("position[start_sha]", Just (T.encodeUtf8 shaCommitTarget)), + ("position[head_sha]", Just (T.encodeUtf8 shaHeadMR)), + ("position[position_type]", Just (T.encodeUtf8 (T.pack (show typePosRef)))), + ("position[new_path]", Just (T.encodeUtf8 filePathAfter)), + ("position[old_path]", Just (T.encodeUtf8 filePathBefore)) + ] + where + discussionAddr :: Text + discussionAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/merge_requests/" + <> T.pack (show mergeRequestIid) + <> "/discussions" + +-- | Resolve/unresolve whole thread of a merge request. +resolveMergeRequestThread :: + -- | project + Project -> + -- | merge request IID + Int -> + -- | discussion ID + Int -> + -- | Resolve/unresolve the discussion + Bool -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +resolveMergeRequestThread prj mergeRequestIid discussionId resolved = + gitlabPut noteAddr [("resolved", Just (T.encodeUtf8 (resolvedStr resolved)))] + where + noteAddr :: Text + noteAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/merge_requests/" + <> T.pack (show mergeRequestIid) + <> "/discussions/" + <> T.pack (show discussionId) + resolvedStr True = "true" + resolvedStr False = "false" + +-- | Adds a new note to the thread. This can also create a thread from a single comment. +addNoteToMergeRequestThread :: + -- | project + Project -> + -- | merge request ID + Int -> + -- | discussion ID + Int -> + -- -- | note ID + -- Int -> + + -- | The content of the note/reply + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +addNoteToMergeRequestThread prj mergeRequestIid discussionId content = + gitlabPost + discussionAddr + [ ("body", Just (T.encodeUtf8 content)) + ] + where + discussionAddr :: Text + discussionAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/merge_requests/" + <> T.pack (show mergeRequestIid) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes" + +-- | exactly one of body or resolved must be a 'Just' value +modifyMergeRequestThreadNote :: + -- | project + Project -> + -- | merge request IID + Int -> + -- | discussion ID + Int -> + -- | note ID + Int -> + -- | The content of the note/reply + Maybe Text -> + -- | Resolve/unresolve the note + Maybe Bool -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +modifyMergeRequestThreadNote prj mergeRequestIid discussionId noteId content resolved = + gitlabPut + noteAddr + (catMaybes [contentAttr, resolveAttr]) + where + contentAttr = + case content of + Nothing -> Nothing + Just x -> Just ("body", Just (T.encodeUtf8 x)) + resolveAttr = + case resolved of + Nothing -> Nothing + Just x -> + if x + then Just ("resolved", Just (T.encodeUtf8 "true")) + else Just ("resolved", Just (T.encodeUtf8 "false")) + noteAddr :: Text + noteAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/merge_requests/" + <> T.pack (show mergeRequestIid) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes/" + <> T.pack (show noteId) + +-- | Deletes an existing thread note of a merge request. +deleteMergeRequestThreadNote :: + -- | project + Project -> + -- | merge request IID + Int -> + -- | discussion ID + Int -> + -- | note ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteMergeRequestThreadNote prj mergeRequestIid discussionId noteId = do + gitlabDelete noteAddr [] + where + noteAddr :: Text + noteAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/merge_requests/" + <> T.pack (show mergeRequestIid) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes/" + <> T.pack (show noteId) + +-- | Gets a list of all discussion items for a single commit. +projectCommitDiscussionItems :: + -- | project + Project -> + -- | commit ID + Int -> + GitLab (Either (Response BSL.ByteString) [Discussion]) +projectCommitDiscussionItems prj commitId = + gitlabGetMany urlPath [] + where + urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/commits/" + <> show commitId + <> "/discussions" + +-- | Returns a single discussion item for a specific project commit. +projectCommitDiscussionItem :: + -- | project + Project -> + -- | commit ID + Int -> + -- | discussion ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +projectCommitDiscussionItem prj commitId discussionId = + gitlabGetOne urlPath [] + where + urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/commits/" + <> show commitId + <> "/discussions/" + <> show discussionId + +-- | Creates a new thread to a single project commit. This is similar +-- to creating a note but other comments (replies) can be added to it +-- later. +createCommitThread :: + -- | project + Project -> + -- | commit ID + Int -> + -- | The content of the thread + Text -> + -- | SHA of the parent commit + Text -> + -- | SHA of the parent commit (bug in GitLab document?) + Text -> + -- | The SHA of this commit + Text -> + -- | Type of the position reference + PositionReference -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +createCommitThread prj commitId content shaParent shaStart shaThisCommit typePosRef = + gitlabPost + discussionAddr + [ ("body", Just (T.encodeUtf8 content)), + ("position[base_sha]", Just (T.encodeUtf8 shaParent)), + ("position[start_sha]", Just (T.encodeUtf8 shaStart)), + ("position[head_sha]", Just (T.encodeUtf8 shaThisCommit)), + ("position[position_type]", Just (T.encodeUtf8 (T.pack (show typePosRef)))) + ] + where + discussionAddr :: Text + discussionAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/commits/" + <> T.pack (show commitId) + <> "/discussions" + +-- | Adds a new note to the thread. +addNoteToCommitThread :: + -- | project + Project -> + -- | commit ID + Int -> + -- | discussion ID + Int -> + -- -- | note ID + -- Int -> + + -- | The content of the note/reply + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +addNoteToCommitThread prj commitId discussionId content = + gitlabPost + discussionAddr + [ ("body", Just (T.encodeUtf8 content)) + ] + where + discussionAddr :: Text + discussionAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/commits/" + <> T.pack (show commitId) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes" + +-- | Adds a new note to the thread. +modifyCommityThreadNote :: + -- | project + Project -> + -- | commit ID + Int -> + -- | discussion ID + Int -> + -- | note ID + Int -> + -- | The content of the note/reply + Maybe Text -> + -- | Resolve/unresolve the note + Maybe Bool -> + GitLab (Either (Response BSL.ByteString) (Maybe Discussion)) +modifyCommityThreadNote prj commitId discussionId noteId content resolved = + gitlabPut + noteAddr + (catMaybes [contentAttr, resolveAttr]) + where + contentAttr = + case content of + Nothing -> Nothing + Just x -> Just ("body", Just (T.encodeUtf8 x)) + resolveAttr = + case resolved of + Nothing -> Nothing + Just x -> + if x + then Just ("resolved", Just (T.encodeUtf8 "true")) + else Just ("resolved", Just (T.encodeUtf8 "false")) + noteAddr :: Text + noteAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/commits/" + <> T.pack (show commitId) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes/" + <> T.pack (show noteId) + +-- | Deletes an existing thread note of a commit. +deleteCommitThreadNote :: + -- | project + Project -> + -- | commit ID + Int -> + -- | discussion ID + Int -> + -- | The ID of a discussion note + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteCommitThreadNote prj commitId discussionId noteId = do + gitlabDelete noteAddr [] + where + noteAddr :: Text + noteAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/commits/" + <> T.pack (show commitId) + <> "/discussions/" + <> T.pack (show discussionId) + <> "/notes/" + <> T.pack (show noteId) diff --git a/src/GitLab/API/Groups.hs b/src/GitLab/API/Groups.hs --- a/src/GitLab/API/Groups.hs +++ b/src/GitLab/API/Groups.hs @@ -8,9 +8,55 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Groups where +module GitLab.API.Groups + ( -- * List groups + groups, + -- * List a group’s subgroups + subGroups, + + -- * List a group’s descendant groups + descendantGroups, + + -- * List a group’s projects + groupProjects, + + -- * List a group’s shared projects + groupSharedProjects, + + -- * Details of a group + group, + + -- * New group + newGroup, + + -- * New Subgroup + newSubGroup, + + -- * Update group + updateGroup, + + -- * Remove group + removeGroup, + + -- * Search for group + searchGroup, + + -- * Group attributes + ListGroupsAttrs (..), + GroupOrderBy (..), + GroupProjectAttrs (..), + GroupProjectOrderBy (..), + GroupAttrs (..), + BranchProtection (..), + defaultGroupFilters, + defaultListGroupsFilters, + ) +where + import qualified Data.ByteString.Lazy as BSL +import Data.Either +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -18,46 +64,351 @@ import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client --- | gets groups with the given group name, path or full path. --- --- > projectsWithNameOrPath "group1" -groupsWithNameOrPath :: - -- | group name being searched for. - Text -> - GitLab (Either (Response BSL.ByteString) [Group]) -groupsWithNameOrPath groupName = do - result <- gitlabGetMany "/groups" [("search", Just (T.encodeUtf8 groupName))] - case result of - Left {} -> return result - Right groups -> - return - ( Right $ - filter - ( \group -> - groupName == group_name group - || groupName == group_path group - || groupName == group_full_path group - ) - groups - ) +-- | Get a list of visible groups for the authenticated user. +groups :: ListGroupsAttrs -> GitLab [Group] +groups attrs = + fromRight (error "groups error") + <$> gitlabGetMany "/groups" (listGroupsAttrs attrs) --- | Get a list of projects in this group -groupProjects :: - -- | group - Group -> - GitLab (Either (Response BSL.ByteString) [Project]) -groupProjects group = do - groupProjects' (group_id group) +-- | Get a list of visible direct subgroups in this group. +subGroups :: Group -> ListGroupsAttrs -> GitLab [Group] +subGroups parentGrp attrs = + fromRight (error "subGroups error") + <$> gitlabGetMany + ( "/groups/" + <> T.pack (show (group_id parentGrp)) + <> "/subgroups" + ) + (listGroupsAttrs attrs) --- | Get a list of projects in this group -groupProjects' :: +-- | Get a list of visible descendant groups of this group. +descendantGroups :: Group -> ListGroupsAttrs -> GitLab [Group] +descendantGroups parentGrp attrs = + fromRight (error "subGroups error") + <$> gitlabGetMany + ( "/groups/" + <> T.pack (show (group_id parentGrp)) + <> "/descendant_groups" + ) + (listGroupsAttrs attrs) + +-- | Get a list of projects in this group. +groupProjects :: Group -> GroupProjectAttrs -> GitLab [Project] +groupProjects parentGrp attrs = + fromRight (error "groupProjects error") + <$> gitlabGetMany + ( "/groups/" + <> T.pack (show (group_id parentGrp)) + <> "/projects" + ) + (groupProjectAttrs attrs) + +-- | Get a list of projects in this group. +groupSharedProjects :: Group -> GroupProjectAttrs -> GitLab [Project] +groupSharedProjects parentGrp attrs = + fromRight (error "groupSharedProjects error") + <$> gitlabGetMany + ( "/groups/" + <> T.pack (show (group_id parentGrp)) + <> "/projects/shared" + ) + (groupProjectAttrs attrs) + +-- | Get all details of a group. +group :: -- | group ID Int -> - GitLab (Either (Response BSL.ByteString) [Project]) -groupProjects' groupID = do - let urlPath = - T.pack $ - "/groups/" - <> show groupID - <> "/projects" - gitlabGetMany urlPath [] + GitLab (Either (Response BSL.ByteString) (Maybe Group)) +group pId = do + gitlabGetOne urlPath [] + where + urlPath = + "/groups/" + <> T.pack (show pId) + +-- | Creates a new project group (TODO include attributes). +newGroup :: + -- | group name + Text -> + -- | group path + Text -> + -- | group attributes + GroupAttrs -> + GitLab (Either (Response BSL.ByteString) (Maybe Group)) +newGroup nameTxt pathTxt attrs = do + gitlabPost + newProjectAddr + ([("name", Just (T.encodeUtf8 nameTxt)), ("path", Just (T.encodeUtf8 pathTxt))] <> groupAttrs attrs) + where + newProjectAddr :: Text + newProjectAddr = + "/groups" + +-- | Creates a new project group. +newSubGroup :: + -- | group name + Text -> + -- | group path + Text -> + -- | parent group ID + Int -> + -- | group attributes + GroupAttrs -> + GitLab (Either (Response BSL.ByteString) (Maybe Group)) +newSubGroup nameTxt pathTxt parentId attrs = do + gitlabPost + newProjectAddr + ([("name", Just (T.encodeUtf8 nameTxt)), ("path", Just (T.encodeUtf8 pathTxt)), ("parent_id", Just (T.encodeUtf8 (T.pack (show parentId))))] <> groupAttrs attrs) + where + newProjectAddr :: Text + newProjectAddr = + "/groups" + +-- | Updates the project group. Only available to group owners and +-- administrators. +updateGroup :: + -- | The ID of the group. + Int -> + -- | Group attributes + GroupAttrs -> + GitLab (Either (Response BSL.ByteString) (Maybe Group)) +updateGroup groupId attrs = + gitlabPut + newProjectAddr + (groupAttrs attrs) + where + newProjectAddr :: Text + newProjectAddr = + "/groups/" + <> T.pack (show groupId) + +-- | Only available to group owners and administrators. +removeGroup :: + -- | The ID of the group. + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +removeGroup grpId = + gitlabDelete groupAddr [] + where + groupAddr :: Text + groupAddr = + "/groups/" + <> T.pack (show grpId) + +-- | Get all groups that match your string in their name or path. +searchGroup :: + -- | String or path to search for. + Text -> + GitLab [Group] +searchGroup searchTxt = + fromRight (error "searchGroups error") + <$> gitlabGetMany "/groups" [("search", Just (T.encodeUtf8 searchTxt))] + +-- | Attributes related to a group +data GroupProjectAttrs = GroupProjectAttrs + { groupProjectFilter_id :: Maybe Int, + groupProjectFilter_archived :: Maybe Bool, + groupProjectFilter_visibility :: Maybe Visibility, + groupProjectFilter_order_by :: Maybe GroupProjectOrderBy, + groupProjectFilter_sort :: Maybe SortBy, + groupProjectFilter_search :: Maybe Text, + groupProjectFilter_simple :: Maybe Bool, + groupProjectFilter_owned :: Maybe Bool, + groupProjectFilter_starred :: Maybe Bool, + groupProjectFilter_with_issues_enabled :: Maybe Bool, + groupProjectFilter_with_merge_requests_enabled :: Maybe Bool, + groupProjectFilter_with_shared :: Maybe Bool, + groupProjectFilter_include_subgroups :: Maybe Bool, + groupProjectFilter_min_access_level :: Maybe AccessLevel, + groupProjectFilter_with_custom_attributes :: Maybe Bool, + groupProjectFilter_with_security_reports :: Maybe Bool + } + +-- | The order of group projects in search results. +data GroupProjectOrderBy + = GroupProjectOrderId + | GroupProjectOrderName + | GroupProjectOrderPath + | GroupProjectOrderCreatedAt + | GroupProjectOrderUpdatedAt + | GroupProjectOrderSimilarity + | GroupProjectOrderLastActivityAt + +instance Show GroupProjectOrderBy where + show GroupProjectOrderName = "id" + show GroupProjectOrderPath = "name" + show GroupProjectOrderId = "path" + show GroupProjectOrderCreatedAt = "created_at" + show GroupProjectOrderUpdatedAt = "updated_at" + show GroupProjectOrderSimilarity = "similarity" + show GroupProjectOrderLastActivityAt = "last_activity_at" + +groupProjectAttrs :: GroupProjectAttrs -> [GitLabParam] +groupProjectAttrs filters = + catMaybes + [ (\i -> Just ("id", textToBS (T.pack (show i)))) =<< groupProjectFilter_id filters, + (\b -> Just ("archived", textToBS (showBool b))) =<< groupProjectFilter_archived filters, + (\v -> Just ("visibility", textToBS (T.pack (show v)))) =<< groupProjectFilter_search filters, + (\grpOrder -> Just ("order_by", textToBS (T.pack (show grpOrder)))) =<< groupProjectFilter_order_by filters, + (\sortBy -> Just ("sort", textToBS (T.pack (show sortBy)))) =<< groupProjectFilter_sort filters, + (\x -> Just ("search", textToBS (T.pack (show x)))) =<< groupProjectFilter_search filters, + (\b -> Just ("simple", textToBS (showBool b))) =<< groupProjectFilter_simple filters, + (\b -> Just ("owned", textToBS (showBool b))) =<< groupProjectFilter_owned filters, + (\b -> Just ("starred", textToBS (showBool b))) =<< groupProjectFilter_starred filters, + (\b -> Just ("with_issues_enabled", textToBS (showBool b))) =<< groupProjectFilter_with_issues_enabled filters, + (\b -> Just ("with_merge_requests_enabled", textToBS (showBool b))) =<< groupProjectFilter_with_merge_requests_enabled filters, + (\b -> Just ("with_shared", textToBS (showBool b))) =<< groupProjectFilter_with_shared filters, + (\b -> Just ("include_subgroups", textToBS (showBool b))) =<< groupProjectFilter_include_subgroups filters, + (\x -> Just ("min_access_level", textToBS (T.pack (show x)))) =<< groupProjectFilter_min_access_level filters, + (\b -> Just ("with_custom_attributes", textToBS (showBool b))) =<< groupProjectFilter_with_custom_attributes filters, + (\b -> Just ("with_security_reports", textToBS (showBool b))) =<< groupProjectFilter_with_security_reports filters + ] + where + textToBS = Just . T.encodeUtf8 + showBool :: Bool -> Text + showBool True = "true" + showBool False = "false" + +-- | Attributes related to listing groups +data ListGroupsAttrs = ListGroupsAttrs + { listGroupsFilter_skip_groups :: Maybe [Int], + listGroupsFilter_all_available :: Maybe Bool, + listGroupsFilter_search :: Maybe Text, + listGroupsFilter_order_by :: Maybe GroupOrderBy, + listGroupsFilter_sort :: Maybe SortBy, + listGroupsFilter_owned :: Maybe Bool, + listGroupsFilter_min_access_level :: Maybe AccessLevel, + listGroupsFilter_top_level_only :: Maybe Bool + } + +-- | The order of groups in search results. +data GroupOrderBy + = GroupOrderName + | GroupOrderPath + | GroupOrderId + | GroupOrderSimilarity + +instance Show GroupOrderBy where + show GroupOrderName = "name" + show GroupOrderPath = "path" + show GroupOrderId = "id" + show GroupOrderSimilarity = "similarity" + +listGroupsAttrs :: ListGroupsAttrs -> [GitLabParam] +listGroupsAttrs filters = + catMaybes + [ (\i -> Just ("skip_groups", textToBS (T.pack (show i)))) =<< listGroupsFilter_skip_groups filters, + (\b -> Just ("all_available", textToBS (showBool b))) =<< listGroupsFilter_all_available filters, + (\t -> Just ("search", textToBS t)) =<< listGroupsFilter_search filters, + (\grpOrder -> Just ("order_by", textToBS (T.pack (show grpOrder)))) =<< listGroupsFilter_order_by filters, + (\sortBy -> Just ("sort", textToBS (T.pack (show sortBy)))) =<< listGroupsFilter_sort filters, + (\b -> Just ("owned", textToBS (showBool b))) =<< listGroupsFilter_owned filters, + (\accLevel -> Just ("min_access_level", textToBS (T.pack (show accLevel)))) =<< listGroupsFilter_min_access_level filters, + (\b -> Just ("top_level_only", textToBS (showBool b))) =<< listGroupsFilter_top_level_only filters + ] + where + textToBS = Just . T.encodeUtf8 + showBool :: Bool -> Text + showBool True = "true" + showBool False = "false" + +-- | No group filters applied, thereby returning all groups. +defaultListGroupsFilters :: ListGroupsAttrs +defaultListGroupsFilters = + ListGroupsAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Attributes related to a group +data GroupAttrs = GroupAttrs + { -- | The name of the group. + groupFilter_name :: Maybe Text, + -- | The path of the group. + groupFilter_path :: Maybe Text, + -- | Default to Auto DevOps pipeline for all projects within this + -- group. + groupFilter_auto_devops_enabled :: Maybe Bool, + -- | Default to the global level default branch protection + -- setting. + groupFilter_default_branch_protection :: Maybe BranchProtection, + -- | The group’s description. + groupFilter_description :: Maybe Text, + -- | Disable email notifications. + groupFilter_emails_disabled :: Maybe Bool, + -- | Enable/disable Large File Storage (LFS) for the projects in + -- this group. + groupFilter_lfs_enabled :: Maybe Bool, + -- | Disable the capability of a group from getting mentioned. + groupFilter_mentions_disabled :: Maybe Bool, + -- | The parent group ID for creating nested group. + groupFilter_parent_id :: Maybe Int, + -- | Determine if developers can create projects in the group. Can + -- be noone (No one), maintainer (users with the Maintainer role), + -- or developer (users with the Developer or Maintainer role). + groupFilter_project_creation_level :: Maybe AccessLevel, + -- | Allow users to request member access. + groupFilter_request_access_enabled :: Maybe Bool, + -- | Require all users in this group to setup Two-factor + -- authentication. + groupFilter_require_two_factor_authentication :: Maybe Bool, + -- | Prevent sharing a project with another group within this + -- group. + groupFilter_share_with_group_lock :: Maybe Bool, + -- | Allowed to create subgroups. Can be owner (Owners), or + -- maintainer (users with the Maintainer role). + groupFilter_subgroup_creation_level :: Maybe AccessLevel, + -- | Time before Two-factor authentication is enforced (in hours). + groupFilter_two_factor_grace_period :: Maybe Int, + -- | The group’s visibility. Can be private, internal, or public. + groupFilter_visibility :: Maybe Visibility + } + +-- | A group level branch protection setting. +data BranchProtection + = -- | Users with the Developer or Maintainer role can: push new + -- commits, force push changes, delete the branch + NoProtection + | -- | Users with the Developer or Maintainer role can: push new commits + PartialProtection + | -- | Only users with the Maintainer role can: push new commits + FullProtection + | -- | Users with the Maintainer role can: push new commits, force + -- push changes, accept merge requests; Users with the Developer + -- role can: accept merge requests + ProtectAgainstPushes + +instance Show BranchProtection where + show NoProtection = "0" + show PartialProtection = "1" + show FullProtection = "2" + show ProtectAgainstPushes = "3" + +groupAttrs :: GroupAttrs -> [GitLabParam] +groupAttrs filters = + catMaybes + [ (\t -> Just ("name", textToBS t)) =<< groupFilter_name filters, + (\t -> Just ("path", textToBS t)) =<< groupFilter_path filters, + (\b -> Just ("auto_devops_enabled", textToBS (showBool b))) =<< groupFilter_auto_devops_enabled filters, + (\a -> Just ("default_branch_protection", textToBS (T.pack (show a)))) =<< groupFilter_default_branch_protection filters, + (\t -> Just ("description", textToBS t)) =<< groupFilter_description filters, + (\b -> Just ("emails_disabled", textToBS (showBool b))) =<< groupFilter_emails_disabled filters, + (\b -> Just ("lfs_enabled", textToBS (showBool b))) =<< groupFilter_lfs_enabled filters, + (\b -> Just ("mentions_disabled", textToBS (showBool b))) =<< groupFilter_mentions_disabled filters, + (\i -> Just ("parent_id", textToBS (T.pack (show i)))) =<< groupFilter_parent_id filters, + (\a -> Just ("project_creation_level", textToBS (T.pack (show a)))) =<< groupFilter_project_creation_level filters, + (\b -> Just ("request_access_enabled", textToBS (showBool b))) =<< groupFilter_request_access_enabled filters, + (\b -> Just ("require_two_factor_authentication", textToBS (showBool b))) =<< groupFilter_require_two_factor_authentication filters, + (\b -> Just ("share_with_group_lock", textToBS (showBool b))) =<< groupFilter_share_with_group_lock filters, + (\a -> Just ("subgroup_creation_level", textToBS (T.pack (show a)))) =<< groupFilter_subgroup_creation_level filters, + (\i -> Just ("two_factor_grace_period", textToBS (T.pack (show i)))) =<< groupFilter_two_factor_grace_period filters, + (\a -> Just ("visibility", textToBS (T.pack (show a)))) =<< groupFilter_visibility filters + ] + where + textToBS = Just . T.encodeUtf8 + showBool :: Bool -> Text + showBool True = "true" + showBool False = "false" + +-- | No group filters applied. +defaultGroupFilters :: + GroupAttrs +defaultGroupFilters = + GroupAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing diff --git a/src/GitLab/API/Issues.hs b/src/GitLab/API/Issues.hs --- a/src/GitLab/API/Issues.hs +++ b/src/GitLab/API/Issues.hs @@ -9,25 +9,75 @@ -- Maintainer : robstewart57@gmail.com -- Stability : stable module GitLab.API.Issues - ( defaultIssueFilters, - IssueAttrs (..), - DueDate (..), - IssueSearchIn (..), - IssueOrderBy (..), - IssueScope (..), - IssueSortBy (..), - IssueState (..), + ( -- * List issues + + -- * List group issues + groupIssues, + + -- * List project issues projectIssues, - projectIssues', - issueStatisticsUser, - issueStatisticsGroup, - issueStatisticsGroup', - issueStatisticsProject, - issueStatisticsProject', + + -- * Single issue + issue, + + -- * User issues userIssues, + + -- * Single project issue + projectIssue, + + -- * New issue newIssue, - newIssue', + + -- * Edit issue editIssue, + + -- * Delete an issue + deleteIssue, + + -- * Reorder an issue + reorderIssue, + + -- * Move an issue + moveIssue, + + -- * Clone an issue + cloneIssue, + + -- * Subscribe to an issue + subscribeIssue, + + -- * Unsubscribe from an issue + unsubscribeIssue, + + -- * Create a to-do item + createTodo, + + -- * List merge requests related to issue + issueMergeRequests, + + -- * List merge requests that close a particular issue on merge + issueMergeRequestsThatClose, + + -- * Participants on issues + issueParticipants, + + -- * Comments on issues + + -- * Get issues statistics + issueStatisticsUser, + + -- * Get group issues statistics + issueStatisticsGroup, + + -- * Get project issues statistics + issueStatisticsProject, + + -- * Issues attributes + defaultIssueFilters, + IssueAttrs (..), + DueDate (..), + IssueState (..), ) where @@ -43,88 +93,26 @@ import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client --- | No issue filters, thereby returning all issues. Default scope is "all". -defaultIssueFilters :: IssueAttrs -defaultIssueFilters = - IssueAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just All) Nothing Nothing Nothing Nothing Nothing Nothing - --- | When an issue is due -data DueDate - = NoDueDate - | Overdue - | Week - | Month - | NextMonthPreviousTwoWeeks - -instance Show DueDate where - show NoDueDate = "0" - show Overdue = "overdue" - show Week = "week" - show Month = "month" - show NextMonthPreviousTwoWeeks = "next_month_and_previous_two_weeks" - --- | Where to filter a search within -data IssueSearchIn - = JustTitle - | JustDescription - | TitleAndDescription - -instance Show IssueSearchIn where - show JustTitle = "title" - show JustDescription = "description" - show TitleAndDescription = "title,description" - --- | Ordering search results -data IssueOrderBy - = CreatedAt - | UpdatedAt - | Priority - | DueDate - | RelativePosition - | LabelPriority - | MilestoneDue - | Popularity - | Weight - -instance Show IssueOrderBy where - show CreatedAt = "created_at" - show UpdatedAt = "updated_at" - show Priority = "priority" - show DueDate = "due_date" - show RelativePosition = "relative_position" - show LabelPriority = "label_priority" - show MilestoneDue = "milestone_due" - show Popularity = "popularity" - show Weight = "weight" - --- | Scope of issue search results -data IssueScope - = CreatedByMe - | AssignedToMe - | All - -instance Show IssueScope where - show CreatedByMe = "created_by_me" - show AssignedToMe = "assigned_to_me" - show All = "all" - --- | Sort issues in ascending or descending order -data IssueSortBy - = Ascending - | Descending - -instance Show IssueSortBy where - show Ascending = "asc" - show Descending = "desc" - --- | Is a project issues open or closed -data IssueState - = IssueOpen - | IssueClosed +-- | Get a list of a project’s issues +groupIssues :: + -- | the group + Group -> + -- | filter the issues, see https://docs.gitlab.com/ee/api/issues.html#list-issues + IssueAttrs -> + -- the GitLab issues + GitLab [Issue] +groupIssues grp attrs = do + result <- gitlabGetMany urlPath (issuesAttrs attrs) + return (fromRight (error "groupsIssues error") result) + where + urlPath = + T.pack $ + "/groups/" + <> show (group_id grp) + <> "/issues" -instance Show IssueState where - show IssueOpen = "opened" - show IssueClosed = "closed" +-- result <- projectIssues' (project_id p) filters +-- return (fromRight (error "projectIssues error") result) -- | Get a list of a project’s issues projectIssues :: @@ -155,6 +143,319 @@ <> show projectId <> "/issues" +-- | Only for administrators. Get a single issue. +issue :: + -- | issue ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Issue)) +issue issId = + gitlabGetOne urlPath [] + where + urlPath = + T.pack + "/issues/" + <> T.pack (show issId) + +-- | gets all issues create by a user. +userIssues :: + -- | the user + User -> + GitLab [Issue] +userIssues usr = + fromRight (error "userIssues error") <$> gitlabGetMany addr params + where + addr = "/issues" + params :: [GitLabParam] + params = + [ ("author_id", Just (T.encodeUtf8 (T.pack (show (user_id usr))))), + ("scope", Just "all") + ] + +-- | Get a single project issue. If the project is private or the +-- issue is confidential, you need to provide credentials to +-- authorize. +projectIssue :: + -- | Project + Project -> + -- | issue ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Issue)) +projectIssue p issId = + gitlabGetOne urlPath [] + where + urlPath = + T.pack + "/project/" + <> T.pack (show (project_id p)) + <> "/issues/" + <> T.pack (show issId) + +-- | create a new issue. +newIssue :: + -- | project + Project -> + -- | issue title + Text -> + -- | issue description + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Issue)) +newIssue project = + newIssue' (project_id project) + +-- | create a new issue. +newIssue' :: + -- | project ID + Int -> + -- | issue title + Text -> + -- | issue description + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Issue)) +newIssue' projectId issueTitle issueDescription = + gitlabPost addr dataBody + where + dataBody :: [GitLabParam] + dataBody = + [ ("title", Just (T.encodeUtf8 issueTitle)), + ("description", Just (T.encodeUtf8 issueDescription)) + ] + addr = + "/projects/" + <> T.pack (show projectId) + <> "/issues" + +-- | edits an issue. see +editIssue :: + Project -> + -- | issue ID + IssueId -> + EditIssueReq -> + GitLab (Either (Response BSL.ByteString) Issue) +editIssue prj issueId editIssueReq = do + let urlPath = + "/projects/" <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueId) + result <- + gitlabPut + urlPath + (editIssuesAttrs editIssueReq) + case result of + Left resp -> return (Left resp) + Right Nothing -> error "editIssue error" + Right (Just iss) -> return (Right iss) + +-- | deletes an issue. see +deleteIssue :: + Project -> + -- | issue ID + IssueId -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteIssue prj issueId = do + gitlabDelete issueAddr [] + where + issueAddr :: Text + issueAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueId) + +-- | edits an issue. see +reorderIssue :: + Project -> + -- | issue ID + IssueId -> + -- | The ID of a project’s issue that should be placed after this + -- issue + Int -> + -- | The ID of a project’s issue that should be placed before this + -- issue + Int -> + GitLab (Either (Response BSL.ByteString) Issue) +reorderIssue prj issueId moveAfterId moveBeforeId = do + let urlPath = + "/projects/" <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueId) + <> "/reorder" + result <- + gitlabPut + urlPath + [ ("move_after_id", Just (T.encodeUtf8 (T.pack (show moveAfterId)))), + ("move_before_id", Just (T.encodeUtf8 (T.pack (show moveBeforeId)))) + ] + case result of + Left resp -> return (Left resp) + Right Nothing -> error "reorderIssue error" + Right (Just iss) -> return (Right iss) + +-- | Moves an issue to a different project. If a given label or +-- milestone with the same name also exists in the target project, +-- it’s then assigned to the issue being moved. +moveIssue :: + -- | project + Project -> + -- | The internal ID of a project’s issue + IssueId -> + -- | The ID of the new project + ProjectId -> + GitLab (Either (Response BSL.ByteString) (Maybe Issue)) +moveIssue prj issueId toPrjId = + gitlabPost addr dataBody + where + dataBody :: [GitLabParam] + dataBody = + [ ("to_project_id", Just (T.encodeUtf8 (T.pack (show toPrjId)))) + ] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueId) + <> "/move" + +-- | Clone the issue to given project. Copies as much data as possible +-- as long as the target project contains equivalent labels, +-- milestones, and so on. +cloneIssue :: + -- | project + Project -> + -- | The internal ID of a project’s issue + IssueId -> + -- | The ID of the new project + ProjectId -> + GitLab (Either (Response BSL.ByteString) (Maybe Issue)) +cloneIssue prj issueId toPrjId = + gitlabPost addr dataBody + where + dataBody :: [GitLabParam] + dataBody = + [ ("to_project_id", Just (T.encodeUtf8 (T.pack (show toPrjId)))) + ] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueId) + <> "/clone" + +-- | Subscribes the authenticated user to an issue to receive +-- notifications. +subscribeIssue :: + -- | project + Project -> + -- | The internal ID of a project’s issue + IssueId -> + GitLab (Either (Response BSL.ByteString) (Maybe Issue)) +subscribeIssue prj issueId = + gitlabPost addr dataBody + where + dataBody :: [GitLabParam] + dataBody = + [] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueId) + <> "/subscribe" + +-- | Unsubscribes the authenticated user from the issue to not receive +-- notifications from it. +unsubscribeIssue :: + -- | project + Project -> + -- | The internal ID of a project’s issue + IssueId -> + GitLab (Either (Response BSL.ByteString) (Maybe Issue)) +unsubscribeIssue prj issueId = + gitlabPost addr dataBody + where + dataBody :: [GitLabParam] + dataBody = + [] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueId) + <> "/unsubscribe" + +-- | Get all the merge requests that are related to the issue. +createTodo :: + -- | project + Project -> + -- | The internal ID of a project’s issue + IssueId -> + GitLab (Either (Response BSL.ByteString) (Maybe Todo)) +createTodo prj issueId = + gitlabPost addr dataBody + where + dataBody :: [GitLabParam] + dataBody = + [] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueId) + <> "/todo" + +-- | Get all the merge requests that are related to the issue. +issueMergeRequests :: + -- | project + Project -> + -- | The internal ID of a project’s issue + IssueId -> + GitLab (Either (Response BSL.ByteString) [MergeRequest]) +issueMergeRequests prj issueId = do + gitlabGetMany urlPath [] + where + urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/issues/" + <> show issueId + <> "/related_merge_requests" + +-- | get all merge requests that close a particular issue when merged. +issueMergeRequestsThatClose :: + -- | project + Project -> + -- | The internal ID of a project’s issue + IssueId -> + GitLab (Either (Response BSL.ByteString) [MergeRequest]) +issueMergeRequestsThatClose prj issueId = do + gitlabGetMany urlPath [] + where + urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/issues/" + <> show issueId + <> "/closed_by" + +-- | get all merge requests that close a particular issue when merged. +issueParticipants :: + -- | project + Project -> + -- | The internal ID of a project’s issue + IssueId -> + GitLab (Either (Response BSL.ByteString) [User]) +issueParticipants prj issueId = do + gitlabGetMany urlPath [] + where + urlPath = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/issues/" + <> show issueId + <> "/participants" + -- | Gets issues count statistics on all issues the authenticated user has access to. issueStatisticsUser :: -- | filter the issues, see https://docs.gitlab.com/ee/api/issues_statistics.html#get-issues-statistics @@ -165,7 +466,7 @@ gitlabUnsafe (gitlabGetOne urlPath (issuesAttrs attrs)) where urlPath = - T.pack $ + T.pack "/issues_statistics" -- | Gets issues count statistics for a given group. @@ -209,7 +510,7 @@ -- | the issue statistics GitLab IssueStatistics issueStatisticsProject proj filters = do - result <- issueStatisticsGroup' (project_id proj) filters + result <- issueStatisticsProject' (project_id proj) filters case result of Left _s -> error "issueStatisticsProject error" Right Nothing -> error "issueStatisticsProject error" @@ -232,75 +533,6 @@ <> show projId <> "/issues_statistics" --- | gets all issues create by a user. -userIssues :: - -- | the user - User -> - GitLab [Issue] -userIssues usr = - fromRight (error "userIssues error") <$> gitlabGetMany addr params - where - addr = "/issues" - params :: [GitLabParam] - params = - [ ("author_id", Just (T.encodeUtf8 (T.pack (show (user_id usr))))), - ("scope", Just "all") - ] - --- | create a new issue. -newIssue :: - -- | project - Project -> - -- | issue title - Text -> - -- | issue description - Text -> - GitLab (Either (Response BSL.ByteString) (Maybe Issue)) -newIssue project = - newIssue' (project_id project) - --- | create a new issue. -newIssue' :: - -- | project ID - Int -> - -- | issue title - Text -> - -- | issue description - Text -> - GitLab (Either (Response BSL.ByteString) (Maybe Issue)) -newIssue' projectId issueTitle issueDescription = - gitlabPost addr dataBody - where - dataBody :: [GitLabParam] - dataBody = - [ ("title", Just (T.encodeUtf8 issueTitle)), - ("description", Just (T.encodeUtf8 issueDescription)) - ] - addr = - "/projects/" - <> T.pack (show projectId) - <> "/issues" - --- | edits an issue. see -editIssue :: - ProjectId -> - IssueId -> - EditIssueReq -> - GitLab (Either (Response BSL.ByteString) Issue) -editIssue projId issueId editIssueReq = do - let urlPath = - "/projects/" <> T.pack (show projId) - <> "/issues/" - <> T.pack (show issueId) - result <- - gitlabPut - urlPath - (editIssuesAttrs editIssueReq) - case result of - Left resp -> return (Left resp) - Right Nothing -> error "editIssue error" - Right (Just issue) -> return (Right issue) - -- | Attributes related to a project issue data IssueAttrs = IssueAttrs { issueFilter_assignee_id :: Maybe Int, @@ -312,17 +544,17 @@ issueFilter_created_before :: Maybe UTCTime, issueFilter_due_date :: Maybe DueDate, issueFilter_iids :: Maybe Int, - issueFilter_in :: Maybe IssueSearchIn, + issueFilter_in :: Maybe SearchIn, issueFilter_iteration_id :: Maybe Int, issueFilter_iteration_title :: Maybe String, issueFilter_milestone :: Maybe String, issueFilter_labels :: Maybe String, issueFilter_my_reaction_emoji :: Maybe String, issueFilter_non_archived :: Maybe Bool, - issueFilter_order_by :: Maybe IssueOrderBy, - issueFilter_scope :: Maybe IssueScope, + issueFilter_order_by :: Maybe OrderBy, + issueFilter_scope :: Maybe Scope, issueFilter_search :: Maybe String, - issueFilter_sort :: Maybe IssueSortBy, + issueFilter_sort :: Maybe SortBy, issueFilter_state :: Maybe IssueState, issueFilter_updated_after :: Maybe UTCTime, issueFilter_updated_before :: Maybe UTCTime, @@ -344,7 +576,7 @@ -- TODO -- (\ts -> Just ("labels", textToBS (T.pack (show i)))) =<< edit_issue_labels filters, (\t -> Just ("state_event", textToBS t)) =<< edit_issue_state_event filters, - (\t -> Just ("updated_at", textToBS t)) =<< edit_issue_updated_at filters, + (\d -> Just ("updated_at", stringToBS (show d))) =<< edit_issue_updated_at filters, (\t -> Just ("due_date", textToBS t)) =<< edit_issue_due_date filters, (\i -> Just ("weight", textToBS (T.pack (show i)))) =<< edit_issue_weight filters, (\b -> Just ("discussion_locked", textToBS (showBool b))) =<< edit_issue_discussion_locked filters, @@ -353,6 +585,7 @@ ] where textToBS = Just . T.encodeUtf8 + stringToBS = Just . T.encodeUtf8 . T.pack showBool :: Bool -> Text showBool True = "true" showBool False = "false" @@ -363,7 +596,7 @@ [ (\i -> Just ("assignee_id", textToBS (T.pack (show i)))) =<< issueFilter_assignee_id filters, (\t -> Just ("assignee_username", textToBS (T.pack t))) =<< issueFilter_assignee_username filters, (\i -> Just ("author_id", textToBS (T.pack (show i)))) =<< issueFilter_author_id filters, - (\i -> Just ("author_username", textToBS ((T.pack (show i))))) =<< issueFilter_author_username filters, + (\i -> Just ("author_username", textToBS (T.pack (show i)))) =<< issueFilter_author_username filters, (\b -> Just ("confidential", textToBS (showBool b))) =<< issueFilter_confidential filters, (\t -> Just ("created_after", textToBS (showTime t))) =<< issueFilter_created_after filters, (\t -> Just ("created_before", textToBS (showTime t))) =<< issueFilter_created_before filters, @@ -392,3 +625,32 @@ showBool False = "false" showTime :: UTCTime -> Text showTime = T.pack . iso8601Show + +-- | When an issue is due +data DueDate + = NoDueDate + | Overdue + | Week + | Month + | NextMonthPreviousTwoWeeks + +instance Show DueDate where + show NoDueDate = "0" + show Overdue = "overdue" + show Week = "week" + show Month = "month" + show NextMonthPreviousTwoWeeks = "next_month_and_previous_two_weeks" + +-- | Is a project issues open or closed +data IssueState + = IssueOpen + | IssueClosed + +instance Show IssueState where + show IssueOpen = "opened" + show IssueClosed = "closed" + +-- | No issue filters, thereby returning all issues. Default scope is "all". +defaultIssueFilters :: IssueAttrs +defaultIssueFilters = + IssueAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just All) Nothing Nothing Nothing Nothing Nothing Nothing diff --git a/src/GitLab/API/Jobs.hs b/src/GitLab/API/Jobs.hs --- a/src/GitLab/API/Jobs.hs +++ b/src/GitLab/API/Jobs.hs @@ -7,8 +7,33 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Jobs where +module GitLab.API.Jobs + ( -- * List project jobs + jobs, + -- * List pipeline jobs + pipelineJobs, + + -- * List pipeline bridges + pipelineBridges, + + -- * Get a single job + job, + + -- * Cancel a job + cancelJob, + + -- * Retry a job + retryJob, + + -- * Erase a job + eraseJob, + + -- * Run a job + runJob, + ) +where + import qualified Data.ByteString.Lazy as BSL import Data.Either import qualified Data.Text as T @@ -25,7 +50,8 @@ result <- jobs' (project_id project) return (fromRight (error "jobs error") result) --- | returns all jobs ran on a project given its project ID. +-- | Get a list of jobs in a project. Jobs are sorted in descending +-- order of their IDs. jobs' :: -- | the project ID Int -> @@ -37,3 +63,121 @@ "/projects/" <> T.pack (show projectId) <> "/jobs" + +-- | Get a list of jobs for a pipeline. +pipelineJobs :: + -- | the project + Project -> + -- | pipeline ID + Int -> + GitLab (Either (Response BSL.ByteString) [Job]) +pipelineJobs prj pipelineId = + gitlabGetMany addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/pipelines/" + <> T.pack (show pipelineId) + <> "/jobs" + +-- | Get a list of bridge jobs for a pipeline. +pipelineBridges :: + -- | the project + Project -> + -- | pipeline ID + Int -> + GitLab (Either (Response BSL.ByteString) [Job]) +pipelineBridges prj pipelineId = + gitlabGetMany addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/pipelines/" + <> T.pack (show pipelineId) + <> "/bridges" + +-- | Get a single job of a project. +job :: + -- | the project + Project -> + -- | job ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Job)) +job prj jobId = + gitlabGetOne addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/jobs/" + <> T.pack (show jobId) + +-- | Cancel a single job of a project. +cancelJob :: + -- | the project + Project -> + -- | job ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Job)) +cancelJob prj jobId = + gitlabPost addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/jobs/" + <> T.pack (show jobId) + <> "/cancel" + +-- | Retry a single job of a project. +retryJob :: + -- | the project + Project -> + -- | job ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Job)) +retryJob prj jobId = + gitlabPost addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/jobs/" + <> T.pack (show jobId) + <> "/cancel" + +-- | Retry a single job of a project. +eraseJob :: + -- | the project + Project -> + -- | job ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Job)) +eraseJob prj jobId = + gitlabPost addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/jobs/" + <> T.pack (show jobId) + <> "/erase" + +-- | Triggers a manual action to start a job. +runJob :: + -- | the project + Project -> + -- | job ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Job)) +runJob prj jobId = + gitlabPost addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/jobs/" + <> T.pack (show jobId) + <> "/play" diff --git a/src/GitLab/API/Members.hs b/src/GitLab/API/Members.hs --- a/src/GitLab/API/Members.hs +++ b/src/GitLab/API/Members.hs @@ -3,7 +3,7 @@ -- | -- Module : Members --- Description : Queries about and updates to members of projects +-- Description : Queries about and updates to members of projects and groups -- Copyright : (c) Rob Stewart, Heriot-Watt University, 2021 -- License : BSD3 -- Maintainer : robstewart57@gmail.com @@ -14,41 +14,48 @@ -- * Projects -- * Project membership + memberOfProject, membersOfProject, - membersOfProject', + memberOfProjectWithInherited, + membersOfProjectWithInherited, -- ** Adding project members addMemberToProject, - addMemberToProject', addMembersToProject, - addMembersToProject', + -- ** Editing project members + editMemberOfProject, + -- ** Removing project members removeUserFromProject, - removeUserFromProject', -- * Groups -- * Group membership + memberOfGroup, membersOfGroup, - membersOfGroup', + memberOfGroupWithInherited, + membersOfGroupWithInherited, -- ** Adding group members addAllUsersToGroup, addUserToGroup, - addUserToGroup', addUsersToGroup, - addUsersToGroup', + -- ** Editing group members + editMemberOfGroup, + -- ** Removing group members removeUserFromGroup, - removeUserFromGroup', + + -- ** Pending members + approvePendingMember, + approveAllPendingMembers, + pendingMembers, ) where import qualified Data.ByteString.Lazy as BSL -import Data.Either -import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -59,67 +66,104 @@ import Network.HTTP.Client import Network.HTTP.Types.URI --- | the access levels for project members. See -data AccessLevel - = Guest - | Reporter - | Developer - | Maintainer - | Owner +----------- +-- projects +----------- -instance Show AccessLevel where - show Guest = "10" - show Reporter = "20" - show Developer = "30" - show Maintainer = "40" - show Owner = "50" +-- | Gets a list of project members viewable by the authenticated +-- user. Returns only direct members and not inherited members through +-- ancestors groups. +membersOfProject :: Project -> GitLab (Either (Response BSL.ByteString) [Member]) +membersOfProject prj = + gitlabGetMany addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/members" --- | the members of a project. -membersOfProject :: Project -> GitLab [Member] -membersOfProject p = do - result <- membersOfProject' (project_id p) - return (fromRight (error "membersOfProject error") result) +-- | Gets a list of project members viewable by the authenticated +-- user, including inherited members, invited users, and permissions +-- through ancestor groups. +-- +-- If a user is a member of this project and also of one or more +-- ancestor groups, only its membership with the highest access_level +-- is returned. This represents the effective permission of the user. +-- +-- Members from an invited group are returned if either: the invited +-- group is public, or the requester is also a member of the invited group. +membersOfProjectWithInherited :: Project -> GitLab (Either (Response BSL.ByteString) [Member]) +membersOfProjectWithInherited prj = + gitlabGetMany addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/members" + <> "/all" --- | the members of a project given its ID. -membersOfProject' :: Int -> GitLab (Either (Response BSL.ByteString) [Member]) -membersOfProject' projectId = - membersOfEntity' projectId "projects" +-- | Gets a member of a project. Returns only direct members and not +-- inherited members through ancestor groups. +memberOfProject :: + -- | The project + Project -> + -- | The user ID of the member + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Member)) +memberOfProject prj usrId = + gitlabGetOne addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/members/" + <> T.pack (show usrId) --- | adds a user to a project with the given access level. Returns --- 'Right Member' for each successful action, otherwise it returns --- 'Left Status'. -addMemberToProject :: - -- | the project +-- | Gets a member of a project, including members inherited or +-- invited through ancestor groups. +-- +-- If a user is a member of this project and also of one or more +-- ancestor groups, only its membership with the highest access_level +-- is returned. This represents the effective permission of the user. +-- +-- Members from an invited group are returned if either: the invited +-- group is public, or the requester is also a member of the invited +-- group. +memberOfProjectWithInherited :: + -- | The project Project -> - -- | level of access - AccessLevel -> - -- | the user - User -> + -- | The user ID of the member + Int -> GitLab (Either (Response BSL.ByteString) (Maybe Member)) -addMemberToProject project access usr = - addMemberToProject' (project_id project) access (user_id usr) +memberOfProjectWithInherited prj usrId = + gitlabGetOne addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/members" + <> "/all/" + <> T.pack (show usrId) --- | adds a user to a project with the given access level, given the --- project's ID and the user's ID. Returns @Right Member@ for each --- successful action, otherwise it returns @Left Status@. -addMemberToProject' :: +-- | Adds a member to a project. +addMemberToProject :: -- | project ID - Int -> + Project -> -- | level of access AccessLevel -> -- | user ID - Int -> + User -> GitLab (Either (Response BSL.ByteString) (Maybe Member)) -addMemberToProject' projectId access usrId = +addMemberToProject prj access usr = gitlabPost addr params where params :: [GitLabParam] params = - [ ("user_id", Just (T.encodeUtf8 (T.pack (show usrId)))), + [ ("user_id", Just (T.encodeUtf8 (T.pack (show (user_id usr))))), ("access_level", Just (T.encodeUtf8 (T.pack (show access)))) ] addr = - "/projects/" <> T.pack (show projectId) <> "/members" + "/projects/" <> T.pack (show (project_id prj)) <> "/members" -- | adds a list of users to a project with the given access -- level. Returns 'Right Member' for each successful action, otherwise @@ -135,153 +179,264 @@ addMembersToProject project access = mapM (addMemberToProject project access) --- | adds a list of users to a project with the given access level, --- given the project's ID and the user IDs. Returns @Right Member@ for --- each successful action, otherwise it returns @Left Status@. -addMembersToProject' :: - -- | project ID - Int -> - -- | level of acces +-- | Updates a member of a project. +editMemberOfProject :: + -- | the project + Project -> + -- | the new level of access AccessLevel -> - -- | IDs of users to add to the project - [Int] -> - GitLab [Either (Response BSL.ByteString) (Maybe Member)] -addMembersToProject' projectId access = - mapM (addMemberToProject' projectId access) + -- | user ID + User -> + GitLab (Either (Response BSL.ByteString) (Maybe Member)) +editMemberOfProject prj access usr = + gitlabPut addr params + where + params :: [GitLabParam] + params = + [ ("access_level", Just (T.encodeUtf8 (T.pack (show access)))) + ] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/members/" + <> T.pack (show (user_id usr)) --- | the members of a group. -membersOfGroup :: Group -> GitLab [Member] -membersOfGroup p = do - result <- membersOfGroup' (group_id p) - return (fromRight (error "membersOfGroup error") result) +--------- +-- groups +--------- --- | the members of a group given its ID. -membersOfGroup' :: Int -> GitLab (Either (Response BSL.ByteString) [Member]) -membersOfGroup' projectId = - membersOfEntity' projectId "groups" +-- | Gets a list of group members viewable by the authenticated +-- user. Returns only direct members and not inherited members through +-- ancestors groups. +membersOfGroup :: Group -> GitLab (Either (Response BSL.ByteString) [Member]) +membersOfGroup grp = + gitlabGetMany addr [] + where + addr = + "/groups/" + <> T.pack (show (group_id grp)) + <> "/members" +-- | Gets a member of a group. Returns only direct members +-- and not inherited members through ancestor groups. +memberOfGroup :: + -- | The group + Group -> + -- | The user ID of the member + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Member)) +memberOfGroup grp usrId = + gitlabGetOne addr [] + where + addr = + "/projects/" + <> T.pack (show (group_id grp)) + <> "/members/" + <> T.pack (show usrId) + +-- | Gets a member of a group, including members inherited or invited +-- through ancestor groups. +-- +-- If a user is a member of this group and also of one or more +-- ancestor groups, only its membership with the highest access_level +-- is returned. This represents the effective permission of the user. +-- +-- Members from an invited group are returned if either: the invited +-- group is public, or the requester is also a member of the invited +-- group. +memberOfGroupWithInherited :: + -- | The group + Group -> + -- | The user ID of the member + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Member)) +memberOfGroupWithInherited prj usrId = + gitlabGetOne addr [] + where + addr = + "/groups/" + <> T.pack (show (group_id prj)) + <> "/members" + <> "/all/" + <> T.pack (show usrId) + +-- | Gets a list of group members viewable by the authenticated +-- user, including inherited members, invited users, and permissions +-- through ancestor groups. +-- +-- If a user is a member of this group and also of one or more +-- ancestor groups, only its membership with the highest access_level +-- is returned. This represents the effective permission of the user. +-- +-- Members from an invited group are returned if either: the invited +-- group is public, or the requester is also a member of the invited group. +membersOfGroupWithInherited :: Group -> GitLab (Either (Response BSL.ByteString) [Member]) +membersOfGroupWithInherited prj = + gitlabGetMany addr [] + where + addr = + "/groups/" + <> T.pack (show (group_id prj)) + <> "/members" + <> "/all" + -- | adds all registered users to a group. addAllUsersToGroup :: - -- | group name - Text -> + -- | the group + Group -> -- | level of access granted AccessLevel -> GitLab [Either (Response BSL.ByteString) (Maybe Member)] -addAllUsersToGroup groupName access = do - allRegisteredUsers <- allUsers - let allUserIds = map user_username allRegisteredUsers - addUsersToGroup' groupName access allUserIds +addAllUsersToGroup grp access = do + allRegisteredUsers <- users + addUsersToGroup grp access allRegisteredUsers --- | adds a user to a group. +-- | Adds a member to a group. addUserToGroup :: - -- | group name - Text -> + -- | the group + Group -> -- | level of access granted AccessLevel -> -- | the user User -> GitLab (Either (Response BSL.ByteString) (Maybe Member)) -addUserToGroup groupName access usr = - addUserToGroup' groupName access (user_id usr) - --- | adds a user with a given user ID to a group. -addUserToGroup' :: - -- | group name - Text -> - -- | level of access granted - AccessLevel -> - -- | user ID - Int -> - GitLab (Either (Response BSL.ByteString) (Maybe Member)) -addUserToGroup' groupName access usrId = do - attempt <- groupsWithNameOrPath groupName - case attempt of - Left resp -> return (Left resp) - Right [] -> - return (Right Nothing) - Right [grp] -> - gitlabPost addr params - where - params :: [GitLabParam] - params = - [ ("user_id", Just (T.encodeUtf8 (T.pack (show usrId)))), - ("access_level", Just (T.encodeUtf8 (T.pack (show access)))) - ] - addr = - "/groups/" - <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (T.pack (show (group_id grp))))) - <> "/members" - Right (_ : _) -> - return (Right Nothing) +addUserToGroup grp access usr = do + gitlabPost addr params + where + params :: [GitLabParam] + params = + [ ("user_id", Just (T.encodeUtf8 (T.pack (show (user_id usr))))), + ("access_level", Just (T.encodeUtf8 (T.pack (show access)))) + ] + addr = + "/groups/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (T.pack (show (group_id grp))))) + <> "/members" -- | adds a list of users to a group. addUsersToGroup :: - -- | group name - Text -> + -- | the group + Group -> -- | level of access granted AccessLevel -> -- | list of usernames to be added to the group [User] -> GitLab [Either (Response BSL.ByteString) (Maybe Member)] -addUsersToGroup groupName access = - mapM (addUserToGroup groupName access) +addUsersToGroup grp access = + mapM (addUserToGroup grp access) --- | adds a list of users to a group. -addUsersToGroup' :: - -- | group name - Text -> - -- | level of access granted +-- | Updates a member of a group. +editMemberOfGroup :: + -- | the group + Group -> + -- | the new level of access AccessLevel -> - -- | list of usernames to be added to the group - [Text] -> - GitLab [Either (Response BSL.ByteString) (Maybe Member)] -addUsersToGroup' groupName access usernames = do - users <- catMaybes <$> mapM searchUser usernames - mapM (addUserToGroup' groupName access . user_id) users + -- | user ID + User -> + GitLab (Either (Response BSL.ByteString) (Maybe Member)) +editMemberOfGroup grp access usr = + gitlabPut addr params + where + params :: [GitLabParam] + params = + [ ("access_level", Just (T.encodeUtf8 (T.pack (show access)))) + ] + addr = + "/groups/" + <> T.pack (show (group_id grp)) + <> "/members/" + <> T.pack (show (user_id usr)) --- | Removes a user from a project where the user has been explicitly assigned a role +-- | Removes a user from a project where the user has been explicitly +-- assigned a role. +-- +-- The user needs to be a group member to qualify for removal. For +-- example, if the user was added directly to a project within the +-- group but not this group explicitly, you cannot use this API to +-- remove them. removeUserFromProject :: - -- | project name - Text -> + -- | the project + Project -> -- | user User -> GitLab (Either (Response BSL.ByteString) (Maybe ())) -removeUserFromProject grpName usr = - removeUserFromEntity grpName "projects" usr - --- | Removes a user from a project where the user has been explicitly assigned a role -removeUserFromProject' :: - -- | project name - Text -> - -- | user ID - Int -> - GitLab (Either (Response BSL.ByteString) (Maybe ())) -removeUserFromProject' grpName usrId = - removeUserFromEntity' grpName "projects" usrId +removeUserFromProject prj = + removeUserFromEntity (project_name prj) "projects" --- | Removes a user from a group where the user has been explicitly assigned a role +-- | Removes a user from a group where the user has been explicitly +-- assigned a role. +-- +-- The user needs to be a group member to qualify for removal. For +-- example, if the user was added directly to a project within the +-- group but not this group explicitly, you cannot use this API to +-- remove them. removeUserFromGroup :: - -- | group name - Text -> + -- | the group + Group -> -- | user User -> GitLab (Either (Response BSL.ByteString) (Maybe ())) -removeUserFromGroup grpName usr = - removeUserFromEntity grpName "groups" usr +removeUserFromGroup grp = + removeUserFromEntity (group_name grp) "groups" --- | Removes a user from a group where the user has been explicitly assigned a role -removeUserFromGroup' :: - -- | group name - Text -> - -- | user ID - Int -> - GitLab (Either (Response BSL.ByteString) (Maybe ())) -removeUserFromGroup' grpName usrId = - removeUserFromEntity' grpName "groups" usrId +-- | Approves a pending user for a group and its subgroups and +-- projects. +approvePendingMember :: + -- | the group + Group -> + -- | the member + User -> + GitLab (Either (Response BSL.ByteString) (Maybe Member)) +approvePendingMember grp usr = + gitlabPut addr [] + where + addr = + "/groups/" + <> T.pack (show (group_id grp)) + <> "/members/" + <> T.pack (show (user_id usr)) + <> "/approve" ------------------------ --- Internal functions. +-- | Approves all pending users for a group and its subgroups and +-- projects. +approveAllPendingMembers :: + -- | the group + Group -> + GitLab (Either (Response BSL.ByteString) (Maybe Member)) +approveAllPendingMembers grp = + gitlabPut addr [] + where + addr = + "/groups/" + <> T.pack (show (group_id grp)) + <> "/members/" + <> "/approve_all" +-- | For a group and its subgroups and projects, get a list of all +-- members in an awaiting state and those who are invited but do not +-- have a GitLab account. This request returns all matching group and +-- project members from all groups and projects in the root group’s +-- hierarchy. When the member is an invited user that has not signed +-- up for a GitLab account yet, the invited email address is +-- returned. This API endpoint works on top-level groups only. It does +-- not work on subgroups. This API endpoint requires permission to +-- administer members for the group. +pendingMembers :: + -- | the group + Group -> + GitLab (Either (Response BSL.ByteString) [Member]) +pendingMembers grp = + gitlabGetMany addr [] + where + addr = + "/groups/" + <> T.pack (show (group_id grp)) + <> "/pending_members" + +--------------------- +-- Internal functions +--------------------- + -- | removes a user from a group or project. removeUserFromEntity :: -- | group name @@ -304,13 +459,12 @@ Int -> GitLab (Either (Response BSL.ByteString) (Maybe ())) removeUserFromEntity' groupName entity usrId = do - attempt <- groupsWithNameOrPath groupName + attempt <- groups (defaultListGroupsFilters {listGroupsFilter_search = Just groupName}) case attempt of - Left resp -> return (Left resp) - Right [] -> + [] -> return (Right Nothing) - Right [grp] -> do - result <- gitlabDelete addr + [grp] -> do + result <- gitlabDelete addr [] case result of Left err -> return (Left err) -- GitLab version 14.2.3 returns Version JSON info when a @@ -326,22 +480,5 @@ <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (T.pack (show (group_id grp))))) <> "/members/" <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (T.pack (show usrId)))) - Right (_ : _) -> + (_ : _) -> return (Right Nothing) - --- | the members of a project given its ID. -membersOfEntity' :: - -- | group or project ID - Int -> - -- | entity ("groups" or "projects") - Text -> - GitLab (Either (Response BSL.ByteString) [Member]) -membersOfEntity' projectId entity = - gitlabGetMany addr [] - where - addr = - "/" - <> entity - <> "/" - <> T.pack (show projectId) - <> "/members" diff --git a/src/GitLab/API/MergeRequests.hs b/src/GitLab/API/MergeRequests.hs --- a/src/GitLab/API/MergeRequests.hs +++ b/src/GitLab/API/MergeRequests.hs @@ -7,13 +7,59 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.MergeRequests where +module GitLab.API.MergeRequests + ( -- * List merge requests + mergeRequests, + mergeRequestsWith, + -- -- * Merge requests list response notes + -- -- * List project merge requests + + -- -- * List group merge requests + + -- * Get single MR + mergeRequest, + -- -- * Single merge request response notes + + -- -- * Get single MR participants + + -- -- * Get single MR reviewers + + -- -- * Get single MR commits + + -- -- * Get single MR changes + + -- -- * List MR pipelines + + -- -- * Create MR Pipeline + + -- * Create MR + createMergeRequest, + -- -- * Update MR + + -- * Accept MR + acceptMergeRequest, + + -- * Delete a merge request + deleteMergeRequest, + + -- * merge request attributes + mrAttrs, + MergeProjectAttrs (..), + MergeRequestState (..), + WIP (..), + ) +where + +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Either +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Time.Clock +import Data.Time.Format.ISO8601 import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client @@ -68,6 +114,47 @@ <> T.pack (show projectId) <> "/merge_requests" +-- | returns the merge requests for a project and a set of search +-- attributes as 'Just' values in 'MergeProjectAttrs'. The 'mrAttrs' +-- value has default merge request search values, which is a record +-- that can be modified with 'Just' values. +-- +-- For example to search only for open merge requests for a project: +-- +-- > mergeRequestsWith myProject (mrAttrs {mr_attr_state = Just MROpened}) +mergeRequestsWith :: + -- | the project + Project -> + -- | merge request search attributes + MergeProjectAttrs -> + GitLab [MergeRequest] +mergeRequestsWith p attrs = do + result <- mergeRequestsWith' (project_id p) attrs + return (fromRight (error "mergeRequests error") result) + +-- | returns the merge requests for a project given its project ID and +-- a set of search attributes as 'Just' values in 'MergeProjectAttrs'. +-- The 'mrAttrs' value has default merge request search values, which +-- is a record that can be modified with 'Just' values. +-- +-- For example to search only for open merge requests for project with +-- ID 11744514: +-- +-- > mergeRequestsWith' 11744514 (mrAttrs {mr_attr_state = Just MROpened}) +mergeRequestsWith' :: + -- | project ID + Int -> + -- | merge request search attributes + MergeProjectAttrs -> + GitLab (Either (Response BSL.ByteString) [MergeRequest]) +mergeRequestsWith' projectId attrs = + gitlabGetMany addr (mrAttrsParams attrs) + where + addr = + "/projects/" + <> T.pack (show projectId) + <> "/merge_requests" + -- | Creates a merge request. createMergeRequest :: -- | project @@ -161,9 +248,181 @@ -- | merge request IID Int -> GitLab (Either (Response BSL.ByteString) (Maybe ())) -deleteMergeRequest' projectId mergeRequestIid = gitlabDelete addr +deleteMergeRequest' projectId mergeRequestIid = gitlabDelete addr [] where addr = T.pack $ "/projects/" <> show projectId <> "/merge_requests/" <> show mergeRequestIid + +-- | Attributes when searching for merge requests with the +-- 'mergeRequestsWith' functions. +data MergeProjectAttrs = MergeProjectAttrs + { -- | Return all merge requests or just those that are opened, + -- closed, locked, or merged. + mr_attr_state :: Maybe MergeRequestState, + -- | Return requests ordered by created_at or updated_at + -- fields. Default is created_at. Note that the 'OrderBy' type has + -- more options, but only 'CreatedAt' and 'UpdatedAt' are + -- applicable for ordering merge requests. + mr_attr_order_by :: Maybe OrderBy, + -- | Return requests sorted in asc or desc order. Default is desc. + mr_attr_sort :: Maybe SortBy, + -- | Return merge requests for a specific milestone. None returns + -- merge requests with no milestone. Any returns merge requests + -- that have an assigned milestone. + mr_attr_milestone :: Maybe Milestone, + -- -- | If simple, returns the iid, URL, title, description, and + -- -- basic state of merge request. + -- merge_request_view :: Maybe MergeRequestView, + + -- | Return merge requests matching a comma separated list of + -- labels. + mr_attr_labels :: Maybe Text, + -- | If true, response returns more details for each label in + -- labels field: :name, :color, :description, :description_html, + -- :text_color. Default is false. + mr_attr_with_labels_details :: Maybe Bool, + -- | If true, this projection requests (but does not guarantee) + -- that the merge_status field be recalculated + -- asynchronously. Default is false. + mr_attr_with_merge_status_recheck :: Maybe Bool, + -- | Return merge requests created on or after the given time. + mr_attr_created_after :: Maybe UTCTime, + -- | Return merge requests created on or before the given time. + mr_attr_created_before :: Maybe UTCTime, + -- | Return merge requests updated on or after the given time. + mr_attr_updated_after :: Maybe UTCTime, + -- | Return merge requests updated on or before the given time. + mr_attr_updated_before :: Maybe UTCTime, + -- | Return merge requests for the given scope: created_by_me, + -- assigned_to_me or all. Defaults to created_by_me. + mr_attr_scope :: Maybe Scope, + -- | Returns merge requests created by the given user id. Mutually + -- exclusive with author_username. Combine with scope=all or + -- scope=assigned_to_me. + mr_attr_author_id :: Maybe Int, + -- | Returns merge requests created by the given + -- username. Mutually exclusive with author_id. + mr_attr_author_username :: Maybe Text, + -- | Returns merge requests assigned to the given user id. + mr_attr_assignee_id :: Maybe Int, + -- | Returns merge requests which have specified all the users + -- with the given ids as individual approvers. + mr_attr_approver_ids :: Maybe [Int], + -- | Returns merge requests which have been approved by all the + -- users with the given ids (Max: 5). + mr_attr_approved_by_ids :: Maybe [Int], + -- | Returns merge requests which have the user as a reviewer with + -- the given user id. Mutually exclusive with reviewer_username. + mr_attr_reviewer_id :: Maybe Int, + -- | Returns merge requests which have the user as a reviewer with + -- the given username. Mutually exclusive with reviewer_id. + mr_attr_reviewer_username :: Maybe Text, + -- | Return merge requests reacted by the authenticated user by + -- the given emoji. + mr_attr_my_reaction_emoji :: Maybe Text, + -- | Return merge requests with the given source branch. + mr_attr_source_branch :: Maybe Text, + -- | Return merge requests with the given target branch. + mr_attr_target_branch :: Maybe Text, + -- | Search merge requests against their title and description. + mr_attr_search :: Maybe Text, + -- | Modify the scope of the search attribute. title, description, + -- or a string joining them with comma. Default is + -- title,description. + mr_attr_in :: Maybe SearchIn, + -- | Filter merge requests against their wip status. yes to return + -- only draft merge requests, no to return non-draft merge + -- requests. + mr_attr_wip :: Maybe WIP, + -- -- | Return merge requests that do not match the parameters + -- -- supplied. Accepts: labels, milestone, author_id, + -- -- author_username, assignee_id, assignee_username, reviewer_id, + -- -- reviewer_username, my_reaction_emoji. + -- merge_request_not :: Maybe Text, + + -- | Returns merge requests deployed to the given environment. + mr_attr_environment :: Maybe UTCTime, + -- | Return merge requests deployed before the given date/time. + mr_attr_deployed_before :: Maybe UTCTime, + -- | Return merge requests deployed after the given date/time. + mr_attr_deployed_after :: Maybe UTCTime + } + +-- TODO create types for merge_request_my_reaction_emoji + +-- | for filtering by merge request state. +data MergeRequestState + = -- | return only opened merge requests + MROpened + | -- | return only closed merge requests + MRClosed + | -- | return only locked merge requests + MRLocked + | -- | return only merged merge requests + MRMerged + +instance Show MergeRequestState where + show MROpened = "opened" + show MRClosed = "closed" + show MRLocked = "locked" + show MRMerged = "merged" + +-- | WIP status of merge requests +data WIP + = -- | return only draft merge requests + WIPYes + | -- | return non-draft merge requests + WIPNo + +instance Show WIP where + show WIPYes = "yes" + show WIPNo = "no" + +-- | No merge request search filters, thereby returning all merge requests. Default scope is "all". +mrAttrs :: MergeProjectAttrs +mrAttrs = + MergeProjectAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +mrAttrsParams :: MergeProjectAttrs -> [GitLabParam] +mrAttrsParams attrs = + catMaybes + [ (\x -> Just ("state", showAttr x)) =<< mr_attr_state attrs, + (\x -> Just ("order_by", showAttr x)) =<< mr_attr_order_by attrs, + (\x -> Just ("sort", showAttr x)) =<< mr_attr_sort attrs, + (\x -> Just ("milestone", showAttr x)) =<< mr_attr_milestone attrs, + (\t -> Just ("labels", showAttrT t)) =<< mr_attr_labels attrs, + (\b -> Just ("with_labels_details", showBool b)) =<< mr_attr_with_labels_details attrs, + (\b -> Just ("with_merge_status_recheck", showBool b)) =<< mr_attr_with_merge_status_recheck attrs, + (\t -> Just ("created_after", showTime t)) =<< mr_attr_created_after attrs, + (\t -> Just ("created_before", showTime t)) =<< mr_attr_created_before attrs, + (\t -> Just ("updated_after", showTime t)) =<< mr_attr_updated_after attrs, + (\t -> Just ("updated_before", showTime t)) =<< mr_attr_updated_before attrs, + (\x -> Just ("scope", showAttr x)) =<< mr_attr_scope attrs, + (\i -> Just ("author_id", showAttr i)) =<< mr_attr_author_id attrs, + (\t -> Just ("author_username", showAttrT t)) =<< mr_attr_author_username attrs, + (\i -> Just ("assignee_id", showAttr i)) =<< mr_attr_assignee_id attrs, + (\i -> Just ("approver_ids", showAttr i)) =<< mr_attr_approver_ids attrs, + (\is -> Just ("approved_by_ids", showAttr is)) =<< mr_attr_approved_by_ids attrs, + (\i -> Just ("reviewer_id", showAttr i)) =<< mr_attr_reviewer_id attrs, + (\t -> Just ("reviewer_username", showAttrT t)) =<< mr_attr_reviewer_username attrs, + (\t -> Just ("my_reaction_emoji", showAttrT t)) =<< mr_attr_my_reaction_emoji attrs, + (\t -> Just ("source_branch", showAttrT t)) =<< mr_attr_source_branch attrs, + (\t -> Just ("target_branch", showAttrT t)) =<< mr_attr_target_branch attrs, + (\t -> Just ("search", showAttrT t)) =<< mr_attr_search attrs, + (\x -> Just ("in", showAttr x)) =<< mr_attr_in attrs, + (\x -> Just ("wip", showAttr x)) =<< mr_attr_wip attrs, + (\t -> Just ("environment", showTime t)) =<< mr_attr_environment attrs, + (\t -> Just ("deployed_before", showTime t)) =<< mr_attr_deployed_before attrs, + (\t -> Just ("deployed_after", showTime t)) =<< mr_attr_deployed_after attrs + ] + where + showAttr :: (Show a) => a -> Maybe BS.ByteString + showAttr = Just . T.encodeUtf8 . T.pack . show + showAttrT = Just . T.encodeUtf8 + showBool :: Bool -> Maybe BS.ByteString + showBool True = Just (T.encodeUtf8 (T.pack "true")) + showBool False = Just (T.encodeUtf8 (T.pack "false")) + showTime :: UTCTime -> Maybe BS.ByteString + showTime = Just . T.encodeUtf8 . T.pack . iso8601Show diff --git a/src/GitLab/API/Notes.hs b/src/GitLab/API/Notes.hs --- a/src/GitLab/API/Notes.hs +++ b/src/GitLab/API/Notes.hs @@ -7,9 +7,33 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Notes where +module GitLab.API.Notes + ( -- * Issues + issueNotes, + issueNote, + newIssueNote, + modifyIssueNote, + deleteIssueNote, + -- * Snippets + snippetNotes, + snippetNote, + newSnippetNote, + modifySnippetNote, + deleteSnippetNote, + + -- * Merge Requests + mergeRequestNotes, + mergeRequestNote, + newMergeRequestNote, + modifyMergeRequestNote, + deleteMergeRequestNote, + ) +where + +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -17,38 +41,401 @@ import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client --- | Creates a new note for a single merge request. -createMergeRequestNote :: +-- | Gets a list of all notes for a single issue. +issueNotes :: -- | project Project -> - -- | merge request IID + -- | issue IID Int -> - -- | the note + -- | sort the issues + Maybe SortBy -> + -- | Return issue notes ordered by created_at or updated_at fields + Maybe OrderBy -> + GitLab (Either (Response BSL.ByteString) [Note]) +issueNotes prj issueIid sort order = + gitlabGetMany addr params + where + params :: [GitLabParam] + params = + catMaybes + [ (\x -> Just ("sort", showAttr x)) =<< sort, + (\x -> Just ("order_by", showAttr x)) =<< order + ] + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/issues/" + <> show issueIid + <> "/notes" + showAttr :: (Show a) => a -> Maybe BS.ByteString + showAttr = Just . T.encodeUtf8 . T.pack . show + +-- | Returns a single note for a specific project issue. +issueNote :: + -- | project + Project -> + -- | issue IID + Int -> + -- | note ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Note)) +issueNote prj issueIid noteId = + gitlabGetOne addr params + where + params :: [GitLabParam] + params = [] + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/issues/" + <> show issueIid + <> "/notes/" + <> show noteId + +-- | Creates a new note to a single project issue. +newIssueNote :: + -- | project + Project -> + -- | issue IID + Int -> + -- | the body of the note Text -> + -- | The confidential flag of a note. Default is false. + Maybe Bool -> GitLab (Either (Response BSL.ByteString) (Maybe ())) -createMergeRequestNote project = - createMergeRequestNote' (project_id project) +newIssueNote prj issueIid theNote isConfidential = + gitlabPost addr params + where + params :: [GitLabParam] + params = + catMaybes + [ Just ("body", Just (T.encodeUtf8 theNote)), + (\x -> Just ("confidential", showAttr x)) =<< isConfidential + ] + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/issues/" + <> show issueIid + <> "/notes" + showAttr :: (Show a) => a -> Maybe BS.ByteString + showAttr = Just . T.encodeUtf8 . T.pack . show --- | Creates a new note for a single merge request. -createMergeRequestNote' :: - -- | project ID +-- | Modify existing note of an issue. +modifyIssueNote :: + -- | project + Project -> + -- | issue IID Int -> + -- | note ID + Int -> + -- | the body of the note + Maybe Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Note)) +modifyIssueNote prj issueIid noteId theNote = do + gitlabPut urlPath params + where + urlPath = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/issues/" + <> T.pack (show issueIid) + <> "/notes/" + <> T.pack + (show noteId) + params :: + [GitLabParam] + params = + catMaybes + [ (\x -> Just ("body", Just (T.encodeUtf8 x))) =<< theNote + ] + +-- | Deletes an existing note of an issue. +deleteIssueNote :: + -- | project + Project -> + -- | issue IID + Int -> + -- | note ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteIssueNote prj issueIid noteId = do + gitlabDelete addr [] + where + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/issues/" + <> show issueIid + <> "/notes/" + <> show noteId + +-- | Gets a list of all notes for a single snippet. +snippetNotes :: + -- | project + Project -> + -- | snippet IID + Int -> + -- | sort the snippets + Maybe SortBy -> + -- | Return snippet notes ordered by created_at or updated_at fields + Maybe OrderBy -> + GitLab (Either (Response BSL.ByteString) [Note]) +snippetNotes prj snippetIid sort order = + gitlabGetMany addr params + where + params :: [GitLabParam] + params = + catMaybes + [ (\x -> Just ("sort", showAttr x)) =<< sort, + (\x -> Just ("order_by", showAttr x)) =<< order + ] + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/snippets/" + <> show snippetIid + <> "/notes" + showAttr :: (Show a) => a -> Maybe BS.ByteString + showAttr = Just . T.encodeUtf8 . T.pack . show + +-- | Returns a single note for a specific project snippet. +snippetNote :: + -- | project + Project -> + -- | snippet IID + Int -> + -- | note ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Note)) +snippetNote prj snippetIid noteId = + gitlabGetOne addr params + where + params :: [GitLabParam] + params = [] + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/snippets/" + <> show snippetIid + <> "/notes/" + <> show noteId + +-- | Creates a new note to a single project snippet. +newSnippetNote :: + -- | project + Project -> + -- | snippet IID + Int -> + -- | the body of the note + Text -> + -- | The confidential flag of a note. Default is false. + Maybe Bool -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +newSnippetNote prj snippetIid theNote isConfidential = + gitlabPost addr params + where + params :: [GitLabParam] + params = + catMaybes + [ Just ("body", Just (T.encodeUtf8 theNote)), + (\x -> Just ("confidential", showAttr x)) =<< isConfidential + ] + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/snippets/" + <> show snippetIid + <> "/notes" + showAttr :: (Show a) => a -> Maybe BS.ByteString + showAttr = Just . T.encodeUtf8 . T.pack . show + +-- | Modify existing note of an snippet. +modifySnippetNote :: + -- | project + Project -> + -- | snippet IID + Int -> + -- | note ID + Int -> + -- | the body of the note + Maybe Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Note)) +modifySnippetNote prj snippetIid noteId theNote = do + gitlabPut urlPath params + where + urlPath = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/snippets/" + <> T.pack (show snippetIid) + <> "/notes/" + <> T.pack + (show noteId) + params :: + [GitLabParam] + params = + catMaybes + [ (\x -> Just ("body", Just (T.encodeUtf8 x))) =<< theNote + ] + +-- | Deletes an existing note of an snippet. +deleteSnippetNote :: + -- | project + Project -> + -- | snippet IID + Int -> + -- | note ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteSnippetNote prj snippetIid noteId = do + gitlabDelete addr [] + where + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/snippets/" + <> show snippetIid + <> "/notes/" + <> show noteId + +-- | Gets a list of all notes for a single merge request. +mergeRequestNotes :: + -- | project + Project -> -- | merge request IID Int -> - -- | the note + -- | sort the merge requests + Maybe SortBy -> + -- | Return merge request notes ordered by created_at or updated_at fields + Maybe OrderBy -> + GitLab (Either (Response BSL.ByteString) [Note]) +mergeRequestNotes prj mergeRequestIid sort order = + gitlabGetMany addr params + where + params :: [GitLabParam] + params = + catMaybes + [ (\x -> Just ("sort", showAttr x)) =<< sort, + (\x -> Just ("order_by", showAttr x)) =<< order + ] + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/merge_requests/" + <> show mergeRequestIid + <> "/notes" + showAttr :: (Show a) => a -> Maybe BS.ByteString + showAttr = Just . T.encodeUtf8 . T.pack . show + +-- | Returns a single note for a specific project merge request. +mergeRequestNote :: + -- | project + Project -> + -- | merge request IID + Int -> + -- | note ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Note)) +mergeRequestNote prj mergeRequestIid noteId = + gitlabGetOne addr params + where + params :: [GitLabParam] + params = [] + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/merge_requests/" + <> show mergeRequestIid + <> "/notes/" + <> show noteId + +-- | Creates a new note to a single project merge request. +newMergeRequestNote :: + -- | project + Project -> + -- | merge request IID + Int -> + -- | the body of the note Text -> + -- | The confidential flag of a note. Default is false. + Maybe Bool -> GitLab (Either (Response BSL.ByteString) (Maybe ())) -createMergeRequestNote' projectId mergeRequestIID comment = +newMergeRequestNote prj mergeRequestIid theNote isConfidential = gitlabPost addr params where params :: [GitLabParam] params = - [ ("id", Just (T.encodeUtf8 (T.pack (show projectId)))), - ("merge_request_iid", Just (T.encodeUtf8 (T.pack (show mergeRequestIID)))), - ("body", Just (T.encodeUtf8 comment)) - ] + catMaybes + [ Just ("body", Just (T.encodeUtf8 theNote)), + (\x -> Just ("confidential", showAttr x)) =<< isConfidential + ] addr = T.pack $ - "/projects/" <> show projectId <> "/merge_requests/" - <> show mergeRequestIID + "/projects/" + <> show (project_id prj) + <> "/merge_requests/" + <> show mergeRequestIid <> "/notes" + showAttr :: (Show a) => a -> Maybe BS.ByteString + showAttr = Just . T.encodeUtf8 . T.pack . show + +-- | Modify existing note of an merge request. +modifyMergeRequestNote :: + -- | project + Project -> + -- | merge request IID + Int -> + -- | note ID + Int -> + -- | the body of the note + Maybe Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Note)) +modifyMergeRequestNote prj mergeRequestIid noteId theNote = do + gitlabPut urlPath params + where + urlPath = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/merge_requests/" + <> T.pack (show mergeRequestIid) + <> "/notes/" + <> T.pack + (show noteId) + params :: + [GitLabParam] + params = + catMaybes + [ (\x -> Just ("body", Just (T.encodeUtf8 x))) =<< theNote + ] + +-- | Deletes an existing note of an merge request. +deleteMergeRequestNote :: + -- | project + Project -> + -- | merge request IID + Int -> + -- | note ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteMergeRequestNote prj mergeRequestIid noteId = do + gitlabDelete addr [] + where + addr = + T.pack $ + "/projects/" + <> show (project_id prj) + <> "/merge_requests/" + <> show mergeRequestIid + <> "/notes/" + <> show noteId diff --git a/src/GitLab/API/Pipelines.hs b/src/GitLab/API/Pipelines.hs --- a/src/GitLab/API/Pipelines.hs +++ b/src/GitLab/API/Pipelines.hs @@ -7,16 +7,41 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Pipelines where +module GitLab.API.Pipelines + ( -- * List project pipelines + pipelines, + -- * Get a single pipeline + pipeline, + + -- * Get a pipeline’s test report + pipelineTestReport, + + -- * Create a new pipeline + newPipeline, + + -- * Retry jobs in a pipeline + retryPipeline, + + -- * Cancel a pipeline’s jobs + cancelPipelineJobs, + + -- * Delete a pipeline + deletePipeline, + ) +where + import qualified Data.ByteString.Lazy as BSL import Data.Either +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client --- | returns the pipelines for a project. +-- | List pipelines in a project. Child pipelines are not included in +-- the results, but you can get child pipeline individually. pipelines :: -- | the project Project -> @@ -40,33 +65,113 @@ <> T.pack (show projectId) <> "/pipelines" --- | get a pipeline’s test report. Since GitLab 13.0. -pipelineTestReport :: +-- | Get one pipeline from a project. +pipeline :: -- | the project Project -> - -- | the pipeline - Pipeline -> - GitLab TestReport -pipelineTestReport proj pipeline = do - result <- pipelineTestReport' (project_id proj) (pipeline_id pipeline) - case fromRight (error "pipelineTestReport error") result of - Nothing -> error "pipelineTestReport error" - Just testReport -> return testReport + -- | The ID of a pipeline + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Pipeline)) +pipeline prj pipelineId = + gitlabGetOne + addr + [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/pipelines/" + <> T.pack (show pipelineId) -- | get a pipeline’s test report. Since GitLab 13.0. -pipelineTestReport' :: - -- | the project ID - Int -> +pipelineTestReport :: + -- | the project + Project -> -- | the pipeline ID Int -> GitLab (Either (Response BSL.ByteString) (Maybe TestReport)) -pipelineTestReport' projId pipelineId = do +pipelineTestReport prj pipelineId = do let urlPath = T.pack ( "/projects/" - <> show projId + <> show (project_id prj) <> "/pipelines/" <> show pipelineId <> "/test_report" ) gitlabGetOne urlPath [] + +-- | Create a new pipeline. Since GitLab 14.6. +newPipeline :: + -- | the project + Project -> + -- | The branch or tag to run the pipeline on. + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Pipeline)) +newPipeline prj ref = do + gitlabPost + pipelineAddr + [("ref", Just (T.encodeUtf8 ref))] + where + pipelineAddr :: Text + pipelineAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/pipeline" + +-- | Retry a pipeline. Since GitLab 14.6. +retryPipeline :: + -- | the project + Project -> + -- | The ID of a pipeline + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Pipeline)) +retryPipeline prj pipelineId = do + gitlabPost + pipelineAddr + [] + where + pipelineAddr :: Text + pipelineAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/pipelines/" + <> T.pack (show pipelineId) + <> "/retry" + +-- | Cancel a pipeline's jobs. +cancelPipelineJobs :: + -- | the project + Project -> + -- | The ID of a pipeline + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe Pipeline)) +cancelPipelineJobs prj pipelineId = do + gitlabPost + pipelineAddr + [] + where + pipelineAddr :: Text + pipelineAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/pipelines/" + <> T.pack (show pipelineId) + <> "/cancel" + +-- | Delete a pipline. Since GitLab 14.6. +deletePipeline :: + -- | the project + Project -> + -- | The ID of a pipeline + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deletePipeline prj pipelineId = do + gitlabDelete pipelineAddr [] + where + pipelineAddr :: Text + pipelineAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/pipelines/" + <> T.pack (show pipelineId) diff --git a/src/GitLab/API/Projects.hs b/src/GitLab/API/Projects.hs --- a/src/GitLab/API/Projects.hs +++ b/src/GitLab/API/Projects.hs @@ -10,31 +10,87 @@ -- Maintainer : robstewart57@gmail.com -- Stability : stable module GitLab.API.Projects - ( allProjects, + ( -- * List all projects + projects, + + -- * Get single project + project, + + -- * Get project users + projectUsers, + + -- * User projects + userProjects, + + -- * starredProjects + starredProjects, + + -- * project groups + projectGroups, + + -- * create project + createProject, + createProjectForUser, + + -- * edit project + editProject, + + -- * fork project + forkProject, + + -- * forks of project projectForks, - searchProjectId, + + -- * starring projects + starProject, + unstarProject, + projectStarrers, + + -- * archving projects + archiveProject, + unarchiveProject, + + -- * delete project + deleteProject, + + -- * share projects with groups + shareProjectWithGroup, + unshareProjectWithGroup, + + -- * impport project members + importMembersFromProject, + + -- * fork relationship + forkRelation, + unforkRelation, + + -- * Search for projects projectsWithName, - projectsWithNameAndUser, + projectWithPathAndName, + + -- * housekeeping + houseKeeping, + + -- * Transfer projects + transferProject, + + -- * Additional functionality beyond the GitLab Projects API multipleCommitters, commitsEmailAddresses, - commitsEmailAddresses', - userProjects, - userProjects', projectOfIssue, - issuesCreatedByUser, - issuesOnForks, - projectMemebersCount, - projectCISuccess, - namespacePathToUserId, + -- issuesCreatedByUser, + -- issuesOnForks, + -- projectMemebersCount, + -- projectCISuccess, + -- namespacePathToUserId, projectDiffs, - projectDiffs', - addGroupToProject, - transferProject, - transferProject', - editProject, - editProject', - defaultEditProjectAttrs, - EditProjectAttrs (..), + -- addGroupToProject, + -- transferProject, + -- transferProject', + defaultProjectAttrs, + defaultProjectSearchAttrs, + ProjectAttrs (..), + ProjectSearchAttrs (..), EnabledDisabled (..), AutoDeployStrategy (..), GitStrategy (..), @@ -51,112 +107,73 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Time.Clock import GHC.Generics import GitLab.API.Commits -import GitLab.API.Issues import GitLab.API.Members -import GitLab.API.Pipelines import GitLab.API.Users import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client import Network.HTTP.Types.URI --- | gets all projects. -allProjects :: GitLab [Project] -allProjects = - fromRight (error "allProjects error") - <$> gitlabGetMany "/projects" [("statistics", Just "true")] - --- | gets all forks of a project. Supports use of namespaces. --- --- > projectForks "project1" --- > projectForks "group1/project1" -projectForks :: - -- | name or namespace of the project - Text -> - GitLab (Either (Response BSL.ByteString) [Project]) -projectForks projectName = do - let urlPath = - "/projects/" - <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 projectName)) - <> "/forks" - gitlabGetMany urlPath [] +-- | Get a list of all visible projects across GitLab for the +-- authenticated user. When accessed without authentication, only +-- public projects with simple fields are returned. +projects :: + -- | project filters + ProjectSearchAttrs -> + GitLab [Project] +projects attrs = + fromRight (error "projects error") + <$> gitlabGetMany + "/projects" + (projectSearchAttrsParams attrs) --- | searches for a 'Project' with the given project ID, returns --- 'Nothing' if a project with the given ID is not found. -searchProjectId :: - -- | project ID +-- | Get a specific project. This endpoint can be accessed without +-- authentication if the project is publicly accessible. +project :: Int -> GitLab (Either (Response BSL.ByteString) (Maybe Project)) -searchProjectId projectId = do - let urlPath = T.pack ("/projects/" <> show projectId) - gitlabGetOne urlPath [("statistics", Just "true")] - --- | gets all projects with the given project name. --- --- > projectsWithName "project1" -projectsWithName :: - -- | project name being searched for. - Text -> - GitLab [Project] -projectsWithName projectName = do - results <- gitlabGetMany "/projects" [("search", Just (T.encodeUtf8 projectName))] - case results of - Left _ -> error "projectsWithName error" - Right projects -> - return $ - filter (\project -> projectName == project_path project) projects - --- | gets a project with the given name for the given username. E.g. --- --- > projectsWithNameAndUser "user1" "project1" --- --- looks for "user1/project1" -projectsWithNameAndUser :: Text -> Text -> GitLab (Either (Response BSL.ByteString) (Maybe Project)) -projectsWithNameAndUser username projectName = - gitlabGetOne - ( "/projects/" - <> T.decodeUtf8 - (urlEncode False (T.encodeUtf8 (username <> "/" <> projectName))) - ) - [("statistics", Just "true")] - --- | returns 'True' if a project has multiple committers, according to --- the email addresses of the commits. -multipleCommitters :: Project -> GitLab Bool -multipleCommitters project = do - emailAddresses <- commitsEmailAddresses project - return (length (nub emailAddresses) > 1) +project pId = do + gitlabGetOne urlPath [] + where + urlPath = + "/projects/" + <> T.pack (show pId) --- | gets the email addresses in the author information in all commit --- for a project. -commitsEmailAddresses :: Project -> GitLab [Text] -commitsEmailAddresses project = do - result <- commitsEmailAddresses' (project_id project) - return (fromRight (error "commitsEmailAddresses error") result) +-- | Get the users list of a project. +projectUsers :: + Project -> + GitLab (Either (Response BSL.ByteString) [User]) +projectUsers prj = do + projectUsers' (project_id prj) --- | gets the email addresses in the author information in all commit --- for a project defined by the project's ID. -commitsEmailAddresses' :: Int -> GitLab (Either (Response BSL.ByteString) [Text]) -commitsEmailAddresses' projectId = do - -- (commits :: [Commit]) <- projectCommits' projectId - attempt <- projectCommits' projectId - case attempt of - Left resp -> return (Left resp) - Right (commits :: [Commit]) -> - return (Right (map author_email commits)) +-- | Get the users list of a project. +projectUsers' :: + Int -> + GitLab (Either (Response BSL.ByteString) [User]) +projectUsers' pId = do + gitlabGetMany urlPath [] + where + urlPath = + "/projects/" + <> T.pack (show pId) + <> "/users" -- | gets all projects for a user given their username. -- -- > userProjects "harry" -userProjects' :: Text -> GitLab (Maybe [Project]) -userProjects' username = do +userProjects' :: Text -> ProjectSearchAttrs -> GitLab (Maybe [Project]) +userProjects' username attrs = do userMaybe <- searchUser username case userMaybe of Nothing -> return Nothing Just usr -> do - result <- gitlabGetMany (urlPath (user_id usr)) [] + result <- + gitlabGetMany + (urlPath (user_id usr)) + (projectSearchAttrsParams attrs) case result of Left _ -> error "userProjects' error" Right projs -> return (Just projs) @@ -166,122 +183,242 @@ -- | gets all projects for a user. -- -- > userProjects myUser -userProjects :: User -> GitLab (Maybe [Project]) +userProjects :: User -> ProjectSearchAttrs -> GitLab (Maybe [Project]) userProjects theUser = userProjects' (user_username theUser) --- | gets the 'GitLab.Types.Project' against which the given 'Issue' --- was created. -projectOfIssue :: Issue -> GitLab Project -projectOfIssue issue = do - result <- searchProjectId (issue_project_id issue) - case fromRight (error "projectOfIssue error") result of - Nothing -> error "projectOfIssue error" - Just proj -> return proj +-- | Get a list of visible projects starred by the given user. When +-- accessed without authentication, only public projects are returned. +-- +-- > userProjects myUser +starredProjects :: User -> ProjectSearchAttrs -> GitLab [Project] +starredProjects usr attrs = do + fromRight (error "starredProjects error") + <$> gitlabGetMany + ( "/users/" + <> T.pack (show (user_id usr)) + <> "/starred_projects" + ) + (projectSearchAttrsParams attrs) --- | finds all issues created by a user. +-- | Get a list of ancestor groups for this project. +projectGroups :: + Project -> + GitLab (Either (Response BSL.ByteString) [Group]) +projectGroups prj = do + projectGroups' (project_id prj) + +-- | Get a list of ancestor groups for this project. +projectGroups' :: + Int -> + GitLab (Either (Response BSL.ByteString) [Group]) +projectGroups' gId = do + gitlabGetMany urlPath [] + where + urlPath = + "/projects/" + <> T.pack (show gId) + <> "/groups" + +-- | Creates a new project owned by the authenticated user. +createProject :: + Text -> + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Project)) +createProject nameTxt pathTxt = do + gitlabPost newProjectAddr [("name", Just (T.encodeUtf8 nameTxt)), ("path", Just (T.encodeUtf8 pathTxt))] + where + newProjectAddr :: Text + newProjectAddr = + "/projects" + +-- | Creates a new project owned by the specified user. Available only +-- for administrators. +createProjectForUser :: + -- | user to create the project for + User -> + -- | name of the new project + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Project)) +createProjectForUser usrId nameTxt = do + gitlabPost newProjectAddr [("name", Just (T.encodeUtf8 nameTxt))] + where + newProjectAddr :: Text + newProjectAddr = + "/projects" + <> "/user/" + <> T.pack (show usrId) + +-- | Edit a project. The 'defaultProjectAttrs' value has default project +-- search values, which is a record that can be modified with 'Just' +-- values. -- --- > issuesCreatedByUser "user1" +-- For example to disable project specific email notifications: -- --- returns a (user,projects) tuple, where user is the 'User' found --- for the given searched username, and a list of 'Project's that the --- user has created issues for. -issuesCreatedByUser :: Text -> GitLab (Maybe (User, [Project])) -issuesCreatedByUser username = do - user_maybe <- searchUser username - case user_maybe of - Nothing -> return Nothing - Just usr -> do - usersIssues <- userIssues usr - projects <- mapM projectOfIssue usersIssues - return (Just (usr, projects)) +-- > editProject myProject (defaultProjectAttrs { project_edit_emails_disabled = Just True }) +editProject :: + -- | project + Project -> + -- | project attributes + ProjectAttrs -> + GitLab (Either (Response BSL.ByteString) Project) +editProject prj = editProject' (project_id prj) --- | searches for all projects with the given name, and returns a list --- of triples of: 1) the found project, 2) the list of issues for the --- found projects, and 3) a list of users who've created issues. -issuesOnForks :: +-- | Edit a project. The 'defaultProjectAttrs' value has default project +-- search values, which is a record that can be modified with 'Just' +-- values. +-- +-- For example to disable project specific email notifications for a +-- project with project ID 11744514: +-- +-- > editProject' 11744514 (defaultProjectAttrs { project_edit_emails_disabled = Just True }) +editProject' :: + -- | project ID + Int -> + -- | project attributes + ProjectAttrs -> + GitLab (Either (Response BSL.ByteString) Project) +editProject' projId attrs = do + let urlPath = + "/projects/" + <> T.pack (show projId) + result <- + gitlabPut + urlPath + (projectAttrsParams attrs) + case result of + Left resp -> return (Left resp) + Right Nothing -> error "editProject error" + Right (Just proj) -> return (Right proj) + +-- | Forks a project into the user namespace of the authenticated user +-- or the one provided. +forkProject :: + -- project to fork + Project -> + GitLab (Either (Response BSL.ByteString) (Maybe Project)) +forkProject prj = + gitlabPost addr params + where + params :: [GitLabParam] + params = [] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/fork" + +-- | List the projects accessible to the calling user that have an +-- established, forked relationship with the specified project +-- +-- > projectForks "project1" +-- > projectForks "group1/project1" +projectForks :: -- | name or namespace of the project Text -> - GitLab [(Project, [Issue], [User])] -issuesOnForks projectName = do - projects <- projectsWithName projectName - mapM processProject projects + GitLab (Either (Response BSL.ByteString) [Project]) +projectForks projectName = do + let urlPath = + "/projects/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 projectName)) + <> "/forks" + gitlabGetMany urlPath [] + +-- | Stars a given project. +starProject :: + -- project to star + Project -> + GitLab (Either (Response BSL.ByteString) (Maybe Project)) +starProject prj = + gitlabPost addr params where - processProject :: - Project -> - GitLab (Project, [Issue], [User]) - processProject proj = do - (openIssues :: [Issue]) <- projectIssues proj defaultIssueFilters - let authors = map issue_author openIssues - return (proj, openIssues, authors) + params :: [GitLabParam] + params = [] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/star" --- | returns a (namespace,members) tuple for the given 'Project', --- where namespace is the namespace of the project --- e.g. "user1/project1", and members is a list of (username,name) --- tuples about all members of the project. -projectMemebersCount :: Project -> GitLab (Text, [(Text, Text)]) -projectMemebersCount project = do - friends <- count - return (namespace_name (namespace project), friends) +-- | Stars a given project. +unstarProject :: + -- project to star + Project -> + GitLab (Either (Response BSL.ByteString) (Maybe Project)) +unstarProject prj = + gitlabPost addr params where - count = do - let addr = - "/projects/" <> T.pack (show (project_id project)) <> "/members/all" - (res :: [Member]) <- fromRight (error "projectMembersCount error") <$> gitlabGetMany addr [] - return (map (\x -> (member_username x, member_name x)) res) + params :: [GitLabParam] + params = [] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/unstar" --- | returns 'True' is the last commit for a project passes all --- continuous integration tests. -projectCISuccess :: - -- | the name or namespace of the project +-- | List the users who starred the specified project. +projectStarrers :: Project -> - GitLab Bool -projectCISuccess project = do - pipes <- pipelines project - case pipes of - [] -> return False - (x : _) -> return (pipeline_status x == "success") + GitLab (Either (Response BSL.ByteString) [Group]) +projectStarrers prj = do + gitlabGetMany urlPath [] + where + urlPath = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/starrers" --- | searches for a username, and returns a user ID for that user, or --- 'Nothing' if a user cannot be found. -namespacePathToUserId :: - -- | name or namespace of project - Text -> - GitLab (Maybe Int) -namespacePathToUserId namespacePath = do - user_maybe <- searchUser namespacePath - case user_maybe of - Nothing -> return Nothing - Just usr -> return (Just (user_id usr)) +-- | Archives the project if the user is either an administrator or +-- the owner of this project. +archiveProject :: + -- project to archive + Project -> + GitLab (Either (Response BSL.ByteString) (Maybe Project)) +archiveProject prj = + gitlabPost addr params + where + params :: [GitLabParam] + params = [] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/archive" --- | gets all diffs in a project for a given commit SHA. -projectDiffs :: Project -> Text -> GitLab (Either (Response BSL.ByteString) [Diff]) -projectDiffs proj = - projectDiffs' (project_id proj) +-- | Unarchives the project if the user is either an administrator or +-- the owner of this project. +unarchiveProject :: + -- project to unarchive + Project -> + GitLab (Either (Response BSL.ByteString) (Maybe Project)) +unarchiveProject prj = + gitlabPost addr params + where + params :: [GitLabParam] + params = [] + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/unarchive" --- | gets all diffs in a project for a given project ID, for a given --- commit SHA. -projectDiffs' :: Int -> Text -> GitLab (Either (Response BSL.ByteString) [Diff]) -projectDiffs' projId commitSha = - gitlabGetMany - ( "/projects/" - <> T.pack (show projId) - <> "/repository/commits/" - <> commitSha - <> "/diff/" - ) - [] +-- | Deletes a project including all associated resources. +deleteProject :: + Project -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteProject prj = do + gitlabDelete projAddr [] + where + projAddr :: Text + projAddr = + "/projects/" + <> T.pack (show (project_id prj)) --- | add a group to a project. -addGroupToProject :: +-- | Allow to share project with group. +shareProjectWithGroup :: -- | group ID Int -> - -- | project ID - Int -> + -- | project + Project -> -- | level of access granted AccessLevel -> - GitLab (Either (Response BSL.ByteString) (Maybe GroupShare)) -addGroupToProject groupId projectId access = + GitLab (Either (Response BSL.ByteString) (Maybe Project)) +shareProjectWithGroup groupId prj access = gitlabPost addr params where params :: [GitLabParam] @@ -291,9 +428,128 @@ ] addr = "/projects/" - <> T.pack (show projectId) + <> T.pack (show (project_id prj)) <> "/share" +-- | Unshare the project from the group. +unshareProjectWithGroup :: + -- | group ID + Int -> + -- | project + Project -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +unshareProjectWithGroup groupId prj = + gitlabDelete addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/share/" + <> T.pack (show groupId) + +-- | Import members from another project. +importMembersFromProject :: + -- | project to receive memvers + Project -> + -- | source project to import members from + Project -> + GitLab + (Either (Response BSL.ByteString) (Maybe Project)) +importMembersFromProject toPrj fromPrj = + gitlabPost addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id toPrj)) + <> "/import_project_members/" + <> T.pack (show (project_id fromPrj)) + +-- | Allows modification of the forked relationship between existing +-- projects. Available only for project owners and administrators. +forkRelation :: + -- | forked project + Project -> + -- | project that was forked from + Project -> + GitLab + (Either (Response BSL.ByteString) (Maybe Project)) +forkRelation toPrj fromPrj = + gitlabPost addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id toPrj)) + <> "/fork/" + <> T.pack (show (project_id fromPrj)) + +-- | Delete an existing forked from relationship. +unforkRelation :: + -- | forked project + Project -> + GitLab + (Either (Response BSL.ByteString) (Maybe ())) +unforkRelation prj = + gitlabDelete addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/fork" + +-- | gets all projects with the given project name. It only returns +-- projects with an exact match with the project path. +-- +-- > projectsWithName "project1" +projectsWithName :: + -- | project name being searched for. + Text -> + GitLab [Project] +projectsWithName projectName = do + foundProjects <- + fromRight (error "projectsWithName error") + <$> gitlabGetMany + "/projects" + [("search", Just (T.encodeUtf8 projectName))] + return $ + filter (\prj -> projectName == project_path prj) foundProjects + +-- | gets a project with the given name for the given full path of the +-- namespace. E.g. +-- +-- > projectWithPathAndName "user1" "project1" +-- +-- looks for "user1/project1" +-- +-- > projectWithPathAndName "group1/subgroup1" "project1" +-- +-- looks for "project1" within the namespace with full path "group1/subgroup1" +projectWithPathAndName :: Text -> Text -> GitLab (Either (Response BSL.ByteString) (Maybe Project)) +projectWithPathAndName namespaceFullPath projectName = do + gitlabGetOne + ( "/projects/" + <> T.decodeUtf8 + ( urlEncode + False + ( T.encodeUtf8 + (namespaceFullPath <> "/" <> projectName) + ) + ) + ) + [("statistics", Just "true")] + +-- | Start the Housekeeping task for a project. +houseKeeping :: + -- | the project + Project -> + GitLab (Either (Response BSL.ByteString) (Maybe Project)) +houseKeeping prj = + gitlabPost addr [] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/housekeeping" + -- | transfer a project to a new namespace. transferProject :: -- | project @@ -326,46 +582,64 @@ Right Nothing -> error "transferProject error" Right (Just proj) -> return (Right proj) --- | edit a project. -editProject :: - -- | project - Project -> - -- | EditProjectAttributes - EditProjectAttrs -> - GitLab (Either (Response BSL.ByteString) Project) -editProject prj = editProject' (project_id prj) +-------------------- +-- Additional functionality beyond the GitLab Projects API --- | edit a project. -editProject' :: - -- | project ID - Int -> - -- | EditProjectAttributes - EditProjectAttrs -> - GitLab (Either (Response BSL.ByteString) Project) -editProject' projId attrs = do - let urlPath = - "/projects/" - <> T.pack (show projId) - result <- - gitlabPut - urlPath - (editProjectAttrs attrs) - case result of - Left resp -> return (Left resp) - Right Nothing -> error "editProject error" - Right (Just proj) -> return (Right proj) +-- | Returns 'True' is a projecthas multiple email addresses +-- associated with all commits in a project, 'False' otherwise. +multipleCommitters :: Project -> GitLab Bool +multipleCommitters prj = do + emailAddresses <- commitsEmailAddresses prj + return (length (nub emailAddresses) > 1) +-- | gets the email addresses in the author information in all commit +-- for a project. +commitsEmailAddresses :: Project -> GitLab [Text] +commitsEmailAddresses prj = do + commits <- repoCommits prj + return (map commit_author_email commits) + +-- | gets the 'GitLab.Types.Project' against which the given 'Issue' +-- was created. +projectOfIssue :: Issue -> GitLab Project +projectOfIssue iss = do + let prId = fromMaybe (error "projectOfIssue error") (issue_project_id iss) + result <- project prId + case fromRight (error "projectOfIssue error") result of + Nothing -> error "projectOfIssue error" + Just proj -> return proj + +-- | gets all diffs in a project for a given commit SHA. +projectDiffs :: Project -> Text -> GitLab (Either (Response BSL.ByteString) [Diff]) +projectDiffs proj = + projectDiffs' (project_id proj) + +-- | gets all diffs in a project for a given project ID, for a given +-- commit SHA. +projectDiffs' :: Int -> Text -> GitLab (Either (Response BSL.ByteString) [Diff]) +projectDiffs' projId commitSha = + gitlabGetMany + ( "/projects/" + <> T.pack (show projId) + <> "/repository/commits/" + <> commitSha + <> "/diff/" + ) + [] + -- | A default set of project attributes to override with the --- 'editProject' functions. -defaultEditProjectAttrs :: +-- 'editProject' functions. Only the project ID value is set is a +-- search parameter, all other search parameters are not set and can +-- be overwritten. +defaultProjectAttrs :: -- | project ID Int -> - EditProjectAttrs -defaultEditProjectAttrs projId = - EditProjectAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing projId Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + ProjectAttrs +defaultProjectAttrs projId = + ProjectAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing projId Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -editProjectAttrs :: EditProjectAttrs -> [GitLabParam] -editProjectAttrs filters = +projectAttrsParams :: ProjectAttrs -> [GitLabParam] +projectAttrsParams filters = catMaybes [ (\b -> Just ("allow_merge_on_skipped_pipeline", textToBS (showBool b))) =<< project_edit_allow_merge_on_skipped_pipeline filters, (\x -> Just ("analytics_access_level", textToBS (T.pack (show x)))) =<< project_edit_analytics_access_level filters, @@ -390,7 +664,7 @@ (\b -> Just ("emails_disabled", textToBS (showBool b))) =<< project_edit_emails_disabled filters, (\t -> Just ("external_authorization_classification_label", textToBS t)) =<< project_edit_external_authorization_classification_label filters, (\x -> Just ("forking_access_level", textToBS (T.pack (show x)))) =<< project_edit_forking_access_level filters, - (Just ("id", textToBS (T.pack (show (project_edit_id filters))))), + Just ("id", textToBS (T.pack (show (project_edit_id filters)))), (\t -> Just ("import_url", textToBS t)) =<< project_edit_import_url filters, (\x -> Just ("issues_access_level", textToBS (T.pack (show x)))) =<< project_edit_issues_access_level filters, (\b -> Just ("lfs_enabled", textToBS (showBool b))) =<< project_edit_lfs_enabled filters, @@ -436,7 +710,7 @@ -- | Attributes for updating when editing a project with the -- 'editProject' functions. -data EditProjectAttrs = EditProjectAttrs +data ProjectAttrs = ProjectAttrs { -- | Set whether or not merge requests can be merged with skipped jobs. project_edit_allow_merge_on_skipped_pipeline :: Maybe Bool, -- | One of disabled, private or enabled. @@ -627,3 +901,188 @@ show AlwaysSquash = "always" show DefaultOnSquash = "default_on" show DefaultOffSquash = "default_off" + +-- | A default set of project searc filters where no project filters +-- are applied, thereby returning all projects. +defaultProjectSearchAttrs :: ProjectSearchAttrs +defaultProjectSearchAttrs = + ProjectSearchAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Attributes related to a group +data ProjectSearchAttrs = ProjectSearchAttrs + { -- | Limit by archived status. + projectSearchFilter_archived :: Maybe Bool, + -- | Limit results to projects with IDs greater than the specified + -- ID. + projectSearchFilter_id_after :: Maybe Int, + -- | Limit results to projects with IDs less than the specified + -- ID. + projectSearchFilter_id_before :: Maybe Bool, + -- | Limit results to projects which were imported from external + -- systems by current user. + projectSearchFilter_imported :: Maybe Bool, + -- | Limit results to projects with last_activity after specified + -- time. + projectSearchFilter_last_activity_after :: Maybe UTCTime, + -- | Limit results to projects with last_activity before specified + -- time. + projectSearchFilter_last_activity_before :: Maybe UTCTime, + -- | Limit by projects that the current user is a member of. + projectSearchFilter_membership :: Maybe Bool, + -- | Limit by current user minimal access level. + projectSearchFilter_min_access_level :: Maybe AccessLevel, + -- | Return projects ordered by a given criteria. + projectSearchFilter_order_by :: Maybe OrderBy, + -- | Limit by projects explicitly owned by the current user. + projectSearchFilter_owned :: Maybe Bool, + -- | Limit projects where the repository checksum calculation has + -- failed. + projectSearchFilter_repository_checksum_failed :: Maybe Bool, + -- | Limit results to projects stored on + -- repository_storage. (administrators only). + projectSearchFilter_repository_storage :: Maybe Text, + -- | Include ancestor namespaces when matching search + -- criteria. Default is false. + projectSearchFilter_search_namespaces :: Maybe Bool, + -- | Return list of projects matching the search criteria. + projectSearchFilter_search :: Maybe Text, + -- | Return only limited fields for each project. This is a no-op + -- without authentication as then only simple fields are returned. + projectSearchFilter_simple :: Maybe Bool, + -- | Return projects sorted in asc or desc order. Default is desc. + projectSearchFilter_sort :: Maybe SortBy, + -- | Limit by projects starred by the current user. + projectSearchFilter_starred :: Maybe Bool, + -- | Include project statistics. Only available to Reporter or + -- higher level role members. + projectSearchFilter_statistics :: Maybe Bool, + -- | Comma-separated topic names. Limit results to projects that + -- match all of given topics. + projectSearchFilter_topic :: Maybe Text, + -- | Limit results to projects with the assigned topic given by + -- the topic ID. + projectSearchFilter_topic_id :: Maybe Int, + -- | Limit by visibility. + projectSearchFilter_visibility :: Maybe Visibility, + -- | Include custom attributes in response. (administrator only). + projectSearchFilter_with_custom_attributes :: Maybe Bool, + -- | Limit by enabled issues feature. + projectSearchFilter_with_issues_enabled :: Maybe Bool, + -- | Limit by enabled merge requests feature. + projectSearchFilter_with_merge_requests_enabled :: Maybe Bool, + -- | Limit by projects which use the given programming language. + projectSearchFilter_with_programming_language :: Maybe Text + } + +projectSearchAttrsParams :: ProjectSearchAttrs -> [GitLabParam] +projectSearchAttrsParams filters = + catMaybes + [ (\b -> Just ("archived", textToBS (showBool b))) =<< projectSearchFilter_archived filters, + (\i -> Just ("id_after", textToBS (T.pack (show i)))) =<< projectSearchFilter_id_after filters, + (\i -> Just ("id_before", textToBS (T.pack (show i)))) =<< projectSearchFilter_id_before filters, + (\b -> Just ("imported", textToBS (showBool b))) =<< projectSearchFilter_imported filters, + (\x -> Just ("last_activity_after", textToBS (T.pack (show x)))) =<< projectSearchFilter_last_activity_after filters, + (\x -> Just ("last_activity_before", textToBS (T.pack (show x)))) =<< projectSearchFilter_last_activity_before filters, + (\b -> Just ("membership", textToBS (showBool b))) =<< projectSearchFilter_membership filters, + (\x -> Just ("min_access_level", textToBS (T.pack (show x)))) =<< projectSearchFilter_min_access_level filters, + (\x -> Just ("order_by", textToBS (T.pack (show x)))) =<< projectSearchFilter_order_by filters, + (\b -> Just ("owned", textToBS (showBool b))) =<< projectSearchFilter_owned filters, + (\b -> Just ("repository_checksum_failed", textToBS (showBool b))) =<< projectSearchFilter_repository_checksum_failed filters, + (\t -> Just ("repository_storage", textToBS t)) =<< projectSearchFilter_repository_storage filters, + (\b -> Just ("search_namespaces", textToBS (showBool b))) =<< projectSearchFilter_search_namespaces filters, + (\t -> Just ("search", textToBS t)) =<< projectSearchFilter_search filters, + (\b -> Just ("simple", textToBS (showBool b))) =<< projectSearchFilter_simple filters, + (\i -> Just ("sort", textToBS (T.pack (show i)))) =<< projectSearchFilter_sort filters, + (\b -> Just ("starred", textToBS (showBool b))) =<< projectSearchFilter_starred filters, + (\b -> Just ("statistics", textToBS (showBool b))) =<< projectSearchFilter_statistics filters, + (\t -> Just ("topic", textToBS t)) =<< projectSearchFilter_topic filters, + (\i -> Just ("topic_id", textToBS (T.pack (show i)))) =<< projectSearchFilter_topic_id filters, + (\i -> Just ("visibility", textToBS (T.pack (show i)))) =<< projectSearchFilter_visibility filters, + (\b -> Just ("with_custom_attributes", textToBS (showBool b))) =<< projectSearchFilter_with_custom_attributes filters, + (\b -> Just ("with_issues_enabled", textToBS (showBool b))) =<< projectSearchFilter_with_issues_enabled filters, + (\b -> Just ("with_merge_requests_enabled", textToBS (showBool b))) =<< projectSearchFilter_with_merge_requests_enabled filters, + (\t -> Just ("with_programming_language", textToBS t)) =<< projectSearchFilter_with_programming_language filters + ] + where + textToBS = Just . T.encodeUtf8 + showBool :: Bool -> Text + showBool True = "true" + showBool False = "false" + +------------------ +-- functions below are candidates for deletion + +-- -- | finds all issues created by a user. +-- -- +-- -- > issuesCreatedByUser "user1" +-- -- +-- -- returns a (user,projects) tuple, where user is the 'User' found +-- -- for the given searched username, and a list of 'Project's that the +-- -- user has created issues for. +-- issuesCreatedByUser :: Text -> GitLab (Maybe (User, [Project])) +-- issuesCreatedByUser username = do +-- user_maybe <- searchUser username +-- case user_maybe of +-- Nothing -> return Nothing +-- Just usr -> do +-- usersIssues <- userIssues usr +-- projects <- mapM projectOfIssue usersIssues +-- return (Just (usr, projects)) + +-- -- | searches for all projects with the given name, and returns a list +-- -- of triples of: 1) the found project, 2) the list of issues for the +-- -- found projects, and 3) a list of users who've created issues. +-- issuesOnForks :: +-- -- | name or namespace of the project +-- Text -> +-- GitLab [(Project, [Issue], [User])] +-- issuesOnForks projectName = do +-- projects <- projectsWithName projectName +-- mapM processProject projects +-- where +-- processProject :: +-- Project -> +-- GitLab (Project, [Issue], [User]) +-- processProject proj = do +-- (openIssues :: [Issue]) <- projectIssues proj defaultIssueFilters +-- let authors = map (fromMaybe (error "issuesOnForks error") . issue_author) openIssues +-- return (proj, openIssues, authors) + +-- -- | returns a (namespace,members) tuple for the given 'Project', +-- -- where namespace is the namespace of the project +-- -- e.g. "user1/project1", and members is a list of (username,name) +-- -- tuples about all members of the project. +-- projectMemebersCount :: Project -> GitLab (Text, [(Text, Text)]) +-- projectMemebersCount project = do +-- friends <- count +-- return (namespace_name (fromMaybe (error "projectMemebersCount error") (project_namespace project)), friends) +-- where +-- count = do +-- let addr = +-- "/projects/" <> T.pack (show (project_id project)) <> "/members/all" +-- (res :: [Member]) <- fromRight (error "projectMembersCount error") <$> gitlabGetMany addr [] +-- return (map (\x -> (fromMaybe (error "projectMemebersCount error") (member_username x), fromMaybe (error "projectMemebersCount error") (member_name x))) res) + +-- -- | returns 'True' is the last commit for a project passes all +-- -- continuous integration tests. +-- projectCISuccess :: +-- -- | the name or namespace of the project +-- Project -> +-- GitLab Bool +-- projectCISuccess project = do +-- pipes <- pipelines project +-- case pipes of +-- [] -> return False +-- (x : _) -> return (pipeline_status x == "success") + +-- -- | searches for a username, and returns a user ID for that user, or +-- -- 'Nothing' if a user cannot be found. +-- namespacePathToUserId :: +-- -- | name or namespace of project +-- Text -> +-- GitLab (Maybe Int) +-- namespacePathToUserId namespacePath = do +-- user_maybe <- searchUser namespacePath +-- case user_maybe of +-- Nothing -> return Nothing +-- Just usr -> return (Just (user_id usr)) diff --git a/src/GitLab/API/Repositories.hs b/src/GitLab/API/Repositories.hs --- a/src/GitLab/API/Repositories.hs +++ b/src/GitLab/API/Repositories.hs @@ -7,23 +7,41 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Repositories where +module GitLab.API.Repositories + ( -- * List repository tree + repositoryTree, + -- * Get file archive + fileArchive, + fileArchiveBS, + + -- * Contributors + contributors, + + -- * Merge Base + mergeBase, + ) +where + import Control.Monad.IO.Class +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Either +import Data.Maybe +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client import Network.HTTP.Types.Status -- | returns a list of repository files and directories in a project. -repositories :: +repositoryTree :: -- | the project Project -> GitLab [Repository] -repositories project = +repositoryTree project = fromRight (error "repositories error") <$> repositories' (project_id project) -- | returns a list of repository files and directories in a project @@ -43,8 +61,8 @@ -- | get a file archive of the repository files. For example: -- --- > getFileArchive myProject TarGz "/tmp/myProject.tar.gz" -getFileArchive :: +-- > fileArchive myProject TarGz "/tmp/myProject.tar.gz" +fileArchive :: -- | project Project -> -- | file format @@ -52,19 +70,19 @@ -- | file path to store the archive FilePath -> GitLab (Either (Response BSL.ByteString) ()) -getFileArchive project = getFileArchive' (project_id project) +fileArchive project = getFileArchive' (project_id project) -- | get a file archive of the repository files as a -- 'BSL.ByteString'. For example: -- --- > getFileArchiveBS myProject TarGz "/tmp/myProject.tar.gz" -getFileArchiveBS :: +-- > fileArchiveBS myProject TarGz "/tmp/myProject.tar.gz" +fileArchiveBS :: -- | project Project -> -- | file format ArchiveFormat -> GitLab (Either (Response BSL.ByteString) BSL.ByteString) -getFileArchiveBS project format = do +fileArchiveBS project format = do result <- getFileArchiveBS' (project_id project) format case result of Left resp -> return (Left resp) @@ -115,3 +133,55 @@ <> "/repository" <> "/archive" <> T.pack (show format) + +-- | Get repository contributors list. +contributors :: + -- | project + Project -> + -- | Return contributors ordered by name, email, or commits (orders + -- by commit date) fields. Default is commits. + Maybe OrderBy -> + -- | Return contributors sorted in asc or desc order. Default is + -- asc. + Maybe SortBy -> + GitLab [Contributor] +contributors prj order sort = + fromRight (error "contributors error") + <$> gitlabGetMany addr params + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/repository" + <> "/contributors" + params :: [GitLabParam] + params = + catMaybes + [ (\x -> Just ("sort", showAttr x)) =<< sort, + (\x -> Just ("order_by", showAttr x)) =<< order + ] + showAttr :: (Show a) => a -> Maybe BS.ByteString + showAttr = Just . T.encodeUtf8 . T.pack . show + +-- | Get the common ancestor for 2 or more refs. +mergeBase :: + -- | project + Project -> + -- | The refs to find the common ancestor of, multiple refs can be + -- passed. An example of a ref is + -- '304d257dcb821665ab5110318fc58a007bd104ed'. + [Text] -> + GitLab (Either (Response BSL.ByteString) (Maybe Commit)) +mergeBase prj refs = + gitlabGetOne + addr + params + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/repository" + <> "/merge_base" + params :: [GitLabParam] + params = + map (\ref -> ("refs[]", Just (T.encodeUtf8 ref))) refs diff --git a/src/GitLab/API/RepositoryFiles.hs b/src/GitLab/API/RepositoryFiles.hs --- a/src/GitLab/API/RepositoryFiles.hs +++ b/src/GitLab/API/RepositoryFiles.hs @@ -10,16 +10,19 @@ module GitLab.API.RepositoryFiles where import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client +import Network.HTTP.Types.Status import Network.HTTP.Types.URI --- | Get a list of repository files and directories in a project. -repositoryFiles :: +-- | Allows you to receive information about file in repository like +-- name, size, content. File content is Base64 encoded. +repositoryFile :: -- | the project Project -> -- | the file path @@ -27,38 +30,74 @@ -- | name of the branch, tag or commit Text -> GitLab (Either (Response BSL.ByteString) (Maybe RepositoryFile)) -repositoryFiles project = repositoryFiles' (project_id project) +repositoryFile prj filePath reference = + gitlabGetOne addr [("ref", Just (T.encodeUtf8 reference))] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/repository" + <> "/files" + <> "/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 filePath)) --- | Get a list of repository files and directories in a project given --- the project's ID. -repositoryFiles' :: - -- | project ID - Int -> +-- | Allows you to receive blame information. Each blame range +-- contains lines and corresponding commit information. +repositoryFileBlame :: + -- | the project + Project -> -- | the file path Text -> -- | name of the branch, tag or commit Text -> - GitLab (Either (Response BSL.ByteString) (Maybe RepositoryFile)) -repositoryFiles' projectId filePath reference = + GitLab (Either (Response BSL.ByteString) (Maybe RepositoryFileBlame)) +repositoryFileBlame prj filePath reference = gitlabGetOne addr [("ref", Just (T.encodeUtf8 reference))] where addr = "/projects/" - <> T.pack (show projectId) + <> T.pack (show (project_id prj)) <> "/repository" <> "/files" <> "/" <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 filePath)) + <> "/blame" --- | Get raw data for a given file blob hash. +-- | Get a raw file from a repository. +repositoryFileRawFile :: + -- | the project + Project -> + -- | the file path + Text -> + -- | The name of branch, tag or commit. Default is the HEAD of the + -- project. + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Text)) +repositoryFileRawFile prj filePath reference = + gitlabGetOne addr [("ref", Just (T.encodeUtf8 reference))] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/repository" + <> "/files" + <> "/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 filePath)) + <> "/raw" + +-- | Allows you to receive information about blob in repository like +-- size and content. Blob content is Base64 encoded. repositoryFileBlob :: -- | project ID Int -> -- | blob SHA Text -> - GitLab (Either (Response BSL.ByteString) (Maybe String)) -repositoryFileBlob projectId blobSha = - gitlabGetOne addr [] + GitLab (Either (Response BSL.ByteString) String) +repositoryFileBlob projectId blobSha = do + resp <- gitlabGetByteStringResponse addr [] + if successStatus (responseStatus resp) + then return (Right (BSL8.unpack (responseBody resp))) + else return (Left resp) where addr = "/projects/" @@ -67,3 +106,78 @@ <> "/blobs/" <> blobSha <> "/raw" + successStatus :: Status -> Bool + successStatus (Status n _msg) = + n >= 200 && n <= 226 + +-- | This allows you to create a single file. For creating multiple +-- files with a single request see the commits API. +createRepositoryFile :: + -- | the project + Project -> + -- | the file path + Text -> + -- | Name of the new branch to create. The commit is added to this + -- branch. + Text -> + -- | The file’s content + Text -> + -- | The commit message + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe RepositoryFileSimple)) +createRepositoryFile prj filePath branchName fContent commitMsg = + gitlabPost addr [("branch", Just (T.encodeUtf8 branchName)), ("content", Just (T.encodeUtf8 fContent)), ("commit_message", Just (T.encodeUtf8 commitMsg))] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/repository" + <> "/files/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 filePath)) + +-- | This allows you to update a single file. For updating multiple +-- files with a single request see the commits API. +updateRepositoryFile :: + -- | the project + Project -> + -- | the file path + Text -> + -- | Name of the new branch to create. The commit is added to this + -- branch. + Text -> + -- | The file’s content + Text -> + -- | The commit message + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe RepositoryFileSimple)) +updateRepositoryFile prj filePath branchName fContent commitMsg = + gitlabPut addr [("branch", Just (T.encodeUtf8 branchName)), ("content", Just (T.encodeUtf8 fContent)), ("commit_message", Just (T.encodeUtf8 commitMsg))] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/repository" + <> "/files/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 filePath)) + +-- | This allows you to delete a single file. For deleting multiple files with a single request, see the commits API. +deleteRepositoryFile :: + -- | the project + Project -> + -- | the file path + Text -> + -- | Name of the new branch to create. The commit is added to this + -- branch. + Text -> + -- | The commit message + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteRepositoryFile prj filePath branchName commitMsg = + gitlabDelete addr [("branch", Just (T.encodeUtf8 branchName)), ("commit_message", Just (T.encodeUtf8 commitMsg))] + where + addr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/repository" + <> "/files/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 filePath)) diff --git a/src/GitLab/API/Tags.hs b/src/GitLab/API/Tags.hs --- a/src/GitLab/API/Tags.hs +++ b/src/GitLab/API/Tags.hs @@ -3,37 +3,100 @@ -- | -- Module : Tags -- Description : Queries about tags in repositories --- Copyright : (c) Jihyun Yu, 2021 +-- Copyright : (c) Jihyun Yu, 2021; Rob Stewart, 2022 -- License : BSD3 --- Maintainer : yjh0502@gmail.com +-- Maintainer : yjh0502@gmail.com, robstewart57@gmail.com -- Stability : stable -module GitLab.API.Tags where +module GitLab.API.Tags + ( -- * List project repository tags + tags, + -- * Get a single repository tag + tag, + + -- * Create a new tag + createTag, + + -- * Delete a tag + deleteTag, + ) +where + import qualified Data.ByteString.Lazy as BSL -import Data.Either import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client --- | returns all commits with tags. +-- | Get a list of repository tags from a project. tags :: - -- | project + -- | the project Project -> - GitLab [Tag] -tags project = do - result <- tags' (project_id project) - return (fromRight [] result) - --- | returns all commits with tags from a project given its project ID. -tags' :: - -- | project ID - Int -> GitLab (Either (Response BSL.ByteString) [Tag]) -tags' projectId = do - gitlabGetMany (commitsAddr projectId) [] +tags prj = do + gitlabGetMany (commitsAddr (project_id prj)) [] where commitsAddr :: Int -> Text commitsAddr projId = - "/projects/" <> T.pack (show projId) <> "/repository" <> "/tags" + "/projects/" + <> T.pack (show projId) + <> "/repository" + <> "/tags" + +-- | Get a specific repository tag determined by its name. +tag :: + -- | the project + Project -> + -- | the name of the tag + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Tag)) +tag prj tagName = do + gitlabGetOne (commitsAddr (project_id prj)) [] + where + commitsAddr :: Int -> Text + commitsAddr projId = + "/projects/" + <> T.pack (show projId) + <> "/repository" + <> "/tags/" + <> tagName + +-- | Creates a new tag in the repository that points to the supplied +-- ref. +createTag :: + -- | the project + Project -> + -- | the name of the tag + Text -> + -- | Create tag using commit SHA, another tag name, or branch name + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Tag)) +createTag prj tagName ref = do + gitlabPost newTagAddr [("tag_name", Just (T.encodeUtf8 tagName)), ("ref", Just (T.encodeUtf8 ref))] + where + newTagAddr :: Text + newTagAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/repository" + <> "/tags" + +-- | Deletes a tag of a repository with given name. +deleteTag :: + -- | the project + Project -> + -- | the name of the tag + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteTag prj tagName = + gitlabDelete tagAddr [] + where + tagAddr :: Text + tagAddr = + "/projects/" + <> T.pack (show (project_id prj)) + <> "/repository" + <> "/tags/" + <> tagName diff --git a/src/GitLab/API/Todos.hs b/src/GitLab/API/Todos.hs --- a/src/GitLab/API/Todos.hs +++ b/src/GitLab/API/Todos.hs @@ -7,11 +7,95 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Todos where +module GitLab.API.Todos + ( -- * Get a list of to-do items + todos, + -- * Mark a to-do item as done + todoDone, + + -- * Mark all to-do items as done + todosDone, + + -- * TODO's filters + defaultTodoFilters, + TodoAttrs (..), + ) +where + +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Client -- | returns all pending todos for the user, as defined by the access token. -todos :: GitLab [Todo] -todos = gitlabUnsafe (gitlabGetOne "/todos" []) +todos :: TodoAttrs -> GitLab [Todo] +todos attrs = gitlabUnsafe (gitlabGetOne "/todos" params) + where + params :: [GitLabParam] + params = groupProjectAttrs attrs + +-- | Attributes related to listing groups +data TodoAttrs = TodoAttrs + { -- | The action to be filtered + todoFilter_action :: Maybe TodoAction, + -- | The ID of an author + todoFilter_author_id :: Maybe Int, + -- | The ID of a project + todoFilter_project_id :: Maybe Int, + -- | The ID of a group + todoFilter_group_id :: Maybe Int, + -- | The state of the to-do item + todoFilter_state :: Maybe TodoState, + -- | The type of to-do item. + todoFilter_type :: Maybe TodoType + } + +groupProjectAttrs :: TodoAttrs -> [GitLabParam] +groupProjectAttrs filters = + catMaybes + [ (\x -> Just ("action", textToBS (T.pack (show x)))) =<< todoFilter_action filters, + (\i -> Just ("author_id", textToBS (T.pack (show i)))) =<< todoFilter_author_id filters, + (\i -> Just ("project_id", textToBS (T.pack (show i)))) =<< todoFilter_project_id filters, + (\i -> Just ("group_id", textToBS (T.pack (show i)))) =<< todoFilter_group_id filters, + (\x -> Just ("state", textToBS (T.pack (show x)))) =<< todoFilter_state filters, + (\x -> Just ("type", textToBS (T.pack (show x)))) =<< todoFilter_type filters + ] + where + textToBS = Just . T.encodeUtf8 + +-- | No todo filters applied. +defaultTodoFilters :: TodoAttrs +defaultTodoFilters = + TodoAttrs Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Marks a single pending to-do item given by its ID for the current +-- user as done. +todoDone :: + -- | The ID of to-do item + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +todoDone todoId = + gitlabPost addr [] + where + addr = + T.pack $ + "/todos/" + <> show todoId + <> "/mark_as_done" + +-- | Marks all pending to-do items for the current user as done. It +-- returns the HTTP status code 204 with an empty response. +todosDone :: + GitLab + (Either (Response BSL.ByteString) (Maybe ())) +todosDone = + gitlabPost addr [] + where + addr = + T.pack $ + "/todos" + <> "/mark_as_done" diff --git a/src/GitLab/API/Users.hs b/src/GitLab/API/Users.hs --- a/src/GitLab/API/Users.hs +++ b/src/GitLab/API/Users.hs @@ -8,64 +8,565 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Users where +module GitLab.API.Users + ( -- * List users + users, + -- * Single user + user, + searchUser, + + -- * User creation + createUser, + + -- * User modification + modifyUser, + + -- * Delete authentication identity from user + deleteAuthIdentity, + + -- * User deletion + deleteUser, + + -- * List current user + currentUser, + + -- * User status + currentUserStatus, + + -- * Get the status of a user + userStatus, + + -- * Get user preferences + userPreferences, + + -- * Follow and unfollow users + followUser, + unfollowUser, + + -- * User counts + currentUserCounts, + + -- * List SSH keys + currentUserSshKeys, + + -- * List SSH keys for user + userSshKeys, + + -- * Add SSH key + addSshKeyCurrentUser, + + -- * Add SSH key for user + addSshKeyUser, + + -- * Delete SSH key for current user + deleteSshKeyCurrentUser, + + -- * Delete SSH key for given user + deleteSshKeyUser, + + -- * List emails + emails, + + -- * List emails for user + emailsCurrentUser, + + -- * Block or unblock user + blockUser, + unblockUser, + + -- * Activate or deactivate user + activateUser, + deactivateUser, + + -- * Ban or unban user + banUser, + unbanUser, + + -- * Approve or reject user + approveUser, + rejectUser, + + -- * Users attributes + defaultUserFilters, + UserAttrs (..), + ) +where + +import qualified Data.ByteString.Lazy as BSL import Data.Either -import Data.List import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Client -- | all registered users. -allUsers :: GitLab [User] -allUsers = do - let path = "/users" - fromRight (error "allUsers error") <$> gitlabGetMany path [] +users :: GitLab [User] +users = do + let pathUser = "/users" + fromRight (error "allUsers error") <$> gitlabGetMany pathUser [] --- | searches for a user given a user ID. Returns @Just User@ if the --- user is found, otherwise @Nothing@. -userId :: - -- | username to search for +-- | Get a single user. +user :: + -- | ID of users Int -> + GitLab (Either (Response BSL.ByteString) (Maybe User)) +user usrId = + gitlabGetOne pathUser [] + where + pathUser = + "/users/" + <> T.pack (show usrId) + +-- | Creates a new user. Note only administrators can create new +-- users. Either password, reset_password, or force_random_password +-- must be specified. If reset_password and force_random_password are +-- both false, then password is required. force_random_password and +-- reset_password take priority over password. In addition, +-- reset_password and force_random_password can be used together. +createUser :: + -- | email address + Text -> + -- | user's name + Text -> + -- | user's username + Text -> + -- | optional attributes + UserAttrs -> + GitLab (Either (Response BSL.ByteString) (Maybe User)) +createUser emailAddr name username attrs = + gitlabPost + userAddr + ( [ ("name", Just (T.encodeUtf8 name)), + ("username", Just (T.encodeUtf8 username)), + ("email", Just (T.encodeUtf8 emailAddr)) + ] + <> userAttrs attrs + ) + where + userAddr :: Text + userAddr = + "/users" + +-- | Modifies an existing user. Only administrators can change +-- attributes of a user. +modifyUser :: + -- | user ID + Int -> + -- | optional attributes + UserAttrs -> + GitLab (Either (Response BSL.ByteString) (Maybe User)) +modifyUser userId attrs = + gitlabPut + userAddr + (userAttrs attrs) + where + userAddr :: Text + userAddr = + "/users/" + <> T.pack (show userId) + +-- | Deletes a user’s authentication identity using the provider name +-- associated with that identity. Available only for administrators. +deleteAuthIdentity :: + -- | user + User -> + -- | external providor name + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteAuthIdentity usr providor = + gitlabDelete userAddr [] + where + userAddr :: Text + userAddr = + "/users/" + <> T.pack (show (user_id usr)) + <> "/identities/" + <> providor + +-- | Deletes a user. Available only for administrators. +deleteUser :: + -- | user + User -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteUser usr = + gitlabDelete userAddr [] + where + userAddr :: Text + userAddr = + "/users/" + <> T.pack (show (user_id usr)) + +-- | Get current user. +currentUser :: GitLab User +currentUser = + fromMaybe (error "currentUser") . fromRight (error "currentUser error") <$> gitlabGetOne pathUser [] + where + pathUser = + "/user" + +-- | Get current user status. +currentUserStatus :: GitLab UserStatus +currentUserStatus = + fromMaybe (error "currentUserStatus") . fromRight (error "currentUserStatus error") <$> gitlabGetOne pathUser [] + where + pathUser = + "/user/status" + +-- | Get the status of a user. +userStatus :: + -- | user + User -> + GitLab UserStatus +userStatus usr = + fromMaybe (error "userStatus") . fromRight (error "userStatus error") <$> gitlabGetOne pathUser [] + where + pathUser = + "/users/" + <> T.pack (show (user_id usr)) + <> "/status" + +-- | Get the status of the current user. +userPreferences :: + GitLab UserPrefs +userPreferences = + fromMaybe (error "userPreferences") . fromRight (error "userPreferences error") <$> gitlabGetOne pathUser [] + where + pathUser = + "/user/preferences" + +-- | Follow a user. +followUser :: + -- | user + User -> + GitLab (Either (Response BSL.ByteString) (Maybe User)) +followUser usr = + gitlabPost + userAddr + [] + where + userAddr :: Text + userAddr = + "/users/" + <> T.pack (show (user_id usr)) + <> "/follow" + +-- | Unfollow a user. +unfollowUser :: + -- | user + User -> + GitLab (Either (Response BSL.ByteString) (Maybe User)) +unfollowUser usr = + gitlabPost + userAddr + [] + where + userAddr :: Text + userAddr = + "/users/" + <> T.pack (show (user_id usr)) + <> "/unfollow" + +-- | Get the counts of the currently signed in user. +currentUserCounts :: GitLab UserCount +currentUserCounts = + fromMaybe (error "currentUserCounts") . fromRight (error "currentUserCounts error") <$> gitlabGetOne pathUser [] + where + pathUser = + "/user_counts" + +-- | Get a list of currently authenticated user’s SSH keys. +currentUserSshKeys :: GitLab Key +currentUserSshKeys = + fromMaybe (error "currentUserSshKeys") . fromRight (error "currentUserSshKeys error") <$> gitlabGetOne pathUser [] + where + pathUser = + "/user/keys" + +-- | Get a list of a specified user’s SSH keys. +userSshKeys :: + -- | user + User -> + GitLab Key +userSshKeys usr = + fromMaybe (error "userSshKeys") . fromRight (error "userSshKeys error") <$> gitlabGetOne pathUser [] + where + pathUser = + "/user/" + <> T.pack (show (user_id usr)) + <> "/keys" + +-- | Creates a new key owned by the currently authenticated user. +addSshKeyCurrentUser :: + -- | key + Text -> + -- | title + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Key)) +addSshKeyCurrentUser theKey theTitle = + gitlabPost + userAddr + [ ("key", Just (T.encodeUtf8 theKey)), + ("title", Just (T.encodeUtf8 theTitle)) + ] + where + userAddr :: Text + userAddr = + "/user/keys" + +-- | Create new key owned by specified user. Available only for +-- administrator. +addSshKeyUser :: + -- | User + User -> + -- | key + Text -> + -- | title + Text -> + GitLab (Either (Response BSL.ByteString) (Maybe Key)) +addSshKeyUser usr theKey theTitle = + gitlabPost + userAddr + [ ("key", Just (T.encodeUtf8 theKey)), + ("title", Just (T.encodeUtf8 theTitle)) + ] + where + userAddr :: Text + userAddr = + "/users/" + <> T.pack (show (user_id usr)) + <> "/keys" + +-- | Deletes key owned by currently authenticated user. +deleteSshKeyCurrentUser :: + -- | key ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteSshKeyCurrentUser keyId = + gitlabDelete userAddr [] + where + userAddr :: Text + userAddr = + "/users/keys/" + <> T.pack (show keyId) + +-- | Deletes key owned by a specified user. Available only for +-- administrator. +deleteSshKeyUser :: + -- | user + User -> + -- | key ID + Int -> + GitLab (Either (Response BSL.ByteString) (Maybe ())) +deleteSshKeyUser usr keyId = + gitlabDelete userAddr [] + where + userAddr :: Text + userAddr = + "/users/" + <> T.pack (show (user_id usr)) + <> "/keys/" + <> T.pack (show keyId) + +-- | Get a list of currently authenticated user’s emails. +emails :: GitLab [Email] +emails = do + let pathUser = "/user/emails/" + fromRight (error "emails error") <$> gitlabGetMany pathUser [] + +-- | Get a list of currently authenticated user’s emails. +emailsCurrentUser :: + -- | user + User -> + GitLab [Email] +emailsCurrentUser usr = do + let pathUser = + "/user/" + <> T.pack (show (user_email usr)) + <> "/emails/" + fromRight (error "emails error") <$> gitlabGetMany pathUser [] + +-- | Used internally by the following functions +userAction :: + -- | user action + Text -> + -- | function name for the error + Text -> + -- | user + User -> GitLab (Maybe User) -userId usrId = do - let path = - "/users/" - <> T.pack (show usrId) - res <- gitlabGetOne path [] - case res of - Left _err -> return Nothing - Right Nothing -> return Nothing - Right (Just user) -> return (Just user) +userAction action funcName usr = + fromRight (error (T.unpack funcName <> " error")) <$> gitlabPost userAddr [] + where + userAddr :: Text + userAddr = + "/users/" + <> T.pack (show (user_id usr)) + <> action --- | searches for a user given a username. Returns @Just User@ if the --- user is found, otherwise @Nothing@. +-- | Blocks the specified user. Available only for administrator. +blockUser :: + -- | user + User -> + GitLab (Maybe User) +blockUser = userAction "/block" "blockUser" + +-- | Unblocks the specified user. Available only for administrator. +unblockUser :: + -- | user + User -> + GitLab (Maybe User) +unblockUser = userAction "/unblock" "unblockUser" + +-- | Deactivates the specified user. Available only for administrator. +deactivateUser :: + -- | user + User -> + GitLab (Maybe User) +deactivateUser = userAction "/deactivate" "deactivateUser" + +-- | Activates the specified user. Available only for administrator. +activateUser :: + -- | user + User -> + GitLab (Maybe User) +activateUser = userAction "/activate" "activateUser" + +-- | Bans the specified user. Available only for administrator. +banUser :: + -- | user + User -> + GitLab (Maybe User) +banUser = userAction "/ban" "banUser" + +-- | Unbans the specified user. Available only for administrator. +unbanUser :: + -- | user + User -> + GitLab (Maybe User) +unbanUser = userAction "/unban" "unbanUser" + +-- | Approves the specified user. Available only for administrator. +approveUser :: + -- | user + User -> + GitLab (Maybe User) +approveUser = userAction "/approve" "approveUser" + +-- | Rejects specified user that is pending approval. Available only for administrator. +rejectUser :: + -- | user + User -> + GitLab (Maybe User) +rejectUser = userAction "/reject" "rejectUser" + +-- | No group filters applied, thereby returning all groups. +defaultUserFilters :: UserAttrs +defaultUserFilters = + UserAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Attributes related to a group +data UserAttrs = UserAttrs + { -- | User is an administrator - default is false + userFilter_admin :: Maybe Bool, + -- | User’s biography + userFilter_bio :: Maybe Text, + -- | User can create groups + userFilter_can_create_group :: Maybe Bool, + -- | email address + userFilter_email :: Maybe Text, + -- | External UID + userFilter_extern_uid :: Maybe Bool, + -- | Flag the user as external - default is fale + userFilter_external :: Maybe Bool, + -- | Set user password to a random value - default is false + userFilter_force_random_password :: Maybe Bool, + -- | ID of group where SAML has been configured + userFilter_group_id_for_saml :: Maybe Int, + -- | User's LinkedIn account + userFilter_linkedin :: Maybe Text, + -- | User's location + userFilter_location :: Maybe Text, + -- | User's name + userFilter_name :: Maybe Text, + -- | Administrator notes for this user + userFilter_note :: Maybe Text, + -- | Organization name + userFilter_organization :: Maybe Text, + -- | User's password + userFilter_password :: Maybe Text, + -- | User’s profile is private - default is false + userFilter_private_profile :: Maybe Bool, + -- | Number of projects user can create + userFilter_projects_limit :: Maybe Int, + -- | External provider name + userFilter_providor :: Maybe Text, + -- | Send user password reset link - default is false + userFilter_reset_password :: Maybe Bool, + -- | Skip confirmation - default is false + userFilter_skip_confirmation :: Maybe Bool, + -- | User's Skype ID + userFilter_skype :: Maybe Text, + -- | User's theme ID - GitLab theme for the user + userFilter_theme_id :: Maybe Int, + -- | User's Twitter account + userFilter_twitter :: Maybe Text, + -- | User's username + userFilter_username :: Maybe Text, + -- | Flag indicating the user sees only one file diff per page + userFilter_view_diffs_file_by_file :: Maybe Bool, + -- | User's website URL + userFilter_website :: Maybe Text + } + +userAttrs :: UserAttrs -> [GitLabParam] +userAttrs filters = + catMaybes + [ (\t -> Just ("admin", textToBS t)) =<< userFilter_name filters, + (\t -> Just ("bio", textToBS t)) =<< userFilter_bio filters, + (\b -> Just ("can_create_group", textToBS (showBool b))) =<< userFilter_can_create_group filters, + (\t -> Just ("email", textToBS t)) =<< userFilter_email filters, + (\i -> Just ("extern_uid", textToBS (T.pack (show i)))) =<< userFilter_extern_uid filters, + (\b -> Just ("external", textToBS (showBool b))) =<< userFilter_external filters, + (\b -> Just ("force_random_password", textToBS (showBool b))) =<< userFilter_force_random_password filters, + (\i -> Just ("group_id_for_saml", textToBS (T.pack (show i)))) =<< userFilter_group_id_for_saml filters, + (\t -> Just ("linkedin", textToBS t)) =<< userFilter_linkedin filters, + (\t -> Just ("location", textToBS t)) =<< userFilter_location filters, + (\t -> Just ("name", textToBS t)) =<< userFilter_name filters, + (\t -> Just ("note", textToBS t)) =<< userFilter_note filters, + (\t -> Just ("organization", textToBS t)) =<< userFilter_organization filters, + (\t -> Just ("password", textToBS t)) =<< userFilter_password filters, + (\b -> Just ("private_profile", textToBS (showBool b))) =<< userFilter_private_profile filters, + (\i -> Just ("projects_limit", textToBS (T.pack (show i)))) =<< userFilter_projects_limit filters, + (\t -> Just ("providor", textToBS t)) =<< userFilter_providor filters, + (\b -> Just ("reset_password", textToBS (showBool b))) =<< userFilter_reset_password filters, + (\b -> Just ("skip_confirmation", textToBS (showBool b))) =<< userFilter_skip_confirmation filters, + (\t -> Just ("skype", textToBS t)) =<< userFilter_skype filters, + (\i -> Just ("theme_id", textToBS (T.pack (show i)))) =<< userFilter_theme_id filters, + (\t -> Just ("twitter", textToBS t)) =<< userFilter_twitter filters, + (\t -> Just ("username", textToBS t)) =<< userFilter_username filters, + (\b -> Just ("view_diffs_file_by_file", textToBS (showBool b))) =<< userFilter_view_diffs_file_by_file filters, + (\t -> Just ("website", textToBS t)) =<< userFilter_website filters + ] + where + textToBS = Just . T.encodeUtf8 + showBool :: Bool -> Text + showBool True = "true" + showBool False = "false" + +-- | searches for a user given a username. searchUser :: -- | username to search for Text -> GitLab (Maybe User) searchUser username = do - let path = "/users" + let pathUser = "/users" params = [("username", Just (T.encodeUtf8 username))] - result <- gitlabGetMany path params + result <- gitlabGetMany pathUser params case result of Left _err -> return Nothing Right [] -> return Nothing Right (x : _) -> return (Just x) - --- | searches for users given a list of usernames, returns them in --- alphabetical order of their usernames. -orderedUsers :: - -- | usernames to search for - [Text] -> - GitLab [User] -orderedUsers usernames = do - users <- catMaybes <$> mapM searchUser usernames - return (orderUsersByName users) - where - orderUsersByName :: [User] -> [User] - orderUsersByName = - sortBy (\u1 u2 -> compare (user_name u1) (user_name u2)) diff --git a/src/GitLab/API/Version.hs b/src/GitLab/API/Version.hs --- a/src/GitLab/API/Version.hs +++ b/src/GitLab/API/Version.hs @@ -14,7 +14,7 @@ import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client --- | Get the version of the GitLab server. +-- | Retrieve version information for this GitLab instance. gitlabVersion :: GitLab (Either (Response BSL.ByteString) (Maybe Version)) gitlabVersion = do let urlPath = "/version" diff --git a/src/GitLab/SystemHooks/Rules.hs b/src/GitLab/SystemHooks/Rules.hs --- a/src/GitLab/SystemHooks/Rules.hs +++ b/src/GitLab/SystemHooks/Rules.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | -- Module : GitLab.SystemHooks.Rules -- Description : Common GitLab system hook rules @@ -10,7 +8,8 @@ module GitLab.SystemHooks.Rules (ruleAddMembers, ruleAddNewUserToGroups) where import Control.Monad -import Data.Text +import Data.Text (Text) +import GitLab.API.Groups import GitLab.API.Members import GitLab.API.Projects import GitLab.API.Users @@ -35,10 +34,20 @@ ) ( \event@UserCreate {} -> do mapM_ - ( \groupName -> - -- will return value of type `Left Status` if user already - -- member of the group, `void` silently ignores any outcome. - addUserToGroup' groupName Reporter (userCreate_user_id event) + ( \groupName -> do + grps <- groups (defaultListGroupsFilters {listGroupsFilter_search = Just groupName}) + + case grps of + [] -> return () + [grp] -> do + result <- user (userCreate_user_id event) + case result of + Left _ -> return () + Right Nothing -> return () + Right (Just usr) -> + void $ + addUserToGroup grp Reporter usr + (_ : _) -> return () ) groupNames ) @@ -57,7 +66,7 @@ matchIf label ( \event@ProjectCreate {} -> do - request <- searchProjectId (projectCreate_project_id event) + request <- project (projectCreate_project_id event) case request of Left _ -> return False Right Nothing -> return False @@ -73,12 +82,17 @@ request <- searchUser userName case request of Nothing -> return () - Just foundUser -> - void $ - addMemberToProject' - (projectCreate_project_id event) - Reporter - (user_id foundUser) + Just foundUser -> do + result <- project (projectCreate_project_id event) + case result of + Right (Just prj) -> + void $ + addMemberToProject + prj + Reporter + foundUser + Right Nothing -> return () + Left _ -> return () ) userNames ) diff --git a/src/GitLab/SystemHooks/Types.hs b/src/GitLab/SystemHooks/Types.hs --- a/src/GitLab/SystemHooks/Types.hs +++ b/src/GitLab/SystemHooks/Types.hs @@ -680,7 +680,7 @@ deriving (Typeable, Show, Eq, Generic) -- | Merge parameters associated with a merge request -data MergeParams = MergeParams +newtype MergeParams = MergeParams { mergeParams_force_remove_source_branch :: Maybe Text } deriving (Typeable, Show, Eq, Generic) diff --git a/src/GitLab/Types.hs b/src/GitLab/Types.hs --- a/src/GitLab/Types.hs +++ b/src/GitLab/Types.hs @@ -1,1378 +1,1627 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} - --- | --- Module : GitLab.Types --- Description : Haskell records corresponding to JSON data from GitLab API calls --- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 --- License : BSD3 --- Maintainer : robstewart57@gmail.com --- Stability : stable -module GitLab.Types - ( GitLab, - GitLabState (..), - GitLabServerConfig (..), - defaultGitLabServer, - ArchiveFormat (..), - Member (..), - Namespace (..), - Links (..), - Owner (..), - Permissions (..), - ProjectId, - Project (..), - ProjectStats (..), - User (..), - Milestone (..), - MilestoneState (..), - TimeStats (..), - IssueId, - Issue (..), - Pipeline (..), - Commit (..), - CommitTodo (..), - CommitStats (..), - Tag (..), - Release (..), - Diff (..), - Repository (..), - Job (..), - Artifact (..), - Group (..), - GroupShare (..), - Branch (..), - RepositoryFile (..), - MergeRequest (..), - Todo (..), - TodoProject (..), - TodoAction (..), - TodoTarget (..), - TodoState (..), - Version (..), - URL, - EditIssueReq (..), - Discussion (..), - Note (..), - IssueStatistics (..), - IssueStats (..), - IssueCounts (..), - IssueBoard (..), - BoardIssue (..), - BoardIssueLabel (..), - ProjectBoard (..), - Visibility (..), - TestReport (..), - TestSuite (..), - TestCase (..), - ) -where - -import Control.Monad.Trans.Reader -import Data.Aeson -import Data.Aeson.Types -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock -import GHC.Generics -import Network.HTTP.Conduit - --- | type synonym for all GitLab actions. -type GitLab a = ReaderT GitLabState IO a - --- | state used by GitLab actions, used internally. -data GitLabState = GitLabState - { serverCfg :: GitLabServerConfig, - httpManager :: Manager - } - --- | configuration data specific to a GitLab server. -data GitLabServerConfig = GitLabServerConfig - { url :: Text, - -- | personal access token, see - token :: Text, - -- | milliseconds - timeout :: Int, - -- | how many times to retry a HTTP request before giving up and returning an error. - retries :: Int, - -- | write system hook events to files in the system temporary - -- directory. - debugSystemHooks :: Bool - } - --- | default settings, the 'url' and 'token' values will need to be overwritten. -defaultGitLabServer :: GitLabServerConfig -defaultGitLabServer = - GitLabServerConfig - { url = "https://gitlab.com", - token = "", - timeout = 15000000, -- 15 seconds - retries = 5, - debugSystemHooks = False - } - --- https://docs.gitlab.com/ee/api/repositories.html#get-file-archive --- tar.gz, tar.bz2, tbz, tbz2, tb2, bz2, tar, and zip - --- | archive format for file archives of repositories. --- See 'GitLab.API.Repositories.getFileArchive' in 'GitLab.API.Repositories'. -data ArchiveFormat - = -- | ".tar.gz" - TarGz - | -- | ".tar.bz2" - TarBz2 - | -- | ".tbz" - Tbz - | -- | ".tbz2" - Tbz2 - | -- | ".tb2" - Tb2 - | -- | ".bz2" - Bz2 - | -- | ".tar" - Tar - | -- | ".zip" - Zip - -instance Show ArchiveFormat where - show TarGz = ".tar.gz" - show TarBz2 = ".tar.bz2" - show Tbz = ".tbz" - show Tbz2 = ".tbz2" - show Tb2 = ".tb2" - show Bz2 = ".bz2" - show Tar = ".tar" - show Zip = ".zip" - --- | member of a project. -data Member = Member - { member_id :: Int, - member_name :: Text, - member_username :: Text, - member_state :: Text, - member_avatar_uri :: Maybe Text, - member_web_url :: Maybe Text, - access_level :: Int, - expires_at :: Maybe Text - } - deriving (Generic, Show) - --- | namespaces. -data Namespace = Namespace - { namespace_id :: Int, - namespace_name :: Text, - namespace_path :: Text, - kind :: Text, - full_path :: Text, - parent_id :: Maybe Int - } - deriving (Generic, Show) - --- | links. -data Links = Links - { self :: Text, - issues :: Maybe Text, - merge_requests :: Maybe Text, - repo_branches :: Text, - link_labels :: Text, - link_events :: Text, - members :: Text - } - deriving (Generic, Show) - --- | owners. -data Owner = Ownwer - { owner_id :: Int, - owner_name :: Text, - owner_username :: Text, - state :: Text, - owner_avatar_url :: Maybe Text, - owner_web_url :: Text - } - deriving (Generic, Show, Eq) - --- | permissions. -data Permissions = Permissions - { project_access :: Maybe Object, - group_access :: Maybe Object - } - deriving (Generic, Show) - --- | projects. -data Project = Project - { project_id :: Int, - description :: Maybe Text, - project_name :: Text, - name_with_namespace :: Text, - project_path :: Text, - project_path_with_namespace :: Text, - project_created_at :: Text, - default_branch :: Maybe Text, - tag_list :: [Text], -- check - ssh_url_to_repo :: Text, - http_url_to_repo :: Text, - project_web_url :: Text, - readme_url :: Maybe Text, -- check - project_avatar_url :: Maybe Text, -- check - star_count :: Int, - forks_count :: Int, - last_activity_at :: Text, - namespace :: Namespace, - _links :: Maybe Links, - archived :: Maybe Bool, - visibility :: Maybe Text, - owner :: Maybe Owner, - resolve_outdated_diff_discussions :: Maybe Bool, - container_registry_enabled :: Maybe Bool, - issues_enabled :: Maybe Bool, - merge_requests_enabled :: Maybe Bool, - wiki_enabled :: Maybe Bool, - jobs_enabled :: Maybe Bool, - snippets_enabled :: Maybe Bool, - shared_runners_enabled :: Maybe Bool, - lfs_enabled :: Maybe Bool, - creator_id :: Maybe Int, - forked_from_project :: Maybe Project, - import_status :: Maybe String, - open_issues_count :: Maybe Int, - public_jobs :: Maybe Bool, - ci_config_path :: Maybe Text, -- check null - shared_with_groups :: Maybe [Object], - only_allow_merge_if_pipeline_succeeds :: Maybe Bool, - request_access_enabled :: Maybe Bool, - only_allow_merge_if_all_discussions_are_resolved :: Maybe Bool, - printing_merge_request_link_enabled :: Maybe Bool, - merge_method :: Maybe Text, - permissions :: Maybe Permissions, - project_stats :: Maybe ProjectStats - } - deriving (Generic, Show) - --- | project statistics. -data ProjectStats = ProjectStats - { commit_count :: Int, - storage_size :: Int, - repository_size :: Int, - wiki_size :: Maybe Int, - lfs_objects_size :: Maybe Int, - job_artifacts_size :: Maybe Int, - packages_size :: Maybe Int - } - deriving (Generic, Show) - --- | registered users. -data User = User - { user_id :: Int, - user_username :: Text, - user_name :: Text, - user_state :: Text, - user_avatar_uri :: Maybe Text, - user_web_url :: Maybe Text - } - deriving (Generic, Show) - --- | milestone state. -data MilestoneState - = MSActive - | MSClosed - deriving (Show, Eq) - -instance FromJSON MilestoneState where - parseJSON (String "active") = return MSActive - parseJSON (String "closed") = return MSClosed - parseJSON x = unexpected x - --- | milestones. -data Milestone = Milestone - { milestone_project_id :: Maybe Int, - milestone_group_id :: Maybe Int, - milestone_description :: Maybe Text, - milestone_state :: Maybe MilestoneState, - milestone_due_date :: Maybe Text, - milestone_iid :: Maybe Int, - milestone_created_at :: Maybe UTCTime, - milestone_title :: Text, - milestone_id :: Int, - milestone_updated_at :: Maybe UTCTime, - milestone_web_url :: Maybe URL - } - deriving (Generic, Show, Eq) - -instance FromJSON Milestone where - parseJSON = genericParseJSON (defaultOptions {fieldLabelModifier = drop 10}) - --- | time stats. -data TimeStats = TimeStats - { time_estimate :: Int, - total_time_spent :: Int, - human_time_estimate :: Maybe Int, - human_total_time_spent :: Maybe Int - } - deriving (Generic, Show) - --- | alias for project id -type ProjectId = Int - --- | alias for issue id -type IssueId = Int - --- | project issues. -data Issue = Issue - { issue_state :: Text, - issue_description :: Maybe Text, - issue_author :: User, - milestone :: Maybe Milestone, - issue_project_id :: ProjectId, - assignees :: Maybe [User], - assignee :: Maybe User, - updated_at :: Text, - closed_at :: Maybe Text, - closed_by :: Maybe User, - issue_id :: IssueId, - issue_title :: Text, - issue_created_at :: Text, - iid :: Int, - issue_labels :: [Text], - upvotes :: Int, - downvotes :: Int, - user_notes_count :: Int, - issue_due_date :: Maybe Text, - issue_web_url :: Text, - confidential :: Bool, - weight :: Maybe Text, -- Int? - discussion_locked :: Maybe Bool, - time_stats :: TimeStats - } - deriving (Generic, Show) - --- | project pipelines -data Pipeline = Pipeline - { pipeline_id :: Int, - sha :: Text, - pipeline_ref :: Text, - pipeline_status :: Text, - pipeline_web_url :: Maybe Text - } - deriving (Generic, Show) - --- | code commits. -data Commit = Commit - { commit_id :: Text, - short_id :: Text, - title :: Text, - author_name :: Text, - author_email :: Text, - authored_date :: Text, - committer_name :: Text, - committer_email :: Text, - committed_date :: Text, - commit_created_at :: Text, - message :: Text, - commit_parent_ids :: Maybe [String], - last_pipeline :: Maybe Pipeline, - commit_stats :: Maybe CommitStats, - commit_status :: Maybe Text - } - deriving (Generic, Show) - --- | summary of a code commit for TODOs. -data CommitTodo = CommitTodo - { todo_commit_id :: Text, - todo_commit_short_id :: Text, - todo_commit_created_at :: Text, - todo_parent_ids :: Maybe [String] - } - deriving (Generic, Show) - --- | commit stats. -data CommitStats = Stats - { additions :: Int, - deletions :: Int, - total :: Int - } - deriving (Generic, Show) - --- | tags. -data Tag = Tag - { tag_commit :: Commit, - tag_release :: Maybe Release, - tag_name :: Text, - tag_target :: Text, - tag_message :: Maybe Text, - tag_protected :: Bool - } - deriving (Generic, Show) - --- | Release associated with a tag -data Release = Release - { release_tag_name :: Text, - release_description :: Text - } - deriving (Generic, Show) - --- | diff between two commits. -data Diff = Diff - { diff :: Text, - new_path :: Text, - old_path :: Text, - a_mode :: Maybe Text, - b_mode :: Maybe Text, - new_file :: Bool, - renamed_file :: Bool, - deleted_file :: Bool - } - deriving (Generic, Show) - --- | repositories. -data Repository = Repository - { repository_id :: Text, - repository_name :: Text, - repository_type :: Text, - repository_path :: Text, - mode :: Text - } - deriving (Generic, Show) - --- | jobs. -data Job = Job - { job_commit :: Commit, - job_coverage :: Maybe Text, -- ? - job_created_at :: Text, - job_started_at :: Text, - job_finished_at :: Text, - job_duration :: Double, - job_artifacts_expire_at :: Maybe Text, - job_id :: Int, - job_name :: Text, - job_pipeline :: Pipeline, - job_ref :: Text, - job_artifacts :: [Artifact], - -- , runner :: Maybe Text - job_stage :: Text, - job_status :: Text, - job_tag :: Bool, - job_web_url :: Text, - job_user :: User - } - deriving (Generic, Show) - --- | artifacts. -data Artifact = Artifact - { file_type :: Text, - size :: Int, - filename :: Text, - file_format :: Maybe Text - } - deriving (Generic, Show) - --- | groups. -data Group = Group - { group_id :: Int, - group_name :: Text, - group_path :: Text, - group_description :: Text, - group_visibility :: Text, - group_lfs_enabled :: Bool, - group_avatar_url :: Maybe Text, - group_web_url :: Text, - group_request_access_enabled :: Bool, - group_full_name :: Text, - group_full_path :: Text, - group_file_template_project_id :: Maybe Int, - group_parent_id :: Maybe Int - } - deriving (Generic, Show) - --- | response to sharing a project with a group. -data GroupShare = GroupShare - { share_id :: Int, - share_project_id :: Int, - share_group_id :: Int, - share_group_access :: Int, - share_expires_at :: Maybe Text - } - deriving (Generic, Show) - --- | code branches. -data Branch = Branch - { branch_name :: Text, - merged :: Bool, - protected :: Bool, - branch_default :: Bool, - developers_can_push :: Bool, - developers_can_merge :: Bool, - can_push :: Bool, - branch_commit :: Commit - } - deriving (Generic, Show) - --- | files in a repository. -data RepositoryFile = RepositoryFile - { repository_file_file_name :: Text, - repository_file_file_path :: Text, - repository_file_size :: Int, - encoding :: Text, - content :: Text, - content_sha256 :: Text, - ref :: Text, - blob_id :: Text, - repository_file_commit_id :: Text, - last_commit_id :: Text - } - deriving (Generic, Show) - --- | project merge requests. -data MergeRequest = MergeRequest - { merge_request_id :: Int, - merge_request_iid :: Int, - merge_request_project_id :: Int, - merge_request_title :: Text, - merge_request_description :: Text, - merge_request_state :: Text, - merge_request_merged_by :: Maybe User, - merge_request_merged_at :: Maybe Text, - merge_request_closed_by :: Maybe User, - merge_request_closed_at :: Maybe Text, - merge_request_created_at :: Text, - merge_request_updated_at :: Text, - merge_request_target_branch :: Text, - merge_request_source_branch :: Text, - merge_request_upvotes :: Int, - merge_request_downvotes :: Int, - merge_request_author :: User, - merge_request_assignee :: Maybe User, - merge_request_source_project_id :: Int, - merge_request_target_project_id :: Int, - merge_request_labels :: [Text], - merge_request_work_in_progress :: Bool, - merge_request_milestone :: Maybe Milestone, - merge_request_merge_when_pipeline_succeeds :: Bool, - merge_request_merge_status :: Text, - merge_request_sha :: Text, - merge_request_merge_commit_sha :: Maybe Text, - merge_request_user_notes_count :: Int, - merge_request_discussion_locked :: Maybe Bool, - merge_request_should_remove_source_branch :: Maybe Bool, - merge_request_force_remove_source_branch :: Maybe Bool, - merge_request_allow_collaboration :: Maybe Bool, - merge_request_allow_maintainer_to_push :: Maybe Bool, - merge_request_web_url :: Text, - merge_request_time_stats :: TimeStats, - merge_request_squash :: Bool, - merge_request_changes_count :: Maybe String, - merge_request_pipeline :: Maybe Pipeline, - merge_request_diverged_commits_count :: Maybe Int, - merge_request_rebase_in_progress :: Maybe Bool, - merge_request_has_conflicts :: Bool, - merge_request_blocking_discussions_resolved :: Maybe Bool, - merge_request_approvals_before_merge :: Maybe Bool -- ? - } - deriving (Generic, Show) - --- | TODO actions. -data TodoAction - = TAAssigned - | TAMentioned - | TABuildFailed - | TAMarked - | TAApprovalRequired - | TAUnmergeable - | TADirectlyAddressed - deriving (Show) - -instance FromJSON TodoAction where - parseJSON (String "assigned") = return TAAssigned - parseJSON (String "mentioned") = return TAMentioned - parseJSON (String "build_failed") = return TABuildFailed - parseJSON (String "marked") = return TAMarked - parseJSON (String "approval_required") = return TAApprovalRequired - parseJSON (String "unmergeable") = return TAUnmergeable - parseJSON (String "directly_addressed") = return TADirectlyAddressed - parseJSON x = unexpected x - --- | TODO targets. -data TodoTarget - = TTIssue Issue - | TTMergeRequest MergeRequest - | TTCommit CommitTodo - deriving (Show) - --- | URL is a synonym for 'Text'. -type URL = Text - --- | TODO states. -data TodoState - = TSPending - | TSDone - deriving (Show) - -instance FromJSON TodoState where - parseJSON (String "pending") = return TSPending - parseJSON (String "done") = return TSDone - parseJSON x = unexpected x - --- | A project TODO. -data TodoProject = TP - { tp_id :: Int, - tp_description :: Text, - tp_name :: Text, - tp_name_with_namespace :: Text, - tp_path :: Text, - tp_path_with_namespace :: Text, - tp_created_at :: UTCTime - } - deriving (Generic, Show) - -instance FromJSON TodoProject where - parseJSON = genericParseJSON (defaultOptions {fieldLabelModifier = drop 3}) - --- | TODOs. -data Todo = Todo - { todo_id :: Int, - todo_project :: TodoProject, - todo_author :: User, - todo_action_name :: TodoAction, - todo_target :: TodoTarget, - todo_target_url :: URL, - todo_body :: Text, - todo_state :: TodoState, - todo_created_at :: UTCTime - } - deriving (Show) - -instance FromJSON Todo where - parseJSON = withObject "Todo" $ \v -> - Todo - <$> v .: "id" - <*> v .: "project" - <*> v .: "author" - <*> v .: "action_name" - <*> ( v .: "target_type" >>= \case - "MergeRequest" -> TTMergeRequest <$> v .: "target" - "Issue" -> TTIssue <$> v .: "target" - "Commit" -> TTCommit <$> v .: "target" - (_ :: Text) -> fail "" - ) - <*> v .: "target_url" - <*> v .: "body" - <*> v .: "state" - <*> v .: "created_at" - --- | version of the GitLab instance. -data Version = Version - { version :: Text, - revision :: Text - } - deriving (Generic, Show) - --- | An edit issue request. -data EditIssueReq = EditIssueReq - { edit_issue_id :: ProjectId, - edit_issue_issue_iid :: IssueId, - edit_issue_title :: Maybe Text, - edit_issue_description :: Maybe Text, - edit_issue_confidential :: Maybe Bool, - edit_issue_assignee_ids :: Maybe [Int], - edit_issue_milestone_id :: Maybe Int, - edit_issue_labels :: Maybe [Text], - edit_issue_state_event :: Maybe Text, - edit_issue_updated_at :: Maybe Text, - edit_issue_due_date :: Maybe Text, - edit_issue_weight :: Maybe Int, - edit_issue_discussion_locked :: Maybe Bool, - edit_issue_epic_id :: Maybe Int, - edit_issue_epic_iid :: Maybe Int - } - deriving (Generic, Show) - --- | Discussions https://docs.gitlab.com/ee/api/discussions.html -data Discussion = Discussion - { discussion_id :: Text, - discussion_individual_note :: Bool, - discussion_notes :: [Note] - } - deriving (Generic, Show) - --- | Notes -data Note = Note - { note_id :: Int, - -- https://docs.gitlab.com/ee/api/discussions.html#list-project-commit-discussion-items - note_type :: Maybe Text, -- TODO create type for this, e.g. from "DiscussionNote" - note_body :: Text, - note_attachment :: Maybe Text, - note_author :: Owner, - -- -- TODO parse these as date type - note_created_at :: Text, - note_updated_at :: Text, - note_system :: Bool, - note_noteable_id :: Maybe Int, - note_noteable_type :: Maybe Text, -- create type e.g. from "Commit" - note_noteable_iid :: Maybe Int, - note_resolvable :: Bool - } - deriving (Generic, Show) - --- | Statistics and an issue -newtype IssueStatistics = IssueStatistics - { issues_statistics :: IssueStats - } - deriving (Generic, Show) - --- | Issue statistics -newtype IssueStats = IssueStats - { issues_counts :: IssueCounts - } - deriving (Generic, Show) - --- | A count of all, open and closed issues against a project -data IssueCounts = IssueCounts - { issues_all :: Int, - issues_closed :: Int, - issues_opened :: Int - } - deriving (Generic, Show) - --- | Project issue boards https://docs.gitlab.com/ee/user/project/issue_board.html -data IssueBoard = IssueBoard - { board_id :: Int, - board_name :: Text, - board_project :: ProjectBoard, - board_milestone :: Maybe Milestone, - board_lists :: [BoardIssue], - board_group :: Maybe Text, -- not sure, documentation doesn't indicate type - board_assignee :: Maybe Owner, - board_labels :: Maybe [BoardIssueLabel], - board_weight :: Maybe Int - } - deriving (Generic, Show, Eq) - --- | Issues associated with a project issue board -data BoardIssue = BoardIssue - { board_issue_id :: Int, - board_issue_label :: BoardIssueLabel, - board_issue_position :: Int, - board_issue_max_issue_count :: Int, - board_issue_max_issue_weight :: Int, - -- TODO, the docs don't say what type this should be - board_issue_limit_metric :: Maybe Int - } - deriving (Generic, Show, Eq) - --- | Label of an issues for a project issue board -data BoardIssueLabel = BoardIssueLabel - { board_issue_label_id :: Maybe Int, - board_issue_label_name :: Text, - board_issue_label_color :: Text, -- parse into type from e.g. "#F0AD4E" - board_issue_label_description :: Maybe Text - } - deriving (Generic, Show, Eq) - --- | A project board -data ProjectBoard = ProjectBoard - { project_board_id :: Int, - project_board_name :: Text, - project_board_name_with_namespace :: Text, - project_board_path :: Text, - project_board_path_with_namespace :: Text, - project_board_http_url_to_repo :: Text, - project_board_web_url :: Text - } - deriving (Generic, Show, Eq) - --- | Project visibility. -data Visibility - = Public - | Private - | Internal - deriving (Show, Eq) - -instance FromJSON Visibility where - parseJSON (String "public") = return Public - parseJSON (String "private") = return Private - parseJSON (String "internal") = return Internal - parseJSON (Number 0) = return Private - parseJSON (Number 10) = return Internal - parseJSON (Number 20) = return Public - parseJSON n = error (show n) - --- | Unit test reports for a CI pipeline https://docs.gitlab.com/ee/ci/unit_test_reports.html -data TestReport = TestReport - { total_time :: Double, - total_count :: Int, - success_count :: Int, - failed_count :: Int, - skipped_count :: Int, - error_count :: Int, - test_suites :: [TestSuite] - } - deriving (Generic, Show, Eq) - --- | Testsuites associated with a test report -data TestSuite = TestSuite - { testsuite_name :: Text, - testsuite_total_time :: Double, - testsuite_success_count :: Int, - testsuite_failed_count :: Int, - testsuite_skipped_count :: Int, - testsuite_error_count :: Int, - testsuite_test_cases :: [TestCase] - } - deriving (Generic, Show, Eq) - -testsuitePrefix :: String -> String -testsuitePrefix "testsuite_name" = "name" -testsuitePrefix "testsuite_total_time" = "total_time" -testsuitePrefix "testsuite_success_count" = "success_count" -testsuitePrefix "testsuite_failed_count" = "failed_count" -testsuitePrefix "testsuite_skipped_count" = "skipped_count" -testsuitePrefix "testsuite_error_count" = "error_count" -testsuitePrefix "testsuite_test_cases" = "test_cases" -testsuitePrefix s = s - --- | Test case associated with a testsuite -data TestCase = TestCase - { testcase_status :: Text, -- could turn this into a type e.g. for "success" - testcase_name :: Text, - testcase_classname :: Text, - testcase_execution_time :: Double, - testcase_system_output :: Maybe Text, - testcase_stack_trace :: Maybe Text - } - deriving (Generic, Show, Eq) - -testcasePrefix :: String -> String -testcasePrefix "testcase_status" = "status" -testcasePrefix "testcase_name" = "name" -testcasePrefix "testcase_classname" = "classname" -testcasePrefix "testcase_execution_time" = "execution_time" -testcasePrefix "testcase_system_output" = "system_output" -testcasePrefix "testcase_stack_trace" = "stack_trace" -testcasePrefix s = s - ------------------------------ --- JSON GitLab parsers below ------------------------------ - -bodyNoPrefix :: String -> String -bodyNoPrefix "commit_created_at" = "created_at" -bodyNoPrefix "commit_id" = "id" -bodyNoPrefix "commit_status" = "status" -bodyNoPrefix "commit_parent_ids" = "parent_ids" -bodyNoPrefix "todo_commit_id" = "id" -bodyNoPrefix "todo_commit_short_id" = "short_id" -bodyNoPrefix "todo_commit_created_at" = "created_at" -bodyNoPrefix "todo_parent_ids" = "parent_ids" -bodyNoPrefix "issue_author" = "author" -bodyNoPrefix "issue_created_at" = "created_at" -bodyNoPrefix "issue_description" = "description" -bodyNoPrefix "issue_due_date" = "due_date" -bodyNoPrefix "issue_id" = "id" -bodyNoPrefix "issue_labels" = "labels" -bodyNoPrefix "issue_project_id" = "project_id" -bodyNoPrefix "issue_state" = "state" -bodyNoPrefix "issue_title" = "title" -bodyNoPrefix "issue_web_url" = "web_url" -bodyNoPrefix "link_events" = "events" -bodyNoPrefix "link_labels" = "labels" -bodyNoPrefix "member_avatar_url" = "avatar_url" -bodyNoPrefix "member_id" = "id" -bodyNoPrefix "member_name" = "name" -bodyNoPrefix "member_state" = "state" -bodyNoPrefix "member_username" = "username" -bodyNoPrefix "member_web_url" = "we_url" -bodyNoPrefix "namespace_id" = "id" -bodyNoPrefix "namespace_name" = "name" -bodyNoPrefix "namespace_path" = "path" -bodyNoPrefix "owner_avatar_url" = "avatar_url" -bodyNoPrefix "owner_id" = "id" -bodyNoPrefix "owner_name" = "name" -bodyNoPrefix "owner_username" = "username" -bodyNoPrefix "owner_web_url" = "web_url" -bodyNoPrefix "pipeline_id" = "id" -bodyNoPrefix "pipeline_status" = "status" -bodyNoPrefix "pipeline_web_url" = "web_url" -bodyNoPrefix "project_avatar_url" = "avatar_url" -bodyNoPrefix "project_created_at" = "created_at" -bodyNoPrefix "project_id" = "id" -bodyNoPrefix "project_name" = "name" -bodyNoPrefix "project_path" = "path" -bodyNoPrefix "project_path_with_namespace" = "path_with_namespace" -bodyNoPrefix "project_web_url" = "web_url" -bodyNoPrefix "repository_id" = "id" -bodyNoPrefix "repository_name" = "name" -bodyNoPrefix "repository_path" = "path" -bodyNoPrefix "repository_type" = "type" -bodyNoPrefix "user_avatar_uri" = "avatar_url" -bodyNoPrefix "user_id" = "id" -bodyNoPrefix "user_name" = "name" -bodyNoPrefix "user_state" = "state" -bodyNoPrefix "user_username" = "username" -bodyNoPrefix "user_web_url" = "web_url" -bodyNoPrefix "event_title" = "title" -bodyNoPrefix "event_project_id" = "project_id" -bodyNoPrefix "pipeline_ref" = "ref" -bodyNoPrefix "branch_name" = "name" -bodyNoPrefix "branch_default" = "default" -bodyNoPrefix "branch_commit" = "commit" -bodyNoPrefix "repository_file_file_name" = "file_name" -bodyNoPrefix "repository_file_file_path" = "file_path" -bodyNoPrefix "repository_file_size" = "size" -bodyNoPrefix "repository_file_commit_id" = "commit_id" -bodyNoPrefix "merge_request_id" = "id" -bodyNoPrefix "merge_request_iid" = "iid" -bodyNoPrefix "merge_request_project_id" = "project_id" -bodyNoPrefix "merge_request_title" = "title" -bodyNoPrefix "merge_request_description" = "description" -bodyNoPrefix "merge_request_state" = "state" -bodyNoPrefix "merge_request_merged_by" = "merged_by" -bodyNoPrefix "merge_request_merged_at" = "merged_at" -bodyNoPrefix "merge_request_closed_by" = "closed_by" -bodyNoPrefix "merge_request_closed_at" = "closed_at" -bodyNoPrefix "merge_request_created_at" = "created_at" -bodyNoPrefix "merge_request_updated_at" = "updated_at" -bodyNoPrefix "merge_request_target_branch" = "target_branch" -bodyNoPrefix "merge_request_source_branch" = "source_branch" -bodyNoPrefix "merge_request_upvotes" = "upvotes" -bodyNoPrefix "merge_request_downvotes" = "downvotes" -bodyNoPrefix "merge_request_author" = "author" -bodyNoPrefix "merge_request_assignee" = "assignee" -bodyNoPrefix "merge_request_source_project_id" = "source_project_id" -bodyNoPrefix "merge_request_target_project_id" = "target_project_id" -bodyNoPrefix "merge_request_labels" = "labels" -bodyNoPrefix "merge_request_work_in_progress" = "work_in_progress" -bodyNoPrefix "merge_request_milestone" = "milestone" -bodyNoPrefix "merge_request_merge_when_pipeline_succeeds" = "merge_when_pipeline_succeeds" -bodyNoPrefix "merge_request_merge_status" = "merge_status" -bodyNoPrefix "merge_request_sha" = "sha" -bodyNoPrefix "merge_request_merge_commit_sha" = "merge_commit_sha" -bodyNoPrefix "merge_request_user_notes_count" = "user_notes_count" -bodyNoPrefix "merge_request_discussion_locked" = "discussion_locked" -bodyNoPrefix "merge_request_should_remove_source_branch" = "should_remove_source_branch" -bodyNoPrefix "merge_request_force_remove_source_branch" = "force_remove_source_branch" -bodyNoPrefix "merge_request_allow_collaboration" = "allow_collaboration" -bodyNoPrefix "merge_request_allow_maintainer_to_push" = "allow_maintainer_to_push" -bodyNoPrefix "merge_request_web_url" = "web_url" -bodyNoPrefix "merge_request_time_stats" = "time_stats" -bodyNoPrefix "merge_request_squash" = "squash" -bodyNoPrefix "merge_request_approvals_before_merge" = "approvals_before_merge" -bodyNoPrefix "merge_request_allow_contribution" = "allow_contribution" -bodyNoPrefix "merge_request_changes_count" = "changes_count" -bodyNoPrefix "merge_request_pipeline" = "pipeline" -bodyNoPrefix "merge_request_diverged_commits_count" = "diverged_commits_count" -bodyNoPrefix "merge_request_rebase_in_progress" = "rebase_in_progress" -bodyNoPrefix "merge_request_has_conflicts" = "has_conflicts" -bodyNoPrefix "merge_request_blocking_discussions_resolved" = "blocking_discussions_resolved" -bodyNoPrefix "project_stats" = "statistics" -bodyNoPrefix "commit_stats" = "stats" -bodyNoPrefix "share_id" = "id" -bodyNoPrefix "share_project_id" = "project_id" -bodyNoPrefix "share_group_id" = "group_id" -bodyNoPrefix "share_group_access" = "group_access" -bodyNoPrefix "share_expires_at" = "expires_at" -bodyNoPrefix "group_id" = "id" -bodyNoPrefix "group_name" = "name" -bodyNoPrefix "group_path" = "path" -bodyNoPrefix "group_description" = "description" -bodyNoPrefix "group_visibility" = "visibility" -bodyNoPrefix "group_lfs_enabled" = "lfs_enabled" -bodyNoPrefix "group_avatar_url" = "avatar_url" -bodyNoPrefix "group_web_url" = "web_url" -bodyNoPrefix "group_request_access_enabled" = "request_access_enabled" -bodyNoPrefix "group_full_name" = "full_name" -bodyNoPrefix "group_full_path" = "full_path" -bodyNoPrefix "group_file_template_project_id" = "file_template_project_id" -bodyNoPrefix "group_parent_id" = "parent_id" -bodyNoPrefix "job_commit" = "commit" -bodyNoPrefix "job_coverage" = "coverage" -bodyNoPrefix "job_created_at" = "created_at" -bodyNoPrefix "job_started_at" = "started_at" -bodyNoPrefix "job_finished_at" = "finished_at" -bodyNoPrefix "job_duration" = "duration" -bodyNoPrefix "job_artifacts_expire_at" = "artifacts_expire_at" -bodyNoPrefix "job_id" = "id" -bodyNoPrefix "job_name" = "name" -bodyNoPrefix "job_pipeline" = "pipeline" -bodyNoPrefix "job_ref" = "ref" -bodyNoPrefix "job_artifacts" = "artifacts" -bodyNoPrefix "job_stage" = "stage" -bodyNoPrefix "job_status" = "status" -bodyNoPrefix "job_tag" = "tag" -bodyNoPrefix "job_web_url" = "web_url" -bodyNoPrefix "job_user" = "user" -bodyNoPrefix "discussion_id" = "id" -bodyNoPrefix "discussion_individual_note" = "individual_note" -bodyNoPrefix "discussion_notes" = "notes" -bodyNoPrefix "note_id" = "id" -bodyNoPrefix "note_type" = "type" -bodyNoPrefix "note_body" = "body" -bodyNoPrefix "note_attachment" = "attachment" -bodyNoPrefix "note_author" = "author" -bodyNoPrefix "note_created_at" = "created_at" -bodyNoPrefix "note_updated_at" = "updated_at" -bodyNoPrefix "note_system" = "system" -bodyNoPrefix "note_noteable_id" = "noteable_id" -bodyNoPrefix "note_noteable_type" = "noteable_type" -bodyNoPrefix "note_noteable_iid" = "iid" -bodyNoPrefix "note_resolvable" = "resolvable" --- TODO field names for Issues data type -bodyNoPrefix s = s - --- TODO refactor bodyNoPrefix function above into smaller --- String -> String --- functions like those below. - -tagPrefix :: String -> String -tagPrefix "tag_commit" = "commit" -tagPrefix "tag_release" = "release" -tagPrefix "tag_name" = "name" -tagPrefix "tag_target" = "target" -tagPrefix "tag_message" = "message" -tagPrefix "tag_protected" = "protected" -tagPrefix s = s - -releasePrefix :: String -> String -releasePrefix "release_tag_name" = "tag_name" -releasePrefix "release_description" = "description" -releasePrefix s = s - -issueStatsPrefix :: String -> String -issueStatsPrefix "issues_all" = "all" -issueStatsPrefix "issues_closed" = "closed" -issueStatsPrefix "issues_opened" = "opened" -issueStatsPrefix "issues_statistics" = "statistics" -issueStatsPrefix "issues_counts" = "counts" -issueStatsPrefix s = s - -boardsPrefix :: String -> String -boardsPrefix "board_id" = "id" -boardsPrefix "board_name" = "name" -boardsPrefix "board_project" = "project" -boardsPrefix "board_milestone" = "milestone" -boardsPrefix "board_lists" = "lists" -boardsPrefix "board_issue_id" = "id" -boardsPrefix "board_issue_label" = "label" -boardsPrefix "board_issue_position" = "position" -boardsPrefix "board_issue_max_issue_count" = "max_issue_count" -boardsPrefix "board_issue_max_issue_weight" = "max_issue_weight" -boardsPrefix "board_issue_limit_metric" = "limit_metric" -boardsPrefix "board_issue_label_name" = "name" -boardsPrefix "board_issue_label_color" = "color" -boardsPrefix "board_issue_label_description" = "description" -boardsPrefix "project_board_id" = "id" -boardsPrefix "project_board_name" = "name" -boardsPrefix "project_board_name_with_namespace" = "name_with_namespace" -boardsPrefix "project_board_path" = "path" -boardsPrefix "project_board_path_with_namespace" = "path_with_namespace" -boardsPrefix "project_board_http_url_to_repo" = "http_url_to_repo" -boardsPrefix "project_board_web_url" = "web_url" -boardsPrefix s = s - -instance FromJSON TimeStats where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Issue where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON User where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Commit where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON CommitTodo where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Tag where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = tagPrefix - } - ) - -instance FromJSON Release where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = releasePrefix - } - ) - -instance FromJSON CommitStats where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Pipeline where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Member where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Permissions where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Owner where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Links where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Namespace where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Project where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON ProjectStats where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Repository where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Job where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Artifact where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Group where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON GroupShare where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Branch where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON RepositoryFile where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON MergeRequest where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Diff where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Version where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance ToJSON EditIssueReq where - toEncoding = - genericToEncoding - defaultOptions - { fieldLabelModifier = drop (T.length "edit_issue_"), - omitNothingFields = True - } - -instance FromJSON Discussion where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON Note where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = bodyNoPrefix - } - ) - -instance FromJSON IssueCounts where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = issueStatsPrefix - } - ) - -instance FromJSON IssueStats where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = issueStatsPrefix - } - ) - -instance FromJSON IssueStatistics where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = issueStatsPrefix - } - ) - -instance FromJSON IssueBoard where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = boardsPrefix - } - ) - -instance FromJSON BoardIssue where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = boardsPrefix - } - ) - -instance FromJSON BoardIssueLabel where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = boardsPrefix - } - ) - -instance FromJSON ProjectBoard where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = boardsPrefix - } - ) - -instance FromJSON TestReport where - parseJSON = - genericParseJSON defaultOptions - -instance FromJSON TestSuite where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = testsuitePrefix - } - ) - -instance FromJSON TestCase where - parseJSON = - genericParseJSON - ( defaultOptions - { fieldLabelModifier = testcasePrefix - } - ) +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : GitLab.Types +-- Description : Haskell records corresponding to JSON data from GitLab API calls +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable +module GitLab.Types + ( GitLab, + GitLabState (..), + GitLabServerConfig (..), + defaultGitLabServer, + ArchiveFormat (..), + AccessLevel (..), + SearchIn (..), + Scope (..), + SortBy (..), + OrderBy (..), + Member (..), + SamlIdentity (..), + Identity (..), + Namespace (..), + Links (..), + Owner (..), + Permissions (..), + ProjectId, + Project (..), + Statistics (..), + User (..), + Milestone (..), + MilestoneState (..), + TimeStats (..), + IssueId, + Issue (..), + Epic (..), + Pipeline (..), + Commit (..), + CommitTodo (..), + CommitStats (..), + Contributor (..), + Tag (..), + Release (..), + Diff (..), + Repository (..), + Job (..), + Artifact (..), + Group (..), + GroupShare (..), + Branch (..), + RepositoryFile (..), + RepositoryFileBlame (..), + RepositoryFileSimple (..), + MergeRequest (..), + Todo (..), + TodoProject (..), + TodoAction (..), + TodoTarget (..), + TodoTargetType (..), + TodoType (..), + TodoState (..), + Version (..), + URL, + EditIssueReq (..), + Discussion (..), + CommitNote (..), + Note (..), + CommandsChanges (..), + IssueStatistics (..), + IssueStats (..), + IssueCounts (..), + IssueBoard (..), + BoardIssue (..), + BoardIssueLabel (..), + Visibility (..), + TestReport (..), + TestSuite (..), + TestCase (..), + TimeEstimate (..), + TaskCompletionStatus (..), + References (..), + Change (..), + DiffRefs (..), + DetailedStatus (..), + License (..), + ExpirationPolicy (..), + RepositoryStorage (..), + Starrer (..), + ProjectAvatar (..), + Email (..), + Key (..), + UserPrefs (..), + UserStatus (..), + UserCount (..), + Event (..), + EventActionName (..), + EventTargetType (..), + PushData (..), + ) +where + +import Control.Monad.Trans.Reader +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Types +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock +import Network.HTTP.Conduit + +-- | type synonym for all GitLab actions. +type GitLab a = ReaderT GitLabState IO a + +-- | state used by GitLab actions, used internally. +data GitLabState = GitLabState + { serverCfg :: GitLabServerConfig, + httpManager :: Manager + } + +-- | configuration data specific to a GitLab server. +data GitLabServerConfig = GitLabServerConfig + { url :: Text, + -- | personal access token, see + token :: Text, + -- | milliseconds + timeout :: Int, + -- | how many times to retry a HTTP request before giving up and returning an error. + retries :: Int, + -- | write system hook events to files in the system temporary + -- directory. + debugSystemHooks :: Bool + } + +-- | default settings, the 'url' and 'token' values will need to be overwritten. +defaultGitLabServer :: GitLabServerConfig +defaultGitLabServer = + GitLabServerConfig + { url = "https://gitlab.com", + token = "", + timeout = 15000000, -- 15 seconds + retries = 5, + debugSystemHooks = False + } + +-- https://docs.gitlab.com/ee/api/repositories.html#get-file-archive +-- tar.gz, tar.bz2, tbz, tbz2, tb2, bz2, tar, and zip + +-- | archive format for file archives of repositories. +-- See 'GitLab.API.Repositories.getFileArchive' in 'GitLab.API.Repositories'. +data ArchiveFormat + = -- | ".tar.gz" + TarGz + | -- | ".tar.bz2" + TarBz2 + | -- | ".tbz" + Tbz + | -- | ".tbz2" + Tbz2 + | -- | ".tb2" + Tb2 + | -- | ".bz2" + Bz2 + | -- | ".tar" + Tar + | -- | ".zip" + Zip + +instance Show ArchiveFormat where + show TarGz = ".tar.gz" + show TarBz2 = ".tar.bz2" + show Tbz = ".tbz" + show Tbz2 = ".tbz2" + show Tb2 = ".tb2" + show Bz2 = ".bz2" + show Tar = ".tar" + show Zip = ".zip" + +-- | the access levels for project members. See +data AccessLevel + = Guest + | Reporter + | Developer + | Maintainer + | Owner + deriving (Eq) + +instance Show AccessLevel where + show Guest = "10" + show Reporter = "20" + show Developer = "30" + show Maintainer = "40" + show Owner = "50" + +-- | Where to filter a search within +data SearchIn + = JustTitle + | JustDescription + | TitleAndDescription + +instance Show SearchIn where + show JustTitle = "title" + show JustDescription = "description" + show TitleAndDescription = "title,description" + +-- | Scope of search results +data Scope + = CreatedByMe + | AssignedToMe + | All + +instance Show Scope where + show CreatedByMe = "created_by_me" + show AssignedToMe = "assigned_to_me" + show All = "all" + +-- | Sort objects in ascending or descending order +data SortBy + = Ascending + | Descending + +instance Show SortBy where + show Ascending = "asc" + show Descending = "desc" + +-- | Ordering search results +data OrderBy + = CreatedAt + | UpdatedAt + | Priority + | DueDate + | RelativePosition + | LabelPriority + | MilestoneDue + | Popularity + | Weight + +instance Show OrderBy where + show CreatedAt = "created_at" + show UpdatedAt = "updated_at" + show Priority = "priority" + show DueDate = "due_date" + show RelativePosition = "relative_position" + show LabelPriority = "label_priority" + show MilestoneDue = "milestone_due" + show Popularity = "popularity" + show Weight = "weight" + +-- | member of a project. +data Member = Member + { member_id :: Int, + member_name :: Maybe Text, + member_email :: Maybe Text, --- TODO type for email address e.g. zhang@example.com + member_username :: Maybe Text, + member_state :: Maybe Text, + member_avatar_uri :: Maybe Text, + member_web_url :: Maybe Text, + member_access_level :: Maybe Int, + member_group_saml_identity :: Maybe SamlIdentity, + member_expires_at :: Maybe Text, + member_invited :: Maybe Bool, + member_override :: Maybe Bool, + member_avatar_url :: Maybe Text, -- TODO type for URL + member_approved :: Maybe Bool, + member_membership_type :: Maybe Text, -- TODO type for "group_member" + member_last_activity_on :: Maybe Text, -- TODO type for "2021-01-27" + member_created_at :: Maybe UTCTime, + member_removable :: Maybe Bool, + member_membership_state :: Maybe Text -- type for "active" + } + deriving (Show, Eq) + +-- TODO merge Identity and SamlIdentity into a single type. + +-- | identity +data Identity = Identity + { identity_extern_uid :: Text, + identity_provider :: Text, + identity_provider_id :: Maybe Int + } + deriving (Show, Eq) + +-- | SAML identity +data SamlIdentity = SamlIdentity + { saml_identity_extern_uid :: Text, + saml_identity_provider :: Text, + saml_identity_saml_provider_id :: Maybe Int + } + deriving (Show, Eq) + +-- | namespaces. +data Namespace = Namespace + { namespace_id :: Int, + namespace_name :: Text, + namespace_path :: Text, + namespace_kind :: Text, + namespace_full_path :: Maybe Text, + namespace_avatar_url :: Maybe Text, + namespace_web_url :: Maybe Text, + namespace_parent_id :: Maybe Int + } + deriving (Show, Eq) + +-- | links. +data Links = Links + { links_self :: Text, + links_issues :: Maybe Text, + links_notes :: Maybe Text, + links_award_emoji :: Maybe Text, + links_project :: Maybe Text, + links_merge_requests :: Maybe Text, + links_repo_branches :: Maybe Text, + links_labels :: Maybe Text, + links_events :: Maybe Text, + links_members :: Maybe Text + } + deriving (Show, Eq) + +-- | owners. +data Owner = Ownwer + { owner_id :: Int, + owner_name :: Text, + owner_username :: Maybe Text, + owner_email :: Maybe Text, + owner_state :: Maybe Text, + owner_avatar_url :: Maybe Text, + owner_web_url :: Maybe Text, + owner_created_at :: Maybe UTCTime + } + deriving (Show, Eq) + +-- | permissions. +data Permissions = Permissions + { permissions_project_access :: Maybe Value, + permissions_group_access :: Maybe Value + } + deriving (Show, Eq) + +-- | projects. +data Project = Project + { project_id :: Int, + project_description :: Maybe Text, + project_name :: Text, + project_name_with_namespace :: Text, + project_path :: Text, + project_path_with_namespace :: Text, + project_created_at :: Maybe UTCTime, + project_default_branch :: Maybe Text, + project_tag_list :: Maybe [Text], -- GitLab Docs: "deprecated, use `topics` instead" + project_topics :: Maybe [Text], + project_ssh_url_to_repo :: Maybe Text, + project_http_url_to_repo :: Maybe Text, + project_web_url :: Text, + project_readme_url :: Maybe Text, -- check + project_avatar_url :: Maybe Text, + project_license_url :: Maybe Text, + project_license :: Maybe License, + project_star_count :: Maybe Int, + project_runners_token :: Maybe Text, -- "b8547b1dc37721d05889db52fa2f02" + project_ci_default_git_depth :: Maybe Int, + project_ci_forward_deployment_enabled :: Maybe Bool, + project_forks_count :: Maybe Int, + project_last_activity_at :: Maybe UTCTime, + project_namespace :: Maybe Namespace, + project_archived :: Maybe Bool, + project_visibility :: Maybe Text, + project_owner :: Maybe Owner, + project_resolve_outdated_diff_discussions :: Maybe Bool, + project_container_registry_enabled :: Maybe Bool, + project_container_registry_access_level :: Maybe Text, -- TODO + project_container_expiration_policy :: Maybe ExpirationPolicy, + -- type for "disabled" + project_issues_enabled :: Maybe Bool, + project_merge_requests_enabled :: Maybe Bool, + project_wiki_enabled :: Maybe Bool, + project_jobs_enabled :: Maybe Bool, + project_snippets_enabled :: Maybe Bool, + project_can_create_merge_request_in :: Maybe Bool, + project_issues_access_level :: Maybe Text, -- TODO a type for "enabled" + project_repository_access_level :: Maybe Text, -- TODO a type for "enabled" + project_merge_requests_access_level :: Maybe Text, -- TODO a type for "enabled" + project_forking_access_level :: Maybe Text, -- TODO a type for "enabled" + project_analytics_access_level :: Maybe Text, -- TODO a type for "enabled" + project_wiki_access_level :: Maybe Text, -- TODO a type for "enabled" + project_builds_access_level :: Maybe Text, -- TODO a type for "enabled" + project_snippets_access_level :: Maybe Text, -- TODO a type for "enabled" + project_pages_access_level :: Maybe Text, -- TODO a type for "enabled" + project_emails_disabled :: Maybe Bool, -- check + project_shared_runners_enabled :: Maybe Bool, + project_lfs_enabled :: Maybe Bool, + project_creator_id :: Maybe Int, + project_forked_from_project :: Maybe Project, + project_import_status :: Maybe String, + project_open_issues_count :: Maybe Int, + project_public_jobs :: Maybe Bool, + project_build_timeout :: Maybe Int, + project_auto_cancel_pending_pipelines :: Maybe Text, -- TODO a type for "enabled" + project_ci_config_path :: Maybe Text, -- check null + project_shared_with_groups :: Maybe [GroupShare], + project_only_allow_merge_if_pipeline_succeeds :: Maybe Bool, + project_allow_merge_on_skipped_pipeline :: Maybe Bool, + project_restrict_user_defined_variables :: Maybe Bool, + project_request_access_enabled :: Maybe Bool, + project_only_allow_merge_if_all_discussions_are_resolved :: Maybe Bool, + project_remove_source_branch_after_merge :: Maybe Bool, + project_printing_merge_request_link_enabled :: Maybe Bool, + project_printing_merge_requests_link_enabled :: Maybe Bool, + project_merge_method :: Maybe Text, -- TODO type for "merge" + project_squash_option :: Maybe Text, -- TODO type for "default_on" + project_autoclose_referenced_issues :: Maybe Bool, + project_suggestion_commit_message :: Maybe Text, + project_marked_for_deletion_at :: Maybe Text, -- TODO "2020-04-03" + project_marked_for_deletion_on :: Maybe Text, -- TODO "2020-04-03" + project_compliance_frameworks :: Maybe [Text], + project_statistics :: Maybe Statistics, + project_permissions :: Maybe Permissions, + project_container_registry_image_prefix :: Maybe Text, + project__links :: Maybe Links, + project_mirror :: Maybe Bool, + project_mirror_overwrites_diverged_branches :: Maybe Bool, + project_mirror_trigger_builds :: Maybe Bool, + project_auto_devops_deploy_strategy :: Maybe Text, + project_auto_devops_enabled :: Maybe Bool, + project_service_desk_enabled :: Maybe Bool, + project_approvals_before_merge :: Maybe Int, + project_mirror_user_id :: Maybe Int, + project_packages_enabled :: Maybe Bool, + project_empty_repo :: Maybe Bool, + project_only_mirror_protected_branches :: Maybe Bool, + project_repository_storage :: Maybe Text -- TODO type for "default" + } + deriving (Show, Eq) + +-- | Licenses. +data License = License + { license_key :: Maybe Text, + license_name :: Maybe Text, + license_nickname :: Maybe Text, + license_html_url :: Maybe Text, + license_source_url :: Maybe Text + } + deriving (Show, Eq) + +-- | Expiration policies. +data ExpirationPolicy = ExpirationPolicy + { expiration_policy_cadence :: Maybe Text, + expiration_policy_enabled :: Maybe Bool, + expiration_policy_keep_n :: Maybe Int, + expiration_policy_older_than :: Maybe Text, + expiration_policy_name_regex :: Maybe Text, + expiration_policy_name_regex_delete :: Maybe Value, -- TODO + expiration_policy_name_regex_keep :: Maybe Value, -- TODO + expiration_policy_next_run_at :: Maybe UTCTime + } + deriving (Show, Eq) + +-- | Information about repository storage. +data RepositoryStorage = RepositoryStorage + { repository_storage_project_id :: Int, + repository_storage_disk_path :: Maybe Text, + repository_storage_created_at :: Maybe UTCTime, + repository_storage_repository_storage :: Maybe Text + } + deriving (Show, Eq) + +-- | project statistics. +data Statistics = Statistics + { statistics_commit_count :: Maybe Int, + statistics_storage_size :: Int, + statistics_repository_size :: Int, + statistics_wiki_size :: Maybe Int, + statistics_lfs_objects_size :: Maybe Int, + statistics_job_artifacts_size :: Maybe Int, + statistics_packages_size :: Maybe Int, + statistics_uploads_size :: Maybe Int, + statistics_snippets_size :: Maybe Int, + statistics_pipeline_artifacts_size :: Maybe Int + } + deriving (Show, Eq) + +-- | registered users. +data User = User + { user_id :: Int, + user_username :: Text, + user_bio :: Maybe Text, + user_two_factor_enabled :: Maybe Bool, + user_last_sign_in_at :: Maybe UTCTime, + user_current_sign_in_at :: Maybe UTCTime, + user_last_activity_on :: Maybe Text, -- test current-user has '2012-05-23' + user_skype :: Maybe Text, + user_twitter :: Maybe Text, + user_website_url :: Maybe Text, + user_theme_id :: Maybe Int, + user_color_scheme_id :: Maybe Int, + user_external :: Maybe Bool, + user_private_profile :: Maybe Bool, + user_projects_limit :: Maybe Int, + user_can_create_group :: Maybe Bool, + user_can_create_project :: Maybe Bool, + user_public_email :: Maybe Text, + user_organization :: Maybe Text, + user_job_title :: Maybe Text, + user_linkedin :: Maybe Text, + user_confirmed_at :: Maybe UTCTime, + user_identities :: Maybe [Identity], + user_name :: Text, + user_email :: Maybe Text, + user_followers :: Maybe Int, + user_bot :: Maybe Bool, + user_following :: Maybe Int, + user_state :: Text, + user_avatar_url :: Maybe Text, + user_web_url :: Maybe Text, + user_discussion_locked :: Maybe Bool, -- only for author of 'TODO' type + user_created_at :: Maybe UTCTime + } + deriving (Show, Eq) + +-- | milestone state. +data MilestoneState + = MSActive + | MSClosed + deriving (Show, Eq) + +instance FromJSON MilestoneState where + parseJSON (String "active") = return MSActive + parseJSON (String "closed") = return MSClosed + parseJSON x = unexpected x + +-- | milestones. +data Milestone = Milestone + { milestone_project_id :: Maybe Int, + milestone_group_id :: Maybe Int, + milestone_description :: Maybe Text, + milestone_state :: Maybe MilestoneState, + milestone_due_date :: Maybe Text, + milestone_start_date :: Maybe Text, + milestone_iid :: Maybe Int, + milestone_created_at :: Maybe UTCTime, + milestone_closed_at :: Maybe UTCTime, + milestone_title :: Text, + milestone_id :: Int, + milestone_updated_at :: Maybe UTCTime, + milestone_web_url :: Maybe URL + } + deriving (Show, Eq) + +-- instance FromJSON Milestone where +-- parseJSON = genericParseJSON (defaultOptions {fieldLabelModifier = drop 10}) + +-- | time stats. +data TimeStats = TimeStats + { time_stats_time_estimate :: Int, + time_stats_total_time_spent :: Int, + time_stats_human_time_estimate :: Maybe Int, + time_stats_human_total_time_spent :: Maybe Int + } + deriving (Show, Eq) + +-- | alias for project id +type ProjectId = Int + +-- | alias for issue id +type IssueId = Int + +-- | project issues. +data Issue = Issue + { issue_state :: Text, + issue_description :: Maybe Text, + issue_health_status :: Maybe Text, -- TODO type for "on_track" + issue_author :: Maybe User, + issue_milestone :: Maybe Milestone, + issue_project_id :: Maybe ProjectId, + issue_assignees :: Maybe [User], + issue_assignee :: Maybe User, + issue_updated_at :: Maybe UTCTime, + issue_closed_at :: Maybe Text, + issue_closed_by :: Maybe User, + issue_id :: IssueId, + issue_title :: Text, + issue_created_at :: Maybe UTCTime, + issue_iid :: Int, + -- TODO: what is the difference between the two below? + issue_type :: Maybe Text, -- type for this e.g. "ISSUE" + issue_issue_type :: Maybe Text, -- type for this e.g. "issue" + issue_labels :: Maybe [Text], + issue_upvotes :: Int, + issue_downvotes :: Int, + issue_merge_requests_count :: Maybe Int, + issue_user_notes_count :: Maybe Int, + issue_due_date :: Maybe Text, + issue_web_url :: Text, + issue_references :: Maybe References, + issue_confidential :: Maybe Bool, + issue_weight :: Maybe Text, -- Int? + issue_epic :: Maybe Epic, -- Int? + issue_discussion_locked :: Maybe Bool, + issue_time_stats :: Maybe TimeStats, + issue_has_tasks :: Maybe Bool, + issue_task_status :: Maybe Text, + issue__links :: Maybe Links, + issue_task_completion_status :: Maybe TaskCompletionStatus, + issue_blocking_issues_count :: Maybe Int, + issue_subscribed :: Maybe Bool, + issue_service_desk_reply_to :: Maybe Text + } + deriving (Show, Eq) + +-- | GitLab epic. +data Epic = Epic + { epic_id :: Int, + epic_iid :: Int, + epic_title :: Text, + epic_url :: Text, + epic_group_id :: Int + } + deriving (Show, Eq) + +-- | project pipelines +data Pipeline = Pipeline + { pipeline_id :: Int, + pipeline_iid :: Maybe Int, + pipeline_project_id :: Maybe Int, + pipeline_sha :: Text, + pipeline_ref :: Text, + pipeline_status :: Text, + pipeline_web_url :: Maybe Text, + pipeline_before_sha :: Maybe Text, + pipeline_tag :: Maybe Bool, + pipeline_yaml_errors :: Maybe Text, + pipeline_user :: Maybe User, + pipeline_created_at :: Maybe UTCTime, + pipeline_updated_at :: Maybe UTCTime, + pipeline_started_at :: Maybe UTCTime, + pipeline_finished_at :: Maybe UTCTime, + pipelined_committed_at :: Maybe UTCTime, + pipeline_duration :: Maybe Int, + pipeline_queued_duration :: Maybe Double, + pipeline_coverage :: Maybe Text, + pipeline_detailed_status :: Maybe DetailedStatus + } + deriving (Show, Eq) + +-- | project pipelines +data DetailedStatus = DetailedStatus + { detailed_status_icon :: Maybe Text, -- "status_pending" + detailed_status_text :: Maybe Text, + detailed_status_label :: Maybe Text, + detailed_status_group :: Maybe Text, + detailed_status_tooltip :: Maybe Text, + detailed_status_has_details :: Maybe Bool, + detailed_status_details_path :: Maybe Text, + detailed_status_illustration :: Maybe Text, + detailed_status_favicon :: Maybe Text + } + deriving (Show, Eq) + +-- | code commits. +data Commit = Commit + { commit_id :: Text, + commit_short_id :: Text, + commit_title :: Text, + commit_author_name :: Text, + commit_author_email :: Text, + commit_authored_date :: Maybe Text, -- ZonedTime ? + commit_committer_name :: Maybe Text, + commit_committer_email :: Maybe Text, + commit_committed_date :: Maybe Text, -- ZonedTime ? + commit_created_at :: Maybe Text, -- ZonedTime ? + commit_message :: Text, + commit_parent_ids :: Maybe [String], + commit_last_pipeline :: Maybe Pipeline, + commit_stats :: Maybe CommitStats, + commit_status :: Maybe Text, + commit_web_url :: Maybe Text + } + deriving (Show, Eq) + +-- | summary of a code commit for TODOs. +data CommitTodo = CommitTodo + { commit_todo_id :: Text, + commit_todo_short_id :: Text, + commit_todo_created_at :: UTCTime, + commit_todo_parent_ids :: Maybe [String] + } + deriving (Show, Eq) + +-- | repository contributors. +data Contributor = Contributor + { contributor_name :: Text, + contributor_email :: Text, + contributor_commits :: Int, + contributor_additions :: Int, + contributor_deletions :: Int + } + deriving (Show, Eq) + +-- | commit stats. +data CommitStats = CommitStats + { commitstats_additions :: Int, + commitstats_deletions :: Int, + commitstats_total :: Int + } + deriving (Show, Eq) + +-- | tags. +data Tag = Tag + { tag_commit :: Commit, + tag_release :: Maybe Release, + tag_name :: Text, + tag_target :: Text, + tag_message :: Maybe Text, + tag_protected :: Bool + } + deriving (Show, Eq) + +-- | Release associated with a tag +data Release = Release + { release_tag_name :: Text, + release_description :: Text + } + deriving (Show, Eq) + +-- | diff between two commits. +data Diff = Diff + { diff_diff :: Text, + diff_new_path :: Text, + diff_old_path :: Text, + diff_a_mode :: Maybe Text, + diff_b_mode :: Maybe Text, + diff_new_file :: Bool, + diff_renamed_file :: Bool, + diff_deleted_file :: Bool + } + deriving (Show, Eq) + +-- | repositories. +data Repository = Repository + { repository_id :: Text, + repository_name :: Text, + repository_type :: Text, + repository_path :: Text, + repository_mode :: Text + } + deriving (Show, Eq) + +-- | artifacts. +data Artifact = Artifact + { artifact_file_type :: Maybe Text, + artifact_size :: Int, + artifact_filename :: Text, + artifact_file_format :: Maybe Text + } + deriving (Show, Eq) + +-- | groups. +data Group = Group + { group_id :: Int, + group_name :: Text, + group_path :: Maybe Text, + group_description :: Maybe Text, + group_visibility :: Maybe Text, + group_share_with_group_lock :: Maybe Bool, + group_require_two_factor_authentication :: Maybe Bool, + group_two_factor_grace_period :: Maybe Int, + group_project_creation_level :: Maybe Text, -- TODO type for "developer" + group_auto_devops_enabled :: Maybe Bool, + group_subgroup_creation_level :: Maybe Text, -- TODO type for "owner" + group_emails_disabled :: Maybe Bool, + group_mentions_disabled :: Maybe Bool, + group_default_branch_protection :: Maybe Int, + group_lfs_enabled :: Maybe Bool, + group_avatar_url :: Maybe Text, + group_web_url :: Maybe Text, + group_request_access_enabled :: Maybe Bool, + group_full_name :: Maybe Text, + group_full_path :: Maybe Text, + group_runners_token :: Maybe Text, + group_file_template_project_id :: Maybe Int, + group_parent_id :: Maybe Int, + group_created_at :: Maybe UTCTime, + group_statistics :: Maybe Statistics, + group_shared_with_groups :: Maybe [GroupShare], + group_prevent_sharing_groups_outside_hierarchy :: Maybe Bool + } + deriving (Show, Eq) + +-- | response to sharing a project with a group. +data GroupShare = GroupShare + { groupshare_id :: Maybe Int, + groupshare_project_id :: Maybe Int, + groupshare_group_id :: Int, + groupshare_group_name :: Maybe Text, + groupshare_group_full_path :: Maybe Text, + groupshare_group_access_level :: Int, -- TODO change this to 'AccessLevel' + groupshare_expires_at :: Maybe Text + } + deriving (Show, Eq) + +-- | code branches. +data Branch = Branch + { branch_name :: Text, + branch_merged :: Bool, + branch_protected :: Bool, + branch_default :: Bool, + branch_developers_can_push :: Bool, + branch_developers_can_merge :: Bool, + branch_can_push :: Bool, + branch_web_url :: Maybe Text, + branch_commit :: Commit + } + deriving (Show, Eq) + +-- | files in a repository. +data RepositoryFile = RepositoryFile + { repository_file_file_name :: Text, + repository_file_file_path :: Text, + repository_file_size :: Int, + repository_file_encoding :: Text, + repository_file_content :: Text, + repository_file_content_sha256 :: Text, + repository_file_ref :: Text, + repository_file_blob_id :: Text, + repository_file_commit_id :: Text, + repository_file_last_commit_id :: Text, + repository_file_execute_filemode :: Maybe Bool + } + deriving (Show, Eq) + +-- | files in a repository. +data RepositoryFileSimple = RepositoryFileSimple + { repository_file_simple_file_path :: Text, + repository_file_simple_branch :: Text + } + deriving (Show, Eq) + +-- | files in a repository. +data RepositoryFileBlame = RepositoryFileBlame + { repository_file_blame_commit :: Commit, + repository_file_blame_lines :: [Text] + } + deriving (Show, Eq) + +-- | project merge requests. +data MergeRequest = MergeRequest + { merge_request_id :: Int, + merge_request_iid :: Int, + merge_request_project_id :: Int, + merge_request_title :: Text, + merge_request_description :: Text, + merge_request_state :: Text, -- TODO make a type e.g. 'reopened' + merge_request_created_at :: UTCTime, + merge_request_updated_at :: UTCTime, + merge_request_target_branch :: Text, + merge_request_source_branch :: Text, + merge_request_upvotes :: Int, + merge_request_downvotes :: Int, + merge_request_author :: User, + merge_request_assignee :: Maybe User, + merge_request_assignees :: Maybe [User], + merge_request_reviewers :: Maybe [User], + merge_request_source_project_id :: Int, + merge_request_target_project_id :: Int, + merge_request_labels :: [Text], + merge_request_draft :: Maybe Bool, + merge_request_work_in_progress :: Bool, + merge_request_milestone :: Maybe Milestone, + merge_request_merge_when_pipeline_succeeds :: Bool, + merge_request_merge_status :: Text, -- create type e.g. for "can_be_merged" + merge_request_merge_error :: Maybe Text, + merge_request_sha :: Maybe Text, + merge_request_merge_commit_sha :: Maybe Text, + merge_request_squash_commit_sha :: Maybe Text, + merge_request_user_notes_count :: Int, + merge_request_discussion_locked :: Maybe Bool, + merge_request_should_remove_source_branch :: Maybe Bool, + merge_request_force_remove_source_branch :: Maybe Bool, + merge_request_allow_collaboration :: Maybe Bool, + merge_request_allow_maintainer_to_push :: Maybe Bool, + merge_request_web_url :: Maybe Text, + merge_request_time_stats :: Maybe TimeStats, + merge_request_squash :: Maybe Bool, + merge_request_subscribed :: Maybe Bool, + merge_request_changes_count :: Maybe String, + merge_request_merged_by :: Maybe User, + merge_request_merged_at :: Maybe UTCTime, + merge_request_closed_by :: Maybe User, + merge_request_closed_at :: Maybe UTCTime, + merge_request_latest_build_started_at :: Maybe UTCTime, + merge_request_latest_build_finished_at :: Maybe UTCTime, + merge_request_first_deployed_to_production_at :: Maybe UTCTime, + merge_request_pipeline :: Maybe Pipeline, + merge_request_head_pipeline :: Maybe Pipeline, + merge_request_diverged_commits_count :: Maybe Int, + merge_request_rebase_in_progress :: Maybe Bool, + merge_request_first_contribution :: Maybe Bool, + merge_request_has_conflicts :: Maybe Bool, + merge_request_blocking_discussions_resolved :: Maybe Bool, + merge_request_approvals_before_merge :: Maybe Int, + merge_request_mirror :: Maybe Bool, + merge_request_task_completion_status :: Maybe TaskCompletionStatus, + merge_request_reference :: Maybe Text, + merge_request_references :: Maybe References, + merge_request_changes :: Maybe [Change], + merge_request_overflow :: Maybe Bool, + merge_request_diff_refs :: Maybe DiffRefs + } + deriving (Show, Eq) + +-- | monitors a task completion status. +data TaskCompletionStatus = TaskCompletionStatus + { task_completion_status_count :: Int, + task_completion_status_completed_count :: Maybe Int + } + deriving (Show, Eq) + +-- | references. +data References = References + { references_short :: Text, + references_relative :: Text, + references_full :: Text + } + deriving (Show, Eq) + +-- | Change between commits. +data Change = Change + { change_old_path :: Text, + change_new_path :: Text, + change_a_mode :: Text, -- find type for "100644" + change_b_mode :: Text, -- find type for "100644" + change_diff :: Text, -- find type for "--- a/VERSION\\ +++ b/VERSION\\ @@ -1 +1 @@\\ -1.9.7\\ +1.9.8" + change_new_file :: Bool, + change_renamed_file :: Bool, + change_deleted_file :: Bool + } + deriving (Show, Eq) + +-- | diff references. +data DiffRefs = DiffRefs + { diff_refs_base_sha :: Text, + diff_refs_head_sha :: Text, + diff_refs_start_sha :: Text + } + deriving (Show, Eq) + +{- TODO for MergeRequest + + "references": { + "short": "!1", + "relative": "!1", + "full": "my-group/my-project!1" + }, + + "changes": [ + { + "old_path": "VERSION", + "new_path": "VERSION", + "a_mode": "100644", + "b_mode": "100644", + "diff": "--- a/VERSION\\ +++ b/VERSION\\ @@ -1 +1 @@\\ -1.9.7\\ +1.9.8", + "new_file": false, + "renamed_file": false, + "deleted_file": false + } + + "overflow": false + + "diff_refs": { + "base_sha": "c380d3acebd181f13629a25d2e2acca46ffe1e00", + "head_sha": "2be7ddb704c7b6b83732fdd5b9f09d5a397b5f8f", + "start_sha": "c380d3acebd181f13629a25d2e2acca46ffe1e00" + }, + +-} + +-- | TODO action. +data TodoAction + = TAAssigned + | TAMentioned + | TABuildFailed + | TAMarked + | TAApprovalRequired + | TAUnmergeable + | TADirectlyAddressed + deriving (Show, Eq) + +instance FromJSON TodoAction where + parseJSON (String "assigned") = return TAAssigned + parseJSON (String "mentioned") = return TAMentioned + parseJSON (String "build_failed") = return TABuildFailed + parseJSON (String "marked") = return TAMarked + parseJSON (String "approval_required") = return TAApprovalRequired + parseJSON (String "unmergeable") = return TAUnmergeable + parseJSON (String "directly_addressed") = return TADirectlyAddressed + parseJSON x = unexpected x + +-- | TODO targets. +data TodoTarget + = TTIssue Issue + | TTMergeRequest MergeRequest + | TTCommit CommitTodo + deriving (Show, Eq) + +-- | URL is a synonym for 'Text'. +type URL = Text + +-- | TODO states. +data TodoState + = TSPending + | TSDone + deriving (Show, Eq) + +-- | A project TODO. +data TodoProject = TodoProject + { todo_project_id :: Int, + todo_project_description :: Maybe Text, + todo_project_name :: Text, + todo_project_name_with_namespace :: Text, + todo_project_path :: Text, + todo_project_path_with_namespace :: Text, + todo_project_created_at :: Maybe UTCTime + } + deriving (Show, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "todo_project_"), omitNothingFields = True} ''TodoProject) + +-- | TODOs. +data Todo = Todo + { todo_id :: Int, + todo_project :: TodoProject, + todo_author :: User, + todo_action_name :: TodoAction, + todo_target_type :: TodoTargetType, + todo_target :: TodoTarget, + todo_target_url :: URL, + todo_body :: Text, + todo_state :: TodoState, + todo_created_at :: UTCTime, + todo_updated_at :: Maybe UTCTime + } + deriving (Show, Eq) + +-- | Target type of a TODO. +data TodoTargetType + = MergeRequestTarget + | IssueTarget + | CommitTarget + deriving (Show, Eq) + +-- | Type of a TODO. +data TodoType + = TodoTypeIssue + | TodoTypeMergeRequest + | TodoTypeCommit + | TodoTypeEpic + | TodoTypeDesign + | TodoTypeAlert + +instance Show TodoType where + show TodoTypeIssue = "Issue" + show TodoTypeMergeRequest = "MergeRequest" + show TodoTypeCommit = "Commit" + show TodoTypeEpic = "Epic" + show TodoTypeDesign = "DesignManagement::Design" + show TodoTypeAlert = "AlertManagement::Alert" + +-- | version of the GitLab instance. +data Version = Version + { version_version :: Text, + version_revision :: Text + } + deriving (Show, Eq) + +-- | An edit issue request. +data EditIssueReq = EditIssueReq + { edit_issue_id :: ProjectId, + edit_issue_issue_iid :: IssueId, + edit_issue_title :: Maybe Text, + edit_issue_description :: Maybe Text, + edit_issue_confidential :: Maybe Bool, + edit_issue_assignee_ids :: Maybe [Int], + edit_issue_milestone_id :: Maybe Int, + edit_issue_labels :: Maybe [Text], + edit_issue_state_event :: Maybe Text, + edit_issue_updated_at :: Maybe UTCTime, + edit_issue_due_date :: Maybe Text, + edit_issue_weight :: Maybe Int, + edit_issue_discussion_locked :: Maybe Bool, + edit_issue_epic_id :: Maybe Int, + edit_issue_epic_iid :: Maybe Int + } + deriving (Show) + +-- | Discussions https://docs.gitlab.com/ee/api/discussions.html +data Discussion = Discussion + { discussion_id :: Text, + discussion_individual_note :: Bool, + discussion_notes :: [Note] + } + deriving (Show, Eq) + +-- | Note attached to a commit. +data CommitNote = CommitNote + { commitnote_note :: Text, + commitnote_author :: User + } + deriving (Show, Eq) + +-- | Notes +data Note = Note + { note_id :: Int, + note_title :: Maybe Text, -- for snippets + note_file_name :: Maybe Text, -- for snippets + -- https://docs.gitlab.com/ee/api/discussions.html#list-project-commit-discussion-items + note_type :: Maybe Text, -- TODO create type for this, e.g. from "DiscussionNote" + note_body :: Maybe Text, + note_attachment :: Maybe Text, + note_author :: Owner, + note_created_at :: UTCTime, + note_updated_at :: Maybe UTCTime, + note_system :: Maybe Bool, + note_noteable_id :: Maybe Int, + note_noteable_type :: Maybe Text, -- create type e.g. from "Commit" + note_noteable_iid :: Maybe Int, + note_commands_changes :: Maybe CommandsChanges, + note_resolved :: Maybe Bool, + note_resolvable :: Maybe Bool, + note_confidential :: Maybe Bool, + note_resolved_by :: Maybe User -- TODO check + } + deriving (Show, Eq) + +-- | has a change been promoted to an epic. +newtype CommandsChanges = CommanandsChanges + { commands_changes_promote_to_epic :: Bool + } + deriving (Show, Eq) + +-- | Statistics and an issue +newtype IssueStatistics = IssueStatistics + { issue_statistics_stats :: IssueStats + } + deriving (Show, Eq) + +-- | Issue statistics +newtype IssueStats = IssueStats + { issue_stats_issue_counts :: IssueCounts + } + deriving (Show, Eq) + +-- | A count of all, open and closed issues against a project +data IssueCounts = IssueCounts + { issue_counts__all :: Int, + issue_counts_closed :: Int, + issue_counts_opened :: Int + } + deriving (Show, Eq) + +-- | Project issue boards https://docs.gitlab.com/ee/user/project/issue_board.html +data IssueBoard = IssueBoard + { board_id :: Int, + board_name :: Text, + board_project :: Project, + board_milestone :: Maybe Milestone, + board_lists :: [BoardIssue], + board_group :: Maybe Text, -- not sure, documentation doesn't indicate type + board_assignee :: Maybe Owner, + board_labels :: Maybe [BoardIssueLabel], + board_weight :: Maybe Int + } + deriving (Show, Eq) + +-- | Issues associated with a project issue board +data BoardIssue = BoardIssue + { board_issue_id :: Int, + board_issue_label :: BoardIssueLabel, + board_issue_position :: Int, + board_issue_max_issue_count :: Int, + board_issue_max_issue_weight :: Int, + -- TODO, the docs don't say what type this should be + board_issue_limit_metric :: Maybe Int + } + deriving (Show, Eq) + +-- | Label of an issues for a project issue board +data BoardIssueLabel = BoardIssueLabel + { board_issue_label_id :: Maybe Int, + board_issue_label_name :: Text, + board_issue_label_color :: Text, -- parse into type from e.g. "#F0AD4E" + board_issue_label_description :: Maybe Text + } + deriving (Show, Eq) + +-- | Project visibility. +data Visibility + = Public + | Private + | Internal + deriving (Show, Eq) + +instance FromJSON Visibility where + parseJSON (String "public") = return Public + parseJSON (String "private") = return Private + parseJSON (String "internal") = return Internal + parseJSON (Number 0) = return Private + parseJSON (Number 10) = return Internal + parseJSON (Number 20) = return Public + parseJSON n = error (show n) + +-- | Unit test reports for a CI pipeline https://docs.gitlab.com/ee/ci/unit_test_reports.html +data TestReport = TestReport + { test_report_total_time :: Double, + test_report_total_count :: Int, + test_report_success_count :: Int, + test_report_failed_count :: Int, + test_report_skipped_count :: Int, + test_report_error_count :: Int, + test_report_test_suites :: [TestSuite] + } + deriving (Show, Eq) + +-- | Testsuites associated with a test report +data TestSuite = TestSuite + { testsuite_name :: Text, + testsuite_total_time :: Double, + testsuite_success_count :: Int, + testsuite_failed_count :: Int, + testsuite_skipped_count :: Int, + testsuite_error_count :: Int, + testsuite_test_cases :: [TestCase] + } + deriving (Show, Eq) + +-- | Test case associated with a testsuite +data TestCase = TestCase + { testcase_status :: Text, -- could turn this into a type e.g. for "success" + testcase_name :: Text, + testcase_classname :: Text, + testcase_execution_time :: Double, + testcase_system_output :: Maybe Text, + testcase_stack_trace :: Maybe Text + } + deriving (Show, Eq) + +-- | Estimated humand and total time spent. +data TimeEstimate = TimeEstimate + { time_estimate_human_time_estimate :: Maybe Text, + time_estimate_human_total_time_spent :: Maybe Text, + time_estimate_time_estimate :: Maybe Int, + time_estimate_total_time_spent :: Maybe Int + } + deriving (Show, Eq) + +-- | Email information. +data Email = Email + { email_id :: Int, + email_email :: Text, + email_confirmed_at :: Maybe UTCTime + } + deriving (Show, Eq) + +-- | User preferences. +data UserPrefs = UserPrefs + { user_prefs_id :: Int, + user_prefs_user_id :: Int, + user_prefs_view_diffs_file_by_file :: Bool, + user_prefs_show_whitespace_in_diffs :: Bool + } + deriving (Show, Eq) + +-- | SSH key information. +data Key = Key + { key_id :: Maybe Int, + key_title :: Maybe Text, + key_key :: Text, + key_created_at :: Maybe UTCTime, + key_expires_at :: Maybe UTCTime + } + deriving (Show, Eq) + +-- | User status. +data UserStatus = UserStatus + { user_status_emoji :: Maybe Text, -- TODO type for "coffee" + user_status_availability :: Maybe Text, -- TODO type for "busy" + user_status_message :: Maybe Text, + user_status_message_html :: Maybe Text, -- TODO type for HTML content + user_status_clear_status_at :: Maybe UTCTime + } + deriving (Show, Eq) + +-- | Tracks counts for a user's activity. +data UserCount = UserCount + { user_count_merge_requests :: Int, -- TODO type for "coffee" + user_count_assigned_issues :: Int, -- TODO type for "busy" + user_count_assigned_merge_requests :: Int, + user_count_review_requested_merge_requests :: Int, -- TODO type for HTML content + user_count_todos :: Int + } + deriving (Show, Eq) + +-- TODO this data type could be improved to remove redundant Maybe +-- values. E.g. the push_data field will only be populated for the +-- "pushed" action_name, but would be Nothing for all action_name +-- values. Same for 'commented on' and the existence of a 'event_note' +-- field value. + +-- | Events https://docs.gitlab.com/ee/api/events.html +data Event = Event + { event_id :: Int, + event_title :: Maybe Text, + event_project_id :: Int, + event_action_name :: EventActionName, + event_target_id :: Maybe Int, + event_target_iid :: Maybe Int, + event_target_type :: Maybe EventTargetType, + event_author_id :: Int, + event_target_title :: Maybe Text, + event_created_at :: Maybe UTCTime, + event_author :: User, + event_author_username :: Text, + event_push_data :: Maybe PushData, + event_note :: Maybe Note + } + deriving (Show, Eq) + +-- | Information about a git push. +data PushData = PushData + { push_data_commit_count :: Int, + push_data_action :: EventActionName, + push_data_ref_type :: Text, -- TODO type for "branch" + push_data_commit_from :: Text, -- sha hash + push_data_commit_to :: Text, -- sha hash + push_data_ref :: Text, + push_data_commit_title :: Text + } + deriving (Show, Eq) + +-- | Tracks whether an action is open, closed, pushed or commented on. +data EventActionName + = ANOpened + | ANClosed + | ANPushed + | ANCommentedOn + deriving (Show, Eq) + +instance ToJSON EventActionName where + toJSON ANOpened = String "opened" + toJSON ANClosed = String "closed" + toJSON ANPushed = String "pushed" + toJSON ANCommentedOn = String "commented on" + +instance FromJSON EventActionName where + parseJSON (String "opened") = return ANOpened + parseJSON (String "closed") = return ANClosed + parseJSON (String "pushed") = return ANPushed + parseJSON (String "commented on") = return ANCommentedOn + parseJSON x = unexpected x + +-- | Associates an event with a particular target. +data EventTargetType + = ETTIssue + | ETTMilestone + | ETTMergeRequest + | ETTNote + | ETTProject + | ETTSnippet + | ETTUser + deriving (Show, Eq) + +instance ToJSON EventTargetType where + toJSON ETTIssue = String "Issue" + toJSON ETTMilestone = String "Milestone" + toJSON ETTMergeRequest = String "MergeRequest" + toJSON ETTNote = String "Note" + toJSON ETTProject = String "Project" + toJSON ETTSnippet = String "Snippet" + toJSON ETTUser = String "User" + +instance FromJSON EventTargetType where + parseJSON (String "Issue") = return ETTIssue + parseJSON (String "Milestone") = return ETTMilestone + parseJSON (String "MergeRequest") = return ETTMergeRequest + parseJSON (String "Note") = return ETTNote + parseJSON (String "Project") = return ETTProject + parseJSON (String "Snippet") = return ETTSnippet + parseJSON (String "User") = return ETTUser + parseJSON x = unexpected x + +-- | Events https://docs.gitlab.com/ee/api/events.html +data Job = Job + { job_commit :: Commit, + job_coverage :: Maybe Text, -- ?? + job_allow_failure :: Bool, + job_created_at :: UTCTime, + job_started_at :: Maybe UTCTime, + job_finished_at :: Maybe UTCTime, + job_duration :: Maybe Double, + job_queued_duration :: Double, + job_artifacts_file :: Maybe Artifact, + job_artifacts :: Maybe [Artifact], + job_artifacts_expire_at :: Maybe UTCTime, + job_tag_list :: Maybe [Text], + job_id :: Int, + job_name :: Text, + job_pipeline :: Maybe Pipeline, + job_ref :: Text, + job_stage :: Maybe Text, + job_status :: Text, -- TODO type for "failed" and others + job_failure_reason :: Maybe Text, -- TODO type for "script_failure" and others + job_tag :: Bool, + job_web_url :: Text, -- TODO type for URL like "https://example.com/foo/bar/-/jobs/7" + job_user :: Maybe User, + job_downstream_pipeline :: Maybe Pipeline + } + deriving (Show, Eq) + +----------------------------- +-- JSON GitLab parsers below +----------------------------- + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "time_stats_"), omitNothingFields = True} ''TimeStats) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "user_"), omitNothingFields = True} ''User) + +instance ToJSON MilestoneState where + toJSON MSActive = String "active" + toJSON MSClosed = String "closed" + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "milestone_"), omitNothingFields = True} ''Milestone) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "references_"), omitNothingFields = True} ''References) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "epic_"), omitNothingFields = True} ''Epic) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "links_"), omitNothingFields = True} ''Links) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "task_completion_status_"), omitNothingFields = True} ''TaskCompletionStatus) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "issue_"), omitNothingFields = True} ''Issue) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "detailed_status_"), omitNothingFields = True} ''DetailedStatus) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "pipeline_"), omitNothingFields = True} ''Pipeline) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "commitstats_"), omitNothingFields = True} ''CommitStats) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "commit_"), omitNothingFields = True} ''Commit) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "release_"), omitNothingFields = True} ''Release) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "tag_"), omitNothingFields = True} ''Tag) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "contributor_"), omitNothingFields = True} ''Contributor) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "saml_identity_"), omitNothingFields = True} ''SamlIdentity) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "identity_"), omitNothingFields = True} ''Identity) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "member_"), omitNothingFields = True} ''Member) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "permissions_"), omitNothingFields = True} ''Permissions) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "owner_"), omitNothingFields = True} ''Owner) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "namespace_"), omitNothingFields = True} ''Namespace) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "expiration_policy_"), omitNothingFields = True} ''ExpirationPolicy) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "license_"), omitNothingFields = True} ''License) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "groupshare_"), omitNothingFields = True} ''GroupShare) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "statistics_"), omitNothingFields = True} ''Statistics) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "project_"), omitNothingFields = True} ''Project) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "repository_"), omitNothingFields = True} ''Repository) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "artifact_"), omitNothingFields = True} ''Artifact) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "job_"), omitNothingFields = True} ''Job) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "branch_"), omitNothingFields = True} ''Branch) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "repository_file_"), omitNothingFields = True} ''RepositoryFile) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "repository_file_simple_"), omitNothingFields = True} ''RepositoryFileSimple) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "repository_file_blame_"), omitNothingFields = True} ''RepositoryFileBlame) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "change_"), omitNothingFields = True} ''Change) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "diff_refs_"), omitNothingFields = True} ''DiffRefs) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "merge_request_"), omitNothingFields = True} ''MergeRequest) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "diff_"), omitNothingFields = True} ''Diff) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "version_"), omitNothingFields = True} ''Version) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "edit_issue_"), omitNothingFields = True} ''EditIssueReq) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "commands_changes_"), omitNothingFields = True} ''CommandsChanges) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "note_"), omitNothingFields = True} ''Note) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "discussion_"), omitNothingFields = True} ''Discussion) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "issue_counts_"), omitNothingFields = True} ''IssueCounts) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "issue_stats_"), omitNothingFields = True} ''IssueStats) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "issue_statistics_"), omitNothingFields = True} ''IssueStatistics) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "board_issue_label_"), omitNothingFields = True} ''BoardIssueLabel) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "board_issue_"), omitNothingFields = True} ''BoardIssue) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "board_"), omitNothingFields = True} ''IssueBoard) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "testcase_"), omitNothingFields = True} ''TestCase) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "testsuite_"), omitNothingFields = True} ''TestSuite) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "test_report_"), omitNothingFields = True} ''TestReport) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "time_estimate_"), omitNothingFields = True} ''TimeEstimate) + +instance ToJSON TodoAction where + toJSON TAAssigned = String "assigned" + toJSON TAMentioned = String "mentioned" + toJSON TABuildFailed = String "build_build" + toJSON TAMarked = String "marked" + toJSON TAApprovalRequired = String "approval_required" + toJSON TAUnmergeable = String "unmergeable" + toJSON TADirectlyAddressed = String "directly_addressed" + +instance FromJSON TodoState where + parseJSON (String "pending") = return TSPending + parseJSON (String "done") = return TSDone + parseJSON x = unexpected x + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "commit_todo_"), omitNothingFields = True} ''CommitTodo) + +instance FromJSON TodoTargetType where + parseJSON (String "MergeRequest") = return MergeRequestTarget + parseJSON (String "Issue") = return IssueTarget + parseJSON (String "Commit") = return CommitTarget + parseJSON x = unexpected x + +instance FromJSON Todo where + parseJSON = withObject "Todo" $ \v -> + Todo + <$> v .: "id" + <*> v .: "project" + <*> v .: "author" + <*> v .: "action_name" + <*> v .: "target_type" + <*> ( v .: "target_type" >>= \case + "MergeRequest" -> TTMergeRequest <$> v .: "target" + "Issue" -> TTIssue <$> v .: "target" + "Commit" -> TTCommit <$> v .: "target" + (_ :: Text) -> fail "" + ) + <*> v .: "target_url" + <*> v .: "body" + <*> v .: "state" + <*> v .: "created_at" + <*> v .:? "updated_at" + +$(deriveToJSON defaultOptions {fieldLabelModifier = drop (T.length "todo_"), omitNothingFields = True} ''Todo) + +instance ToJSON TodoTargetType where + toJSON MergeRequestTarget = String "MergeRequest" + toJSON IssueTarget = String "Issue" + toJSON CommitTarget = String "Commit" + +instance ToJSON TodoState where + toJSON TSPending = String "pending" + toJSON TSDone = String "done" + +instance ToJSON TodoTarget where + toJSON (TTIssue x) = toJSON x + toJSON (TTMergeRequest x) = toJSON x + toJSON (TTCommit x) = toJSON x + +-- | User who is the starrer of a project. +data Starrer = Starrer + { starrer_starred_since :: UTCTime, + starrer_user :: User + } + deriving (Show, Eq) + +-- | Avatar for a project. +newtype ProjectAvatar = ProjectAvatar + { project_avatar_avatar_url :: Text + } + deriving (Show, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "repository_storage_"), omitNothingFields = True} ''RepositoryStorage) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "starrer_"), omitNothingFields = True} ''Starrer) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "project_avatar_"), omitNothingFields = True} ''ProjectAvatar) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "group_"), omitNothingFields = True} ''Group) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "commitnote_"), omitNothingFields = True} ''CommitNote) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "email_"), omitNothingFields = True} ''Email) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "key_"), omitNothingFields = True} ''Key) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "user_prefs_"), omitNothingFields = True} ''UserPrefs) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "user_status_"), omitNothingFields = True} ''UserStatus) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "user_count_"), omitNothingFields = True} ''UserCount) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "event_"), omitNothingFields = True} ''Event) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop (T.length "push_data_"), omitNothingFields = True} ''PushData) diff --git a/src/GitLab/WebRequests/GitLabWebCalls.hs b/src/GitLab/WebRequests/GitLabWebCalls.hs --- a/src/GitLab/WebRequests/GitLabWebCalls.hs +++ b/src/GitLab/WebRequests/GitLabWebCalls.hs @@ -110,8 +110,10 @@ FromJSON a => -- | the URL to post to Text -> + -- | the data to post + [GitLabParam] -> GitLab (Either (Response BSL.ByteString) (Maybe a)) -gitlabDelete urlPath = do +gitlabDelete urlPath params = do request where request = @@ -120,7 +122,7 @@ "application/x-www-form-urlencoded" urlPath [] - [] + params -- | Assumes that HTTP error code responses, e.g. 404, 409, won't be -- returned as (Left response) value. @@ -180,8 +182,7 @@ ], requestBody = RequestBodyBS (renderQuery False contentParams) } - response <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing - return response + liftIO $ tryGitLab 0 request (retries cfg) manager Nothing gitlabHTTPOne :: FromJSON a => diff --git a/tests/API/BoardsTests.hs b/tests/API/BoardsTests.hs --- a/tests/API/BoardsTests.hs +++ b/tests/API/BoardsTests.hs @@ -4,76 +4,39 @@ module API.BoardsTests (boardsTests) where import API.Common -import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BSL import GitLab -import GitLab.SystemHooks.GitLabSystemHooks -import GitLab.SystemHooks.Types import Test.Tasty -import Test.Tasty.HUnit boardsTests :: [TestTree] boardsTests = - [ testCase - "board-list-projects" - ( gitlabParseTestMany - listProjectHaskell - "data/api/boards/list-project.json" - ), - testCase - "board-new-board" - ( gitlabParseTestOne - newBoardHaskell - "data/api/boards/create-board.json" - ), - testCase - "board-update-board" - ( gitlabParseTestOne - updateBoardHaskell - "data/api/boards/update-board.json" - ) - ] - -listProjectHaskell :: [IssueBoard] -listProjectHaskell = - [ IssueBoard - { board_id = 1, - board_name = "board1", - board_project = ProjectBoard {project_board_id = 5, project_board_name = "Diaspora Project Site", project_board_name_with_namespace = "Diaspora / Diaspora Project Site", project_board_path = "diaspora-project-site", project_board_path_with_namespace = "diaspora/diaspora-project-site", project_board_http_url_to_repo = "http://example.com/diaspora/diaspora-project-site.git", project_board_web_url = "http://example.com/diaspora/diaspora-project-site"}, - board_milestone = Just (Milestone {milestone_project_id = Nothing, milestone_group_id = Nothing, milestone_description = Nothing, milestone_state = Nothing, milestone_due_date = Nothing, milestone_iid = Nothing, milestone_created_at = Nothing, milestone_title = "10.0", milestone_id = 12, milestone_updated_at = Nothing, milestone_web_url = Nothing}), - board_lists = [BoardIssue {board_issue_id = 1, board_issue_label = BoardIssueLabel {board_issue_label_id = Nothing, board_issue_label_name = "Testing", board_issue_label_color = "#F0AD4E", board_issue_label_description = Nothing}, board_issue_position = 1, board_issue_max_issue_count = 0, board_issue_max_issue_weight = 0, board_issue_limit_metric = Nothing}, BoardIssue {board_issue_id = 2, board_issue_label = BoardIssueLabel {board_issue_label_id = Nothing, board_issue_label_name = "Ready", board_issue_label_color = "#FF0000", board_issue_label_description = Nothing}, board_issue_position = 2, board_issue_max_issue_count = 0, board_issue_max_issue_weight = 0, board_issue_limit_metric = Nothing}, BoardIssue {board_issue_id = 3, board_issue_label = BoardIssueLabel {board_issue_label_id = Nothing, board_issue_label_name = "Production", board_issue_label_color = "#FF5F00", board_issue_label_description = Nothing}, board_issue_position = 3, board_issue_max_issue_count = 0, board_issue_max_issue_weight = 0, board_issue_limit_metric = Nothing}], - board_group = Nothing, - board_assignee = Nothing, - board_labels = Nothing, - board_weight = Nothing - } - ] - -newBoardHaskell :: IssueBoard -newBoardHaskell = - IssueBoard - { board_id = 1, - board_name = "newboard", - board_project = ProjectBoard {project_board_id = 5, project_board_name = "Diaspora Project Site", project_board_name_with_namespace = "Diaspora / Diaspora Project Site", project_board_path = "diaspora-project-site", project_board_path_with_namespace = "diaspora/diaspora-project-site", project_board_http_url_to_repo = "http://example.com/diaspora/diaspora-project-site.git", project_board_web_url = "http://example.com/diaspora/diaspora-project-site"}, - board_milestone = Nothing, - board_lists = [], - board_group = Nothing, - board_assignee = Nothing, - board_labels = Nothing, - board_weight = Nothing - } - -updateBoardHaskell :: IssueBoard -updateBoardHaskell = - IssueBoard - { board_id = 1, - board_name = "new_name", - board_project = ProjectBoard {project_board_id = 5, project_board_name = "Diaspora Project Site", project_board_name_with_namespace = "Diaspora / Diaspora Project Site", project_board_path = "diaspora-project-site", project_board_path_with_namespace = "diaspora/diaspora-project-site", project_board_http_url_to_repo = "http://example.com/diaspora/diaspora-project-site.git", project_board_web_url = "http://example.com/diaspora/diaspora-project-site"}, - board_milestone = Just (Milestone {milestone_project_id = Just 15, milestone_group_id = Nothing, milestone_description = Just "Milestone 1 desc", milestone_state = Just MSActive, milestone_due_date = Nothing, milestone_iid = Just 1, milestone_created_at = Just (read "2018-07-03 06:36:42.618 UTC"), milestone_title = "Milestone 1", milestone_id = 43, milestone_updated_at = Just (read "2018-07-03 06:36:42.618 UTC"), milestone_web_url = Just "http://example.com/root/board1/milestones/1"}), - board_lists = [], - board_group = Nothing, - board_assignee = Nothing, - board_labels = Nothing, - board_weight = Nothing - } + concat + [ let fname = "data/api/boards/list-project.json" + in gitlabJsonParserTests + "list-project" + fname + (parseOne =<< BSL.readFile fname :: IO [IssueBoard]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [IssueBoard] + parseOne (encode decodedFile) :: IO [IssueBoard] + ), + let fname = "data/api/boards/create-board.json" + in gitlabJsonParserTests + "create-board" + fname + (parseOne =<< BSL.readFile fname :: IO IssueBoard) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO IssueBoard + parseOne (encode decodedFile) :: IO IssueBoard + ), + let fname = "data/api/boards/update-board.json" + in gitlabJsonParserTests + "update-board" + fname + (parseOne =<< BSL.readFile fname :: IO IssueBoard) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO IssueBoard + parseOne (encode decodedFile) :: IO IssueBoard + ) + ] diff --git a/tests/API/BranchesTests.hs b/tests/API/BranchesTests.hs --- a/tests/API/BranchesTests.hs +++ b/tests/API/BranchesTests.hs @@ -16,4 +16,32 @@ -- | https://docs.gitlab.com/ee/api/branches.html branchesTests :: [TestTree] branchesTests = - [] + concat + [ let fname = "data/api/branches/list-repository-branches.json" + in gitlabJsonParserTests + "list-repository-branches" + fname + (parseOne =<< BSL.readFile fname :: IO [Branch]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Branch] + parseOne (encode decodedFile) :: IO [Branch] + ), + let fname = "data/api/branches/get-single-repository-branch.json" + in gitlabJsonParserTests + "get-single-repository-branch" + fname + (parseOne =<< BSL.readFile fname :: IO Branch) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Branch + parseOne (encode decodedFile) :: IO Branch + ), + let fname = "data/api/branches/create-repository-branch.json" + in gitlabJsonParserTests + "create-repository-branch" + fname + (parseOne =<< BSL.readFile fname :: IO Branch) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Branch + parseOne (encode decodedFile) :: IO Branch + ) + ] diff --git a/tests/API/CommitsTests.hs b/tests/API/CommitsTests.hs --- a/tests/API/CommitsTests.hs +++ b/tests/API/CommitsTests.hs @@ -4,16 +4,67 @@ module API.CommitsTests (commitsTests) where import API.Common -import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BSL import GitLab -import GitLab.SystemHooks.GitLabSystemHooks -import GitLab.SystemHooks.Types import Test.Tasty -import Test.Tasty.HUnit -- | https://docs.gitlab.com/ee/api/commits.html commitsTests :: [TestTree] commitsTests = - [] + concat + [ let fname = "data/api/commits/list-repository-commits.json" + in gitlabJsonParserTests + "list-repository-commits" + fname + (parseOne =<< BSL.readFile fname :: IO [Commit]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Commit] + parseOne (encode decodedFile) :: IO [Commit] + ), + let fname = "data/api/commits/create-commit-multiple-files-commits.json" + in gitlabJsonParserTests + "create-commit-multiple-files-commits" + fname + (parseOne =<< BSL.readFile fname :: IO Commit) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Commit + parseOne (encode decodedFile) :: IO Commit + ), + let fname = "data/api/commits/cherry-pick-commit.json" + in gitlabJsonParserTests + "cherry-pick-commit" + fname + (parseOne =<< BSL.readFile fname :: IO Commit) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Commit + parseOne (encode decodedFile) :: IO Commit + ), + let fname = "data/api/commits/revert-commit.json" + in gitlabJsonParserTests + "revert-commit" + fname + (parseOne =<< BSL.readFile fname :: IO Commit) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Commit + parseOne (encode decodedFile) :: IO Commit + ), + let fname = "data/api/commits/get-diff-of-commit.json" + in gitlabJsonParserTests + "get-diff-of-commit" + fname + (parseOne =<< BSL.readFile fname :: IO [Diff]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Diff] + parseOne (encode decodedFile) :: IO [Diff] + ), + let fname = "data/api/commits/get-comments-of-commit.json" + in gitlabJsonParserTests + "get-comments-of-commit" + fname + (parseOne =<< BSL.readFile fname :: IO [CommitNote]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [CommitNote] + parseOne (encode decodedFile) :: IO [CommitNote] + ) + ] diff --git a/tests/API/Common.hs b/tests/API/Common.hs --- a/tests/API/Common.hs +++ b/tests/API/Common.hs @@ -1,28 +1,154 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module API.Common where -import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe +import Data.TreeDiff.Class +import Data.TreeDiff.Pretty +import qualified Data.Vector as Vec +import GHC.Generics import GitLab -import GitLab.SystemHooks.GitLabSystemHooks -import GitLab.SystemHooks.Types + ( ArchiveFormat (..), + Artifact (Artifact), + BoardIssue (BoardIssue), + BoardIssueLabel (BoardIssueLabel), + Branch (Branch), + Change (Change), + CommandsChanges (CommanandsChanges), + Commit (Commit), + CommitNote (CommitNote), + CommitStats (CommitStats), + CommitTodo (CommitTodo), + Contributor (Contributor), + DetailedStatus (DetailedStatus), + Diff (Diff), + DiffRefs (DiffRefs), + Discussion (Discussion), + EditIssueReq (EditIssueReq), + Email (..), + Epic (Epic), + Event (..), + EventActionName (..), + EventTargetType (..), + ExpirationPolicy (ExpirationPolicy), + Group (Group), + GroupShare (GroupShare), + Identity (Identity), + Issue (Issue), + IssueBoard (IssueBoard), + IssueCounts (IssueCounts), + IssueStatistics (IssueStatistics), + IssueStats (IssueStats), + Job (Job), + Key (..), + License (License), + Links (Links), + Member (Member), + MergeRequest (MergeRequest), + Milestone (Milestone), + MilestoneState (..), + Namespace (Namespace), + Note (Note), + Owner (Ownwer), + Permissions (Permissions), + Pipeline (Pipeline), + Project (Project), + ProjectAvatar (ProjectAvatar), + PushData (..), + References (References), + Release (Release), + Repository (Repository), + RepositoryFile (RepositoryFile), + RepositoryFileBlame (RepositoryFileBlame), + RepositoryFileSimple (RepositoryFileSimple), + RepositoryStorage (RepositoryStorage), + SamlIdentity (SamlIdentity), + Starrer (Starrer), + Statistics (Statistics), + Tag (Tag), + TaskCompletionStatus (TaskCompletionStatus), + TestCase (TestCase), + TestReport (TestReport), + TestSuite (TestSuite), + TimeEstimate (TimeEstimate), + TimeStats (TimeStats), + Todo (Todo), + TodoAction (..), + TodoProject (TodoProject), + TodoState (..), + TodoTarget (..), + TodoTargetType (..), + User (User), + UserCount (..), + UserPrefs (..), + UserStatus (..), + Version (Version), + Visibility (..), + ) import Test.Tasty import Test.Tasty.HUnit +import qualified Text.PrettyPrint.ANSI.Leijen as WL -gitlabParseTestOne :: (FromJSON a, Eq a, Show a) => a -> String -> Assertion +removeNulls :: Value -> Maybe Value +removeNulls Null = Nothing +removeNulls (Array vec) = Just (Array (Vec.mapMaybe removeNulls vec)) +removeNulls (String x) = Just $ String x +removeNulls (Number x) = Just $ Number x +removeNulls (Bool x) = Just $ Bool x +removeNulls (Object keyMap) = Just $ Object (HashMap.mapMaybe removeNulls keyMap) + +gitlabJsonParserTests :: (ToExpr a, FromJSON a, ToJSON a, Eq a, Show a) => String -> FilePath -> IO a -> IO a -> [TestTree] +gitlabJsonParserTests testPrefix jsonFilename parseFileF decodedCustomTypeF = do + [ testCase + (testPrefix <> "-decode-encode-decode") + (decodeEncodeDecode parseFileF), + testCase + (testPrefix <> "-json-values-equal") + (jsonValuesEqual jsonFilename decodedCustomTypeF) + ] + +decodeEncodeDecode :: (ToExpr a, FromJSON a, ToJSON a, Eq a, Show a) => IO a -> Assertion +decodeEncodeDecode parseFileF = do + decodedFromFile <- parseFileF + decodedAgain <- parseOne (encode decodedFromFile) + (decodedFromFile == decodedAgain) + @? showWL (ansiWlEditExprCompact (ediff decodedFromFile decodedAgain)) + +jsonValuesEqual :: (ToExpr a, FromJSON a, ToJSON a, Eq a, Show a) => FilePath -> IO a -> Assertion +jsonValuesEqual jsonFilename decodedCustomTypeF = do + jsonValueFromFile <- parseValuesFromFile jsonFilename + decodedCustomType <- decodedCustomTypeF + let (Just jsonFromCustomType) = decode (encode decodedCustomType) :: Maybe Value + (jsonValueFromFile == jsonFromCustomType) + @? showWL (ansiWlEditExprCompact (ediff jsonValueFromFile jsonFromCustomType)) + +parseValuesFromFile :: String -> IO Value +parseValuesFromFile fname = + fromJust . removeNulls . fromJust . decode <$> BSL.readFile fname + +gitlabParseTestOne :: (ToExpr a, FromJSON a, Eq a, Show a) => a -> String -> Assertion gitlabParseTestOne expectedHaskellValue filename = do raw <- BSL.readFile filename result <- parseOne raw - expectedHaskellValue @=? result + (expectedHaskellValue == result) + @? showWL (ansiWlEditExprCompact (ediff expectedHaskellValue result)) -gitlabParseTestMany :: (FromJSON a, Eq a, Show a) => [a] -> String -> Assertion +showWL :: WL.Doc -> String +showWL doc = WL.displayS (WL.renderSmart 0.4 80 doc) "" + +gitlabParseTestMany :: (ToExpr a, FromJSON a, Eq a, Show a) => [a] -> String -> Assertion gitlabParseTestMany expectedHaskellValue filename = do raw <- BSL.readFile filename result <- parseMany raw - expectedHaskellValue @=? result + (expectedHaskellValue == result) + @? showWL (ansiWlEditExprCompact (ediff expectedHaskellValue result)) parseOne :: FromJSON a => BSL.ByteString -> IO a parseOne bs = @@ -35,3 +161,313 @@ case eitherDecode bs of Left err -> assertFailure err Right xs -> return xs + +------------- +-- Generic instances + +deriving instance Generic ArchiveFormat + +deriving instance Generic Member + +deriving instance Generic SamlIdentity + +deriving instance Generic Identity + +deriving instance Generic Namespace + +deriving instance Generic Links + +deriving instance Generic Owner + +deriving instance Generic Permissions + +deriving instance Generic Project + +deriving instance Generic License + +deriving instance Generic ExpirationPolicy + +deriving instance Generic RepositoryStorage + +deriving instance Generic Statistics + +deriving instance Generic User + +deriving instance Generic MilestoneState + +deriving instance Generic Milestone + +deriving instance Generic TimeStats + +deriving instance Generic Issue + +deriving instance Generic Pipeline + +deriving instance Generic DetailedStatus + +deriving instance Generic Commit + +deriving instance Generic CommitTodo + +deriving instance Generic CommitStats + +deriving instance Generic Tag + +deriving instance Generic Release + +deriving instance Generic Repository + +deriving instance Generic Job + +deriving instance Generic Artifact + +deriving instance Generic Group + +deriving instance Generic GroupShare + +deriving instance Generic MergeRequest + +deriving instance Generic TaskCompletionStatus + +deriving instance Generic References + +deriving instance Generic Change + +deriving instance Generic DiffRefs + +deriving instance Generic TodoAction + +deriving instance Generic TodoTarget + +deriving instance Generic TodoState + +deriving instance Generic TodoProject + +deriving instance Generic Todo + +deriving instance Generic TodoTargetType + +deriving instance Generic EditIssueReq + +deriving instance Generic Discussion + +deriving instance Generic CommitNote + +deriving instance Generic Note + +deriving instance Generic IssueBoard + +deriving instance Generic BoardIssue + +deriving instance Generic BoardIssueLabel + +deriving instance Generic Visibility + +deriving instance Generic TestSuite + +deriving instance Generic TestCase + +deriving instance Generic TimeEstimate + +deriving instance Generic ProjectAvatar + +deriving instance Generic Starrer + +deriving instance Generic Branch + +deriving instance Generic Diff + +deriving instance Generic Epic + +deriving instance Generic CommandsChanges + +deriving instance Generic Contributor + +deriving instance Generic RepositoryFile + +deriving instance Generic RepositoryFileSimple + +deriving instance Generic RepositoryFileBlame + +deriving instance Generic Version + +deriving instance Generic IssueStatistics + +deriving instance Generic IssueStats + +deriving instance Generic IssueCounts + +deriving instance Generic TestReport + +deriving instance Generic Email + +deriving instance Generic Key + +deriving instance Generic UserPrefs + +deriving instance Generic UserStatus + +deriving instance Generic UserCount + +deriving instance Generic Event + +deriving instance Generic EventActionName + +deriving instance Generic EventTargetType + +deriving instance Generic PushData + +------------- +-- ToExpr instances + +instance ToExpr ArchiveFormat + +instance ToExpr Member + +instance ToExpr SamlIdentity + +instance ToExpr Identity + +instance ToExpr Namespace + +instance ToExpr Links + +instance ToExpr Owner + +instance ToExpr Permissions + +instance ToExpr Project + +instance ToExpr Statistics + +instance ToExpr User + +instance ToExpr Milestone + +instance ToExpr MilestoneState + +instance ToExpr TimeStats + +instance ToExpr Issue + +instance ToExpr Pipeline + +instance ToExpr Commit + +instance ToExpr CommitTodo + +instance ToExpr CommitStats + +instance ToExpr Tag + +instance ToExpr Release + +instance ToExpr Diff + +instance ToExpr Repository + +instance ToExpr Job + +instance ToExpr Artifact + +instance ToExpr Group + +instance ToExpr GroupShare + +instance ToExpr Branch + +instance ToExpr RepositoryFile + +instance ToExpr RepositoryFileSimple + +instance ToExpr RepositoryFileBlame + +instance ToExpr MergeRequest + +instance ToExpr Todo + +instance ToExpr TodoProject + +instance ToExpr TodoAction + +instance ToExpr TodoTarget + +instance ToExpr TodoState + +instance ToExpr Version + +instance ToExpr EditIssueReq + +instance ToExpr Discussion + +instance ToExpr CommitNote + +instance ToExpr Note + +instance ToExpr IssueStatistics + +instance ToExpr IssueStats + +instance ToExpr IssueCounts + +instance ToExpr IssueBoard + +instance ToExpr BoardIssue + +instance ToExpr BoardIssueLabel + +instance ToExpr Visibility + +instance ToExpr TestReport + +instance ToExpr TestSuite + +instance ToExpr TestCase + +instance ToExpr TimeEstimate + +instance ToExpr TaskCompletionStatus + +instance ToExpr References + +instance ToExpr Change + +instance ToExpr DiffRefs + +instance ToExpr DetailedStatus + +instance ToExpr TodoTargetType + +instance ToExpr License + +instance ToExpr ExpirationPolicy + +instance ToExpr RepositoryStorage + +instance ToExpr Starrer + +instance ToExpr ProjectAvatar + +instance ToExpr Epic + +instance ToExpr CommandsChanges + +instance ToExpr Contributor + +instance ToExpr Email + +instance ToExpr Key + +instance ToExpr UserPrefs + +instance ToExpr UserStatus + +instance ToExpr UserCount + +instance ToExpr Event + +instance ToExpr EventActionName + +instance ToExpr EventTargetType + +instance ToExpr PushData diff --git a/tests/API/DiscussionsTests.hs b/tests/API/DiscussionsTests.hs --- a/tests/API/DiscussionsTests.hs +++ b/tests/API/DiscussionsTests.hs @@ -4,16 +4,58 @@ module API.DiscussionsTests (discussionsTests) where import API.Common -import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BSL import GitLab -import GitLab.SystemHooks.GitLabSystemHooks -import GitLab.SystemHooks.Types import Test.Tasty -import Test.Tasty.HUnit -- | https://docs.gitlab.com/ee/api/discussions.html discussionsTests :: [TestTree] discussionsTests = - [] + concat + [ let fname = "data/api/discussions/list-group-epic-discussion-items.json" + in gitlabJsonParserTests + "list-group-epic-discussion-items" + fname + (parseOne =<< BSL.readFile fname :: IO [Discussion]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Discussion] + parseOne (encode decodedFile) :: IO [Discussion] + ), + let fname = "data/api/discussions/list-project-merge-request-discussion-items.json" + in gitlabJsonParserTests + "list-project-merge-request-discussion-items" + fname + (parseOne =<< BSL.readFile fname :: IO [Discussion]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Discussion] + parseOne (encode decodedFile) :: IO [Discussion] + ), + let fname = "data/api/discussions/list-project-commit-discussion-items.json" + in gitlabJsonParserTests + "list-project-commit-discussion-items" + fname + (parseOne =<< BSL.readFile fname :: IO [Discussion]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Discussion] + parseOne (encode decodedFile) :: IO [Discussion] + ), + let fname = "data/api/discussions/list-project-snippet-discussion-items.json" + in gitlabJsonParserTests + "list-project-snippet-discussion-items" + fname + (parseOne =<< BSL.readFile fname :: IO [Discussion]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Discussion] + parseOne (encode decodedFile) :: IO [Discussion] + ), + let fname = "data/api/discussions/list-project-discussion-items.json" + in gitlabJsonParserTests + "list-project-discussion-items" + fname + (parseOne =<< BSL.readFile fname :: IO [Discussion]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Discussion] + parseOne (encode decodedFile) :: IO [Discussion] + ) + ] diff --git a/tests/API/EventsTests.hs b/tests/API/EventsTests.hs --- a/tests/API/EventsTests.hs +++ b/tests/API/EventsTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.EventsTests (eventsTests) where @@ -16,4 +15,32 @@ -- | https://docs.gitlab.com/ee/api/events.html eventsTests :: [TestTree] eventsTests = - [] + concat + [ let fname = "data/api/events/get-user-contributions-events.json" + in gitlabJsonParserTests + "get-user-contributions-events" + fname + (parseOne =<< BSL.readFile fname :: IO [Event]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Event] + parseOne (encode decodedFile) :: IO [Event] + ), + let fname = "data/api/events/list-current-authenticated-users-events.json" + in gitlabJsonParserTests + "list-current-authenticated-users-events" + fname + (parseOne =<< BSL.readFile fname :: IO [Event]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Event] + parseOne (encode decodedFile) :: IO [Event] + ), + let fname = "data/api/events/list-projects-visible-events.json" + in gitlabJsonParserTests + "list-projects-visible-events" + fname + (parseOne =<< BSL.readFile fname :: IO [Event]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Event] + parseOne (encode decodedFile) :: IO [Event] + ) + ] diff --git a/tests/API/GroupsTests.hs b/tests/API/GroupsTests.hs --- a/tests/API/GroupsTests.hs +++ b/tests/API/GroupsTests.hs @@ -4,16 +4,113 @@ module API.GroupsTests (groupsTests) where import API.Common -import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BSL import GitLab -import GitLab.SystemHooks.GitLabSystemHooks -import GitLab.SystemHooks.Types import Test.Tasty -import Test.Tasty.HUnit -- | https://docs.gitlab.com/ee/api/groups.html groupsTests :: [TestTree] groupsTests = - [] + concat + [ let fname = "data/api/groups/list-groups.json" + in gitlabJsonParserTests + "list-groups" + fname + (parseOne =<< BSL.readFile fname :: IO [Group]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Group] + parseOne (encode decodedFile) :: IO [Group] + ), + let fname = "data/api/groups/list-group-shared-projects.json" + in gitlabJsonParserTests + "list-group-shared-projects" + fname + (parseOne =<< BSL.readFile fname :: IO [Project]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Project] + parseOne (encode decodedFile) :: IO [Project] + ), + let fname = "data/api/groups/update-group.json" + in gitlabJsonParserTests + "update-group" + fname + (parseOne =<< BSL.readFile fname :: IO Group) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Group + parseOne (encode decodedFile) :: IO Group + ), + let fname = "data/api/groups/list-group-subgroups.json" + in gitlabJsonParserTests + "list-group-subgroups" + fname + (parseOne =<< BSL.readFile fname :: IO [Group]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Group] + parseOne (encode decodedFile) :: IO [Group] + ), + let fname = "data/api/groups/list-group-projects.json" + in gitlabJsonParserTests + "list-group-projects" + fname + (parseOne =<< BSL.readFile fname :: IO [Project]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Project] + parseOne (encode decodedFile) :: IO [Project] + ), + let fname = "data/api/groups/list-groups-with-stats.json" + in gitlabJsonParserTests + "list-groups-with-stats" + fname + (parseOne =<< BSL.readFile fname :: IO [Group]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Group] + parseOne (encode decodedFile) :: IO [Group] + ), + let fname = "data/api/groups/list-group-descendant-groups.json" + in gitlabJsonParserTests + "list-group-descendant-groups" + fname + (parseOne =<< BSL.readFile fname :: IO [Group]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Group] + parseOne (encode decodedFile) :: IO [Group] + ), + let fname = "data/api/groups/details-of-group.json" + in gitlabJsonParserTests + "details-of-group" + fname + (parseOne =<< BSL.readFile fname :: IO Group) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Group + parseOne (encode decodedFile) :: IO Group + ), + let fname = "data/api/groups/search-for-group.json" + in gitlabJsonParserTests + "search-for-group" + fname + (parseOne =<< BSL.readFile fname :: IO [Group]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Group] + parseOne (encode decodedFile) :: IO [Group] + ), + let fname = "data/api/groups/details-of-group-with-projects-false.json" + in gitlabJsonParserTests + "details-of-group-with-projects-false" + fname + (parseOne =<< BSL.readFile fname :: IO Group) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Group + parseOne (encode decodedFile) :: IO Group + ) + ] + +{- +Not tested yet: + +add-group-push-rule.json +get-group-hook.json +get-group-push-rules.json +edit-group-push-rule.json + +-} diff --git a/tests/API/IssuesTests.hs b/tests/API/IssuesTests.hs --- a/tests/API/IssuesTests.hs +++ b/tests/API/IssuesTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.IssuesTests (issuesTests) where @@ -16,4 +15,202 @@ -- | https://docs.gitlab.com/ee/api/issues.html issuesTests :: [TestTree] issuesTests = - [] + concat + [ let fname = "data/api/issues/list-project-issues.json" + in gitlabJsonParserTests + "list-project-issues" + fname + (parseOne =<< BSL.readFile fname :: IO [Issue]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Issue] + parseOne (encode decodedFile) :: IO [Issue] + ), + let fname = "data/api/issues/add-time-spent-for-issue.json" + in gitlabJsonParserTests + "add-time-spent-for-issue" + fname + (parseOne =<< BSL.readFile fname :: IO TimeStats) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeStats + parseOne (encode decodedFile) :: IO TimeStats + ), + let fname = "data/api/issues/reset-time-spent-for-issue.json" + in gitlabJsonParserTests + "reset-time-spent-for-issue" + fname + (parseOne =<< BSL.readFile fname :: IO TimeStats) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeStats + parseOne (encode decodedFile) :: IO TimeStats + ), + let fname = "data/api/issues/clone-issue.json" + in gitlabJsonParserTests + "clone-issue" + fname + (parseOne =<< BSL.readFile fname :: IO Issue) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Issue + parseOne (encode decodedFile) :: IO Issue + ), + let fname = "data/api/issues/merge-requests-close-issue-on-merge.json" + in gitlabJsonParserTests + "merge-requests-close-issue-on-merge" + fname + (parseOne =<< BSL.readFile fname :: IO [MergeRequest]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [MergeRequest] + parseOne (encode decodedFile) :: IO [MergeRequest] + ), + let fname = "data/api/issues/set-time-estimate-for-issue.json" + in gitlabJsonParserTests + "set-time-estimate-for-issue" + fname + (parseOne =<< BSL.readFile fname :: IO TimeEstimate) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeEstimate + parseOne (encode decodedFile) :: IO TimeEstimate + ), + let fname = "data/api/issues/reset-time-estimate-for-issue.json" + in gitlabJsonParserTests + "reset-time-estimate-for-issue" + fname + (parseOne =<< BSL.readFile fname :: IO TimeEstimate) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeEstimate + parseOne (encode decodedFile) :: IO TimeEstimate + ), + let fname = "data/api/issues/create-todo-item.json" + in gitlabJsonParserTests + "create-todo-item" + fname + (parseOne =<< BSL.readFile fname :: IO Todo) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Todo + parseOne (encode decodedFile) :: IO Todo + ), + let fname = "data/api/issues/merge-requests-related-to-issue.json" + in gitlabJsonParserTests + "merge-requests-related-to-issue" + fname + (parseOne =<< BSL.readFile fname :: IO [MergeRequest]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [MergeRequest] + parseOne (encode decodedFile) :: IO [MergeRequest] + ), + let fname = "data/api/issues/single-issue.json" + in gitlabJsonParserTests + "single-issue" + fname + (parseOne =<< BSL.readFile fname :: IO Issue) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Issue + parseOne (encode decodedFile) :: IO Issue + ), + let fname = "data/api/issues/edit-issue.json" + in gitlabJsonParserTests + "edit-issue" + fname + (parseOne =<< BSL.readFile fname :: IO Issue) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Issue + parseOne (encode decodedFile) :: IO Issue + ), + let fname = "data/api/issues/move-issue.json" + in gitlabJsonParserTests + "move-issue" + fname + (parseOne =<< BSL.readFile fname :: IO Issue) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Issue + parseOne (encode decodedFile) :: IO Issue + ), + let fname = "data/api/issues/single-project-issue.json" + in gitlabJsonParserTests + "single-project-issue" + fname + (parseOne =<< BSL.readFile fname :: IO Issue) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Issue + parseOne (encode decodedFile) :: IO Issue + ), + let fname = "data/api/issues/new-issue.json" + in gitlabJsonParserTests + "new-issue" + fname + (parseOne =<< BSL.readFile fname :: IO Issue) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Issue + parseOne (encode decodedFile) :: IO Issue + ), + let fname = "data/api/issues/subscribe-to-issue.json" + in gitlabJsonParserTests + "subscribe-to-issue" + fname + (parseOne =<< BSL.readFile fname :: IO Issue) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Issue + parseOne (encode decodedFile) :: IO Issue + ), + let fname = "data/api/issues/list-group-issues.json" + in gitlabJsonParserTests + "list-group-issues" + fname + (parseOne =<< BSL.readFile fname :: IO [Issue]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Issue] + parseOne (encode decodedFile) :: IO [Issue] + ), + let fname = "data/api/issues/participants-on-issues.json" + in gitlabJsonParserTests + "participants-on-issues" + fname + (parseOne =<< BSL.readFile fname :: IO [User]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [User] + parseOne (encode decodedFile) :: IO [User] + ), + let fname = "data/api/issues/unsubscribe-from-issue.json" + in gitlabJsonParserTests + "unsubscribe-from-issue" + fname + (parseOne =<< BSL.readFile fname :: IO Issue) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Issue + parseOne (encode decodedFile) :: IO Issue + ), + let fname = "data/api/issues/list-issues.json" + in gitlabJsonParserTests + "list-issues" + fname + (parseOne =<< BSL.readFile fname :: IO [Issue]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Issue] + parseOne (encode decodedFile) :: IO [Issue] + ), + let fname = "data/api/issues/promote-issue-to-epic.json" + in gitlabJsonParserTests + "promote-issue-to-epic" + fname + (parseOne =<< BSL.readFile fname :: IO Note) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Note + parseOne (encode decodedFile) :: IO Note + ), + let fname = "data/api/issues/get-time-tracking-stats.json" + in gitlabJsonParserTests + "get-time-tracking-stats" + fname + (parseOne =<< BSL.readFile fname :: IO TimeEstimate) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeEstimate + parseOne (encode decodedFile) :: IO TimeEstimate + ) + ] + +{- + +upload-metric-image.json +list-metric-images.json +user-agent-details.json + +-} diff --git a/tests/API/JobsTests.hs b/tests/API/JobsTests.hs --- a/tests/API/JobsTests.hs +++ b/tests/API/JobsTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.JobsTests (jobsTests) where @@ -16,4 +15,86 @@ -- | https://docs.gitlab.com/ee/api/jobs.html jobsTests :: [TestTree] jobsTests = - [] + concat + [ let fname = "data/api/jobs/cancel-job.json" + in gitlabJsonParserTests + "cancel-job" + fname + (parseOne =<< BSL.readFile fname :: IO Job) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Job + parseOne (encode decodedFile) :: IO Job + ), + let fname = "data/api/jobs/job-tokens-job.json" + in gitlabJsonParserTests + "job-tokens-job" + fname + (parseOne =<< BSL.readFile fname :: IO Job) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Job + parseOne (encode decodedFile) :: IO Job + ), + let fname = "data/api/jobs/pipeline-jobs.json" + in gitlabJsonParserTests + "pipeline-jobs" + fname + (parseOne =<< BSL.readFile fname :: IO [Job]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Job] + parseOne (encode decodedFile) :: IO [Job] + ), + let fname = "data/api/jobs/project-jobs.json" + in gitlabJsonParserTests + "project-jobs" + fname + (parseOne =<< BSL.readFile fname :: IO [Job]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Job] + parseOne (encode decodedFile) :: IO [Job] + ), + let fname = "data/api/jobs/single-job.json" + in gitlabJsonParserTests + "single-job" + fname + (parseOne =<< BSL.readFile fname :: IO Job) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Job + parseOne (encode decodedFile) :: IO Job + ), + let fname = "data/api/jobs/erase-job.json" + in gitlabJsonParserTests + "erase-job" + fname + (parseOne =<< BSL.readFile fname :: IO Job) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Job + parseOne (encode decodedFile) :: IO Job + ), + let fname = "data/api/jobs/pipeline-bridges.json" + in gitlabJsonParserTests + "pipeline-bridges" + fname + (parseOne =<< BSL.readFile fname :: IO [Job]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Job] + parseOne (encode decodedFile) :: IO [Job] + ), + let fname = "data/api/jobs/play-job.json" + in gitlabJsonParserTests + "play-job" + fname + (parseOne =<< BSL.readFile fname :: IO Job) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Job + parseOne (encode decodedFile) :: IO Job + ), + let fname = "data/api/jobs/retry-job.json" + in gitlabJsonParserTests + "retry-job" + fname + (parseOne =<< BSL.readFile fname :: IO Job) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Job + parseOne (encode decodedFile) :: IO Job + ) + ] diff --git a/tests/API/MembersTests.hs b/tests/API/MembersTests.hs --- a/tests/API/MembersTests.hs +++ b/tests/API/MembersTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.MembersTests (membersTests) where @@ -16,4 +15,104 @@ -- | https://docs.gitlab.com/ee/api/members.html membersTests :: [TestTree] membersTests = - [] + concat + [ let fname = "data/api/members/list-pending-members.json" + in gitlabJsonParserTests + "list-project-repository-tags" + fname + (parseOne =<< BSL.readFile fname :: IO [Member]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Member] + parseOne (encode decodedFile) :: IO [Member] + ), + let fname = "data/api/members/billable-members-of-group.json" + in gitlabJsonParserTests + "billable-members-of-group" + fname + (parseOne =<< BSL.readFile fname :: IO [Member]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Member] + parseOne (encode decodedFile) :: IO [Member] + ), + let fname = "data/api/members/removed-override-flag-member-group.json" + in gitlabJsonParserTests + "removed-override-flag-member-group" + fname + (parseOne =<< BSL.readFile fname :: IO Member) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Member + parseOne (encode decodedFile) :: IO Member + ), + let fname = "data/api/members/member-group-or-project-including-inherited-invited.json" + in gitlabJsonParserTests + "member-group-or-project-including-inherited-invited" + fname + (parseOne =<< BSL.readFile fname :: IO Member) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Member + parseOne (encode decodedFile) :: IO Member + ), + let fname = "data/api/members/override-flag-member-group.json" + in gitlabJsonParserTests + "override-flag-member-group" + fname + (parseOne =<< BSL.readFile fname :: IO Member) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Member + parseOne (encode decodedFile) :: IO Member + ), + let fname = "data/api/members/member-group-or-project.json" + in gitlabJsonParserTests + "member-group-or-project" + fname + (parseOne =<< BSL.readFile fname :: IO Member) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Member + parseOne (encode decodedFile) :: IO Member + ), + let fname = "data/api/members/edit-member-group-project.json" + in gitlabJsonParserTests + "edit-member-group-project" + fname + (parseOne =<< BSL.readFile fname :: IO Member) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Member + parseOne (encode decodedFile) :: IO Member + ), + let fname = "data/api/members/list-all-memembers-group-or-project-including-inherited-invited.json" + in gitlabJsonParserTests + "list-all-memembers-group-or-project-including-inherited-invited" + fname + (parseOne =<< BSL.readFile fname :: IO [Member]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Member] + parseOne (encode decodedFile) :: IO [Member] + ), + let fname = "data/api/members/add-member-group-project.json" + in gitlabJsonParserTests + "add-member-group-project" + fname + (parseOne =<< BSL.readFile fname :: IO Member) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Member + parseOne (encode decodedFile) :: IO Member + ), + let fname = "data/api/members/list-all-memembers-group-or-project.json" + in gitlabJsonParserTests + "list-all-memembers-group-or-project" + fname + (parseOne =<< BSL.readFile fname :: IO [Member]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Member] + parseOne (encode decodedFile) :: IO [Member] + ) + -- let fname = "data/api/members/membership-billable-member-of-group.json" + -- in gitlabJsonParserTests + -- "membership-billable-member-of-group" + -- fname + -- (parseOne =<< BSL.readFile fname :: IO Member) + -- ( do + -- decodedFile <- parseOne =<< BSL.readFile fname :: IO Member + -- parseOne (encode decodedFile) :: IO Member + -- ) + ] diff --git a/tests/API/MergeRequestsTests.hs b/tests/API/MergeRequestsTests.hs --- a/tests/API/MergeRequestsTests.hs +++ b/tests/API/MergeRequestsTests.hs @@ -4,16 +4,246 @@ module API.MergeRequestsTests (mergeRequestsTests) where import API.Common -import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BSL import GitLab -import GitLab.SystemHooks.GitLabSystemHooks -import GitLab.SystemHooks.Types import Test.Tasty -import Test.Tasty.HUnit -- | https://docs.gitlab.com/ee/api/merge_requests.html mergeRequestsTests :: [TestTree] mergeRequestsTests = - [] + concat + [ let fname = "data/api/merge-requests/accept-merge-request.json" + in gitlabJsonParserTests + "accept-merge-request" + fname + (parseOne =<< BSL.readFile fname :: IO MergeRequest) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO MergeRequest + parseOne (encode decodedFile) :: IO MergeRequest + ), + let fname = "data/api/merge-requests/add-spent-time-merge-request.json" + in gitlabJsonParserTests + "add-spent-time-merge-request" + fname + (parseOne =<< BSL.readFile fname :: IO TimeEstimate) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeEstimate + parseOne (encode decodedFile) :: IO TimeEstimate + ), + let fname = "data/api/merge-requests/cancel-merge-request-when-pipeline-succeeds.json" + in gitlabJsonParserTests + "cancel-merge-request-when-pipeline-succeeds" + fname + (parseOne =<< BSL.readFile fname :: IO MergeRequest) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO MergeRequest + parseOne (encode decodedFile) :: IO MergeRequest + ), + let fname = "data/api/merge-requests/create-merge-request.json" + in gitlabJsonParserTests + "create-merge-request" + fname + (parseOne =<< BSL.readFile fname :: IO MergeRequest) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO MergeRequest + parseOne (encode decodedFile) :: IO MergeRequest + ), + let fname = "data/api/merge-requests/create-merge-request-pipeline.json" + in gitlabJsonParserTests + "create-merge-request-pipeline" + fname + (parseOne =<< BSL.readFile fname :: IO Pipeline) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Pipeline + parseOne (encode decodedFile) :: IO Pipeline + ), + let fname = "data/api/merge-requests/create-todo-item.json" + in gitlabJsonParserTests + "create-todo-item" + fname + (parseOne =<< BSL.readFile fname :: IO Todo) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Todo + parseOne (encode decodedFile) :: IO Todo + ), + let fname = "data/api/merge-requests/list-group-merge-requests.json" + in gitlabJsonParserTests + "list-group-merge-requests" + fname + (parseOne =<< BSL.readFile fname :: IO [MergeRequest]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [MergeRequest] + parseOne (encode decodedFile) :: IO [MergeRequest] + ), + let fname = "data/api/merge-requests/list-merge-request-pipelines.json" + in gitlabJsonParserTests + "list-merge-request-pipelines" + fname + (parseOne =<< BSL.readFile fname :: IO [Pipeline]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Pipeline] + parseOne (encode decodedFile) :: IO [Pipeline] + ), + let fname = "data/api/merge-requests/list-merge-requests.json" + in gitlabJsonParserTests + "list-merge-requests" + fname + (parseOne =<< BSL.readFile fname :: IO [MergeRequest]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [MergeRequest] + parseOne (encode decodedFile) :: IO [MergeRequest] + ), + let fname = "data/api/merge-requests/list-project-merge-requests.json" + in gitlabJsonParserTests + "list-project-merge-requests" + fname + (parseOne =<< BSL.readFile fname :: IO [MergeRequest]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [MergeRequest] + parseOne (encode decodedFile) :: IO [MergeRequest] + ), + let fname = "data/api/merge-requests/list-project-merge-requests.json" + in gitlabJsonParserTests + "list-project-merge-requests" + fname + (parseOne =<< BSL.readFile fname :: IO [MergeRequest]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [MergeRequest] + parseOne (encode decodedFile) :: IO [MergeRequest] + ), + let fname = "data/api/merge-requests/reset-time-estimate-merge-request.json" + in gitlabJsonParserTests + "reset-time-estimate-merge-request" + fname + (parseOne =<< BSL.readFile fname :: IO TimeEstimate) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeEstimate + parseOne (encode decodedFile) :: IO TimeEstimate + ), + let fname = "data/api/merge-requests/reset-time-merge-request.json" + in gitlabJsonParserTests + "reset-time-merge-request" + fname + (parseOne =<< BSL.readFile fname :: IO TimeEstimate) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeEstimate + parseOne (encode decodedFile) :: IO TimeEstimate + ), + let fname = "data/api/merge-requests/single-merge-request-changes.json" + in gitlabJsonParserTests + "single-merge-request-changes" + fname + (parseOne =<< BSL.readFile fname :: IO MergeRequest) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO MergeRequest + parseOne (encode decodedFile) :: IO MergeRequest + ), + let fname = "data/api/merge-requests/single-merge-request-participants.json" + in gitlabJsonParserTests + "single-merge-request-participants" + fname + (parseOne =<< BSL.readFile fname :: IO [User]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [User] + parseOne (encode decodedFile) :: IO [User] + ), + let fname = "data/api/merge-requests/subscribe-merge-request.json" + in gitlabJsonParserTests + "subscribe-merge-request" + fname + (parseOne =<< BSL.readFile fname :: IO MergeRequest) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO MergeRequest + parseOne (encode decodedFile) :: IO MergeRequest + ), + let fname = "data/api/merge-requests/time-estimate-merge-request.json" + in gitlabJsonParserTests + "time-estimate-merge-request" + fname + (parseOne =<< BSL.readFile fname :: IO TimeEstimate) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeEstimate + parseOne (encode decodedFile) :: IO TimeEstimate + ), + let fname = "data/api/merge-requests/time-tracking-stats.json" + in gitlabJsonParserTests + "time-tracking-stats" + fname + (parseOne =<< BSL.readFile fname :: IO TimeEstimate) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO TimeEstimate + parseOne (encode decodedFile) :: IO TimeEstimate + ), + let fname = "data/api/merge-requests/unsubscribe-merge-request.json" + in gitlabJsonParserTests + "unsubscribe-merge-request" + fname + (parseOne =<< BSL.readFile fname :: IO MergeRequest) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO MergeRequest + parseOne (encode decodedFile) :: IO MergeRequest + ), + let fname = "data/api/merge-requests/update-merge-request.json" + in gitlabJsonParserTests + "update-merge-request" + fname + (parseOne =<< BSL.readFile fname :: IO MergeRequest) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO MergeRequest + parseOne (encode decodedFile) :: IO MergeRequest + ) + -- let fname = "data/api/merge-requests/single-merge-request.json" + -- in gitlabJsonParserTests + -- "single-merge-request" + -- fname + -- (parseOne =<< BSL.readFile fname :: IO MergeRequest) + -- ( do + -- decodedFile <- parseOne =<< BSL.readFile fname :: IO MergeRequest + -- parseOne (encode decodedFile) :: IO MergeRequest + -- ) + ] + +{- untested -} + +-- -- testCase +-- -- "merge-request-comments-on-merge-requests" +-- -- ( gitlabParseTestMany +-- -- undefined +-- -- "data/api/merge-requests/comments-on-merge-requests.json" +-- -- ), + +-- -- testCase +-- -- "merge-request-get-merge-request-diff-versions" +-- -- ( gitlabParseTestMany +-- -- undefined +-- -- "data/api/merge-requests/get-merge-request-diff-versions.json" +-- -- ), + +-- -- testCase +-- -- "merge-request-merge-to-default-merge-path" +-- -- ( gitlabParseTestMany +-- -- undefined +-- -- "data/api/merge-requests/merge-to-default-merge-path.json" +-- -- ), + +-- -- testCase +-- -- "merge-request-rebase-merge-request" +-- -- ( gitlabParseTestMany +-- -- undefined +-- -- "data/api/merge-requests/rebase-merge-request.json" +-- -- ), + +-- -- testCase +-- -- "merge-request-single-merge-request-commits" +-- -- ( gitlabParseTestMany +-- -- undefined +-- -- "data/api/merge-requests/single-merge-request-commits.json" +-- -- ), + +-- -- testCase +-- -- "merge-request-single-merge-request-diff-version" +-- -- ( gitlabParseTestMany +-- -- undefined +-- -- "data/api/merge-requests/single-merge-request-diff-version.json" +-- -- ), diff --git a/tests/API/NotesTests.hs b/tests/API/NotesTests.hs --- a/tests/API/NotesTests.hs +++ b/tests/API/NotesTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.NotesTests (notesTests) where @@ -16,4 +15,32 @@ -- | https://docs.gitlab.com/ee/api/notes.html notesTests :: [TestTree] notesTests = - [] + concat + [ let fname = "data/api/notes/project-issue-notes.json" + in gitlabJsonParserTests + "project-issue-notes" + fname + (parseOne =<< BSL.readFile fname :: IO [Note]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Note] + parseOne (encode decodedFile) :: IO [Note] + ), + let fname = "data/api/notes/single-merge-request-note.json" + in gitlabJsonParserTests + "single-merge-request-note" + fname + (parseOne =<< BSL.readFile fname :: IO Note) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Note + parseOne (encode decodedFile) :: IO Note + ), + let fname = "data/api/notes/single-snippet-note.json" + in gitlabJsonParserTests + "single-snippet-note" + fname + (parseOne =<< BSL.readFile fname :: IO Note) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Note + parseOne (encode decodedFile) :: IO Note + ) + ] diff --git a/tests/API/PipelinesTests.hs b/tests/API/PipelinesTests.hs --- a/tests/API/PipelinesTests.hs +++ b/tests/API/PipelinesTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.PipelinesTests (pipelinesTests) where @@ -16,4 +15,25 @@ -- | https://docs.gitlab.com/ee/api/pipelines.html pipelinesTests :: [TestTree] pipelinesTests = - [] + let fname = "data/api/pipelines/cancel-pipeline-jobs.json" + in gitlabJsonParserTests + "cancel-pipeline-jobs" + fname + (parseOne =<< BSL.readFile fname :: IO Pipeline) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Pipeline + parseOne (encode decodedFile) :: IO Pipeline + ) + +{- + +cancel-pipeline-jobs.json +pipeline-test-report.json +project-pipelines.json +single-pipeline.json +create-new-pipeline.json +pipeline-test-report-summary.json +retry-jobs-in-pipeline.json +variables-of-pipeline.json + +-} diff --git a/tests/API/ProjectsTests.hs b/tests/API/ProjectsTests.hs --- a/tests/API/ProjectsTests.hs +++ b/tests/API/ProjectsTests.hs @@ -4,16 +4,168 @@ module API.ProjectsTests (projectsTests) where import API.Common -import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BSL import GitLab -import GitLab.SystemHooks.GitLabSystemHooks -import GitLab.SystemHooks.Types import Test.Tasty -import Test.Tasty.HUnit -- | https://docs.gitlab.com/ee/api/projects.html projectsTests :: [TestTree] projectsTests = - [] + concat + [ let fname = "data/api/projects/list-all-projects.json" + in gitlabJsonParserTests + "list-all-projects" + fname + (parseOne =<< BSL.readFile fname :: IO [Project]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Project] + parseOne (encode decodedFile) :: IO [Project] + ), + let fname = "data/api/projects/archive-project.json" + in gitlabJsonParserTests + "archive-project" + fname + (parseOne =<< BSL.readFile fname :: IO Project) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Project + parseOne (encode decodedFile) :: IO Project + ), + let fname = "data/api/projects/get-single-project.json" + in gitlabJsonParserTests + "get-single-project" + fname + (parseOne =<< BSL.readFile fname :: IO Project) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Project + parseOne (encode decodedFile) :: IO Project + ), + let fname = "data/api/projects/list-projects-starred-by-user.json" + in gitlabJsonParserTests + "list-projects-starred-by-user" + fname + (parseOne =<< BSL.readFile fname :: IO [Project]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Project] + parseOne (encode decodedFile) :: IO [Project] + ), + let fname = "data/api/projects/unarchive-project.json" + in gitlabJsonParserTests + "unarchive-project" + fname + (parseOne =<< BSL.readFile fname :: IO Project) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Project + parseOne (encode decodedFile) :: IO Project + ), + let fname = "data/api/projects/get-path-to-repository-storage.json" + in gitlabJsonParserTests + "get-path-to-repository-storage" + fname + (parseOne =<< BSL.readFile fname :: IO [RepositoryStorage]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [RepositoryStorage] + parseOne (encode decodedFile) :: IO [RepositoryStorage] + ), + let fname = "data/api/projects/list-user-projects.json" + in gitlabJsonParserTests + "list-user-projects" + fname + (parseOne =<< BSL.readFile fname :: IO [Project]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Project] + parseOne (encode decodedFile) :: IO [Project] + ), + let fname = "data/api/projects/unstar-project.json" + in gitlabJsonParserTests + "unstar-project" + fname + (parseOne =<< BSL.readFile fname :: IO Project) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Project + parseOne (encode decodedFile) :: IO Project + ), + let fname = "data/api/projects/star-project.json" + in gitlabJsonParserTests + "star-project" + fname + (parseOne =<< BSL.readFile fname :: IO Project) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Project + parseOne (encode decodedFile) :: IO Project + ), + let fname = "data/api/projects/star-project.json" + in gitlabJsonParserTests + "star-project" + fname + (parseOne =<< BSL.readFile fname :: IO Project) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Project + parseOne (encode decodedFile) :: IO Project + ), + let fname = "data/api/projects/list-forks-of-project.json" + in gitlabJsonParserTests + "list-forks-of-project" + fname + (parseOne =<< BSL.readFile fname :: IO [Project]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Project] + parseOne (encode decodedFile) :: IO [Project] + ), + let fname = "data/api/projects/starrers-of-project.json" + in gitlabJsonParserTests + "starrers-of-project" + fname + (parseOne =<< BSL.readFile fname :: IO [Starrer]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Starrer] + parseOne (encode decodedFile) :: IO [Starrer] + ), + let fname = "data/api/projects/upload-project-avatar.json" + in gitlabJsonParserTests + "upload-project-avatar" + fname + (parseOne =<< BSL.readFile fname :: IO ProjectAvatar) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO ProjectAvatar + parseOne (encode decodedFile) :: IO ProjectAvatar + ), + let fname = "data/api/projects/get-project-users.json" + in gitlabJsonParserTests + "get-project-users" + fname + (parseOne =<< BSL.readFile fname :: IO [User]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [User] + parseOne (encode decodedFile) :: IO [User] + ), + let fname = "data/api/projects/list-project-groups.json" + in gitlabJsonParserTests + "list-project-groups" + fname + (parseOne =<< BSL.readFile fname :: IO [Group]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Group] + parseOne (encode decodedFile) :: IO [Group] + ), + let fname = "data/api/projects/transfer-project-new-namespace.json" + in gitlabJsonParserTests + "transfer-project-new-namespace" + fname + (parseOne =<< BSL.readFile fname :: IO Project) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Project + parseOne (encode decodedFile) :: IO Project + ) + ] + +{- + +Untested data files: + +languages.json +get-project-hook.json +upload-file.json +get-project-push-rules.json + +-} diff --git a/tests/API/RepositoriesTests.hs b/tests/API/RepositoriesTests.hs --- a/tests/API/RepositoriesTests.hs +++ b/tests/API/RepositoriesTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.RepositoriesTests (repositoriesTests) where @@ -16,4 +15,39 @@ -- | https://docs.gitlab.com/ee/api/repositories.html repositoriesTests :: [TestTree] repositoriesTests = - [] + concat + [ let fname = "data/api/repositories/contributors.json" + in gitlabJsonParserTests + "contributors" + fname + (parseOne =<< BSL.readFile fname :: IO [Contributor]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Contributor] + parseOne (encode decodedFile) :: IO [Contributor] + ), + let fname = "data/api/repositories/list-repository-tree.json" + in gitlabJsonParserTests + "list-repository-tree" + fname + (parseOne =<< BSL.readFile fname :: IO [Repository]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Repository] + parseOne (encode decodedFile) :: IO [Repository] + ), + let fname = "data/api/repositories/merge-base.json" + in gitlabJsonParserTests + "merge-base" + fname + (parseOne =<< BSL.readFile fname :: IO Commit) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Commit + parseOne (encode decodedFile) :: IO Commit + ) + ] + +{- + +compare-branches-tags-commits.json +generate-changelog-data.json + +-} diff --git a/tests/API/RepositoryFilesTests.hs b/tests/API/RepositoryFilesTests.hs --- a/tests/API/RepositoryFilesTests.hs +++ b/tests/API/RepositoryFilesTests.hs @@ -1,19 +1,50 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.RepositoryFilesTests (repositoryFilesTests) where import API.Common -import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BSL import GitLab -import GitLab.SystemHooks.GitLabSystemHooks -import GitLab.SystemHooks.Types import Test.Tasty -import Test.Tasty.HUnit -- | https://docs.gitlab.com/ee/api/repository_files.html repositoryFilesTests :: [TestTree] repositoryFilesTests = - [] + -- let fname = "data/api/repository-files/create-new-file-in-repository.json" + -- in gitlabJsonParserTests + -- "create-new-file-in-repository" + -- fname + -- (parseOne =<< BSL.readFile fname :: IO [Note]) + -- ( do + -- decodedFile <- parseOne =<< BSL.readFile fname :: IO [Note] + -- parseOne (encode decodedFile) :: IO [Note] + -- ) + let fname = "data/api/repository-files/get-file-from-repository.json" + in gitlabJsonParserTests + "get-file-from-repository" + fname + (parseOne =<< BSL.readFile fname :: IO RepositoryFile) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO RepositoryFile + parseOne (encode decodedFile) :: IO RepositoryFile + ) + +-- let fname = "data/api/repository-files/get-file-blame-from-repository.json" +-- in gitlabJsonParserTests +-- "get-file-blame-from-repository" +-- fname +-- (parseOne =<< BSL.readFile fname :: IO RepositoryFile) +-- ( do +-- decodedFile <- parseOne =<< BSL.readFile fname :: IO RepositoryFile +-- parseOne (encode decodedFile) :: IO RepositoryFile +-- ) +-- let fname = "data/api/repository-files/update-existing-file-in-repository.json" +-- in gitlabJsonParserTests +-- "update-existing-file-in-repository" +-- fname +-- (parseOne =<< BSL.readFile fname :: IO RepositoryFile) +-- ( do +-- decodedFile <- parseOne =<< BSL.readFile fname :: IO RepositoryFile +-- parseOne (encode decodedFile) :: IO RepositoryFile +-- ) diff --git a/tests/API/TagsTests.hs b/tests/API/TagsTests.hs --- a/tests/API/TagsTests.hs +++ b/tests/API/TagsTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.TagsTests (tagsTests) where @@ -16,4 +15,32 @@ -- | https://docs.gitlab.com/ee/api/tags.html tagsTests :: [TestTree] tagsTests = - [] + concat + [ let fname = "data/api/tags/list-project-repository-tags.json" + in gitlabJsonParserTests + "list-project-repository-tags" + fname + (parseOne =<< BSL.readFile fname :: IO [Tag]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Tag] + parseOne (encode decodedFile) :: IO [Tag] + ), + let fname = "data/api/tags/single-repository-tag.json" + in gitlabJsonParserTests + "single-repository-tag" + fname + (parseOne =<< BSL.readFile fname :: IO Tag) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Tag + parseOne (encode decodedFile) :: IO Tag + ), + let fname = "data/api/tags/create-new-tag.json" + in gitlabJsonParserTests + "create-new-tag" + fname + (parseOne =<< BSL.readFile fname :: IO Tag) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Tag + parseOne (encode decodedFile) :: IO Tag + ) + ] diff --git a/tests/API/TodosTests.hs b/tests/API/TodosTests.hs --- a/tests/API/TodosTests.hs +++ b/tests/API/TodosTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.TodosTests (todosTests) where @@ -16,4 +15,23 @@ -- | https://docs.gitlab.com/ee/api/todos.html todosTests :: [TestTree] todosTests = - [] + ( let fname = "data/api/todos/todo-items.json" + in gitlabJsonParserTests + "todo-items" + fname + (parseOne =<< BSL.readFile fname :: IO [Todo]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Todo] + parseOne (encode decodedFile) :: IO [Todo] + ) + ) + ++ ( let fname = "data/api/todos/mark-todo-item-done.json" + in gitlabJsonParserTests + "mark-todo-item-done" + fname + (parseOne =<< BSL.readFile fname :: IO Todo) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Todo + parseOne (encode decodedFile) :: IO Todo + ) + ) diff --git a/tests/API/UsersTests.hs b/tests/API/UsersTests.hs --- a/tests/API/UsersTests.hs +++ b/tests/API/UsersTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.UsersTests (usersTests) where @@ -16,4 +15,131 @@ -- | https://docs.gitlab.com/ee/api/users.html usersTests :: [TestTree] usersTests = - [] + concat + [ let fname = "data/api/users/emails.json" + in gitlabJsonParserTests + "emails" + fname + (parseOne =<< BSL.readFile fname :: IO [Email]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Email] + parseOne (encode decodedFile) :: IO [Email] + ), + let fname = "data/api/users/add-ssh-key.json" + in gitlabJsonParserTests + "add-ssh-key" + fname + (parseOne =<< BSL.readFile fname :: IO Key) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Key + parseOne (encode decodedFile) :: IO Key + ), + let fname = "data/api/users/ssh-keys.json" + in gitlabJsonParserTests + "ssh-keys" + fname + (parseOne =<< BSL.readFile fname :: IO [Key]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Key] + parseOne (encode decodedFile) :: IO [Key] + ), + let fname = "data/api/users/ssh-key.json" + in gitlabJsonParserTests + "ssh-key" + fname + (parseOne =<< BSL.readFile fname :: IO Key) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Key + parseOne (encode decodedFile) :: IO Key + ), + let fname = "data/api/users/followers.json" + in gitlabJsonParserTests + "followers" + fname + (parseOne =<< BSL.readFile fname :: IO [User]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [User] + parseOne (encode decodedFile) :: IO [User] + ), + let fname = "data/api/users/follow-user.json" + in gitlabJsonParserTests + "follow-user" + fname + (parseOne =<< BSL.readFile fname :: IO User) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO User + parseOne (encode decodedFile) :: IO User + ), + let fname = "data/api/users/user-preferences.json" + in gitlabJsonParserTests + "user-preferences" + fname + (parseOne =<< BSL.readFile fname :: IO UserPrefs) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO UserPrefs + parseOne (encode decodedFile) :: IO UserPrefs + ), + let fname = "data/api/users/user-status.json" + in gitlabJsonParserTests + "user-status" + fname + (parseOne =<< BSL.readFile fname :: IO UserStatus) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO UserStatus + parseOne (encode decodedFile) :: IO UserStatus + ), + let fname = "data/api/users/set-user-status.json" + in gitlabJsonParserTests + "set-user-status" + fname + (parseOne =<< BSL.readFile fname :: IO UserStatus) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO UserStatus + parseOne (encode decodedFile) :: IO UserStatus + ), + let fname = "data/api/users/current-user.json" + in gitlabJsonParserTests + "current-user" + fname + (parseOne =<< BSL.readFile fname :: IO User) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO User + parseOne (encode decodedFile) :: IO User + ), + let fname = "data/api/users/list-user.json" + in gitlabJsonParserTests + "list-user" + fname + (parseOne =<< BSL.readFile fname :: IO User) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO User + parseOne (encode decodedFile) :: IO User + ), + let fname = "data/api/users/list-users.json" + in gitlabJsonParserTests + "list-users" + fname + (parseOne =<< BSL.readFile fname :: IO [User]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [User] + parseOne (encode decodedFile) :: IO [User] + ), + let fname = "data/api/users/gpg-keys.json" + in gitlabJsonParserTests + "gpg-keys" + fname + (parseOne =<< BSL.readFile fname :: IO [Key]) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO [Key] + parseOne (encode decodedFile) :: IO [Key] + ), + let fname = "data/api/users/user-counts.json" + in gitlabJsonParserTests + "user-counts" + fname + (parseOne =<< BSL.readFile fname :: IO UserCount) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO UserCount + parseOne (encode decodedFile) :: IO UserCount + ) + ] diff --git a/tests/API/VersionTests.hs b/tests/API/VersionTests.hs --- a/tests/API/VersionTests.hs +++ b/tests/API/VersionTests.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module API.VersionTests (versionTests) where @@ -16,4 +15,12 @@ -- | https://docs.gitlab.com/ee/api/version.html versionTests :: [TestTree] versionTests = - [] + let fname = "data/api/version/version.json" + in gitlabJsonParserTests + "version" + fname + (parseOne =<< BSL.readFile fname :: IO Version) + ( do + decodedFile <- parseOne =<< BSL.readFile fname :: IO Version + parseOne (encode decodedFile) :: IO Version + ) diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -77,6 +77,9 @@ "api-repositories" repositoriesTests, testGroup + "api-repository-files" + repositoryFilesTests, + testGroup "api-tags" tagsTests, testGroup