diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,10 +24,9 @@ Run all GitLab actions with `runGitLab`: runGitLab :: - (MonadUnliftIO m, MonadIO m) => GitLabServerConfig - -> GitLab m a - -> m a + -> GitLab a + -> IO a For example: @@ -40,8 +39,26 @@ Which uses the functions: - searchUser :: Text -> GitLab m (Maybe User) - userProjects :: User -> GitLab m (Maybe [Project]) + searchUser :: Text -> GitLab (Maybe User) + userProjects :: User -> GitLab (Maybe [Project]) + projectCommits :: Project -> GitLab [Commit] + +This library can also be used to implement rule based GitLab file +system hooks that, when deployed a GitLab server, react in real time +to GitLab events like project creation, new users, merge requests etc. + +The rule based API for implementing file hooks is: + + receive :: [Rule] -> GitLab () + + class (FromJSON a) => SystemHook a where + match :: String -> (a -> GitLab ()) -> Rule + matchIf :: String -> (a -> GitLab Bool) -> (a -> GitLab ()) -> Rule + +For more details about the file system hooks support, see post: +[GitLab automation with file hook rules](https://www.macs.hw.ac.uk/~rs46/posts/2020-06-06-gitlab-system-hooks.html). + +For the complete `gitlab-haskell` API, see the [hackage documentation](https://hackage.haskell.org/package/gitlab-haskell). The `gitlab-tools` command line tool for bulk GitLab transactions uses this library [link](https://gitlab.com/robstewart57/gitlab-tools). diff --git a/data/system-hooks/merge-request.json b/data/system-hooks/merge-request.json --- a/data/system-hooks/merge-request.json +++ b/data/system-hooks/merge-request.json @@ -1,114 +1,125 @@ -{ - "object_kind": "merge_request", - "user": { - "name": "Administrator", - "username": "root", - "avatar_url": "http://www.gravatar.com/avatar/e64c7d89f26bd1972efa854d13d7dd61?s=80&d=identicon" - }, - "project": { - "name": "Example", - "description": "", - "web_url": "http://example.com/jsmith/example", - "avatar_url": null, - "git_ssh_url": "git@example.com:jsmith/example.git", - "git_http_url": "http://example.com/jsmith/example.git", - "namespace": "Jsmith", - "visibility_level": 0, - "path_with_namespace": "jsmith/example", - "default_branch": "master", - "ci_config_path": "", - "homepage": "http://example.com/jsmith/example", - "url": "git@example.com:jsmith/example.git", - "ssh_url": "git@example.com:jsmith/example.git", - "http_url": "http://example.com/jsmith/example.git" - }, - "object_attributes": { - "id": 90, - "target_branch": "master", - "source_branch": "ms-viewport", - "source_project_id": 14, - "author_id": 51, - "assignee_id": 6, - "title": "MS-Viewport", - "created_at": "2017-09-20T08:31:45.944Z", - "updated_at": "2017-09-28T12:23:42.365Z", - "milestone_id": null, - "state": "opened", - "merge_status": "unchecked", - "target_project_id": 14, - "iid": 1, - "description": "", - "updated_by_id": 1, - "merge_error": null, - "merge_params": { - "force_remove_source_branch": "0" - }, - "merge_when_pipeline_succeeds": false, - "merge_user_id": null, - "merge_commit_sha": null, - "deleted_at": null, - "in_progress_merge_commit_sha": null, - "lock_version": 5, - "time_estimate": 0, - "last_edited_at": "2017-09-27T12:43:37.558Z", - "last_edited_by_id": 1, - "head_pipeline_id": 61, - "ref_fetched": true, - "merge_jid": null, - "source": { - "name": "Awesome Project", - "description": "", - "web_url": "http://example.com/awesome_space/awesome_project", - "avatar_url": null, - "git_ssh_url": "git@example.com:awesome_space/awesome_project.git", - "git_http_url": "http://example.com/awesome_space/awesome_project.git", - "namespace": "root", - "visibility_level": 0, - "path_with_namespace": "awesome_space/awesome_project", - "default_branch": "master", - "ci_config_path": "", - "homepage": "http://example.com/awesome_space/awesome_project", - "url": "http://example.com/awesome_space/awesome_project.git", - "ssh_url": "git@example.com:awesome_space/awesome_project.git", - "http_url": "http://example.com/awesome_space/awesome_project.git" - }, - "target": { - "name": "Awesome Project", - "description": "Aut reprehenderit ut est.", - "web_url": "http://example.com/awesome_space/awesome_project", - "avatar_url": null, - "git_ssh_url": "git@example.com:awesome_space/awesome_project.git", - "git_http_url": "http://example.com/awesome_space/awesome_project.git", - "namespace": "Awesome Space", - "visibility_level": 0, - "path_with_namespace": "awesome_space/awesome_project", - "default_branch": "master", - "ci_config_path": "", - "homepage": "http://example.com/awesome_space/awesome_project", - "url": "http://example.com/awesome_space/awesome_project.git", - "ssh_url": "git@example.com:awesome_space/awesome_project.git", - "http_url": "http://example.com/awesome_space/awesome_project.git" - }, - "last_commit": { - "id": "ba3e0d8ff79c80d5b0bbb4f3e2e343e0aaa662b7", - "message": "fixed readme", - "timestamp": "2017-09-26T16:12:57Z", - "url": "http://example.com/awesome_space/awesome_project/commits/da1560886d4f094c3e6c9ef40349f7d38b5d27d7", - "author": { - "name": "GitLab dev user", - "email": "gitlabdev@dv6700.(none)" - } - }, - "work_in_progress": false, - "total_time_spent": 0, - "human_total_time_spent": null, - "human_time_estimate": null - }, - "labels": null, - "repository": { - "name": "git-gpg-test", - "url": "git@example.com:awesome_space/awesome_project.git", - "description": "", - "homepage": "http://example.com/awesome_space/awesome_project" - } +{"object_kind":"merge_request", + "event_type":"merge_request", + "user": + {"name":"Rob", "username":"abc123", + "avatar_url":"", + "email":"" + }, + "project": {"id":8879, + "name":"", + "description":"", + "web_url":"", + "avatar_url":null,"git_ssh_url":"", + "git_http_url":"", + "namespace":"", + "visibility_level":0,"path_with_namespace":"", + "default_branch":"master", "ci_config_path":null, + "homepage":"", + "url":"", + "ssh_url":"", + "http_url":"" + }, + "object_attributes":{"assignee_id":null, + "author_id":5, + "created_at":"2020-12-21 22:56:31 UTC", + "description":"", + "head_pipeline_id":null, + "id":1567, + "iid":7, + "last_edited_at":null, + "last_edited_by_id":null, + "merge_commit_sha":null, + "merge_error":null, + "merge_params":{}, + "merge_status":"unchecked", + "merge_user_id":null, + "merge_when_pipeline_succeeds":false, + "milestone_id":null, + "source_branch":"master", + "source_project_id":8987, + "state_id":1, + "target_branch":"master", + "target_project_id":8879, + "time_estimate":0, + "title":"Master", + "updated_at":"2020-12-21 22:56:31 UTC", + "updated_by_id":null, + "url":"", + "source":{"id":8987, "name":"", + "description":"", + "web_url":"", + "avatar_url":null, + "git_ssh_url":"", + "git_http_url":"", + "namespace":"Rob", "visibility_level":0, + "path_with_namespace":"", + "default_branch":"master", "ci_config_path":null, + "homepage":"", + "url":"", + "ssh_url":"", + "http_url":"" + }, + "target":{"id":8879, "name":"", + "description":"", + "web_url":"", + "avatar_url":null, + "git_ssh_url":"", + "git_http_url":"", + "namespace":"", "visibility_level":0, + "path_with_namespace":"", + "default_branch":"master", "ci_config_path":null, + "homepage":"", + "url":"", + "ssh_url":"", + "http_url":"" + }, + "last_commit":{"id":"", + "message":"", + "title":"", + "timestamp":"2020-09-28T16:13:42+01:00", + "url":"", + "author":{ + "name":"Rob", + "email":"" + } + }, + "work_in_progress":false, + "total_time_spent":0, + "human_total_time_spent":null, + "human_time_estimate":null, + "assignee_ids":[], + "state":"opened", + "action":"open" + }, + "labels":[], + "changes":{"author_id": + {"previous":null, + "current":5 + }, + "created_at": + {"previous":null, + "current":"2020-12-21 22:56:31 UTC" + }, + "description": + {"previous":null, + "current":"" + }, + "id": + {"previous":null, + "current":1567 + }, + "iid":{"previous":null, "current":7}, + "source_branch":{"previous":null, "current":"master"}, + "source_project_id":{"previous":null, "current":8987}, + "target_branch":{"previous":null, "current":"master"}, + "target_project_id":{"previous":null, "current":8879}, + "title":{"previous":null, "current":"Master"}, + "updated_at":{"previous":null, "current":"2020-12-21 22:56:31 UTC"} + }, + "repository": { "name":"", + "url":"", + "description":"", + "homepage":"" + } + } 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.3 +version: 0.2.4 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: @@ -10,10 +10,10 @@ . Run all GitLab actions with `runGitLab`: . - > runGitLab :: (MonadUnliftIO m, MonadIO m) + > runGitLab :: > => GitLabServerConfig -- ^ the GitLab server details - > -> GitLab m a -- ^ the GitLab action - > -> m a + > -> GitLab a -- ^ the GitLab action + > -> IO a . For example: . @@ -25,8 +25,9 @@ . Which uses the functions: . - > searchUser :: Text -> GitLab m (Maybe User) - > userProjects :: User -> GitLab m (Maybe [Project]) + > searchUser :: Text -> GitLab (Maybe User) + > userProjects :: User -> GitLab (Maybe [Project]) + > projectCommits :: Project -> GitLab [Commit] . This library can also be used to develop rule based GitLab file hooks that react in real time to GitLab events with: . @@ -75,6 +76,7 @@ , GitLab.API.RepositoryFiles , GitLab.API.Todos , GitLab.API.Version + , GitLab.API.Notes , GitLab.SystemHooks.Types , GitLab.SystemHooks.GitLabSystemHooks , GitLab.SystemHooks.Rules @@ -94,6 +96,8 @@ , unliftio , unliftio-core , time + , temporary + , unix default-language: Haskell2010 ghc-options: -Wall -- the following two for the stan static analysis tool diff --git a/src/GitLab.hs b/src/GitLab.hs --- a/src/GitLab.hs +++ b/src/GitLab.hs @@ -26,6 +26,7 @@ module GitLab.API.RepositoryFiles, module GitLab.API.Todos, module GitLab.API.Version, + module GitLab.API.Notes, module GitLab.SystemHooks.GitLabSystemHooks, module GitLab.SystemHooks.Types, module GitLab.SystemHooks.Rules, @@ -41,6 +42,7 @@ import GitLab.API.Jobs import GitLab.API.Members import GitLab.API.MergeRequests +import GitLab.API.Notes import GitLab.API.Pipelines import GitLab.API.Projects import GitLab.API.Repositories 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 @@ -49,7 +49,7 @@ Text -> -- | level of access granted AccessLevel -> - GitLab [Either Status Member] + GitLab [Either Status (Maybe Member)] addAllUsersToGroup groupName access = do allRegisteredUsers <- allUsers let allUserIds = map user_username allRegisteredUsers @@ -63,7 +63,7 @@ AccessLevel -> -- | the user User -> - GitLab (Either Status Member) + GitLab (Either Status (Maybe Member)) addUserToGroup groupName access usr = addUserToGroup' groupName access (user_id usr) @@ -75,7 +75,7 @@ AccessLevel -> -- | user ID Int -> - GitLab (Either Status Member) + GitLab (Either Status (Maybe Member)) addUserToGroup' groupName access userId = do attempt <- groupsWithNameOrPath groupName case attempt of @@ -103,7 +103,7 @@ AccessLevel -> -- | list of usernames to be added to the group [User] -> - GitLab [Either Status Member] + GitLab [Either Status (Maybe Member)] addUsersToGroup groupName access = mapM (addUserToGroup groupName access) @@ -115,7 +115,7 @@ AccessLevel -> -- | list of usernames to be added to the group [Text] -> - GitLab [Either Status Member] + GitLab [Either Status (Maybe Member)] addUsersToGroup' groupName access usernames = do users <- catMaybes <$> mapM searchUser usernames mapM (addUserToGroup' groupName access . user_id) users 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 @@ -63,7 +63,7 @@ Text -> -- | issue description Text -> - GitLab (Either Status Issue) + GitLab (Either Status (Maybe Issue)) newIssue project = newIssue' (project_id project) @@ -75,7 +75,7 @@ Text -> -- | issue description Text -> - GitLab (Either Status Issue) + GitLab (Either Status (Maybe Issue)) newIssue' projectId issueTitle issueDescription = gitlabPost addr dataBody where diff --git a/src/GitLab/API/Members.hs b/src/GitLab/API/Members.hs --- a/src/GitLab/API/Members.hs +++ b/src/GitLab/API/Members.hs @@ -56,7 +56,7 @@ AccessLevel -> -- | the user User -> - GitLab (Either Status Member) + GitLab (Either Status (Maybe Member)) addMemberToProject project access usr = addMemberToProject' (project_id project) access (user_id usr) @@ -70,7 +70,7 @@ AccessLevel -> -- | user ID Int -> - GitLab (Either Status Member) + GitLab (Either Status (Maybe Member)) addMemberToProject' projectId access userId = gitlabPost addr dataBody where @@ -90,7 +90,7 @@ AccessLevel -> -- | users to add to the project [User] -> - GitLab [Either Status Member] + GitLab [Either Status (Maybe Member)] addMembersToProject project access = mapM (addMemberToProject project access) @@ -104,6 +104,6 @@ AccessLevel -> -- | IDs of users to add to the project [Int] -> - GitLab [Either Status Member] + GitLab [Either Status (Maybe Member)] addMembersToProject' projectId access = mapM (addMemberToProject' projectId access) diff --git a/src/GitLab/API/MergeRequests.hs b/src/GitLab/API/MergeRequests.hs --- a/src/GitLab/API/MergeRequests.hs +++ b/src/GitLab/API/MergeRequests.hs @@ -52,7 +52,7 @@ Text -> -- | merge request description Text -> - GitLab (Either Status MergeRequest) + GitLab (Either Status (Maybe MergeRequest)) createMergeRequest project = createMergeRequest' (project_id project) @@ -70,7 +70,7 @@ Text -> -- | merge request description Text -> - GitLab (Either Status MergeRequest) + GitLab (Either Status (Maybe MergeRequest)) createMergeRequest' projectId sourceBranch targetBranch targetProjectId mrTitle mrDescription = gitlabPost addr dataBody where @@ -91,7 +91,7 @@ Project -> -- | merge request IID Int -> - GitLab (Either Status MergeRequest) + GitLab (Either Status (Maybe MergeRequest)) acceptMergeRequest project = acceptMergeRequest' (project_id project) @@ -101,7 +101,7 @@ Int -> -- | merge request IID Int -> - GitLab (Either Status MergeRequest) + GitLab (Either Status (Maybe MergeRequest)) acceptMergeRequest' projectId mergeRequestIid = gitlabPost addr dataBody where dataBody :: Text @@ -113,3 +113,27 @@ "/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 Status ()) +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 Status ()) +deleteMergeRequest' projectId mergeRequestIid = gitlabDelete addr + where + addr = + T.pack $ + "/projects/" <> show projectId <> "/merge_requests/" + <> show mergeRequestIid diff --git a/src/GitLab/API/Notes.hs b/src/GitLab/API/Notes.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Notes.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Notes +-- Description : Notes on issues, snippets, merge requests and epics. +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2020 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable +module GitLab.API.Notes where + +import Data.Text (Text) +import qualified Data.Text as T +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status + +createMergeRequestNote :: + -- | project + Project -> + -- | merge request IID + Int -> + -- | the note + Text -> + GitLab (Either Status (Maybe ())) +createMergeRequestNote project = + createMergeRequestNote' (project_id project) + +createMergeRequestNote' :: + -- | project ID + Int -> + -- | merge request IID + Int -> + -- | the note + Text -> + GitLab (Either Status (Maybe ())) +createMergeRequestNote' projectId mergeRequestIID comment = + gitlabPost addr dataBody + where + dataBody :: Text + dataBody = + T.pack $ + "id=" + <> show projectId + <> "&merge_request_iid=" + <> show mergeRequestIID + <> "&body=" + <> T.unpack comment + addr = + T.pack $ + "/projects/" <> show projectId <> "/merge_requests/" + <> show mergeRequestIID + <> "/notes" 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 @@ -226,16 +226,16 @@ <> "/diff/" ) --- | share a project with a group. -shareProjectWithGroup :: +-- | add a group to a project. +addGroupToProject :: -- | group ID Int -> -- | project ID Int -> -- | level of access granted AccessLevel -> - GitLab (Either Status GroupShare) -shareProjectWithGroup groupId projectId access = + GitLab (Either Status (Maybe GroupShare)) +addGroupToProject groupId projectId access = gitlabPost addr dataBody where dataBody :: Text diff --git a/src/GitLab/API/Users.hs b/src/GitLab/API/Users.hs --- a/src/GitLab/API/Users.hs +++ b/src/GitLab/API/Users.hs @@ -13,6 +13,7 @@ import Data.List import Data.Maybe import Data.Text (Text) +import qualified Data.Text as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls @@ -21,6 +22,22 @@ allUsers = do let path = "/users" gitlabUnsafe path + +-- | searches for a user given a user ID. Returns @Just User@ if the +-- user is found, otherwise @Nothing@. +userId :: + -- | username to search for + Int -> + GitLab (Maybe User) +userId usrId = do + let path = + "/users/" + <> T.pack (show usrId) + res <- gitlabOne path + case res of + Left _err -> return Nothing + Right Nothing -> return Nothing + Right (Just user) -> return (Just user) -- | searches for a user given a username. Returns @Just User@ if the -- user is found, otherwise @Nothing@. diff --git a/src/GitLab/SystemHooks/GitLabSystemHooks.hs b/src/GitLab/SystemHooks/GitLabSystemHooks.hs --- a/src/GitLab/SystemHooks/GitLabSystemHooks.hs +++ b/src/GitLab/SystemHooks/GitLabSystemHooks.hs @@ -17,11 +17,15 @@ ) where +import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans.Reader import Data.Typeable import GitLab.SystemHooks.Types import GitLab.Types +import System.IO.Temp +import System.Posix.Files -- | Attempts to fire each rule in sequence. Reads the JSON data -- received from the GitLab server from standard input. @@ -34,7 +38,20 @@ -- received from a function argument. receiveString :: String -> [Rule] -> GitLab () receiveString eventContent rules = do + traceSystemHook eventContent mapM_ (fire eventContent) rules + +traceSystemHook :: String -> GitLab () +traceSystemHook eventContent = do + cfg <- serverCfg <$> ask + liftIO $ + E.catch + ( when (debugSystemHooks cfg) $ do + fpath <- writeSystemTempFile "gitlab-system-hook-" eventContent + void $ setFileMode fpath otherReadMode + ) + -- runGitLabDbg must have been used, which doesn't define a GitLabServerConfig + (\(_exception :: E.ErrorCall) -> return ()) orElse :: GitLab Bool -> GitLab Bool -> GitLab Bool orElse f g = do diff --git a/src/GitLab/SystemHooks/Types.hs b/src/GitLab/SystemHooks/Types.hs --- a/src/GitLab/SystemHooks/Types.hs +++ b/src/GitLab/SystemHooks/Types.hs @@ -46,6 +46,8 @@ CommitAuthorEvent (..), Visibility (..), MergeRequestEvent (..), + MergeRequestChanges (..), + MergeRequestChange (..), ObjectAttributes (..), MergeParams (..), UserEvent (..), @@ -582,26 +584,51 @@ -- in GitLab.Types. data MergeRequestEvent = MergeRequestEvent { mergeRequest_object_kind :: Text, + mergeRequest_event_type :: Text, mergeRequest_user :: UserEvent, mergeRequest_project :: ProjectEvent, mergeRequest_object_attributes :: ObjectAttributes, - mergeRequest_labels :: Maybe Text, + mergeRequest_labels :: Maybe [Text], + mergeRequest_changes :: MergeRequestChanges, mergeRequest_repository :: RepositoryEvent } deriving (Typeable, Show, Eq, Generic) +data MergeRequestChanges = MergeRequestChanges + { mergeRequestChanges_author_id :: MergeRequestChange Int, + mergeRequestChanges_created_at :: MergeRequestChange Text, + mergeRequestChanges_description :: MergeRequestChange Text, + mergeRequestChanges_id :: MergeRequestChange Int, + mergeRequestChanges_iid :: MergeRequestChange Int, + mergeRequestChanges_source_branch :: MergeRequestChange Text, + mergeRequestChanges_source_project_id :: MergeRequestChange Int, + mergeRequestChanges_target_branch :: MergeRequestChange Text, + mergeRequestChanges_target_project_id :: MergeRequestChange Int, + mergeRequestChanges_title :: MergeRequestChange Text, + mergeRequestChanges_updated_at :: MergeRequestChange Text + } + deriving (Typeable, Show, Eq, Generic) + +data MergeRequestChange a = MergeRequestChange + { mergeRequestChange_previous :: Maybe a, + mergeRequestChange_current :: Maybe a + } + deriving (Typeable, Show, Eq, Generic) + data ObjectAttributes = ObjectAttributes { objectAttributes_id :: Int, objectAttributes_target_branch :: Text, objectAttributes_source_branch :: Text, objectAttributes_source_project_id :: Int, objectAttributes_author_id :: Int, - objectAttributes_assignee_id :: Int, + objectAttributes_assignee_id :: Maybe Int, + objectAttributes_assignee_ids :: Maybe [Int], objectAttributes_title :: Text, objectAttributes_created_at :: Text, objectAttributes_updated_at :: Text, objectAttributes_milestone_id :: Maybe Int, objectAttributes_state :: Text, + objectAttributes_state_id :: Maybe Int, objectAttributes_merge_status :: Text, objectAttributes_target_project_id :: Int, objectAttributes_iid :: Int, @@ -616,10 +643,10 @@ objectAttributes_in_progress_merge_commit_sha :: Maybe Text, objectAttributes_lock_version :: Maybe Int, objectAttributes_time_estimate :: Int, - objectAttributes_last_edited_at :: Text, - objectAttributes_last_edited_by_id :: Int, - objectAttributes_head_pipeline_id :: Int, - objectAttributes_ref_fetched :: Bool, + objectAttributes_last_edited_at :: Maybe Text, + objectAttributes_last_edited_by_id :: Maybe Int, + objectAttributes_head_pipeline_id :: Maybe Int, + objectAttributes_ref_fetched :: Maybe Bool, objectAttributes_merge_jid :: Maybe Int, objectAttributes_source :: ProjectEvent, objectAttributes_target :: ProjectEvent, @@ -627,12 +654,13 @@ objectAttributes_work_in_progress :: Bool, objectAttributes_total_time_spent :: Int, objectAttributes_human_total_time_spent :: Maybe Int, - objectAttributes_human_time_estimate :: Maybe Int + objectAttributes_human_time_estimate :: Maybe Int, + objectAttributes_action :: Maybe Text } deriving (Typeable, Show, Eq, Generic) data MergeParams = MergeParams - { mergeParams_force_remove_source_branch :: Text + { mergeParams_force_remove_source_branch :: Maybe Text } deriving (Typeable, Show, Eq, Generic) @@ -1185,7 +1213,11 @@ instance FromJSON MergeRequestEvent where parseJSON = withObject "MergeRequestEvent" $ \v -> do - -- Note: it's `event_name` in all other examples. + -- Note: it's `event_name` in all other examples, but the GitLab + -- documentation for MergeRequests says `object_kind`. + -- + -- `object_kind` has been tried. + -- -- Bug in GitLab system hooks documentation? isProjectEvent <- v .:? "object_kind" case isProjectEvent of @@ -1194,10 +1226,12 @@ MergeRequested -> MergeRequestEvent <$> v .: "object_kind" + <*> v .: "event_type" <*> v .: "user" <*> v .: "project" <*> v .: "object_attributes" <*> v .: "labels" + <*> v .: "changes" <*> v .: "repository" _unexpected -> fail "merge_request parsing failed" _unexpected -> fail "merge_request parsing failed" @@ -1245,11 +1279,13 @@ bodyNoPrefix "objectAttributes_source_project_id" = "source_project_id" bodyNoPrefix "objectAttributes_author_id" = "author_id" bodyNoPrefix "objectAttributes_assignee_id" = "assignee_id" +bodyNoPrefix "objectAttributes_assignee_ids" = "assignee_ids" bodyNoPrefix "objectAttributes_title" = "title" bodyNoPrefix "objectAttributes_created_at" = "created_at" bodyNoPrefix "objectAttributes_updated_at" = "updated_at" bodyNoPrefix "objectAttributes_milestone_id" = "milestone_id" bodyNoPrefix "objectAttributes_state" = "state" +bodyNoPrefix "objectAttributes_state_id" = "state_id" bodyNoPrefix "objectAttributes_merge_status" = "merge_status" bodyNoPrefix "objectAttributes_target_project_id" = "target_project_id" bodyNoPrefix "objectAttributes_iid" = "iid" @@ -1276,6 +1312,20 @@ bodyNoPrefix "objectAttributes_total_time_spent" = "total_time_spent" bodyNoPrefix "objectAttributes_human_total_time_spent" = "human_total_time_spent" bodyNoPrefix "objectAttributes_human_time_estimate" = "human_time_estimate" +bodyNoPrefix "objectAttributes_action" = "action" +bodyNoPrefix "mergeRequestChanges_author_id" = "author_id" +bodyNoPrefix "mergeRequestChanges_created_at" = "created_at" +bodyNoPrefix "mergeRequestChanges_description" = "description" +bodyNoPrefix "mergeRequestChanges_id" = "id" +bodyNoPrefix "mergeRequestChanges_iid" = "iid" +bodyNoPrefix "mergeRequestChanges_source_branch" = "source_branch" +bodyNoPrefix "mergeRequestChanges_source_project_id" = "source_project_id" +bodyNoPrefix "mergeRequestChanges_target_branch" = "target_branch" +bodyNoPrefix "mergeRequestChanges_target_project_id" = "target_project_id" +bodyNoPrefix "mergeRequestChanges_title" = "title" +bodyNoPrefix "mergeRequestChanges_updated_at" = "updated_at" +bodyNoPrefix "mergeRequestChange_previous" = "previous" +bodyNoPrefix "mergeRequestChange_current" = "current" bodyNoPrefix s = error ("uexpected JSON field prefix: " <> s) instance FromJSON ProjectEvent where @@ -1335,6 +1385,22 @@ ) instance FromJSON UserEvent where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON MergeRequestChanges where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance (FromJSON a) => FromJSON (MergeRequestChange a) where parseJSON = genericParseJSON ( defaultOptions diff --git a/src/GitLab/Types.hs b/src/GitLab/Types.hs --- a/src/GitLab/Types.hs +++ b/src/GitLab/Types.hs @@ -81,7 +81,10 @@ -- | milliseconds timeout :: Int, -- | how many times to retry a HTTP request before giving up and returning an error. - retries :: Int + retries :: Int, + -- | write system hook events to files in the system temporary + -- directory. + debugSystemHooks :: Bool } -- | default settings, the 'url' and 'token' values will need to be overwritten. @@ -91,7 +94,8 @@ { url = "https://gitlab.com", token = "", timeout = 15000000, -- 15 seconds - retries = 5 + retries = 5, + debugSystemHooks = False } -- https://docs.gitlab.com/ee/api/repositories.html#get-file-archive @@ -154,7 +158,7 @@ -- | links. data Links = Links { self :: Text, - issues :: Text, + issues :: Maybe Text, merge_requests :: Text, repo_branches :: Text, link_labels :: Text, 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 @@ -14,6 +14,7 @@ -- gitlabWithAttrsOneUnsafe, gitlabPost, gitlabPut, + gitlabDelete, gitlabReqText, gitlabReqByteString, ) @@ -23,6 +24,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader import Data.Aeson +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.ByteString.Lazy.Char8 as C import Data.Either @@ -49,7 +51,7 @@ Text -> -- | the data to post Text -> - GitLab (Either Status b) + GitLab (Either Status (Maybe b)) gitlabPost urlPath dataBody = do cfg <- serverCfg <$> ask manager <- httpManager <$> ask @@ -67,10 +69,11 @@ then return ( case parseBSOne (responseBody resp) of - Just x -> Right x - Nothing -> - Left $ - mkStatus 409 "unable to parse POST response" + Just x -> Right (Just x) + Nothing -> Right Nothing + -- Nothing -> + -- Left $ + -- mkStatus 409 "unable to parse POST response" ) else return (Left (responseStatus resp)) @@ -105,6 +108,29 @@ Left $ mkStatus 409 "unable to parse PUT response" ) + else return (Left (responseStatus resp)) + +gitlabDelete :: + -- | the URL to post to + Text -> + GitLab (Either Status ()) +gitlabDelete urlPath = do + cfg <- serverCfg <$> ask + manager <- httpManager <$> ask + let url' = url cfg <> "/api/v4" <> urlPath + let request' = parseRequest_ (T.unpack url') + request = + request' + { method = "DELETE", + requestHeaders = + [ ("PRIVATE-TOKEN", T.encodeUtf8 (token cfg)), + ("content-type", "application/json") + ], + requestBody = RequestBodyBS BS.empty + } + resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing + if successStatus (responseStatus resp) + then return (Right ()) else return (Left (responseStatus resp)) tryGitLab :: diff --git a/tests/SystemHookTests.hs b/tests/SystemHookTests.hs --- a/tests/SystemHookTests.hs +++ b/tests/SystemHookTests.hs @@ -1108,7 +1108,7 @@ matchIf "mergeRequest rule-if yes" ( \event@MergeRequestEvent {} -> do - return (userEvent_name (mergeRequest_user event) == "Administrator") + return (userEvent_name (mergeRequest_user event) == "Rob") ) ( \MergeRequestEvent {} -> do return () @@ -1473,9 +1473,11 @@ mergeRequestHaskell = MergeRequestEvent { mergeRequest_object_kind = "merge_request", - mergeRequest_user = UserEvent {userEvent_name = "Administrator", userEvent_username = "root", userEvent_avatar_url = "http://www.gravatar.com/avatar/e64c7d89f26bd1972efa854d13d7dd61?s=80&d=identicon"}, - mergeRequest_project = ProjectEvent {projectEvent_name = "Example", projectEvent_description = "", projectEvent_web_url = "http://example.com/jsmith/example", projectEvent_avatar_url = Nothing, projectEvent_git_ssh_url = "git@example.com:jsmith/example.git", projectEvent_git_http_url = "http://example.com/jsmith/example.git", projectEvent_namespace = "Jsmith", projectEvent_visibility_level = Private, projectEvent_path_with_namespace = "jsmith/example", projectEvent_default_branch = "master", projectEvent_homepage = Just "http://example.com/jsmith/example", projectEvent_url = "git@example.com:jsmith/example.git", projectEvent_ssh_url = "git@example.com:jsmith/example.git", projectEvent_http_url = "http://example.com/jsmith/example.git"}, - mergeRequest_object_attributes = ObjectAttributes {objectAttributes_id = 90, objectAttributes_target_branch = "master", objectAttributes_source_branch = "ms-viewport", objectAttributes_source_project_id = 14, objectAttributes_author_id = 51, objectAttributes_assignee_id = 6, objectAttributes_title = "MS-Viewport", objectAttributes_created_at = "2017-09-20T08:31:45.944Z", objectAttributes_updated_at = "2017-09-28T12:23:42.365Z", objectAttributes_milestone_id = Nothing, objectAttributes_state = "opened", objectAttributes_merge_status = "unchecked", objectAttributes_target_project_id = 14, objectAttributes_iid = 1, objectAttributes_description = "", objectAttributes_updated_by_id = Just 1, objectAttributes_merge_error = Nothing, objectAttributes_merge_params = MergeParams {mergeParams_force_remove_source_branch = "0"}, objectAttributes_merge_when_pipeline_succeeds = False, objectAttributes_merge_user_id = Nothing, objectAttributes_merge_commit_sha = Nothing, objectAttributes_deleted_at = Nothing, objectAttributes_in_progress_merge_commit_sha = Nothing, objectAttributes_lock_version = Just 5, objectAttributes_time_estimate = 0, objectAttributes_last_edited_at = "2017-09-27T12:43:37.558Z", objectAttributes_last_edited_by_id = 1, objectAttributes_head_pipeline_id = 61, objectAttributes_ref_fetched = True, objectAttributes_merge_jid = Nothing, objectAttributes_source = ProjectEvent {projectEvent_name = "Awesome Project", projectEvent_description = "", projectEvent_web_url = "http://example.com/awesome_space/awesome_project", projectEvent_avatar_url = Nothing, projectEvent_git_ssh_url = "git@example.com:awesome_space/awesome_project.git", projectEvent_git_http_url = "http://example.com/awesome_space/awesome_project.git", projectEvent_namespace = "root", projectEvent_visibility_level = Private, projectEvent_path_with_namespace = "awesome_space/awesome_project", projectEvent_default_branch = "master", projectEvent_homepage = Just "http://example.com/awesome_space/awesome_project", projectEvent_url = "http://example.com/awesome_space/awesome_project.git", projectEvent_ssh_url = "git@example.com:awesome_space/awesome_project.git", projectEvent_http_url = "http://example.com/awesome_space/awesome_project.git"}, objectAttributes_target = ProjectEvent {projectEvent_name = "Awesome Project", projectEvent_description = "Aut reprehenderit ut est.", projectEvent_web_url = "http://example.com/awesome_space/awesome_project", projectEvent_avatar_url = Nothing, projectEvent_git_ssh_url = "git@example.com:awesome_space/awesome_project.git", projectEvent_git_http_url = "http://example.com/awesome_space/awesome_project.git", projectEvent_namespace = "Awesome Space", projectEvent_visibility_level = Private, projectEvent_path_with_namespace = "awesome_space/awesome_project", projectEvent_default_branch = "master", projectEvent_homepage = Just "http://example.com/awesome_space/awesome_project", projectEvent_url = "http://example.com/awesome_space/awesome_project.git", projectEvent_ssh_url = "git@example.com:awesome_space/awesome_project.git", projectEvent_http_url = "http://example.com/awesome_space/awesome_project.git"}, objectAttributes_last_commit = CommitEvent {commitEvent_id = "ba3e0d8ff79c80d5b0bbb4f3e2e343e0aaa662b7", commitEvent_message = "fixed readme", commitEvent_timestamp = "2017-09-26T16:12:57Z", commitEvent_url = "http://example.com/awesome_space/awesome_project/commits/da1560886d4f094c3e6c9ef40349f7d38b5d27d7", commitEvent_author = CommitAuthorEvent {commitAuthorEvent_name = "GitLab dev user", commitAuthorEvent_email = "gitlabdev@dv6700.(none)"}}, objectAttributes_work_in_progress = False, objectAttributes_total_time_spent = 0, objectAttributes_human_total_time_spent = Nothing, objectAttributes_human_time_estimate = Nothing}, - mergeRequest_labels = Nothing, - mergeRequest_repository = RepositoryEvent {repositoryEvent_name = "git-gpg-test", repositoryEvent_url = "git@example.com:awesome_space/awesome_project.git", repositoryEvent_description = "", repositoryEvent_homepage = Just "http://example.com/awesome_space/awesome_project", repositoryEvent_git_http_url = Nothing, repositoryEvent_git_ssh_url = Nothing, repositoryEvent_visibility_level = Nothing} + mergeRequest_event_type = "merge_request", + mergeRequest_user = UserEvent {userEvent_name = "Rob", userEvent_username = "abc123", userEvent_avatar_url = ""}, + mergeRequest_project = ProjectEvent {projectEvent_name = "", projectEvent_description = "", projectEvent_web_url = "", projectEvent_avatar_url = Nothing, projectEvent_git_ssh_url = "", projectEvent_git_http_url = "", projectEvent_namespace = "", projectEvent_visibility_level = Private, projectEvent_path_with_namespace = "", projectEvent_default_branch = "master", projectEvent_homepage = Just "", projectEvent_url = "", projectEvent_ssh_url = "", projectEvent_http_url = ""}, + mergeRequest_object_attributes = ObjectAttributes {objectAttributes_id = 1567, objectAttributes_target_branch = "master", objectAttributes_source_branch = "master", objectAttributes_source_project_id = 8987, objectAttributes_author_id = 5, objectAttributes_assignee_id = Nothing, objectAttributes_assignee_ids = Just [], objectAttributes_title = "Master", objectAttributes_created_at = "2020-12-21 22:56:31 UTC", objectAttributes_updated_at = "2020-12-21 22:56:31 UTC", objectAttributes_milestone_id = Nothing, objectAttributes_state = "opened", objectAttributes_state_id = Just 1, objectAttributes_merge_status = "unchecked", objectAttributes_target_project_id = 8879, objectAttributes_iid = 7, objectAttributes_description = "", objectAttributes_updated_by_id = Nothing, objectAttributes_merge_error = Nothing, objectAttributes_merge_params = MergeParams {mergeParams_force_remove_source_branch = Nothing}, objectAttributes_merge_when_pipeline_succeeds = False, objectAttributes_merge_user_id = Nothing, objectAttributes_merge_commit_sha = Nothing, objectAttributes_deleted_at = Nothing, objectAttributes_in_progress_merge_commit_sha = Nothing, objectAttributes_lock_version = Nothing, objectAttributes_time_estimate = 0, objectAttributes_last_edited_at = Nothing, objectAttributes_last_edited_by_id = Nothing, objectAttributes_head_pipeline_id = Nothing, objectAttributes_ref_fetched = Nothing, objectAttributes_merge_jid = Nothing, objectAttributes_source = ProjectEvent {projectEvent_name = "", projectEvent_description = "", projectEvent_web_url = "", projectEvent_avatar_url = Nothing, projectEvent_git_ssh_url = "", projectEvent_git_http_url = "", projectEvent_namespace = "Rob", projectEvent_visibility_level = Private, projectEvent_path_with_namespace = "", projectEvent_default_branch = "master", projectEvent_homepage = Just "", projectEvent_url = "", projectEvent_ssh_url = "", projectEvent_http_url = ""}, objectAttributes_target = ProjectEvent {projectEvent_name = "", projectEvent_description = "", projectEvent_web_url = "", projectEvent_avatar_url = Nothing, projectEvent_git_ssh_url = "", projectEvent_git_http_url = "", projectEvent_namespace = "", projectEvent_visibility_level = Private, projectEvent_path_with_namespace = "", projectEvent_default_branch = "master", projectEvent_homepage = Just "", projectEvent_url = "", projectEvent_ssh_url = "", projectEvent_http_url = ""}, objectAttributes_last_commit = CommitEvent {commitEvent_id = "", commitEvent_message = "", commitEvent_timestamp = "2020-09-28T16:13:42+01:00", commitEvent_url = "", commitEvent_author = CommitAuthorEvent {commitAuthorEvent_name = "Rob", commitAuthorEvent_email = ""}}, objectAttributes_work_in_progress = False, objectAttributes_total_time_spent = 0, objectAttributes_human_total_time_spent = Nothing, objectAttributes_human_time_estimate = Nothing, objectAttributes_action = Just "open"}, + mergeRequest_labels = Just [], + mergeRequest_changes = MergeRequestChanges {mergeRequestChanges_author_id = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just 5}, mergeRequestChanges_created_at = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just "2020-12-21 22:56:31 UTC"}, mergeRequestChanges_description = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just ""}, mergeRequestChanges_id = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just 1567}, mergeRequestChanges_iid = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just 7}, mergeRequestChanges_source_branch = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just "master"}, mergeRequestChanges_source_project_id = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just 8987}, mergeRequestChanges_target_branch = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just "master"}, mergeRequestChanges_target_project_id = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just 8879}, mergeRequestChanges_title = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just "Master"}, mergeRequestChanges_updated_at = MergeRequestChange {mergeRequestChange_previous = Nothing, mergeRequestChange_current = Just "2020-12-21 22:56:31 UTC"}}, + mergeRequest_repository = RepositoryEvent {repositoryEvent_name = "", repositoryEvent_url = "", repositoryEvent_description = "", repositoryEvent_homepage = Just "", repositoryEvent_git_http_url = Nothing, repositoryEvent_git_ssh_url = Nothing, repositoryEvent_visibility_level = Nothing} }