Change.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}

module Gerrit.Data.Change (
    GerritQuery (..),
    GerritChangeStatus (..),
    GerritRevisionKind (..),
    GerritFile (..),
    GerritCommit (..),
    GerritRevision (..),
    GerritDetailedLabelVote (..),
    GerritDetailedLabel (..),
    GerritAuthor (..),
    GerritCommitAuthor (..),
    GerritChangeMessage (..),
    GerritChange (..),
    GerritTime (..),
    changeQS,
    queryText,
    defaultQueryChangeOptions,
    hasLabel,
)
where

import Data.Aeson
import Data.Aeson.Casing (aesonPrefix, snakeCase)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)
import GHC.Generics (Generic)

aesonOptions :: Options
aesonOptions = defaultOptions{fieldLabelModifier = recordToJson}
  where
    recordToJson "number" = "_number"
    recordToJson "account_id" = "_account_id"
    recordToJson "aAccountId" = "_account_id"
    recordToJson "aName" = "name"
    recordToJson "aEmail" = "email"
    recordToJson "aUsername" = "username"
    recordToJson "more_changes" = "_more_changes"
    recordToJson n = n

-- https://gerrit-review.googlesource.com/Documentation/user-search.html
data GerritQuery
    = Status GerritChangeStatus
    | Owner Text
    | CommitMessage Text
    | Project Text
    | ChangeId Text
    | After UTCTime
    deriving (Eq, Show)

-- | Convert a GerritQuery object to the search terms
queryText :: GerritQuery -> Text
queryText (Status stat) = "status:" <> T.toLower (T.pack $ show stat)
queryText (Owner owner') = "owner:" <> owner'
queryText (CommitMessage message) = "message:" <> message
queryText (Project project') = "project:" <> project'
queryText (ChangeId changeId) = "change:" <> changeId
queryText (After date') = "after:" <> T.pack formatedDate
  where
    formatedDate = formatTime defaultTimeLocale "%F" date'

defaultQueryChangeOptions :: Text
defaultQueryChangeOptions =
    "o="
        <> T.intercalate
            "&o="
            [ "MESSAGES"
            , "DETAILED_ACCOUNTS"
            , "DETAILED_LABELS"
            , "CURRENT_REVISION"
            , "CURRENT_FILES"
            , "CURRENT_COMMIT"
            ]

{- | Build the Query String for the changes endpoint
>>> changeQS 10 [Project "software-factory/gerrit-haskell"] Nothing
"q=project:software-factory/gerrit-haskell&n=10&o=MESSAGES&o=DETAILED_ACCOUNTS&o=DETAILED_LABELS&o=CURRENT_REVISION&o=CURRENT_FILES&o=CURRENT_COMMIT"
>>> changeQS 10 [Project "software-factory/gerrit-haskell"] $ Just 100
"q=project:software-factory/gerrit-haskell&n=10&o=MESSAGES&o=DETAILED_ACCOUNTS&o=DETAILED_LABELS&o=CURRENT_REVISION&o=CURRENT_FILES&o=CURRENT_COMMIT&start=100"
-}
changeQS :: Int -> [GerritQuery] -> Maybe Int -> Text
changeQS count queries startM =
    let base =
            T.intercalate
                "&"
                [ changeString
                , countString
                , defaultQueryChangeOptions
                ]
     in base <> startString
  where
    changeString = "q=" <> T.intercalate "+" (map queryText queries)
    countString = "n=" <> T.pack (show count)
    startString = maybe mempty (\s -> "&start=" <> T.pack (show s)) startM

-- | Check if a gerrit change as a label
hasLabel :: T.Text -> Int -> GerritChange -> Bool
hasLabel label labelValue change = case M.lookup label (labels change) of
    Just gerritLabel ->
        (> 0) $
            length $
                filter
                    (\vote -> fromMaybe 0 (value vote) == labelValue)
                    (fromMaybe [] (Gerrit.Data.Change.all gerritLabel))
    _ -> False

data GerritChangeStatus = NEW | MERGED | ABANDONED
    deriving (Eq, Show, Generic, FromJSON)

-- https://gerrit-review.googlesource.com/Documentation/json.html
data GerritRevisionKind = REWORK | TRIVIAL_REBASE | MERGE_FIRST_PARENT_UPDATE | NO_CODE_CHANGE | NO_CHANGE
    deriving (Eq, Show, Generic, FromJSON)

data GerritFile = GerritFile
    { gfStatus :: Maybe Text
    , gfLinesInserted :: Maybe Int
    , gfLinesDeleted :: Maybe Int
    , gfSizeDelta :: Maybe Int
    , gfSize :: Maybe Int
    }
    deriving (Eq, Show, Generic)

instance FromJSON GerritFile where
    parseJSON = genericParseJSON $ aesonPrefix snakeCase

data GerritCommit = GerritCommit
    { cAuthor :: GerritCommitAuthor
    , cCommitter :: GerritCommitAuthor
    , cSubject :: Text
    , cMessage :: Text
    }
    deriving (Eq, Show, Generic)

instance FromJSON GerritCommit where
    parseJSON = genericParseJSON $ aesonPrefix snakeCase

data GerritRevision = GerritRevision
    { grRef :: Text
    , grKind :: GerritRevisionKind
    , grFiles :: M.Map Text GerritFile
    , grCommit :: GerritCommit
    , grUploader :: GerritAuthor
    }
    deriving (Eq, Show, Generic)

instance FromJSON GerritRevision where
    parseJSON = genericParseJSON $ aesonPrefix snakeCase

data GerritDetailedLabelVote = GerritDetailedLabelVote
    { value :: Maybe Int
    , account_id :: Int
    }
    deriving (Eq, Show, Generic)

instance FromJSON GerritDetailedLabelVote where
    parseJSON = genericParseJSON aesonOptions

data GerritDetailedLabel = GerritDetailedLabel
    { all :: Maybe [GerritDetailedLabelVote]
    , default_value :: Int
    }
    deriving (Eq, Show, Generic, FromJSON)

data GerritAuthor = GerritAuthor
    { aAccountId :: Int
    , aName :: Maybe Text
    , aEmail :: Maybe Text
    , aUsername :: Maybe Text
    }
    deriving (Eq, Show, Generic)

instance FromJSON GerritAuthor where
    parseJSON = genericParseJSON aesonOptions

data GerritCommitAuthor = GerritCommitAuthor
    { caName :: Text
    , caEmail :: Maybe Text
    , caDate :: GerritTime
    }
    deriving (Eq, Show, Generic)

instance FromJSON GerritCommitAuthor where
    parseJSON = genericParseJSON $ aesonPrefix snakeCase

newtype GerritTime = GerritTime {unGerritTime :: UTCTime}
    deriving (Eq, Show)

instance FromJSON GerritTime where
    parseJSON = withText "UTCTimePlus" (parse . T.unpack)
      where
        format = "%F %T.000000000"
        tryParse = parseTimeM False defaultTimeLocale
        parse s = GerritTime <$> tryParse format s

data GerritChangeMessage = GerritChangeMessage
    { mId :: Text
    , mAuthor :: Maybe GerritAuthor
    , mDate :: GerritTime
    , mMessage :: Text
    }
    deriving (Eq, Show, Generic)

instance FromJSON GerritChangeMessage where
    parseJSON = genericParseJSON $ aesonPrefix snakeCase

data GerritChange = GerritChange
    { id :: Text
    , project :: Text
    , branch :: Text
    , hashtags :: [Text]
    , subject :: Text
    , status :: GerritChangeStatus
    , mergeable :: Maybe Bool
    , revisions :: M.Map Text (Maybe GerritRevision)
    , current_revision :: Maybe Text
    , number :: Int
    , labels :: M.Map Text GerritDetailedLabel
    , messages :: [GerritChangeMessage]
    , owner :: GerritAuthor
    , created :: GerritTime
    , updated :: GerritTime
    , submitted :: Maybe GerritTime
    , submitter :: Maybe GerritAuthor
    , topic :: Maybe Text
    , insertions :: Int
    , deletions :: Int
    , more_changes :: Maybe Bool
    , work_in_progress :: Maybe Bool
    }
    deriving (Eq, Show, Generic)

instance FromJSON GerritChange where
    parseJSON = genericParseJSON aesonOptions