PullRequests.hs

-----------------------------------------------------------------------------
-- |
-- License     :  BSD-3-Clause
-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>
--
module GitHub.Data.PullRequests (
    SimplePullRequest(..),
    PullRequest(..),
    EditPullRequest(..),
    CreatePullRequest(..),
    PullRequestLinks(..),
    PullRequestCommit(..),
    PullRequestEvent(..),
    PullRequestEventType(..),
    PullRequestReference(..),
    MergeResult(..),
    statusMerge,
    ) where

import GitHub.Data.Definitions
import GitHub.Data.Id          (Id)
import GitHub.Data.Options     (IssueState (..), MergeableState (..))
import GitHub.Data.Repos       (Repo)
import GitHub.Data.Request     (StatusMap)
import GitHub.Data.URL         (URL)
import GitHub.Internal.Prelude
import Data.Vector as V (elem, snoc)
import Data.Aeson.Types (Parser)
import qualified Data.Text as T
import Prelude ()

import qualified Data.Text as T

data SimplePullRequest = SimplePullRequest
    { simplePullRequestClosedAt  :: !(Maybe UTCTime)
    , simplePullRequestCreatedAt :: !UTCTime
    , simplePullRequestUser      :: !SimpleUser
    , simplePullRequestPatchUrl  :: !URL
    , simplePullRequestState     :: !IssueState
    , simplePullRequestNumber    :: !Int
    , simplePullRequestHtmlUrl   :: !URL
    , simplePullRequestUpdatedAt :: !UTCTime
    , simplePullRequestBody      :: !(Maybe Text)
    , simplePullRequestAssignees :: !(Vector SimpleUser)
    , simplePullRequestIssueUrl  :: !URL
    , simplePullRequestDiffUrl   :: !URL
    , simplePullRequestUrl       :: !URL
    , simplePullRequestLinks     :: !PullRequestLinks
    , simplePullRequestMergedAt  :: !(Maybe UTCTime)
    , simplePullRequestTitle     :: !Text
    , simplePullRequestId        :: !(Id PullRequest)
    }
  deriving (Show, Data, Typeable, Eq, Ord, Generic)

instance NFData SimplePullRequest where rnf = genericRnf
instance Binary SimplePullRequest

data PullRequest = PullRequest
    { pullRequestClosedAt       :: !(Maybe UTCTime)
    , pullRequestCreatedAt      :: !UTCTime
    , pullRequestUser           :: !SimpleUser
    , pullRequestPatchUrl       :: !URL
    , pullRequestState          :: !IssueState
    , pullRequestNumber         :: !Int
    , pullRequestHtmlUrl        :: !URL
    , pullRequestUpdatedAt      :: !UTCTime
    , pullRequestBody           :: !(Maybe Text)
    , pullRequestAssignees      :: !(Vector SimpleUser)
    , pullRequestIssueUrl       :: !URL
    , pullRequestDiffUrl        :: !URL
    , pullRequestUrl            :: !URL
    , pullRequestLinks          :: !PullRequestLinks
    , pullRequestMergedAt       :: !(Maybe UTCTime)
    , pullRequestTitle          :: !Text
    , pullRequestId             :: !(Id PullRequest)
    , pullRequestMergedBy       :: !(Maybe SimpleUser)
    , pullRequestChangedFiles   :: !Int
    , pullRequestHead           :: !PullRequestCommit
    , pullRequestComments       :: !Count
    , pullRequestDeletions      :: !Count
    , pullRequestAdditions      :: !Count
    , pullRequestBase           :: !PullRequestCommit
    , pullRequestCommits        :: !Count
    , pullRequestMerged         :: !Bool
    , pullRequestMergeable      :: !(Maybe Bool)
    , pullRequestMergeableState :: !MergeableState
    }
  deriving (Show, Data, Typeable, Eq, Ord, Generic)

instance NFData PullRequest where rnf = genericRnf
instance Binary PullRequest

data EditPullRequest = EditPullRequest
    { editPullRequestTitle :: !(Maybe Text)
    , editPullRequestBody  :: !(Maybe Text)
    , editPullRequestState :: !(Maybe IssueState)
    , editPullRequestBase  :: !(Maybe Text)
    , editPullRequestMaintainerCanModify
                           :: !(Maybe Bool)
    }
  deriving (Show, Generic)

instance NFData EditPullRequest where rnf = genericRnf
instance Binary EditPullRequest

data CreatePullRequest
    = CreatePullRequest
      { createPullRequestTitle :: !Text
      , createPullRequestBody  :: !Text
      , createPullRequestHead  :: !Text
      , createPullRequestBase  :: !Text
      }
    | CreatePullRequestIssue
      { createPullRequestIssueNum :: !Int
      , createPullRequestHead     :: !Text
      , createPullRequestBase     :: !Text
      }
  deriving (Show, Generic)

instance NFData CreatePullRequest where rnf = genericRnf
instance Binary CreatePullRequest

data PullRequestLinks = PullRequestLinks
    { pullRequestLinksReviewComments :: !URL
    , pullRequestLinksComments       :: !URL
    , pullRequestLinksHtml           :: !URL
    , pullRequestLinksSelf           :: !URL
    }
  deriving (Show, Data, Typeable, Eq, Ord, Generic)

instance NFData PullRequestLinks where rnf = genericRnf
instance Binary PullRequestLinks

data PullRequestCommit = PullRequestCommit
    { pullRequestCommitLabel :: !Text
    , pullRequestCommitRef   :: !Text
    , pullRequestCommitSha   :: !Text
    , pullRequestCommitUser  :: !SimpleUser
    , pullRequestCommitRepo  :: !Repo
    }
  deriving (Show, Data, Typeable, Eq, Ord, Generic)

instance NFData PullRequestCommit where rnf = genericRnf
instance Binary PullRequestCommit

data PullRequestEvent = PullRequestEvent
    { pullRequestEventAction      :: !PullRequestEventType
    , pullRequestEventNumber      :: !Int
    , pullRequestEventPullRequest :: !PullRequest
    , pullRequestRepository       :: !Repo
    , pullRequestSender           :: !SimpleUser
    }
    deriving (Show, Data, Typeable, Eq, Ord, Generic)

instance NFData PullRequestEvent where rnf = genericRnf
instance Binary PullRequestEvent

data PullRequestEventType
    = PullRequestOpened
    | PullRequestClosed
    | PullRequestSynchronized
    | PullRequestReopened
    | PullRequestAssigned
    | PullRequestUnassigned
    | PullRequestLabeled
    | PullRequestUnlabeled
    | PullRequestReviewRequested
    | PullRequestReviewRequestRemoved
    | PullRequestEdited
    deriving (Show, Data, Typeable, Eq, Ord, Generic)

instance NFData PullRequestEventType where rnf = genericRnf
instance Binary PullRequestEventType

data PullRequestReference = PullRequestReference
    { pullRequestReferenceHtmlUrl  :: !(Maybe URL)
    , pullRequestReferencePatchUrl :: !(Maybe URL)
    , pullRequestReferenceDiffUrl  :: !(Maybe URL)
    }
    deriving (Eq, Ord, Show, Generic, Typeable, Data)

instance NFData PullRequestReference where rnf = genericRnf
instance Binary PullRequestReference


-------------------------------------------------------------------------------
-- JSON instances
-------------------------------------------------------------------------------

-- | Helper function, reads either the "assignee" OR "assignees" OR
-- both from a JSON object.
getAssignees :: Object -> Parser (Vector SimpleUser)
getAssignees o = do
    assignees <- o .:? "assignees" .!= mempty
    maybeAssignee <- o .:? "assignee"
    pure $ case maybeAssignee of
        Nothing -> assignees
        Just assignee | assignee `V.elem` assignees -> assignees
                      | otherwise -> assignees `V.snoc` assignee

instance FromJSON SimplePullRequest where
    parseJSON = withObject "SimplePullRequest" $ \o -> do
      -- | Either key, or both, might be present, and might contain
      -- redundant information. Take both keys and uniquify the list.
      SimplePullRequest
        <$> o .:? "closed_at"
        <*> o .: "created_at"
        <*> o .: "user"
        <*> o .: "patch_url"
        <*> o .: "state"
        <*> o .: "number"
        <*> o .: "html_url"
        <*> o .: "updated_at"
        <*> o .:? "body"
        <*> getAssignees o
        <*> o .: "issue_url"
        <*> o .: "diff_url"
        <*> o .: "url"
        <*> o .: "_links"
        <*> o .:? "merged_at"
        <*> o .: "title"
        <*> o .: "id"

instance ToJSON EditPullRequest where
    toJSON (EditPullRequest t b s base mcm) =
        object $ filter notNull
            [ "title" .= t
            , "body"  .= b
            , "state" .= s
            , "base"  .= base
            , "maintainer_can_modify"
                      .= mcm
            ]
      where
        notNull (_, Null) = False
        notNull (_, _) = True

instance ToJSON CreatePullRequest where
    toJSON (CreatePullRequest t b headPR basePR) =
        object [ "title" .= t, "body" .= b, "head" .= headPR, "base" .= basePR ]
    toJSON (CreatePullRequestIssue issueNum headPR basePR) =
        object [ "issue" .= issueNum, "head" .= headPR, "base" .= basePR]

instance FromJSON PullRequest where
    parseJSON = withObject "PullRequest" $ \o -> PullRequest
        <$> o .:? "closed_at"
        <*> o .: "created_at"
        <*> o .: "user"
        <*> o .: "patch_url"
        <*> o .: "state"
        <*> o .: "number"
        <*> o .: "html_url"
        <*> o .: "updated_at"
        <*> o .:? "body"
        <*> getAssignees o
        <*> o .: "issue_url"
        <*> o .: "diff_url"
        <*> o .: "url"
        <*> o .: "_links"
        <*> o .:? "merged_at"
        <*> o .: "title"
        <*> o .: "id"
        <*> o .:? "merged_by"
        <*> o .: "changed_files"
        <*> o .: "head"
        <*> o .: "comments"
        <*> o .: "deletions"
        <*> o .: "additions"
        <*> o .: "base"
        <*> o .: "commits"
        <*> o .: "merged"
        <*> o .:? "mergeable"
        <*> o .: "mergeable_state"

instance FromJSON PullRequestLinks where
    parseJSON = withObject "PullRequestLinks" $ \o -> PullRequestLinks
        <$> fmap getHref (o .: "review_comments")
        <*> fmap getHref (o .: "comments")
        <*> fmap getHref (o .: "html")
        <*> fmap getHref (o .: "self")

instance FromJSON PullRequestCommit where
    parseJSON = withObject "PullRequestCommit" $ \o -> PullRequestCommit
        <$> o .: "label"
        <*> o .: "ref"
        <*> o .: "sha"
        <*> o .: "user"
        <*> o .: "repo"

instance FromJSON PullRequestEvent where
    parseJSON = withObject "PullRequestEvent" $ \o -> PullRequestEvent
        <$> o .: "action"
        <*> o .: "number"
        <*> o .: "pull_request"
        <*> o .: "repository"
        <*> o .: "sender"

instance FromJSON PullRequestEventType where
    parseJSON (String "opened") = pure PullRequestOpened
    parseJSON (String "closed") = pure PullRequestClosed
    parseJSON (String "synchronize") = pure PullRequestSynchronized
    parseJSON (String "reopened") = pure PullRequestReopened
    parseJSON (String "assigned") = pure PullRequestAssigned
    parseJSON (String "unassigned") = pure PullRequestUnassigned
    parseJSON (String "labeled") = pure PullRequestLabeled
    parseJSON (String "unlabeled") = pure PullRequestUnlabeled
    parseJSON (String "review_requested") = pure PullRequestReviewRequested
    parseJSON (String "review_request_removed") = pure PullRequestReviewRequestRemoved
    parseJSON (String "edited") = pure PullRequestEdited
    parseJSON (String s) = fail $ "Unknown action type " <> T.unpack s
    parseJSON v = typeMismatch "Could not build a PullRequestEventType" v

instance FromJSON PullRequestReference where
    parseJSON = withObject "PullRequestReference" $ \o -> PullRequestReference
        <$> o .:? "html_url"
        <*> o .:? "patch_url"
        <*> o .:? "diff_url"

-- Helpers

newtype Href a = Href { getHref :: a }

instance FromJSON a => FromJSON (Href a) where
    parseJSON = withObject "href object" $
        \obj -> Href <$> obj .: "href"

-- | Pull request merge results
data MergeResult
    = MergeSuccessful
    | MergeCannotPerform
    | MergeConflict
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)

statusMerge :: StatusMap MergeResult
statusMerge =
    [ (200, MergeSuccessful)
    , (405, MergeCannotPerform)
    , (409, MergeConflict)
    ]