Boards.hs

{-# 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
        ]