diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,6 +15,7 @@ * Repositories * Repository files * Users +* Discussions The library parses JSON results into Haskell data types in the `GitLab.Types` module, allowing you to work with statically typed diff --git a/gitlab-haskell.cabal b/gitlab-haskell.cabal --- a/gitlab-haskell.cabal +++ b/gitlab-haskell.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: gitlab-haskell category: Git -version: 0.2.5 +version: 0.3.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: @@ -74,9 +74,12 @@ , GitLab.API.Repositories , GitLab.API.MergeRequests , GitLab.API.RepositoryFiles + , GitLab.API.Tags , GitLab.API.Todos , GitLab.API.Version , GitLab.API.Notes + , GitLab.API.Discussions + , GitLab.API.Boards , GitLab.SystemHooks.Types , GitLab.SystemHooks.GitLabSystemHooks , GitLab.SystemHooks.Rules @@ -108,6 +111,8 @@ type: exitcode-stdio-1.0 main-is: Tests.hs other-modules: SystemHookTests + , API.BoardsTests + , API.Common hs-source-dirs: tests/ default-language: Haskell2010 build-depends: base >= 4.8.0.0 && < 6 diff --git a/src/GitLab.hs b/src/GitLab.hs --- a/src/GitLab.hs +++ b/src/GitLab.hs @@ -24,9 +24,11 @@ module GitLab.API.MergeRequests, module GitLab.API.Repositories, module GitLab.API.RepositoryFiles, + module GitLab.API.Tags, module GitLab.API.Todos, module GitLab.API.Version, module GitLab.API.Notes, + module GitLab.API.Discussions, module GitLab.SystemHooks.GitLabSystemHooks, module GitLab.SystemHooks.Types, module GitLab.SystemHooks.Rules, @@ -37,6 +39,7 @@ import Control.Monad.Trans.Reader import GitLab.API.Branches import GitLab.API.Commits +import GitLab.API.Discussions import GitLab.API.Groups import GitLab.API.Issues import GitLab.API.Jobs @@ -47,6 +50,7 @@ import GitLab.API.Projects import GitLab.API.Repositories import GitLab.API.RepositoryFiles +import GitLab.API.Tags import GitLab.API.Todos import GitLab.API.Users import GitLab.API.Version diff --git a/src/GitLab/API/Boards.hs b/src/GitLab/API/Boards.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Boards.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Boards +-- Description : Project issue boards, see https://docs.gitlab.com/ce/api/boards.html +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2021 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable +module GitLab.API.Boards where + +import Data.Either +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status + +-- | returns all issue boards for a project. +projectIssueBoards :: + -- | the project + Project -> + GitLab [IssueBoard] +projectIssueBoards project = do + result <- projectIssueBoards' (project_id project) + -- return an empty list if the repository could not be found. + return (fromRight [] result) + +-- | returns all issue boards for a project given its project ID. +projectIssueBoards' :: + -- | project ID + Int -> + GitLab (Either Status [IssueBoard]) +projectIssueBoards' projectId = + gitlab (boardsAddr projectId) + where + boardsAddr :: Int -> Text + boardsAddr projId = + "/projects/" <> T.pack (show projId) <> "/boards" + +-- | returns all issue boards for a project. +projectIssueBoard :: + -- | the project + Project -> + -- | the board ID + Int -> + GitLab (Either Status (Maybe IssueBoard)) +projectIssueBoard project = do + projectIssueBoard' (project_id project) + +-- | returns all issue boards for a project. +projectIssueBoard' :: + -- | the project ID + Int -> + -- | the board ID + Int -> + GitLab (Either Status (Maybe IssueBoard)) +projectIssueBoard' projectId boardId = do + gitlabOne boardAddr + where + boardAddr :: Text + boardAddr = + "/projects/" <> T.pack (show projectId) <> "/boards/" <> T.pack (show boardId) + +-- | Creates a project issue board. +createIssueBoard :: + -- | the project + Project -> + -- | board name + Text -> + GitLab (Maybe IssueBoard) +createIssueBoard project boardName = do + result <- createIssueBoard' (project_id project) boardName + return (fromRight Nothing result) + +-- | Creates a project issue board. +createIssueBoard' :: + -- | the project ID + Int -> + -- | board name + Text -> + GitLab (Either Status (Maybe IssueBoard)) +createIssueBoard' projectId boardName = do + gitlabPost boardAddr T.empty + where + boardAddr :: Text + boardAddr = + "/projects/" <> T.pack (show projectId) <> "/boards/?name=" <> boardName + +-- | Updates a project issue board. +updateIssueBoard' :: + -- | the project ID + Int -> + -- | the board ID + Int -> + -- | attributes for updating boards + UpdateBoardAttrs -> + GitLab (Either Status IssueBoard) +updateIssueBoard' projectId boardId attrs = do + gitlabPut boardAddr T.empty + where + boardAddr :: Text + boardAddr = + "/projects/" + <> T.pack (show projectId) + <> "/boards/" + <> T.pack (show boardId) + <> T.pack (updateBoardAttrs attrs) + +-- | Deletes a project issue board. +deleteIssueBoard :: + -- | the project + Project -> + -- | the board + IssueBoard -> + GitLab (Either Status ()) +deleteIssueBoard project board = do + deleteIssueBoard' (project_id project) (board_id board) + +-- | Deletes a project issue board. +deleteIssueBoard' :: + -- | the project ID + Int -> + -- | the board ID + Int -> + GitLab (Either Status ()) +deleteIssueBoard' projectId boardId = do + gitlabDelete boardAddr + where + boardAddr :: Text + boardAddr = + "/projects/" + <> T.pack (show projectId) + <> "/boards/" + <> T.pack (show boardId) + +-- | Get a list of the board’s lists. Does not include open and closed lists. +projectBoardLists :: + -- | the project + Project -> + -- | the board + IssueBoard -> + GitLab [BoardIssue] +projectBoardLists project board = do + result <- projectBoardLists' (project_id project) (board_id board) + -- return an empty list if the repository could not be found. + return (fromRight [] result) + +-- | Get a list of the board’s lists. Does not include open and closed lists. +projectBoardLists' :: + -- | project ID + Int -> + -- | board ID + Int -> + GitLab (Either Status [BoardIssue]) +projectBoardLists' projectId boardId = + gitlab boardsAddr + where + boardsAddr :: Text + 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. +boardList :: + -- | the project + Project -> + -- | the board + IssueBoard -> + -- | list ID + Int -> + GitLab (Maybe BoardIssue) +boardList project board listId = do + result <- boardList' (project_id project) (board_id board) listId + -- 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. +boardList' :: + -- | project ID + Int -> + -- | board ID + Int -> + -- | list ID + Int -> + GitLab (Either Status (Maybe BoardIssue)) +boardList' projectId boardId listId = + gitlabOne boardsAddr + where + boardsAddr :: Text + boardsAddr = + "/projects/" <> T.pack (show projectId) <> "/boards/" <> T.pack (show boardId) <> "/lists/" <> T.pack (show listId) + +-- | Creates a new issue board list. +createBoardList :: + -- | the project + Project -> + -- | the board + IssueBoard -> + -- | attributes for creating boards + CreateBoardAttrs -> + GitLab (Maybe BoardIssue) +createBoardList project board attrs = do + result <- createBoardList' (project_id project) (board_id board) attrs + -- return an empty list if the repository could not be found. + return (fromRight Nothing result) + +-- | Creates a new issue board list. +createBoardList' :: + -- | project ID + Int -> + -- | board ID + Int -> + -- | attributes for creating the board + CreateBoardAttrs -> + GitLab (Either Status (Maybe BoardIssue)) +createBoardList' projectId boardId attrs = + gitlabPost boardsAddr T.empty + where + boardsAddr :: Text + boardsAddr = + "/projects/" + <> T.pack (show projectId) + <> "/boards/" + <> T.pack (show boardId) + <> "/lists" + <> T.pack (createBoardAttrs attrs) + +-- | Updates an existing issue board list. This call is used to change list position. +reorderBoardList :: + -- | project + Project -> + -- | board + IssueBoard -> + -- | list ID + Int -> + -- | the position of the list + Int -> + GitLab (Either Status (Maybe BoardIssue)) +reorderBoardList project board = + reorderBoardList' (project_id project) (board_id board) + +-- | Updates an existing issue board list. This call is used to change list position. +reorderBoardList' :: + -- | project ID + Int -> + -- | board ID + Int -> + -- | list ID + Int -> + -- | the position of the list + Int -> + GitLab (Either Status (Maybe BoardIssue)) +reorderBoardList' projectId boardId listId newPosition = + gitlabPut boardsAddr T.empty + where + boardsAddr :: Text + boardsAddr = + "/projects/" + <> T.pack (show projectId) + <> "/boards/" + <> T.pack (show boardId) + <> "/lists/" + <> T.pack (show listId) + <> T.pack ("?position=" <> show newPosition) + +-- | Only for administrators and project owners. Deletes a board list. +deleteBoardList :: + -- | project + Project -> + -- | board + IssueBoard -> + -- | list ID + Int -> + GitLab (Either Status ()) +deleteBoardList project board = + deleteBoardList' (project_id project) (board_id board) + +-- | Only for administrators and project owners. Deletes a board list. +deleteBoardList' :: + -- | project ID + Int -> + -- | board ID + Int -> + -- | list ID + Int -> + GitLab (Either Status ()) +deleteBoardList' projectId boardId listId = + gitlabDelete boardsAddr + where + boardsAddr :: Text + boardsAddr = + "/projects/" + <> T.pack (show projectId) + <> "/boards/" + <> T.pack (show boardId) + <> "/lists/" + <> T.pack (show listId) + +data UpdateBoardAttrs = UpdateBoardAttrs + { updateBoard_new_name :: Maybe String, + updateBoard_assignee_id :: Maybe Int, + updateBoard_milestone_id :: Maybe Int, + updateBoard_labels :: Maybe String, + updateBoard_weight :: Maybe Int + } + +-- | no attributes for board update. +noUpdateBoardAttrs :: UpdateBoardAttrs +noUpdateBoardAttrs = + UpdateBoardAttrs Nothing Nothing Nothing Nothing Nothing + +updateBoardAttrs :: UpdateBoardAttrs -> String +updateBoardAttrs attrs = + case attrsUrl of + [] -> "" + (x : xs) -> "?" <> x <> concatMap ('&' :) xs + where + attrsUrl = + catMaybes + [ (\s -> Just ("name=" <> s)) =<< updateBoard_new_name attrs, + (\i -> Just ("assignee_id=" <> show i)) =<< updateBoard_assignee_id attrs, + (\i -> Just ("milestone_id=" <> show i)) =<< updateBoard_milestone_id attrs, + (\s -> Just ("labels=" <> s)) =<< updateBoard_labels attrs, + (\i -> Just ("weight=" <> show i)) =<< updateBoard_weight attrs + ] + +-- | exactly one parameter must be provided. +data CreateBoardAttrs = CreateBoardAttrs + { createBoard_label_id :: Maybe Int, + createBoard_assignee_id :: Maybe Int, + createBoard_milestone_id :: Maybe Int + } + +-- | no attributes for board creation. +noCreateBoardAttrs :: CreateBoardAttrs +noCreateBoardAttrs = + CreateBoardAttrs Nothing Nothing Nothing + +createBoardAttrs :: CreateBoardAttrs -> String +createBoardAttrs attrs = + case attrsUrl of + [] -> "" + (x : xs) -> "?" <> x <> concatMap ('&' :) xs + where + attrsUrl = + catMaybes + [ (\i -> Just ("label_id=" <> show i)) =<< createBoard_label_id attrs, + (\i -> Just ("assignee_id=" <> show i)) =<< createBoard_assignee_id attrs, + (\i -> Just ("milestone_id=" <> show i)) =<< createBoard_milestone_id attrs + ] 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 @@ -23,7 +23,8 @@ GitLab [Commit] projectCommits project = do result <- projectCommits' (project_id project) - return (fromRight (error "projectCommits error") result) + -- return an empty list if the repository could not be found. + return (fromRight [] result) -- | returns all commits for a project given its project ID. projectCommits' :: @@ -44,9 +45,10 @@ Project -> -- | branch name Text -> - GitLab (Either Status [Commit]) -branchCommits project = - branchCommits' (project_id project) + GitLab [Commit] +branchCommits project branchName = do + result <- branchCommits' (project_id project) branchName + return (fromRight [] result) -- | returns all commits of a branch from a project -- given its project ID and the branch name. @@ -73,7 +75,7 @@ GitLab (Maybe Commit) commitDetails project theHash = do result <- commitDetails' (project_id project) theHash - return (fromRight (error "commitDetails error") result) + return (fromRight Nothing result) -- | returns a commit for the given project ID and commit hash, if -- such a commit exists. diff --git a/src/GitLab/API/Discussions.hs b/src/GitLab/API/Discussions.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Discussions.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Discussions +-- Description : Queries about discussions, which are a set of related notes on snippets, issues, epics, merge requests and commits. +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2021 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable +module GitLab.API.Discussions where + +import Data.Text (Text) +import qualified Data.Text as T +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status + +-- | gets all discussion for a commit for a project. +commitDiscussions :: + -- | the project + Project -> + -- | commit hash + Text -> + GitLab (Either Status [Discussion]) +commitDiscussions proj = commitDiscussions' (project_id proj) + +-- | gets all discussion for a commit for a project given its project ID. +commitDiscussions' :: + -- | the project ID + Int -> + -- | commit hash + Text -> + GitLab (Either Status [Discussion]) +commitDiscussions' projId commitHash = do + let urlPath = + T.pack $ + "/projects/" + <> show projId + <> "/repository" + <> "/commits/" + <> T.unpack commitHash + <> "/discussions" + gitlab urlPath 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 @@ -119,3 +119,22 @@ addUsersToGroup' groupName access usernames = do users <- catMaybes <$> mapM searchUser usernames mapM (addUserToGroup' groupName access . user_id) users + +groupProjects :: + -- | group + Group -> + GitLab (Either Status [Project]) +groupProjects group = do + groupProjects' (group_id group) + +groupProjects' :: + -- | group ID + Int -> + GitLab (Either Status [Project]) +groupProjects' groupID = do + let urlPath = + T.pack $ + "/groups/" + <> show groupID + <> "/projects" + gitlab urlPath 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 @@ -8,38 +8,227 @@ -- License : BSD3 -- Maintainer : robstewart57@gmail.com -- Stability : stable -module GitLab.API.Issues where +module GitLab.API.Issues + ( defaultIssueFilters, + IssueAttrs (..), + DueDate (..), + IssueSearchIn (..), + IssueOrderBy (..), + IssueScope (..), + IssueSortBy (..), + IssueState (..), + projectIssues, + projectIssues', + issueStatisticsUser, + issueStatisticsGroup, + issueStatisticsGroup', + issueStatisticsProject, + issueStatisticsProject', + userIssues, + newIssue, + newIssue', + editIssue, + ) +where import qualified Data.Aeson as J import Data.Either +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Encoding +import Data.Time.Clock +import Data.Time.Format.ISO8601 import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Types.Status --- | returns all issues against a project. -projectOpenedIssues :: +-- | 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 + +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" + +data IssueSearchIn + = JustTitle + | JustDescription + | TitleAndDescription + +instance Show IssueSearchIn where + show JustTitle = "title" + show JustDescription = "description" + show TitleAndDescription = "title,description" + +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" + +data IssueScope + = CreatedByMe + | AssignedToMe + | All + +instance Show IssueScope where + show CreatedByMe = "created_by_me" + show AssignedToMe = "assigned_to_me" + show All = "all" + +data IssueSortBy + = Ascending + | Descending + +instance Show IssueSortBy where + show Ascending = "asc" + show Descending = "desc" + +data IssueState + = IssueOpen + | IssueClosed + +instance Show IssueState where + show IssueOpen = "opened" + show IssueClosed = "closed" + +projectIssues :: -- | the project Project -> + -- | filter the issues, see https://docs.gitlab.com/ee/api/issues.html#list-issues + IssueAttrs -> + -- the GitLab issues GitLab [Issue] -projectOpenedIssues p = do - result <- projectOpenedIssues' (project_id p) - return (fromRight (error "projectOpenedIssues error") result) +projectIssues p filters = do + result <- projectIssues' (project_id p) filters + return (fromRight (error "projectIssues error") result) --- | returns all issues against a project given its project ID. -projectOpenedIssues' :: +projectIssues' :: -- | the project ID Int -> + -- | filter the issues, see https://docs.gitlab.com/ee/api/issues.html#list-issues + IssueAttrs -> + -- | the GitLab issues GitLab (Either Status [Issue]) -projectOpenedIssues' projectId = do - let path = "/projects/" <> T.pack (show projectId) <> "/issues" +projectIssues' projectId attrs = gitlab path + where + path = + T.pack $ + "/projects/" + <> show projectId + <> "/issues" + <> issuesAttrs attrs --- gitlabReq path "&state=opened" +-- | 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 + IssueAttrs -> + -- | the issue statistics + GitLab IssueStatistics +issueStatisticsUser attrs = + gitlabOneUnsafe path + where + path = + T.pack $ + "/issues_statistics" + <> issuesAttrs attrs +-- | Gets issues count statistics for a given group. +issueStatisticsGroup :: + -- | the group + Group -> + -- | filter the issues, see https://docs.gitlab.com/ee/api/issues_statistics.html#get-issues-statistics + IssueAttrs -> + -- | the issue statistics + GitLab IssueStatistics +issueStatisticsGroup group filters = do + result <- issueStatisticsGroup' (group_id group) filters + case result of + Left _s -> error "issueStatisticsGroup error" + Right Nothing -> error "issueStatisticsGroup error" + Right (Just stats) -> return stats + +-- | Gets issues count statistics for a given group. +issueStatisticsGroup' :: + -- | the group ID + Int -> + -- | filter the issues, see https://docs.gitlab.com/ee/api/issues_statistics.html#get-issues-statistics + IssueAttrs -> + -- | the issue statistics + GitLab (Either Status (Maybe IssueStatistics)) +issueStatisticsGroup' groupId attrs = + gitlabOne path + where + path = + T.pack $ + "/groups/" + <> show groupId + <> "/issues_statistics" + <> issuesAttrs attrs + +-- | Gets issues count statistics for a given group. +issueStatisticsProject :: + -- | the project + Project -> + -- | filter the issues, see https://docs.gitlab.com/ee/api/issues_statistics.html#get-issues-statistics + IssueAttrs -> + -- | the issue statistics + GitLab IssueStatistics +issueStatisticsProject proj filters = do + result <- issueStatisticsGroup' (project_id proj) filters + case result of + Left _s -> error "issueStatisticsProject error" + Right Nothing -> error "issueStatisticsProject error" + Right (Just stats) -> return stats + +-- | Gets issues count statistics for a given project. +issueStatisticsProject' :: + -- | the project ID + Int -> + -- | filter the issues, see https://docs.gitlab.com/ee/api/issues_statistics.html#get-issues-statistics + IssueAttrs -> + -- | the issue statistics + GitLab (Either Status (Maybe IssueStatistics)) +issueStatisticsProject' projId attrs = + gitlabOne path + where + path = + T.pack $ + "/projects/" + <> show projId + <> "/issues_statistics" + <> issuesAttrs attrs + -- | gets all issues create by a user. userIssues :: -- | the user @@ -108,3 +297,73 @@ (J.encode editIssueReq) ) ) + +------------------------------- +-- Internal functions and types + +data IssueAttrs = IssueAttrs + { issueFilter_assignee_id :: Maybe Int, + issueFilter_assignee_username :: Maybe String, + issueFilter_author_id :: Maybe Int, + issueFilter_author_username :: Maybe String, + issueFilter_confidential :: Maybe Bool, + issueFilter_created_after :: Maybe UTCTime, + issueFilter_created_before :: Maybe UTCTime, + issueFilter_due_date :: Maybe DueDate, + issueFilter_iids :: Maybe Int, + issueFilter_in :: Maybe IssueSearchIn, + 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_search :: Maybe String, + issueFilter_sort :: Maybe IssueSortBy, + issueFilter_state :: Maybe IssueState, + issueFilter_updated_after :: Maybe UTCTime, + issueFilter_updated_before :: Maybe UTCTime, + issueFilter_with_labels_details :: Maybe Bool + } + +issuesAttrs :: IssueAttrs -> String +issuesAttrs filters = + case attrsUrl of + [] -> "" + (x : xs) -> "?" <> x <> concatMap ('&' :) xs + where + attrsUrl = + catMaybes + [ (\i -> Just ("assignee_id=" <> show i)) =<< issueFilter_assignee_id filters, + (\t -> Just ("assignee_username=" <> t)) =<< issueFilter_assignee_username filters, + (\i -> Just ("author_id=" <> show i)) =<< issueFilter_author_id filters, + (\i -> Just ("author_username=" <> show i)) =<< issueFilter_author_username filters, + (\b -> Just ("confidential=" <> showBool b)) =<< issueFilter_confidential filters, + (\t -> Just ("created_after=" <> showTime t)) =<< issueFilter_created_after filters, + (\t -> Just ("created_before=" <> showTime t)) =<< issueFilter_created_before filters, + (\due -> Just ("due_date=" <> show due)) =<< issueFilter_due_date filters, + (\iids -> Just ("iids[]=" <> show iids)) =<< issueFilter_iids filters, + (\issueIn -> Just ("assignee_id=" <> show issueIn)) =<< issueFilter_in filters, + (\i -> Just ("iteration_id=" <> show i)) =<< issueFilter_iteration_id filters, + (\s -> Just ("iteration_title=" <> s)) =<< issueFilter_iteration_title filters, + (\s -> Just ("milestone=" <> s)) =<< issueFilter_milestone filters, + (\s -> Just ("labels=" <> s)) =<< issueFilter_labels filters, + (\s -> Just ("my_reaction_emoji=" <> s)) =<< issueFilter_my_reaction_emoji filters, + (\b -> Just ("non_archived=" <> showBool b)) =<< issueFilter_non_archived filters, + (\x -> Just ("order_by=" <> show x)) =<< issueFilter_order_by filters, + (\x -> Just ("scope=" <> show x)) =<< issueFilter_scope filters, + (\s -> Just ("search=" <> s)) =<< issueFilter_search filters, + (\x -> Just ("sort=" <> show x)) =<< issueFilter_sort filters, + (\x -> Just ("state=" <> show x)) =<< issueFilter_state filters, + (\t -> Just ("updated_after=" <> showTime t)) =<< issueFilter_updated_after filters, + (\t -> Just ("updated_before=" <> showTime t)) =<< issueFilter_updated_before filters, + (\b -> Just ("with_labels_details=" <> showBool b)) =<< issueFilter_with_labels_details filters + ] + where + showBool :: Bool -> String + showBool True = "true" + showBool False = "false" + showTime :: UTCTime -> String + showTime = iso8601Show 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 @@ -69,7 +69,7 @@ -- | gets a project with the given name for the given username. E.g. -- --- > projectsNamespaceName "user1" "project1" +-- > projectsWithNameAndUser "user1" "project1" -- -- looks for "user1/project1" projectsWithNameAndUser :: Text -> Text -> GitLab (Either Status (Maybe Project)) @@ -166,7 +166,7 @@ Project -> GitLab (Project, [Issue], [User]) processProject proj = do - (openIssues :: [Issue]) <- projectOpenedIssues proj + (openIssues :: [Issue]) <- projectIssues proj defaultIssueFilters let authors = map issue_author openIssues return (proj, openIssues, authors) diff --git a/src/GitLab/API/Tags.hs b/src/GitLab/API/Tags.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Tags.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Tags +-- Description : Queries about tags in repositories +-- Copyright : (c) Jihyun Yu, 2021 +-- License : BSD3 +-- Maintainer : yjh0502@gmail.com +-- Stability : stable +module GitLab.API.Tags where + +import Data.Either +import Data.Text (Text) +import qualified Data.Text as T +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status + +-- | returns all commits with tags. +tags :: + -- | 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 Status [Tag]) +tags' projectId = do + gitlabWithAttrs (commitsAddr projectId) "" + where + commitsAddr :: Int -> Text + commitsAddr projId = + "/projects/" <> T.pack (show projId) <> "/repository" <> "/tags" diff --git a/src/GitLab/Types.hs b/src/GitLab/Types.hs --- a/src/GitLab/Types.hs +++ b/src/GitLab/Types.hs @@ -35,6 +35,7 @@ Commit (..), CommitTodo (..), CommitStats (..), + Tag (..), Diff (..), Repository (..), Job (..), @@ -52,6 +53,13 @@ Version (..), URL, EditIssueReq (..), + Discussion (..), + IssueStatistics (..), + IssueCounts (..), + IssueBoard (..), + BoardIssue (..), + BoardIssueLabel (..), + ProjectBoard (..), ) where @@ -159,7 +167,7 @@ data Links = Links { self :: Text, issues :: Maybe Text, - merge_requests :: Text, + merge_requests :: Maybe Text, repo_branches :: Text, link_labels :: Text, link_events :: Text, @@ -176,7 +184,7 @@ owner_avatar_url :: Maybe Text, owner_web_url :: Text } - deriving (Generic, Show) + deriving (Generic, Show, Eq) -- | permissions. data Permissions = Permissions @@ -262,7 +270,7 @@ data MilestoneState = MSActive | MSClosed - deriving (Show) + deriving (Show, Eq) instance FromJSON MilestoneState where parseJSON (String "active") = return MSActive @@ -273,17 +281,17 @@ data Milestone = Milestone { milestone_project_id :: Maybe Int, milestone_group_id :: Maybe Int, - milestone_description :: Text, - milestone_state :: MilestoneState, - milestone_due_date :: Maybe UTCTime, - milestone_iid :: 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 :: UTCTime, - milestone_web_url :: URL + milestone_updated_at :: Maybe UTCTime, + milestone_web_url :: Maybe URL } - deriving (Generic, Show) + deriving (Generic, Show, Eq) instance FromJSON Milestone where parseJSON = genericParseJSON (defaultOptions {fieldLabelModifier = drop 10}) @@ -379,6 +387,23 @@ } 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) + +data Release = Release + { release_tag_name :: Text, + release_description :: Text + } + deriving (Generic, Show) + -- | diff between two commits. data Diff = Diff { diff :: Text, @@ -654,6 +679,93 @@ } 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) + +newtype IssueStatistics = IssueStatistics + { issues_statistics :: IssueStats + } + deriving (Generic, Show) + +newtype IssueStats = IssueStats + { issues_counts :: IssueCounts + } + deriving (Generic, Show) + +data IssueCounts = IssueCounts + { issues_all :: Int, + issues_closed :: Int, + issues_opened :: Int + } + deriving (Generic, Show) + +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) + +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) + +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) + +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) + ----------------------------- -- JSON GitLab parsers below ----------------------------- @@ -804,9 +916,74 @@ 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 @@ -847,6 +1024,22 @@ } ) +instance FromJSON Tag where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = tagPrefix + } + ) + +instance FromJSON Release where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = releasePrefix + } + ) + instance FromJSON CommitStats where parseJSON = genericParseJSON @@ -1006,3 +1199,75 @@ { 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 + } + ) 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 @@ -5,13 +5,13 @@ module GitLab.WebRequests.GitLabWebCalls ( gitlab, gitlabUnsafe, + gitlabOneUnsafe, gitlabWithAttrs, gitlabWithAttrsUnsafe, gitlabOne, -- gitlabOneIO, gitlabWithAttrsOne, - -- not currently used. - -- gitlabWithAttrsOneUnsafe, + gitlabWithAttrsOneUnsafe, gitlabPost, gitlabPut, gitlabDelete, @@ -26,7 +26,7 @@ import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import Data.ByteString.Lazy.Char8 as C +import qualified Data.ByteString.Lazy.Char8 as C import Data.Either import Data.Text (Text) import qualified Data.Text as T @@ -278,6 +278,13 @@ gitlabOne :: (FromJSON a) => Text -> GitLab (Either Status (Maybe a)) gitlabOne addr = gitlabReqJsonOne addr "" +gitlabOneUnsafe :: (FromJSON a) => Text -> GitLab a +gitlabOneUnsafe addr = do + result <- fromRight (error "gitlabOneUnsafe error") <$> gitlabOne addr + case result of + Nothing -> error "gitlabOneUnsafe error" + Just value -> return value + gitlabWithAttrs :: (FromJSON a) => Text -> Text -> GitLab (Either Status [a]) gitlabWithAttrs = gitlabReqJsonMany @@ -288,10 +295,13 @@ gitlabWithAttrsOne :: (FromJSON a) => Text -> Text -> GitLab (Either Status (Maybe a)) gitlabWithAttrsOne = gitlabReqJsonOne --- not currently used. --- gitlabWithAttrsOneUnsafe :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab (Maybe a) --- gitlabWithAttrsOneUnsafe gitlabURL attrs = --- fromRight (error "gitlabWithAttrsUnsafe error") <$> gitlabReqJsonOne gitlabURL attrs +gitlabWithAttrsOneUnsafe :: (FromJSON a) => Text -> Text -> GitLab a +gitlabWithAttrsOneUnsafe gitlabURL attrs = do + result <- gitlabReqJsonOne gitlabURL attrs + case result of + Left s -> error ("gitlabWithAttrsOneUnsafe: " <> show s) + Right Nothing -> error ("gitlabWithAttrsOneUnsafe: could not parse JSON for " <> show attrs) + Right (Just x) -> return x totalPages :: Response a -> Int totalPages resp = diff --git a/tests/API/BoardsTests.hs b/tests/API/BoardsTests.hs new file mode 100644 --- /dev/null +++ b/tests/API/BoardsTests.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +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 + } diff --git a/tests/API/Common.hs b/tests/API/Common.hs new file mode 100644 --- /dev/null +++ b/tests/API/Common.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module API.Common where + +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 + +gitlabParseTestOne :: (FromJSON a, Eq a, Show a) => a -> String -> Assertion +gitlabParseTestOne expectedHaskellValue filename = do + raw <- BSL.readFile filename + result <- parseOne raw + expectedHaskellValue @=? result + +gitlabParseTestMany :: (FromJSON a, Eq a, Show a) => [a] -> String -> Assertion +gitlabParseTestMany expectedHaskellValue filename = do + raw <- BSL.readFile filename + result <- parseMany raw + expectedHaskellValue @=? result + +parseOne :: FromJSON a => BSL.ByteString -> IO a +parseOne bs = + case eitherDecode bs of + Left err -> assertFailure err + Right xs -> return xs + +parseMany :: FromJSON a => BSL.ByteString -> IO [a] +parseMany bs = + case eitherDecode bs of + Left err -> assertFailure err + Right xs -> return xs diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -3,6 +3,7 @@ module Main where +import API.BoardsTests import Data.Maybe (fromJust) import SystemHookTests import Test.Tasty @@ -11,6 +12,12 @@ main = do defaultMain ( testGroup - "gitlab system hook tests" - systemHookTests + "gitlab-haskell" + [ testGroup + "gitlab system hook tests" + systemHookTests, + testGroup + "api-boards" + boardsTests + ] )