MergeRequests.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}

-- |
-- Module      : MergeRequests
-- Description : Queries about merge requests against projects
-- Copyright   : (c) Rob Stewart, Heriot-Watt University, 2019
-- License     : BSD3
-- Maintainer  : robstewart57@gmail.com
-- Stability   : stable
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
    mergeRequestCommits,

    -- * Get issues that would be closed by merging an MR
    mergeRequestClosesIssues,
    --     -- * Get single MR changes

    --     -- * List MR pipelines

    --     -- * Create MR Pipeline

    -- * Create MR
    createMergeRequest,
    --     -- * Update MR

    -- * Accept MR
    acceptMergeRequest,
    AcceptMergeRequestAttrs (..),

    -- * Delete a merge request
    deleteMergeRequest,

    -- * merge request attributes
    mrAttrs,
    MergeProjectAttrs (..),
    MergeRequestState (..),
    WIP (..),
  )
where

import Control.Monad.Except
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Default
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 GHC.Generics
import GitLab.Types
import GitLab.WebRequests.GitLabWebCalls
import Network.HTTP.Client

-- | returns the merge request for a project given its merge request
-- IID.
mergeRequest ::
  -- | project
  Project ->
  -- | merge request IID
  Int ->
  GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest))
mergeRequest project =
  mergeRequest' (project_id project)

-- | returns the merge request for a project given its project ID and
-- merge request IID.
mergeRequest' ::
  -- | project ID
  Int ->
  -- | merge request IID
  Int ->
  GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest))
mergeRequest' projectId mergeRequestIID =
  gitlabGetOne addr []
  where
    addr =
      "/projects/"
        <> T.pack (show projectId)
        <> "/merge_requests/"
        <> T.pack (show mergeRequestIID)

-- | returns the merge requests for a project.
mergeRequests ::
  -- | the project
  Project ->
  GitLab [MergeRequest]
mergeRequests p = do
  result <- mergeRequests' (project_id p)
  case result of
    Left er -> throwError (httpResponseError "mergeRequests" er)
    Right x -> return x

-- | returns the merge requests for a project given its project ID.
mergeRequests' ::
  -- | project ID
  Int ->
  GitLab (Either (Response BSL.ByteString) [MergeRequest])
mergeRequests' projectId =
  gitlabGetMany addr [("scope", Just "all")]
  where
    addr =
      "/projects/"
        <> 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
  case result of
    Left er -> throwError (httpResponseError "mergeRequests" er)
    Right x -> return x

-- | 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"

mergeRequestCommits ::
  -- | project ID
  Project ->
  -- | merge request ID
  MergeRequest ->
  GitLab [Commit]
mergeRequestCommits p mr = do
  result <- mergeRequestCommits' (project_id p) (merge_request_iid mr)
  case result of
    Left er -> throwError (httpResponseError "mergeRequestCommits" er)
    Right x -> return x

mergeRequestCommits' ::
  -- | project ID
  Int ->
  -- | merge request IID
  Int ->
  GitLab (Either (Response BSL.ByteString) [Commit])
mergeRequestCommits' projectId mrId =
  gitlabGetMany addr []
  where
    addr =
      "/projects/"
        <> T.pack (show projectId)
        <> "/merge_requests/"
        <> T.pack (show mrId)
        <> "/commits"

-- | Get all issues that would be closed by merging the given merge request.
--
-- Calls @GET \/projects\/:id\/merge_requests\/:merge_request_iid\/closes_issues@
--
-- NB: this information is not always accurate, for example in the following
-- scenario:
--
--  - a previous iteration of the MR contained commits that closed certain issues
--  - after a rebase of the MR (with a force push), these commits are no longer present
--
-- In this case, 'closes_issues' reports a larger set of closed issues than
-- expected, as it includes issues closed by commits that are no longer part of
-- the MR.
mergeRequestClosesIssues ::
  -- | project
  Project ->
  -- | merge request IID
  Int ->
  GitLab (Either (Response BSL.ByteString) [Issue])
mergeRequestClosesIssues project mrIID =
  gitlabGetMany addr []
  where
    addr =
      "/projects/"
        <> T.pack (show (project_id project))
        <> "/merge_requests/"
        <> T.pack (show mrIID)
        <> "/closes_issues"

-- | Creates a merge request.
createMergeRequest ::
  -- | project
  Project ->
  -- | source branch
  Text ->
  -- | target branch
  Text ->
  -- | target project ID
  Int ->
  -- | merge request title
  Text ->
  -- | merge request description
  Text ->
  GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest))
createMergeRequest project =
  createMergeRequest' (project_id project)

-- | Creates a merge request.
createMergeRequest' ::
  -- | project ID
  Int ->
  -- | source branch
  Text ->
  -- | target branch
  Text ->
  -- | target project ID
  Int ->
  -- | merge request title
  Text ->
  -- | merge request description
  Text ->
  GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest))
createMergeRequest' projectId sourceBranch targetBranch targetProjectId mrTitle mrDescription =
  gitlabPost addr params
  where
    params :: [GitLabParam]
    params =
      [ ("source_branch", Just (T.encodeUtf8 sourceBranch)),
        ("target_branch", Just (T.encodeUtf8 targetBranch)),
        ("target_project_id", Just (T.encodeUtf8 (T.pack (show targetProjectId)))),
        ("title", Just (T.encodeUtf8 mrTitle)),
        ("description", Just (T.encodeUtf8 mrDescription))
      ]
    addr = T.pack $ "/projects/" <> show projectId <> "/merge_requests"

-- | Accepts a merge request.
acceptMergeRequest ::
  -- | project
  Project ->
  -- | merge request IID
  Int ->
  -- | accept merge request attributes
  AcceptMergeRequestAttrs ->
  GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest))
acceptMergeRequest project =
  acceptMergeRequest' (project_id project)

-- | Accepts a merge request.
acceptMergeRequest' ::
  -- | project ID
  Int ->
  -- | merge request IID
  Int ->
  -- | accept merge request attributes
  AcceptMergeRequestAttrs ->
  GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest))
acceptMergeRequest' projectId mergeRequestIid attrs =
  gitlabPut addr (acceptMRAttrsParams attrs <> params)
  where
    params :: [GitLabParam]
    params =
      [ ("id", Just (T.encodeUtf8 (T.pack (show projectId)))),
        ("merge_request_iid", Just (T.encodeUtf8 (T.pack (show mergeRequestIid))))
      ]
    addr =
      T.pack $
        "/projects/"
          <> show projectId
          <> "/merge_requests/"
          <> show mergeRequestIid
          <> "/merge"

-- | Deletes a merge request. Only for admins and project owners.
deleteMergeRequest ::
  -- | project
  Project ->
  -- | merge request IID
  Int ->
  GitLab (Either (Response BSL.ByteString) (Maybe ()))
deleteMergeRequest project =
  deleteMergeRequest' (project_id project)

-- | Deletes a merge request. Only for admins and project owners.
deleteMergeRequest' ::
  -- | project ID
  Int ->
  -- | merge request IID
  Int ->
  GitLab (Either (Response BSL.ByteString) (Maybe ()))
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,
    -- | Return only merge requests with the given internal IDs.
    mr_attr_iids :: Maybe [Int]
  }

-- 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 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
    ]
    <> case mr_attr_iids attrs of
      Nothing -> []
      Just iids -> map (\i -> ("iids[]", showAttr i)) iids
  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

-- | Attributes for updating when editing a project with the
-- 'editProject' functions.
data AcceptMergeRequestAttrs = AcceptMergeRequestAttrs
  { -- | Set whether or not merge requests can be merged with skipped jobs.
    accept_mr_attr_auto_merge :: Maybe Bool,
    accept_mr_attr_merge_commit_message :: Maybe Text,
    accept_mr_attr_merge_when_pipeline_succeeds :: Maybe Bool,
    accept_mr_attr_sha :: Maybe Text,
    accept_mr_attr_should_remove_source_branch :: Maybe Bool,
    accept_mr_attr_squash_commit_message :: Maybe Text,
    accept_mr_attr_squash :: Maybe Bool
  }
  deriving (Generic, Show, Eq)

instance Default AcceptMergeRequestAttrs where
  def = AcceptMergeRequestAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing

acceptMRAttrsParams :: AcceptMergeRequestAttrs -> [GitLabParam]
acceptMRAttrsParams attrs =
  catMaybes
    [ (\b -> Just ("auto_merge", showBool b)) =<< accept_mr_attr_auto_merge attrs,
      (\t -> Just ("merge_commit_message", showAttrT t)) =<< accept_mr_attr_merge_commit_message attrs,
      (\b -> Just ("merge_when_pipeline_succeeds", showBool b)) =<< accept_mr_attr_merge_when_pipeline_succeeds attrs,
      (\t -> Just ("sha", showAttrT t)) =<< accept_mr_attr_sha attrs,
      (\b -> Just ("should_remove_source_branch", showBool b)) =<< accept_mr_attr_should_remove_source_branch attrs,
      (\t -> Just ("squash_commit_message", showAttrT t)) =<< accept_mr_attr_squash_commit_message attrs,
      (\b -> Just ("squash", showBool b)) =<< accept_mr_attr_squash attrs
    ]
  where
    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"))