diff --git a/gitlab-haskell.cabal b/gitlab-haskell.cabal
--- a/gitlab-haskell.cabal
+++ b/gitlab-haskell.cabal
@@ -1,11 +1,13 @@
cabal-version: 2.4
name: gitlab-haskell
category: Git
-version: 0.1.8
+version: 0.2
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:
.
+ It also features an API for writing Gitlab file hook applications
+ .
Run all GitLab actions with `runGitLab`:
.
> runGitLab :: (MonadUnliftIO m, MonadIO m)
@@ -26,6 +28,16 @@
> searchUser :: Text -> GitLab m (Maybe User)
> userProjects :: User -> GitLab m (Maybe [Project])
.
+ This library can also be used to develop rule based GitLab file hooks that react in real time to GitLab events with:
+ .
+ > 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 hooks support:
+ .
Unsurprisingly, this library is maintained on GitLab:
@@ -33,7 +45,7 @@
bug-reports: https://gitlab.com/robstewart57/gitlab-haskell/issues
author: Rob Stewart
maintainer: robstewart57@gmail.com
-copyright: 2019 Rob Stewart, Heriot-Watt University
+copyright: 2020 Rob Stewart, Heriot-Watt University
license: BSD-3-Clause
license-file: LICENSE
build-type: Simple
@@ -62,6 +74,8 @@
, GitLab.API.RepositoryFiles
, GitLab.API.Todos
, GitLab.API.Version
+ , GitLab.SystemHooks.Types
+ , GitLab.SystemHooks.GitLabSystemHooks
other-modules:
GitLab.WebRequests.GitLabWebCalls
hs-source-dirs:
@@ -80,3 +94,19 @@
, time
default-language: Haskell2010
ghc-options: -Wall
+ -- the following two for the stan static analysis tool
+ -- -fwrite-ide-info
+ -- -hiedir=.hie
+
+test-suite test-gitlab-haskell
+ type: exitcode-stdio-1.0
+ main-is: Tests.hs
+ other-modules: SystemHookTests
+ hs-source-dirs: tests/
+ default-language: Haskell2010
+ build-depends: base >= 4.8.0.0 && < 6
+ , tasty
+ , tasty-hunit
+ , gitlab-haskell
+ , bytestring
+ , aeson
diff --git a/src/GitLab.hs b/src/GitLab.hs
--- a/src/GitLab.hs
+++ b/src/GitLab.hs
@@ -9,6 +9,7 @@
-- Stability : stable
module GitLab
( runGitLab,
+ runGitLabDbg,
runGitLabWithManager,
module GitLab.Types,
module GitLab.API.Pipelines,
@@ -25,11 +26,12 @@
module GitLab.API.RepositoryFiles,
module GitLab.API.Todos,
module GitLab.API.Version,
+ module GitLab.SystemHooks.GitLabSystemHooks,
+ module GitLab.SystemHooks.Types,
)
where
import Control.Monad.IO.Class
-import Control.Monad.IO.Unlift
import Control.Monad.Trans.Reader
import GitLab.API.Branches
import GitLab.API.Commits
@@ -45,6 +47,8 @@
import GitLab.API.Todos
import GitLab.API.Users
import GitLab.API.Version
+import GitLab.SystemHooks.GitLabSystemHooks
+import GitLab.SystemHooks.Types
import GitLab.Types
import Network.Connection (TLSSettings (..))
import Network.HTTP.Conduit
@@ -61,15 +65,14 @@
--
-- > projectsWithIssuesEnabled :: IO [Project]
-- > projectsWithIssuesEnabled =
--- > runGitLab myConfig $ filter (issueEnabled . issues_enabled) <$> allProjects
+-- > runGitLabyConfig $ filter (issueEnabled . issues_enabled) <$> allProjects
-- > where
-- > myConfig = defaultGitLabServer
-- > { url = "https://gitlab.example.com"
-- > , token = "my_access_token" }
-- > issueEnabled Nothing = False
-- > issueEnabled (Just b) = b
-runGitLab ::
- (MonadUnliftIO m, MonadIO m) => GitLabServerConfig -> GitLab m a -> m a
+runGitLab :: GitLabServerConfig -> GitLab a -> IO a
runGitLab cfg action = do
liftIO $ hSetBuffering stdout LineBuffering
let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing
@@ -78,8 +81,7 @@
-- | The same as 'runGitLab', except that it also takes a connection
-- manager as an argument.
-runGitLabWithManager ::
- (MonadUnliftIO m, MonadIO m) => Manager -> GitLabServerConfig -> GitLab m a -> m a
+runGitLabWithManager :: Manager -> GitLabServerConfig -> GitLab a -> IO a
runGitLabWithManager manager cfg action = do
-- test the token access
tokenTest <- runReaderT gitlabVersion (GitLabState cfg manager)
@@ -89,3 +91,11 @@
Right _versionInfo ->
-- it worked, run the user code.
runReaderT action (GitLabState cfg manager)
+
+-- | Only useful for testing GitLab actions that lift IO actions with
+-- liftIO. Cannot speak to a GitLab server. Only useful for the
+-- gitlab-haskell tests.
+runGitLabDbg :: GitLab a -> IO a
+runGitLabDbg action = do
+ liftIO $ hSetBuffering stdout LineBuffering
+ runReaderT action undefined
diff --git a/src/GitLab/API/Branches.hs b/src/GitLab/API/Branches.hs
--- a/src/GitLab/API/Branches.hs
+++ b/src/GitLab/API/Branches.hs
@@ -9,7 +9,6 @@
-- Stability : stable
module GitLab.API.Branches where
-import Control.Monad.IO.Unlift
import Data.Either
import qualified Data.Text as T
import GitLab.Types
@@ -18,14 +17,14 @@
-- | Get a list of repository branches from a project, sorted by name
-- alphabetically.
-branches :: (MonadIO m) => Project -> GitLab m [Branch]
+branches :: Project -> GitLab [Branch]
branches project = do
result <- branches' (project_id project)
return (fromRight (error "branches error") result)
-- | Get a list of repository branches from a project given its
-- project ID, sorted by name alphabetically.
-branches' :: (MonadIO m) => Int -> GitLab m (Either Status [Branch])
+branches' :: Int -> GitLab (Either Status [Branch])
branches' projectId =
gitlab addr
where
diff --git a/src/GitLab/API/Commits.hs b/src/GitLab/API/Commits.hs
--- a/src/GitLab/API/Commits.hs
+++ b/src/GitLab/API/Commits.hs
@@ -9,7 +9,6 @@
-- Stability : stable
module GitLab.API.Commits where
-import Control.Monad.IO.Unlift
import Data.Either
import Data.Text (Text)
import qualified Data.Text as T
@@ -19,20 +18,18 @@
-- | returns all commits for a project.
projectCommits ::
- (MonadIO m) =>
-- | the project
Project ->
- GitLab m [Commit]
+ GitLab [Commit]
projectCommits project = do
result <- projectCommits' (project_id project)
return (fromRight (error "projectCommits error") result)
-- | returns all commits for a project given its project ID.
projectCommits' ::
- (MonadIO m) =>
-- | project ID
Int ->
- GitLab m (Either Status [Commit])
+ GitLab (Either Status [Commit])
projectCommits' projectId =
gitlabWithAttrs (commitsAddr projectId) "&with_stats=true"
where
@@ -43,12 +40,11 @@
-- | returns a commit for the given project and commit hash, if such
-- a commit exists.
commitDetails ::
- (MonadIO m) =>
-- | the project
Project ->
-- | the commit hash
Text ->
- GitLab m (Maybe Commit)
+ GitLab (Maybe Commit)
commitDetails project theHash = do
result <- commitDetails' (project_id project) theHash
return (fromRight (error "commitDetails error") result)
@@ -56,12 +52,11 @@
-- | returns a commit for the given project ID and commit hash, if
-- such a commit exists.
commitDetails' ::
- (MonadIO m) =>
-- | project ID
Int ->
-- | the commit hash
Text ->
- GitLab m (Either Status (Maybe Commit))
+ GitLab (Either Status (Maybe Commit))
commitDetails' projectId hash =
gitlabOne (commitsAddr projectId)
where
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
@@ -10,9 +10,6 @@
-- Stability : stable
module GitLab.API.Groups where
-import Control.Monad.IO.Class
-import Control.Monad.IO.Unlift
-import qualified Data.ByteString.Char8 as C
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
@@ -28,10 +25,9 @@
--
-- > projectsWithNameOrPath "group1"
groupsWithNameOrPath ::
- (MonadUnliftIO m, MonadIO m) =>
-- | group name being searched for.
Text ->
- GitLab m (Either Status [Group])
+ GitLab (Either Status [Group])
groupsWithNameOrPath groupName = do
result <- gitlabWithAttrs "/groups" ("&search=" <> groupName)
case result of
@@ -49,12 +45,11 @@
-- | adds all registered users to a group.
addAllUsersToGroup ::
- (MonadIO m, MonadUnliftIO m) =>
-- | group name
Text ->
-- | level of access granted
AccessLevel ->
- GitLab m [Either Status Member]
+ GitLab [Either Status Member]
addAllUsersToGroup groupName access = do
allRegisteredUsers <- allUsers
let allUserIds = map user_username allRegisteredUsers
@@ -62,32 +57,30 @@
-- | adds a user to a group.
addUserToGroup ::
- (MonadIO m, MonadUnliftIO m) =>
-- | group name
Text ->
-- | level of access granted
AccessLevel ->
-- | the user
User ->
- GitLab m (Either Status Member)
+ GitLab (Either Status Member)
addUserToGroup groupName access usr =
addUserToGroup' groupName access (user_id usr)
-- | adds a user with a given user ID to a group.
addUserToGroup' ::
- (MonadIO m, MonadUnliftIO m) =>
-- | group name
Text ->
-- | level of access granted
AccessLevel ->
-- | user ID
Int ->
- GitLab m (Either Status Member)
+ GitLab (Either Status Member)
addUserToGroup' groupName access userId = do
attempt <- groupsWithNameOrPath groupName
case attempt of
Left httpStatus -> return (Left httpStatus)
- Right [] -> return (Left (mkStatus 404 (C.pack "cannot find group")))
+ Right [] -> return (Left (mkStatus 404 (T.encodeUtf8 (T.pack "cannot find group"))))
Right [grp] ->
gitlabPost addr dataBody
where
@@ -100,31 +93,29 @@
<> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (T.pack (show (group_id grp)))))
<> "/members"
Right (_ : _) ->
- return (Left (mkStatus 404 (C.pack "too many groups found")))
+ return (Left (mkStatus 404 (T.encodeUtf8 (T.pack "too many groups found"))))
-- | adds a list of users to a group.
addUsersToGroup ::
- (MonadIO m, MonadUnliftIO m) =>
-- | group name
Text ->
-- | level of access granted
AccessLevel ->
-- | list of usernames to be added to the group
[User] ->
- GitLab m [Either Status Member]
+ GitLab [Either Status Member]
addUsersToGroup groupName access =
mapM (addUserToGroup groupName access)
-- | adds a list of users to a group.
addUsersToGroup' ::
- (MonadIO m, MonadUnliftIO m) =>
-- | group name
Text ->
-- | level of access granted
AccessLevel ->
-- | list of usernames to be added to the group
[Text] ->
- GitLab m [Either Status Member]
+ GitLab [Either Status 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
@@ -10,30 +10,30 @@
-- Stability : stable
module GitLab.API.Issues where
-import Control.Monad.IO.Class
-import Control.Monad.IO.Unlift
+import qualified Data.Aeson as J
import Data.Either
+import Data.Text (Text)
import qualified Data.Text as T
+import qualified Data.Text.Lazy
+import qualified Data.Text.Lazy.Encoding
import GitLab.Types
import GitLab.WebRequests.GitLabWebCalls
import Network.HTTP.Types.Status
-- | returns all issues against a project.
projectOpenedIssues ::
- (MonadIO m, MonadUnliftIO m) =>
-- | the project
Project ->
- GitLab m [Issue]
+ GitLab [Issue]
projectOpenedIssues p = do
result <- projectOpenedIssues' (project_id p)
return (fromRight (error "projectOpenedIssues error") result)
-- | returns all issues against a project given its project ID.
projectOpenedIssues' ::
- (MonadIO m, MonadUnliftIO m) =>
-- | the project ID
Int ->
- GitLab m (Either Status [Issue])
+ GitLab (Either Status [Issue])
projectOpenedIssues' projectId = do
let path = "/projects/" <> T.pack (show projectId) <> "/issues"
gitlab path
@@ -42,10 +42,9 @@
-- | gets all issues create by a user.
userIssues ::
- (MonadIO m) =>
-- | the user
User ->
- GitLab m [Issue]
+ GitLab [Issue]
userIssues usr =
gitlabWithAttrsUnsafe addr attrs
where
@@ -55,3 +54,57 @@
"&author_id="
<> show (user_id usr)
<> "&scope=all"
+
+-- | create a new issue.
+newIssue ::
+ -- | project
+ Project ->
+ -- | issue title
+ Text ->
+ -- | issue description
+ Text ->
+ GitLab (Either Status Issue)
+newIssue project =
+ newIssue' (project_id project)
+
+-- | create a new issue.
+newIssue' ::
+ -- | project ID
+ Int ->
+ -- | issue title
+ Text ->
+ -- | issue description
+ Text ->
+ GitLab (Either Status Issue)
+newIssue' projectId issueTitle issueDescription =
+ gitlabPost addr dataBody
+ where
+ dataBody :: Text
+ dataBody =
+ "title="
+ <> issueTitle
+ <> "&description="
+ <> issueDescription
+ addr =
+ "/projects/"
+ <> T.pack (show projectId)
+ <> "/issues"
+
+-- | edits an issue. see
+editIssue ::
+ ProjectId ->
+ IssueId ->
+ EditIssueReq ->
+ GitLab (Either Status Issue)
+editIssue projId issueId editIssueReq = do
+ let path =
+ "/projects/" <> T.pack (show projId)
+ <> "/issues/"
+ <> T.pack (show issueId)
+ gitlabPut
+ path
+ ( Data.Text.Lazy.toStrict
+ ( Data.Text.Lazy.Encoding.decodeUtf8
+ (J.encode editIssueReq)
+ )
+ )
diff --git a/src/GitLab/API/Jobs.hs b/src/GitLab/API/Jobs.hs
--- a/src/GitLab/API/Jobs.hs
+++ b/src/GitLab/API/Jobs.hs
@@ -9,7 +9,6 @@
-- Stability : stable
module GitLab.API.Jobs where
-import Control.Monad.IO.Unlift
import Data.Either
import qualified Data.Text as T
import GitLab.Types
@@ -18,20 +17,18 @@
-- | returns all jobs ran on a project.
jobs ::
- (MonadIO m) =>
-- | the project
Project ->
- GitLab m [Job]
+ GitLab [Job]
jobs project = do
result <- jobs' (project_id project)
return (fromRight (error "jobs error") result)
-- | returns all jobs ran on a project given its project ID.
jobs' ::
- (MonadIO m) =>
-- | the project ID
Int ->
- GitLab m (Either Status [Job])
+ GitLab (Either Status [Job])
jobs' projectId =
gitlab addr
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
@@ -10,7 +10,6 @@
-- Stability : stable
module GitLab.API.Members where
-import Control.Monad.IO.Class
import Data.Either
import Data.Text (Text)
import qualified Data.Text as T
@@ -34,13 +33,13 @@
show Owner = "50"
-- | the members of a project.
-membersOfProject :: (MonadIO m) => Project -> GitLab m [Member]
+membersOfProject :: Project -> GitLab [Member]
membersOfProject p = do
result <- membersOfProject' (project_id p)
return (fromRight (error "membersOfProject error") result)
-- | the members of a project given its ID.
-membersOfProject' :: (MonadIO m) => Int -> GitLab m (Either Status [Member])
+membersOfProject' :: Int -> GitLab (Either Status [Member])
membersOfProject' projectId =
gitlab addr
where
@@ -51,14 +50,13 @@
-- 'Right Member' for each successful action, otherwise it returns
-- 'Left Status'.
addMemberToProject ::
- (MonadIO m) =>
-- | the project
Project ->
-- | level of access
AccessLevel ->
-- | the user
User ->
- GitLab m (Either Status Member)
+ GitLab (Either Status Member)
addMemberToProject project access usr =
addMemberToProject' (project_id project) access (user_id usr)
@@ -66,14 +64,13 @@
-- project's ID and the user's ID. Returns @Right Member@ for each
-- successful action, otherwise it returns @Left Status@.
addMemberToProject' ::
- (MonadIO m) =>
-- | project ID
Int ->
-- | level of access
AccessLevel ->
-- | user ID
Int ->
- GitLab m (Either Status Member)
+ GitLab (Either Status Member)
addMemberToProject' projectId access userId =
gitlabPost addr dataBody
where
@@ -87,14 +84,13 @@
-- level. Returns 'Right Member' for each successful action, otherwise
-- it returns 'Left Status'.
addMembersToProject ::
- (MonadIO m) =>
-- | the project
Project ->
-- | level of access
AccessLevel ->
-- | users to add to the project
[User] ->
- GitLab m [Either Status Member]
+ GitLab [Either Status Member]
addMembersToProject project access =
mapM (addMemberToProject project access)
@@ -102,13 +98,12 @@
-- given the project's ID and the user IDs. Returns @Right Member@ for
-- each successful action, otherwise it returns @Left Status@.
addMembersToProject' ::
- (MonadIO m) =>
-- | project ID
Int ->
-- | level of acces
AccessLevel ->
-- | IDs of users to add to the project
[Int] ->
- GitLab m [Either Status Member]
+ GitLab [Either Status 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
@@ -9,7 +9,6 @@
-- Stability : stable
module GitLab.API.MergeRequests where
-import Control.Monad.IO.Unlift
import Data.Either
import Data.Text (Text)
import qualified Data.Text as T
@@ -19,20 +18,18 @@
-- | returns the merge requests for a project.
mergeRequests ::
- (MonadIO m) =>
-- | the project
Project ->
- GitLab m [MergeRequest]
+ GitLab [MergeRequest]
mergeRequests p = do
result <- mergeRequests' (project_id p)
return (fromRight (error "mergeRequests error") result)
-- | returns the merge requests for a project given its project ID.
mergeRequests' ::
- (MonadIO m) =>
-- | project ID
Int ->
- GitLab m (Either Status [MergeRequest])
+ GitLab (Either Status [MergeRequest])
mergeRequests' projectId =
gitlabWithAttrs addr "&scope=all"
where
@@ -43,7 +40,6 @@
-- | Creates a merge request.
createMergeRequest ::
- (MonadIO m) =>
-- | project
Project ->
-- | source branch
@@ -56,13 +52,12 @@
Text ->
-- | merge request description
Text ->
- GitLab m (Either Status MergeRequest)
+ GitLab (Either Status MergeRequest)
createMergeRequest project =
createMergeRequest' (project_id project)
-- | Creates a merge request.
createMergeRequest' ::
- (MonadIO m) =>
-- | project ID
Int ->
-- | source branch
@@ -75,7 +70,7 @@
Text ->
-- | merge request description
Text ->
- GitLab m (Either Status MergeRequest)
+ GitLab (Either Status MergeRequest)
createMergeRequest' projectId sourceBranch targetBranch targetProjectId mrTitle mrDescription =
gitlabPost addr dataBody
where
@@ -92,23 +87,21 @@
-- | Accepts a merge request.
acceptMergeRequest ::
- (MonadIO m) =>
-- | project
Project ->
-- | merge request IID
Int ->
- GitLab m (Either Status MergeRequest)
+ GitLab (Either Status MergeRequest)
acceptMergeRequest project =
acceptMergeRequest' (project_id project)
-- | Accepts a merge request.
acceptMergeRequest' ::
- (MonadIO m) =>
-- | project ID
Int ->
-- | merge request IID
Int ->
- GitLab m (Either Status MergeRequest)
+ GitLab (Either Status MergeRequest)
acceptMergeRequest' projectId mergeRequestIid = gitlabPost addr dataBody
where
dataBody :: Text
diff --git a/src/GitLab/API/Pipelines.hs b/src/GitLab/API/Pipelines.hs
--- a/src/GitLab/API/Pipelines.hs
+++ b/src/GitLab/API/Pipelines.hs
@@ -9,7 +9,6 @@
-- Stability : stable
module GitLab.API.Pipelines where
-import Control.Monad.IO.Unlift
import Data.Either
import qualified Data.Text as T
import GitLab.Types
@@ -18,20 +17,18 @@
-- | returns the pipelines for a project.
pipelines ::
- (MonadIO m) =>
-- | the project
Project ->
- GitLab m [Pipeline]
+ GitLab [Pipeline]
pipelines p = do
result <- pipelines' (project_id p)
return (fromRight (error "pipelines error") result)
-- | returns the pipelines for a project given its project ID.
pipelines' ::
- (MonadIO m) =>
-- | the project ID
Int ->
- GitLab m (Either Status [Pipeline])
+ GitLab (Either Status [Pipeline])
pipelines' projectId =
gitlabWithAttrs
addr
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
@@ -10,11 +10,8 @@
-- Stability : stable
module GitLab.API.Projects where
-import Control.Monad.IO.Class
-import Control.Monad.IO.Unlift
import Data.Either
import Data.List
-import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
@@ -30,7 +27,7 @@
import UnliftIO.Async
-- | gets all projects.
-allProjects :: (MonadIO m) => GitLab m [Project]
+allProjects :: GitLab [Project]
allProjects =
gitlabWithAttrsUnsafe "/projects" "&statistics=true"
@@ -39,10 +36,9 @@
-- > projectForks "project1"
-- > projectForks "group1/project1"
projectForks ::
- (MonadUnliftIO m, MonadIO m) =>
-- | name or namespace of the project
Text ->
- GitLab m (Either Status [Project])
+ GitLab (Either Status [Project])
projectForks projectName = do
let urlPath =
"/projects/"
@@ -53,10 +49,9 @@
-- | searches for a 'Project' with the given project ID, returns
-- 'Nothing' if a project with the given ID is not found.
searchProjectId ::
- (MonadIO m) =>
-- | project ID
Int ->
- GitLab m (Either Status (Maybe Project))
+ GitLab (Either Status (Maybe Project))
searchProjectId projectId = do
let urlPath = T.pack ("/projects/" <> show projectId)
gitlabWithAttrsOne urlPath "&statistics=true"
@@ -65,10 +60,9 @@
--
-- > projectsWithName "project1"
projectsWithName ::
- (MonadUnliftIO m, MonadIO m) =>
-- | project name being searched for.
Text ->
- GitLab m [Project]
+ GitLab [Project]
projectsWithName projectName =
filter (\project -> projectName == project_path project)
<$> gitlabWithAttrsUnsafe "/projects" ("&search=" <> projectName)
@@ -78,8 +72,7 @@
-- > projectsNamespaceName "user1" "project1"
--
-- looks for "user1/project1"
-projectsWithNameAndUser ::
- (MonadUnliftIO m, MonadIO m) => Text -> Text -> GitLab m (Either Status (Maybe Project))
+projectsWithNameAndUser :: Text -> Text -> GitLab (Either Status (Maybe Project))
projectsWithNameAndUser username projectName =
gitlabWithAttrsOne
( "/projects/"
@@ -90,22 +83,21 @@
-- | returns 'True' if a project has multiple committers, according to
-- the email addresses of the commits.
-multipleCommitters :: (MonadUnliftIO m, MonadIO m) => Project -> GitLab m Bool
+multipleCommitters :: Project -> GitLab Bool
multipleCommitters project = do
emailAddresses <- commitsEmailAddresses project
return (length (nub emailAddresses) > 1)
-- | gets the email addresses in the author information in all commit
-- for a project.
-commitsEmailAddresses ::
- (MonadUnliftIO m, MonadIO m) => Project -> GitLab m [Text]
+commitsEmailAddresses :: Project -> GitLab [Text]
commitsEmailAddresses project = do
result <- commitsEmailAddresses' (project_id project)
return (fromRight (error "commitsEmailAddresses error") result)
-- | gets the email addresses in the author information in all commit
-- for a project defined by the project's ID.
-commitsEmailAddresses' :: (MonadUnliftIO m, MonadIO m) => Int -> GitLab m (Either Status [Text])
+commitsEmailAddresses' :: Int -> GitLab (Either Status [Text])
commitsEmailAddresses' projectId = do
-- (commits :: [Commit]) <- projectCommits' projectId
attempt <- projectCommits' projectId
@@ -117,8 +109,7 @@
-- | gets all projects for a user given their username.
--
-- > userProjects "harry"
-userProjects' ::
- (MonadUnliftIO m, MonadIO m) => Text -> GitLab m (Maybe [Project])
+userProjects' :: Text -> GitLab (Maybe [Project])
userProjects' username = do
userMaybe <- searchUser username
case userMaybe of
@@ -130,26 +121,27 @@
-- | gets all projects for a user.
--
-- > userProjects myUser
-userProjects ::
- (MonadUnliftIO m, MonadIO m) => User -> GitLab m (Maybe [Project])
+userProjects :: User -> GitLab (Maybe [Project])
userProjects theUser =
userProjects' (user_username theUser)
-- | gets the 'GitLab.Types.Project' against which the given 'Issue'
-- was created.
-projectOfIssue :: (MonadIO m) => Issue -> GitLab m Project
+projectOfIssue :: Issue -> GitLab Project
projectOfIssue issue = do
result <- searchProjectId (issue_project_id issue)
- return (fromJust (fromRight (error "projectOfIssue error") result))
+ case fromRight (error "projectOfIssue error") result of
+ Nothing -> error "projectOfIssue error"
+ Just proj -> return proj
-- | finds all issues created by a user.
--
-- > issuesCreatedByUser "user1"
--
--- returns a (user,projects) tuple, where 'user' is the 'User' found
+-- returns a (user,projects) tuple, where user is the 'User' found
-- for the given searched username, and a list of 'Project's that the
-- user has created issues for.
-issuesCreatedByUser :: (MonadUnliftIO m, MonadIO m) => Text -> GitLab m (Maybe (User, [Project]))
+issuesCreatedByUser :: Text -> GitLab (Maybe (User, [Project]))
issuesCreatedByUser username = do
user_maybe <- searchUser username
case user_maybe of
@@ -163,18 +155,16 @@
-- of triples of: 1) the found project, 2) the list of issues for the
-- found projects, and 3) a list of users who've created issues.
issuesOnForks ::
- (MonadUnliftIO m, MonadIO m) =>
-- | name or namespace of the project
Text ->
- GitLab m [(Project, [Issue], [User])]
+ GitLab [(Project, [Issue], [User])]
issuesOnForks projectName = do
projects <- projectsWithName projectName
mapM processProject projects
where
processProject ::
- (MonadUnliftIO m, MonadIO m) =>
Project ->
- GitLab m (Project, [Issue], [User])
+ GitLab (Project, [Issue], [User])
processProject proj = do
(openIssues :: [Issue]) <- projectOpenedIssues proj
let authors = map issue_author openIssues
@@ -184,7 +174,7 @@
-- where namespace is the namespace of the project
-- e.g. "user1/project1", and members is a list of (username,name)
-- tuples about all members of the project.
-projectMemebersCount :: (MonadIO m) => Project -> GitLab m (Text, [(Text, Text)])
+projectMemebersCount :: Project -> GitLab (Text, [(Text, Text)])
projectMemebersCount project = do
friends <- count
return (namespace_name (namespace project), friends)
@@ -198,10 +188,9 @@
-- | returns 'True' is the last commit for a project passes all
-- continuous integration tests.
projectCISuccess ::
- (MonadIO m) =>
-- | the name or namespace of the project
Project ->
- GitLab m Bool
+ GitLab Bool
projectCISuccess project = do
pipes <- pipelines project
case pipes of
@@ -211,10 +200,9 @@
-- | searches for a username, and returns a user ID for that user, or
-- 'Nothing' if a user cannot be found.
namespacePathToUserId ::
- (MonadIO m) =>
-- | name or namespace of project
Text ->
- GitLab m (Maybe Int)
+ GitLab (Maybe Int)
namespacePathToUserId namespacePath = do
user_maybe <- searchUser namespacePath
case user_maybe of
@@ -222,13 +210,13 @@
Just usr -> return (Just (user_id usr))
-- | gets all diffs in a project for a given commit SHA.
-projectDiffs :: (MonadIO m) => Project -> Text -> GitLab m (Either Status [Diff])
+projectDiffs :: Project -> Text -> GitLab (Either Status [Diff])
projectDiffs proj =
projectDiffs' (project_id proj)
-- | gets all diffs in a project for a given project ID, for a given
-- commit SHA.
-projectDiffs' :: (MonadIO m) => Int -> Text -> GitLab m (Either Status [Diff])
+projectDiffs' :: Int -> Text -> GitLab (Either Status [Diff])
projectDiffs' projId commitSha =
gitlab
( "/projects/"
@@ -240,14 +228,13 @@
-- | share a project with a group.
shareProjectWithGroup ::
- (MonadIO m) =>
-- | group ID
Int ->
-- | project ID
Int ->
-- | level of access granted
AccessLevel ->
- GitLab m (Either Status GroupShare)
+ GitLab (Either Status GroupShare)
shareProjectWithGroup groupId projectId access =
gitlabPost addr dataBody
where
diff --git a/src/GitLab/API/Repositories.hs b/src/GitLab/API/Repositories.hs
--- a/src/GitLab/API/Repositories.hs
+++ b/src/GitLab/API/Repositories.hs
@@ -19,20 +19,18 @@
-- | returns a list of repository files and directories in a project.
repositories ::
- (MonadIO m) =>
-- | the project
Project ->
- GitLab m [Repository]
+ GitLab [Repository]
repositories project =
fromRight (error "repositories error") <$> repositories' (project_id project)
-- | returns a list of repository files and directories in a project
-- given its project ID.
repositories' ::
- (MonadIO m) =>
-- | the project ID
Int ->
- GitLab m (Either Status [Repository])
+ GitLab (Either Status [Repository])
repositories' projectId =
gitlab addr
where
@@ -46,14 +44,13 @@
--
-- > getFileArchive myProject TarGz "/tmp/myProject.tar.gz"
getFileArchive ::
- (MonadIO m) =>
-- | project
Project ->
-- | file format
ArchiveFormat ->
-- | file path to store the archive
FilePath ->
- GitLab m (Either Status ())
+ GitLab (Either Status ())
getFileArchive project = getFileArchive' (project_id project)
-- | get a file archive of the repository files as a
@@ -61,12 +58,11 @@
--
-- > getFileArchiveBS myProject TarGz "/tmp/myProject.tar.gz"
getFileArchiveBS ::
- (MonadIO m) =>
-- | project
Project ->
-- | file format
ArchiveFormat ->
- GitLab m (Either Status BSL.ByteString)
+ GitLab (Either Status BSL.ByteString)
getFileArchiveBS project = getFileArchiveBS' (project_id project)
-- | get a file archive of the repository files using the project's
@@ -74,14 +70,13 @@
--
-- > getFileArchive' 3453 Zip "/tmp/myProject.zip"
getFileArchive' ::
- (MonadIO m) =>
-- | project ID
Int ->
-- | file format
ArchiveFormat ->
-- | file path to store the archive
FilePath ->
- GitLab m (Either Status ())
+ GitLab (Either Status ())
getFileArchive' projectId format path = do
attempt <- getFileArchiveBS' projectId format
case attempt of
@@ -94,12 +89,11 @@
--
-- > getFileArchiveBS' 3453 Zip "/tmp/myProject.zip"
getFileArchiveBS' ::
- (MonadIO m) =>
-- | project ID
Int ->
-- | file format
ArchiveFormat ->
- GitLab m (Either Status BSL.ByteString)
+ GitLab (Either Status BSL.ByteString)
getFileArchiveBS' projectId format =
gitlabReqByteString addr
where
diff --git a/src/GitLab/API/RepositoryFiles.hs b/src/GitLab/API/RepositoryFiles.hs
--- a/src/GitLab/API/RepositoryFiles.hs
+++ b/src/GitLab/API/RepositoryFiles.hs
@@ -9,7 +9,6 @@
-- Stability : stable
module GitLab.API.RepositoryFiles where
-import Control.Monad.IO.Unlift
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
@@ -20,27 +19,25 @@
-- | Get a list of repository files and directories in a project.
repositoryFiles ::
- (MonadIO m) =>
-- | the project
Project ->
-- | the file path
Text ->
-- | name of the branch, tag or commit
Text ->
- GitLab m (Either Status (Maybe RepositoryFile))
+ GitLab (Either Status (Maybe RepositoryFile))
repositoryFiles project = repositoryFiles' (project_id project)
-- | Get a list of repository files and directories in a project given
-- the project's ID.
repositoryFiles' ::
- (MonadIO m) =>
-- | project ID
Int ->
-- | the file path
Text ->
-- | name of the branch, tag or commit
Text ->
- GitLab m (Either Status (Maybe RepositoryFile))
+ GitLab (Either Status (Maybe RepositoryFile))
repositoryFiles' projectId filePath reference =
gitlabWithAttrsOne addr ("&ref=" <> reference)
where
@@ -54,12 +51,11 @@
-- | Get raw data for a given file blob hash.
repositoryFileBlob ::
- (MonadIO m) =>
-- | project ID
Int ->
-- | blob SHA
Text ->
- GitLab m (Either Status String)
+ GitLab (Either Status String)
repositoryFileBlob projectId blobSha =
gitlabReqText addr
where
diff --git a/src/GitLab/API/Todos.hs b/src/GitLab/API/Todos.hs
--- a/src/GitLab/API/Todos.hs
+++ b/src/GitLab/API/Todos.hs
@@ -9,10 +9,9 @@
-- Stability : stable
module GitLab.API.Todos where
-import Control.Monad.IO.Class
import GitLab.Types
import GitLab.WebRequests.GitLabWebCalls
-- | returns all pending todos for the user, as defined by the access token.
-todos :: (MonadIO m) => GitLab m [Todo]
+todos :: GitLab [Todo]
todos = gitlabUnsafe "/todos"
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
@@ -10,7 +10,6 @@
-- Stability : stable
module GitLab.API.Users where
-import Control.Monad.IO.Class
import Data.List
import Data.Maybe
import Data.Text (Text)
@@ -18,7 +17,7 @@
import GitLab.WebRequests.GitLabWebCalls
-- | all registered users.
-allUsers :: (MonadIO m) => GitLab m [User]
+allUsers :: GitLab [User]
allUsers = do
let path = "/users"
gitlabUnsafe path
@@ -26,25 +25,23 @@
-- | searches for a user given a username. Returns @Just User@ if the
-- user is found, otherwise @Nothing@.
searchUser ::
- (MonadIO m) =>
-- | username to search for
Text ->
- GitLab m (Maybe User)
+ GitLab (Maybe User)
searchUser username = do
let path = "/users"
attrs = "&username=" <> username
res <- gitlabWithAttrsUnsafe path attrs
- if null res
- then return Nothing
- else return (Just (head res))
+ case res of
+ [] -> return Nothing
+ (user : _) -> return (Just user)
-- | searches for users given a list of usernames, returns them in
-- alphabetical order of their usernames.
orderedUsers ::
- (MonadIO m) =>
-- | usernames to search for
[Text] ->
- GitLab m [User]
+ GitLab [User]
orderedUsers usernames = do
users <- catMaybes <$> mapM searchUser usernames
return (orderUsersByName users)
diff --git a/src/GitLab/API/Version.hs b/src/GitLab/API/Version.hs
--- a/src/GitLab/API/Version.hs
+++ b/src/GitLab/API/Version.hs
@@ -9,12 +9,12 @@
-- Stability : stable
module GitLab.API.Version where
-import Control.Monad.IO.Class
import GitLab.Types
import GitLab.WebRequests.GitLabWebCalls
import Network.HTTP.Types.Status
-gitlabVersion :: (MonadIO m) => GitLab m (Either Status (Maybe Version))
+-- | Get the version of the GitLab server.
+gitlabVersion :: GitLab (Either Status (Maybe Version))
gitlabVersion = do
let path = "/version"
gitlabOne path
diff --git a/src/GitLab/SystemHooks/GitLabSystemHooks.hs b/src/GitLab/SystemHooks/GitLabSystemHooks.hs
new file mode 100644
--- /dev/null
+++ b/src/GitLab/SystemHooks/GitLabSystemHooks.hs
@@ -0,0 +1,262 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- |
+-- Module : GitLab.SystemHooks.GitLabSystemHooks
+-- Description : Haskell records corresponding to JSON data from GitLab system hooks
+-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2020
+-- License : BSD3
+-- Maintainer : robstewart57@gmail.com
+-- Stability : stable
+module GitLab.SystemHooks.GitLabSystemHooks
+ ( receive,
+ receiveString,
+ tryFire,
+ )
+where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Typeable
+import GitLab.SystemHooks.Types
+import GitLab.Types
+
+-- | Attempts to fire each rule in sequence. Reads the JSON data
+-- received from the GitLab server from standard input.
+receive :: [Rule] -> GitLab ()
+receive rules = do
+ eventContent <- liftIO getContents
+ receiveString eventContent rules
+
+-- | Attempts to fire each rule in sequence. Reads the JSON data
+-- received from a function argument.
+receiveString :: String -> [Rule] -> GitLab ()
+receiveString eventContent rules = do
+ mapM_ (fire eventContent) rules
+
+orElse :: GitLab Bool -> GitLab Bool -> GitLab Bool
+orElse f g = do
+ x <- f
+ if x
+ then return True
+ else g
+
+fire :: String -> Rule -> GitLab ()
+fire contents rule = do
+ result <- tryFire contents rule
+ when result $
+ liftIO (putStrLn ("fired: " <> labelOf rule))
+ where
+ labelOf :: Rule -> String
+ labelOf (Match lbl _) = lbl
+ labelOf (MatchIf lbl _ _) = lbl
+
+-- | Try to fire a GitLab rule, returns 'True' if the rule fired and
+-- 'False' if it did not fire.
+tryFire :: String -> Rule -> GitLab Bool
+tryFire contents (Match _ f) = do
+ fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (ProjectCreate -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectCreate)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (ProjectDestroy -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectDestroy)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (ProjectRename -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectRename)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (ProjectTransfer -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectTransfer)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (ProjectUpdate -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectUpdate)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (GroupMemberUpdate -> GitLab ()))
+ (parseEvent contents :: Maybe GroupMemberUpdate)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (UserAddToTeam -> GitLab ()))
+ (parseEvent contents :: Maybe UserAddToTeam)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (UserUpdateForTeam -> GitLab ()))
+ (parseEvent contents :: Maybe UserUpdateForTeam)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (UserRemoveFromTeam -> GitLab ()))
+ (parseEvent contents :: Maybe UserRemoveFromTeam)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (UserCreate -> GitLab ()))
+ (parseEvent contents :: Maybe UserCreate)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (UserRemove -> GitLab ()))
+ (parseEvent contents :: Maybe UserRemove)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (UserFailedLogin -> GitLab ()))
+ (parseEvent contents :: Maybe UserFailedLogin)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (UserRename -> GitLab ()))
+ (parseEvent contents :: Maybe UserRename)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (KeyCreate -> GitLab ()))
+ (parseEvent contents :: Maybe KeyCreate)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (KeyRemove -> GitLab ()))
+ (parseEvent contents :: Maybe KeyRemove)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (GroupCreate -> GitLab ()))
+ (parseEvent contents :: Maybe GroupCreate)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (GroupRemove -> GitLab ()))
+ (parseEvent contents :: Maybe GroupRemove)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (GroupRename -> GitLab ()))
+ (parseEvent contents :: Maybe GroupRename)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (NewGroupMember -> GitLab ()))
+ (parseEvent contents :: Maybe NewGroupMember)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (GroupMemberRemove -> GitLab ()))
+ (parseEvent contents :: Maybe GroupMemberRemove)
+ -- `orElse` fireIf'
+ -- (Just (\_ -> return True))
+ -- (cast f :: Maybe (ProjectEvent -> GitLab ()))
+ -- (parseEvent contents :: Maybe ProjectEvent)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (Push -> GitLab ()))
+ (parseEvent contents :: Maybe Push)
+ `orElse` fireIf'
+ (Just (\_ -> return True))
+ (cast f :: Maybe (TagPush -> GitLab ()))
+ (parseEvent contents :: Maybe TagPush)
+tryFire contents (MatchIf _ predF f) = do
+ fireIf'
+ (cast predF :: Maybe (ProjectCreate -> GitLab Bool))
+ (cast f :: Maybe (ProjectCreate -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectCreate)
+ `orElse` fireIf'
+ (cast predF :: Maybe (ProjectDestroy -> GitLab Bool))
+ (cast f :: Maybe (ProjectDestroy -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectDestroy)
+ `orElse` fireIf'
+ (cast predF :: Maybe (ProjectRename -> GitLab Bool))
+ (cast f :: Maybe (ProjectRename -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectRename)
+ `orElse` fireIf'
+ (cast predF :: Maybe (ProjectTransfer -> GitLab Bool))
+ (cast f :: Maybe (ProjectTransfer -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectTransfer)
+ `orElse` fireIf'
+ (cast predF :: Maybe (ProjectUpdate -> GitLab Bool))
+ (cast f :: Maybe (ProjectUpdate -> GitLab ()))
+ (parseEvent contents :: Maybe ProjectUpdate)
+ `orElse` fireIf'
+ (cast predF :: Maybe (GroupMemberUpdate -> GitLab Bool))
+ (cast f :: Maybe (GroupMemberUpdate -> GitLab ()))
+ (parseEvent contents :: Maybe GroupMemberUpdate)
+ `orElse` fireIf'
+ (cast predF :: Maybe (UserAddToTeam -> GitLab Bool))
+ (cast f :: Maybe (UserAddToTeam -> GitLab ()))
+ (parseEvent contents :: Maybe UserAddToTeam)
+ `orElse` fireIf'
+ (cast predF :: Maybe (UserUpdateForTeam -> GitLab Bool))
+ (cast f :: Maybe (UserUpdateForTeam -> GitLab ()))
+ (parseEvent contents :: Maybe UserUpdateForTeam)
+ `orElse` fireIf'
+ (cast predF :: Maybe (UserRemoveFromTeam -> GitLab Bool))
+ (cast f :: Maybe (UserRemoveFromTeam -> GitLab ()))
+ (parseEvent contents :: Maybe UserRemoveFromTeam)
+ `orElse` fireIf'
+ (cast predF :: Maybe (UserCreate -> GitLab Bool))
+ (cast f :: Maybe (UserCreate -> GitLab ()))
+ (parseEvent contents :: Maybe UserCreate)
+ `orElse` fireIf'
+ (cast predF :: Maybe (UserRemove -> GitLab Bool))
+ (cast f :: Maybe (UserRemove -> GitLab ()))
+ (parseEvent contents :: Maybe UserRemove)
+ `orElse` fireIf'
+ (cast predF :: Maybe (UserFailedLogin -> GitLab Bool))
+ (cast f :: Maybe (UserFailedLogin -> GitLab ()))
+ (parseEvent contents :: Maybe UserFailedLogin)
+ `orElse` fireIf'
+ (cast predF :: Maybe (UserRename -> GitLab Bool))
+ (cast f :: Maybe (UserRename -> GitLab ()))
+ (parseEvent contents :: Maybe UserRename)
+ `orElse` fireIf'
+ (cast predF :: Maybe (KeyCreate -> GitLab Bool))
+ (cast f :: Maybe (KeyCreate -> GitLab ()))
+ (parseEvent contents :: Maybe KeyCreate)
+ `orElse` fireIf'
+ (cast predF :: Maybe (KeyRemove -> GitLab Bool))
+ (cast f :: Maybe (KeyRemove -> GitLab ()))
+ (parseEvent contents :: Maybe KeyRemove)
+ `orElse` fireIf'
+ (cast predF :: Maybe (GroupCreate -> GitLab Bool))
+ (cast f :: Maybe (GroupCreate -> GitLab ()))
+ (parseEvent contents :: Maybe GroupCreate)
+ `orElse` fireIf'
+ (cast predF :: Maybe (GroupRemove -> GitLab Bool))
+ (cast f :: Maybe (GroupRemove -> GitLab ()))
+ (parseEvent contents :: Maybe GroupRemove)
+ `orElse` fireIf'
+ (cast predF :: Maybe (GroupRename -> GitLab Bool))
+ (cast f :: Maybe (GroupRename -> GitLab ()))
+ (parseEvent contents :: Maybe GroupRename)
+ `orElse` fireIf'
+ (cast predF :: Maybe (NewGroupMember -> GitLab Bool))
+ (cast f :: Maybe (NewGroupMember -> GitLab ()))
+ (parseEvent contents :: Maybe NewGroupMember)
+ `orElse` fireIf'
+ (cast predF :: Maybe (GroupMemberRemove -> GitLab Bool))
+ (cast f :: Maybe (GroupMemberRemove -> GitLab ()))
+ (parseEvent contents :: Maybe GroupMemberRemove)
+ -- `orElse` fireIf'
+ -- (cast predF :: Maybe (ProjectEvent -> GitLab Bool))
+ -- (cast f :: Maybe (ProjectEvent -> GitLab ()))
+ -- (parseEvent contents :: Maybe ProjectEvent)
+ `orElse` fireIf'
+ (cast predF :: Maybe (Push -> GitLab Bool))
+ (cast f :: Maybe (Push -> GitLab ()))
+ (parseEvent contents :: Maybe Push)
+ `orElse` fireIf'
+ (cast predF :: Maybe (TagPush -> GitLab Bool))
+ (cast f :: Maybe (TagPush -> GitLab ()))
+ (parseEvent contents :: Maybe TagPush)
+
+fireIf' :: (Typeable a, Show a) => Maybe (a -> GitLab Bool) -> Maybe (a -> GitLab ()) -> Maybe a -> GitLab Bool
+fireIf' castPred castF parsed = do
+ case castPred of
+ Nothing -> return False
+ Just pred' ->
+ case castF of
+ Nothing -> return False
+ Just f' ->
+ case parsed of
+ Nothing -> return False
+ Just parsed' -> do
+ testPred <- pred' parsed'
+ if testPred
+ then do
+ f' parsed'
+ return True
+ else return False
diff --git a/src/GitLab/SystemHooks/Types.hs b/src/GitLab/SystemHooks/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/GitLab/SystemHooks/Types.hs
@@ -0,0 +1,1154 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module : GitLab.SystemHooks.Types
+-- Description : Haskell records corresponding to JSON data from GitLab system hook events
+-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2020
+-- License : BSD3
+-- Maintainer : robstewart57@gmail.com
+-- Stability : stable
+module GitLab.SystemHooks.Types
+ ( Rule (..),
+ SystemHook (..),
+ ProjectCreate (..),
+ ProjectDestroy (..),
+ ProjectRename (..),
+ ProjectTransfer (..),
+ ProjectUpdate (..),
+ UserAddToTeam (..),
+ UserUpdateForTeam (..),
+ UserRemoveFromTeam (..),
+ UserCreate (..),
+ UserRemove (..),
+ UserFailedLogin (..),
+ UserRename (..),
+ KeyCreate (..),
+ KeyRemove (..),
+ GroupCreate (..),
+ GroupRemove (..),
+ GroupRename (..),
+ NewGroupMember (..),
+ GroupMemberRemove (..),
+ GroupMemberUpdate (..),
+ Push (..),
+ TagPush (..),
+ ProjectEvent (..),
+ RepositoryEvent (..),
+ CommitEvent (..),
+ CommitAuthorEvent (..),
+ Visibility (..),
+ parseEvent,
+ )
+where
+
+import Data.Aeson
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import Data.Text (Text)
+import Data.Typeable
+import GHC.Generics
+import GitLab.Types
+
+-- | Pattern matching rules on GitLab hook events.
+data Rule where
+ Match :: (Typeable a) => String -> (a -> GitLab ()) -> Rule
+ MatchIf :: (Typeable a) => String -> (a -> GitLab Bool) -> (a -> GitLab ()) -> Rule
+
+-- | A typeclass for GitLab hook events.
+class (FromJSON a) => SystemHook a where
+ match :: String -> (a -> GitLab ()) -> Rule
+ matchIf :: String -> (a -> GitLab Bool) -> (a -> GitLab ()) -> Rule
+
+-- | Parse JSON data into GitLab events.
+parseEvent :: (FromJSON a) => String -> Maybe a
+parseEvent string =
+ case eitherDecode (BSL.pack string) of
+ Left _error -> Nothing
+ Right event -> Just event
+
+instance SystemHook ProjectCreate where
+ match = Match
+ matchIf = MatchIf
+
+-- | GitLab project creation.
+data ProjectCreate = ProjectCreate
+ { projectCreate_created_at :: Text,
+ projectCreate_updated_at :: Text,
+ projectCreate_action :: Text,
+ projectCreate_name :: Text,
+ projectCreate_owner_email :: Text,
+ projectCreate_owner_name :: Text,
+ projectCreate_path :: Text,
+ projectCreate_path_with_namespace :: Text,
+ projectCreate_project_id :: Int,
+ projectCreate_project_visibility :: Visibility
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook ProjectDestroy where
+ match = Match
+ matchIf = MatchIf
+
+-- | Removal of a GitLab removal.
+data ProjectDestroy = ProjectDestroy
+ { projectDestroy_created_at :: Text,
+ projectDestroy_updated_at :: Text,
+ projectDestroy_action :: Text,
+ projectDestroy_name :: Text,
+ projectDestroy_owner_email :: Text,
+ projectDestroy_owner_name :: Text,
+ projectDestroy_path :: Text,
+ projectDestroy_path_with_namespace :: Text,
+ projectDestroy_project_id :: Int,
+ projectDestroy_project_visibility :: Visibility
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook ProjectRename where
+ match = Match
+ matchIf = MatchIf
+
+-- | Renaming of a GitLab project.
+data ProjectRename = ProjectRename
+ { projectRename_created_at :: Text,
+ projectRename_updated_at :: Text,
+ projectRename_event_name :: Text,
+ projectRename_name :: Text,
+ projectRename_path :: Text,
+ projectRename_path_with_namespace :: Text,
+ projectRename_project_id :: Int,
+ projectRename_owner_name :: Text,
+ projectRename_owner_email :: Text,
+ projectRename_project_visibility :: Visibility,
+ projectRename_old_path_with_namespace :: Text
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook ProjectTransfer where
+ match = Match
+ matchIf = MatchIf
+
+-- | A project has been transferred.
+data ProjectTransfer = ProjectTransfer
+ { projectTransfer_created_at :: Text,
+ projectTransfer_updated_at :: Text,
+ projectTransfer_event_name :: Text,
+ projectTransfer_name :: Text,
+ projectTransfer_path :: Text,
+ projectTransfer_path_with_namespace :: Text,
+ projectTransfer_project_id :: Int,
+ projectTransfer_owner_name :: Text,
+ projectTransfer_owner_email :: Text,
+ projectTransfer_project_visibility :: Visibility,
+ projectTransfer_old_path_with_namespace :: Text
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook ProjectUpdate where
+ match = Match
+ matchIf = MatchIf
+
+-- | A project has been updated.
+data ProjectUpdate = ProjectUpdate
+ { projectUpdate_created_at :: Text,
+ projectUpdate_updated_at :: Text,
+ projectUpdate_event_name :: Text,
+ projectUpdate_name :: Text,
+ projectUpdate_owner_email :: Text,
+ projectUpdate_owner_name :: Text,
+ projectUpdate_path :: Text,
+ projectUpdate_path_with_namespace :: Text,
+ projectUpdate_project_id :: Int,
+ projectUpdate_project_visibility :: Visibility
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook UserAddToTeam where
+ match = Match
+ matchIf = MatchIf
+
+-- | A user has been added to a team.
+data UserAddToTeam = UserAddToTeam
+ { userAddTeam_created_at :: Text, -- todo improve: date
+ userAddTeam_updated_at :: Text, -- todo improve: date
+ userAddTeam_event_name :: Text,
+ userAddTeam_access_level :: Text, -- todo improve: Maintainer/...
+ userAddTeam_project_id :: Int,
+ userAddTeam_project_name :: Text,
+ userAddTeam_project_path :: Text,
+ userAddTeam_project_path_with_namespace :: Text,
+ userAddTeam_user_email :: Text,
+ userAddTeam_user_name :: Text,
+ userAddTeam_user_username :: Text,
+ userAddTeam_user_id :: Int,
+ userAddTeam_project_visibility :: Visibility
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook UserUpdateForTeam where
+ match = Match
+ matchIf = MatchIf
+
+-- | A user in a team has been updated.
+data UserUpdateForTeam = UserUpdateForTeam
+ { userUpdateTeam_created_at :: Text, -- todo improve: date
+ userUpdateTeam_updated_at :: Text, -- todo improve: date
+ userUpdateTeam_event_name :: Text,
+ userUpdateTeam_access_level :: Text, -- todo improve: Maintainer/...
+ userUpdateTeam_project_id :: Int,
+ userUpdateTeam_project_name :: Text,
+ userUpdateTeam_project_path :: Text,
+ userUpdateTeam_project_path_with_namespace :: Text,
+ userUpdateTeam_user_email :: Text,
+ userUpdateTeam_user_name :: Text,
+ userUpdateTeam_user_username :: Text,
+ userUpdateTeam_user_id :: Int,
+ userUpdateTeam_project_visibility :: Visibility
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook UserRemoveFromTeam where
+ match = Match
+ matchIf = MatchIf
+
+-- | A user has been removed from a team.
+data UserRemoveFromTeam = UserRemoveFromTeam
+ { userRemoveTeam_created_at :: Text, -- todo improve: date
+ userRemoveTeam_updated_at :: Text, -- todo improve: date
+ userRemoveTeam_event_name :: Text,
+ userRemoveTeam_access_level :: Text, -- todo improve: Maintainer/...
+ userRemoveTeam_project_id :: Int,
+ userRemoveTeam_project_name :: Text,
+ userRemoveTeam_project_path :: Text,
+ userRemoveTeam_project_path_with_namespace :: Text,
+ userRemoveTeam_user_email :: Text,
+ userRemoveTeam_user_name :: Text,
+ userRemoveTeam_user_username :: Text,
+ userRemoveTeam_user_id :: Int,
+ userRemoveTeam_project_visibility :: Visibility
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook UserCreate where
+ match = Match
+ matchIf = MatchIf
+
+-- | A user has been created.
+data UserCreate = UserCreate
+ { userCreate_created_at :: Text, -- todo improve: date
+ userCreate_updated_at :: Text, -- todo improve: date
+ userCreate_email :: Text,
+ userCreate_event_name :: Text,
+ userCreate_name :: Text,
+ userCreate_username :: Text,
+ userCreate_user_id :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook UserRemove where
+ match = Match
+ matchIf = MatchIf
+
+-- | A user has been removed.
+data UserRemove = UserRemove
+ { userRemove_created_at :: Text, -- todo improve: date
+ userRemove_updated_at :: Text, -- todo improve: date
+ userRemove_email :: Text,
+ userRemove_event_name :: Text,
+ userRemove_name :: Text,
+ userRemove_username :: Text,
+ userRemove_user_id :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook UserFailedLogin where
+ match = Match
+ matchIf = MatchIf
+
+-- | A user has failed to log in.
+data UserFailedLogin = UserFailedLogin
+ { userFailedLogin_event_name :: Text,
+ userFailedLogin_created_at :: Text, -- todo improve: date
+ userFailedLogin_updated_at :: Text, -- todo improve: date
+ userFailedLogin_name :: Text,
+ userFailedLogin_email :: Text,
+ userFailedLogin_user_id :: Int,
+ userFailedLogin_username :: Text,
+ -- create Haskell sum type for this
+ userFailedLogin_state :: Text
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook UserRename where
+ match = Match
+ matchIf = MatchIf
+
+-- | A user has been renamed.
+data UserRename = UserRename
+ { userRename_event_name :: Text,
+ userRename_created_at :: Text, -- todo improve: date
+ userRename_updated_at :: Text, -- todo improve: date
+ userRename_name :: Text,
+ userRename_email :: Text,
+ userRename_user_id :: Int,
+ userRename_username :: Text,
+ userRename_old_username :: Text
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook KeyCreate where
+ match = Match
+ matchIf = MatchIf
+
+-- | A key has been created.
+data KeyCreate = KeyCreate
+ { keyCreate_event_name :: Text,
+ keyCreate_created_at :: Text, -- todo improve: date
+ keyCreate_updated_at :: Text, -- todo improve: date
+ keyCreate_username :: Text,
+ keyCreate_key :: Text,
+ keyCreate_id :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook KeyRemove where
+ match = Match
+ matchIf = MatchIf
+
+-- | A key has been removed.
+data KeyRemove = KeyRemove
+ { keyRemove_event_name :: Text,
+ keyRemove_created_at :: Text, -- todo improve: date
+ keyRemove_updated_at :: Text, -- todo improve: date
+ keyRemove_username :: Text,
+ keyRemove_key :: Text,
+ keyRemove_id :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook GroupCreate where
+ match = Match
+ matchIf = MatchIf
+
+-- | A group has been created.
+data GroupCreate = GroupCreate
+ { groupCreate_created_at :: Text, -- todo improve: date
+ groupCreate_updated_at :: Text, -- todo improve: date
+ groupCreate_event_name :: Text,
+ groupCreate_name :: Text,
+ groupCreate_owner_email :: Maybe Text,
+ groupCreate_owner_name :: Maybe Text,
+ groupCreate_path :: Text,
+ groupCreate_group_id :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook GroupRemove where
+ match = Match
+ matchIf = MatchIf
+
+-- | A group has been removed.
+data GroupRemove = GroupRemove
+ { groupRemove_created_at :: Text, -- todo improve: date
+ groupRemove_updated_at :: Text, -- todo improve: date
+ groupRemove_event_name :: Text,
+ groupRemove_name :: Text,
+ groupRemove_owner_email :: Maybe Text,
+ groupRemove_owner_name :: Maybe Text,
+ groupRemove_path :: Text,
+ groupRemove_group_id :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook GroupRename where
+ match = Match
+ matchIf = MatchIf
+
+-- | A group has been renamed.
+data GroupRename = GroupRename
+ { groupRename_event_name :: Text,
+ groupRename_created_at :: Text, -- todo improve: date
+ groupRename_updated_at :: Text, -- todo improve: date
+ groupRename_name :: Text,
+ groupRename_path :: Text,
+ groupRename_full_path :: Text,
+ groupRename_group_id :: Int,
+ groupRename_owner_name :: Maybe Text,
+ groupRename_owner_email :: Maybe Text,
+ groupRename_old_path :: Text,
+ groupRename_old_full_path :: Text
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook NewGroupMember where
+ match = Match
+ matchIf = MatchIf
+
+-- | A user has been added to a group.
+data NewGroupMember = NewGroupMember
+ { newGroupMember_created_at :: Text, -- todo improve: date
+ newGroupMember_updated_at :: Text, -- todo improve: date
+ newGroupMember_event_name :: Text,
+ newGroupMember_group_access :: Text, -- todo Haskell type for this
+ newGroupMember_group_id :: Int,
+ newGroupMember_group_name :: Text,
+ newGroupMember_group_path :: Text,
+ newGroupMember_user_email :: Text,
+ newGroupMember_user_name :: Text,
+ newGroupMember_user_username :: Text,
+ newGroupMember_user_id :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook GroupMemberRemove where
+ match = Match
+ matchIf = MatchIf
+
+-- | A user has been removed from a group.
+data GroupMemberRemove = GroupMemberRemove
+ { groupMemberRemove_created_at :: Text, -- todo improve: date
+ groupMemberRemove_updated_at :: Text, -- todo improve: date
+ groupMemberRemove_event_name :: Text,
+ groupMemberRemove_group_access :: Text, -- todo Haskell type for this
+ groupMemberRemove_group_id :: Int,
+ groupMemberRemove_group_name :: Text,
+ groupMemberRemove_group_path :: Text,
+ groupMemberRemove_user_email :: Text,
+ groupMemberRemove_user_name :: Text,
+ groupMemberRemove_user_username :: Text,
+ groupMemberRemove_user_id :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook GroupMemberUpdate where
+ match = Match
+ matchIf = MatchIf
+
+-- | A group member has been updated.
+data GroupMemberUpdate = GroupMemberUpdate
+ { groupMemberUpdate_created_at :: Text, -- todo improve: date
+ groupMemberUpdate_updated_at :: Text, -- todo improve: date
+ groupMemberUpdate_event_name :: Text,
+ groupMemberUpdate_group_access :: Text, -- todo Haskell type for this
+ groupMemberUpdate_group_id :: Int,
+ groupMemberUpdate_group_name :: Text,
+ groupMemberUpdate_group_path :: Text,
+ groupMemberUpdate_user_email :: Text,
+ groupMemberUpdate_user_name :: Text,
+ groupMemberUpdate_user_username :: Text,
+ groupMemberUpdate_user_id :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook Push where
+ match = Match
+ matchIf = MatchIf
+
+-- | Commits have been pushed to the server.
+data Push = Push
+ { push_event_name :: Text,
+ push_before :: Text,
+ push_after :: Text,
+ push_ref :: Text,
+ push_checkout_sha :: Text,
+ push_user_id :: Int,
+ push_user_name :: Text,
+ push_user_email :: Text,
+ push_user_avatar :: Text,
+ push_project_id :: Int,
+ push_project :: ProjectEvent,
+ push_repository :: RepositoryEvent,
+ push_commits :: [CommitEvent],
+ push_total_commits_count :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+instance SystemHook TagPush where
+ match = Match
+ matchIf = MatchIf
+
+-- | Tags have been pushed to the server.
+data TagPush = TagPush
+ { tagPush_event_name :: Text,
+ tagPush_before :: Text,
+ tagPush_after :: Text,
+ tagPush_ref :: Text,
+ tagPush_checkout_sha :: Text,
+ tagPush_user_id :: Int,
+ tagPush_user_name :: Text,
+ tagPush_user_avatar :: Text,
+ tagPush_project_id :: Int,
+ tagPush_project :: ProjectEvent,
+ tagPush_repository :: RepositoryEvent,
+ tagPush_commits :: [CommitEvent],
+ tagPush_total_commits_count :: Int
+ }
+ deriving (Typeable, Show, Eq)
+
+-- | A project event.
+data ProjectEvent = ProjectEvent
+ { projectEvent_name :: Text,
+ projectEvent_description :: Text,
+ projectEvent_web_url :: Text,
+ projectEvent_avatar_url :: Maybe Text,
+ projectEvent_git_ssh_url :: Text,
+ projectEvent_git_http_url :: Text,
+ projectEvent_namespace :: Text,
+ projectEvent_visibility_level :: Visibility,
+ projectEvent_path_with_namespace :: Text,
+ projectEvent_default_branch :: Text,
+ -- projectEvent_ci_config_path :: Maybe Text,
+ projectEvent_homepage :: Maybe Text,
+ projectEvent_url :: Text,
+ projectEvent_ssh_url :: Text,
+ projectEvent_http_url :: Text
+ }
+ deriving (Typeable, Show, Eq, Generic)
+
+-- | A repository event.
+data RepositoryEvent = RepositoryEvent
+ { repositoryEvent_name :: Text,
+ repositoryEvent_url :: Text,
+ repositoryEvent_description :: Text,
+ repositoryEvent_homepage :: Maybe Text,
+ repositoryEvent_git_http_url :: Text,
+ repositoryEvent_git_ssh_url :: Text,
+ repositoryEvent_visibility_level :: Visibility
+ }
+ deriving (Typeable, Show, Eq, Generic)
+
+-- | A commit event.
+data CommitEvent = CommitEvent
+ { commitEvent_id :: Text,
+ commitEvent_message :: Text,
+ commitEvent_timestamp :: Text, -- TODO improve.
+ commitEvent_url :: Text,
+ commitEvent_author :: CommitAuthorEvent
+ }
+ deriving (Typeable, Show, Eq, Generic)
+
+-- | Commit author information.
+data CommitAuthorEvent = CommitAuthorEvent
+ { commitAuthorEvent_name :: Text,
+ commitAuthorEvent_email :: Text
+ }
+ deriving (Typeable, Show, Eq, Generic)
+
+data ProjectAction
+ = ProjectCreated
+ | ProjectDestroyed
+ | ProjectRenamed
+ | ProjectTransferred
+ | ProjectUpdated
+ | UserAddedToTeam
+ | UserUpdatedForTeam
+ | UserRemovedFromTeam
+ | UserCreated
+ | UserRemoved
+ | UserFailedToLogin
+ | UserRenamed
+ | KeyCreated
+ | KeyRemoved
+ | GroupCreated
+ | GroupRemoved
+ | GroupRenamed
+ | GroupMemberAdded
+ | GroupMemberRemoved
+ | GroupMemberUpdated
+ | Pushed
+ | TagPushed
+ deriving (Show, Eq)
+
+-- | Project visibility.
+data Visibility
+ = Public
+ | Private
+ | Internal
+ deriving (Show, Eq)
+
+instance FromJSON ProjectCreate where
+ parseJSON =
+ withObject "ProjectCreate" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ ProjectCreated ->
+ ProjectCreate
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "name"
+ <*> v .: "owner_email"
+ <*> v .: "owner_name"
+ <*> v .: "path"
+ <*> v .: "path_with_namespace"
+ <*> v .: "project_id"
+ <*> v .: "project_visibility"
+ _unexpected -> fail "project_create parsing failed"
+ _unexpected -> fail "project_create parsing failed"
+
+instance FromJSON ProjectDestroy where
+ parseJSON =
+ withObject "ProjectDestroy" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ ProjectDestroyed ->
+ ProjectDestroy
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "name"
+ <*> v .: "owner_email"
+ <*> v .: "owner_name"
+ <*> v .: "path"
+ <*> v .: "path_with_namespace"
+ <*> v .: "project_id"
+ <*> v .: "project_visibility"
+ _unexpected -> fail "project_destroy parsing failed"
+ _unexpected -> fail "project_destroy parsing failed"
+
+instance FromJSON ProjectRename where
+ parseJSON =
+ withObject "ProjectRename" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ ProjectRenamed ->
+ ProjectRename
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "name"
+ <*> v .: "path"
+ <*> v .: "path_with_namespace"
+ <*> v .: "project_id"
+ <*> v .: "owner_name"
+ <*> v .: "owner_email"
+ <*> v .: "project_visibility"
+ <*> v .: "old_path_with_namespace"
+ _unexpected -> fail "project_rename parsing failed"
+ _unexpected -> fail "project_rename parsing failed"
+
+instance FromJSON ProjectTransfer where
+ parseJSON =
+ withObject "ProjectTransfer" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ ProjectTransferred ->
+ ProjectTransfer
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "name"
+ <*> v .: "path"
+ <*> v .: "path_with_namespace"
+ <*> v .: "project_id"
+ <*> v .: "owner_name"
+ <*> v .: "owner_email"
+ <*> v .: "project_visibility"
+ <*> v .: "old_path_with_namespace"
+ _unexpected -> fail "project_transfer parsing failed"
+ _unexpected -> fail "project_transfer parsing failed"
+
+instance FromJSON ProjectUpdate where
+ parseJSON =
+ withObject "ProjectUpdate" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ ProjectUpdated ->
+ ProjectUpdate
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "name"
+ <*> v .: "owner_email"
+ <*> v .: "owner_name"
+ <*> v .: "path"
+ <*> v .: "path_with_namespace"
+ <*> v .: "project_id"
+ <*> v .: "project_visibility"
+ _unexpected -> fail "project_update parsing failed"
+ _unexpected -> fail "project_update parsing failed"
+
+instance FromJSON UserAddToTeam where
+ parseJSON =
+ withObject "UserAddToTeam" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ UserAddedToTeam ->
+ UserAddToTeam
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "access_level"
+ <*> v .: "project_id"
+ <*> v .: "project_name"
+ <*> v .: "project_path"
+ <*> v .: "project_path_with_namespace"
+ <*> v .: "user_email"
+ <*> v .: "user_name"
+ <*> v .: "user_username"
+ <*> v .: "user_id"
+ <*> v .: "project_visibility"
+ _unexpected -> fail "user_add_to_team parsing failed"
+ _unexpected -> fail "user_add_to_team parsing failed"
+
+instance FromJSON UserUpdateForTeam where
+ parseJSON =
+ withObject "UserUpdateForTeam" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ UserUpdatedForTeam ->
+ UserUpdateForTeam
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "access_level"
+ <*> v .: "project_id"
+ <*> v .: "project_name"
+ <*> v .: "project_path"
+ <*> v .: "project_path_with_namespace"
+ <*> v .: "user_email"
+ <*> v .: "user_name"
+ <*> v .: "user_username"
+ <*> v .: "user_id"
+ <*> v .: "project_visibility"
+ _unexpected -> fail "user_update_for_team parsing failed"
+ _unexpected -> fail "user_update_for_team parsing failed"
+
+instance FromJSON UserRemoveFromTeam where
+ parseJSON =
+ withObject "UserRemoveFromTeam" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ UserRemovedFromTeam ->
+ UserRemoveFromTeam
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "access_level"
+ <*> v .: "project_id"
+ <*> v .: "project_name"
+ <*> v .: "project_path"
+ <*> v .: "project_path_with_namespace"
+ <*> v .: "user_email"
+ <*> v .: "user_name"
+ <*> v .: "user_username"
+ <*> v .: "user_id"
+ <*> v .: "project_visibility"
+ _unexpected -> fail "user_remove_from_team parsing failed"
+ _unexpected -> fail "user_remove_from_team parsing failed"
+
+instance FromJSON UserCreate where
+ parseJSON =
+ withObject "UserCreate" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ UserCreated ->
+ UserCreate
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "email"
+ <*> v .: "event_name"
+ <*> v .: "name"
+ <*> v .: "username"
+ <*> v .: "user_id"
+ _unexpected -> fail "user_create parsing failed"
+ _unexpected -> fail "user_create parsing failed"
+
+instance FromJSON UserRemove where
+ parseJSON =
+ withObject "UserRemove" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ UserRemoved ->
+ UserRemove
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "email"
+ <*> v .: "event_name"
+ <*> v .: "name"
+ <*> v .: "username"
+ <*> v .: "user_id"
+ _unexpected -> fail "user_destroy parsing failed"
+ _unexpected -> fail "user_destroy parsing failed"
+
+instance FromJSON UserFailedLogin where
+ parseJSON =
+ withObject "UserFailedLogin" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ UserFailedToLogin ->
+ UserFailedLogin
+ <$> v .: "event_name"
+ <*> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "name"
+ <*> v .: "email"
+ <*> v .: "user_id"
+ <*> v .: "username"
+ <*> v .: "state"
+ _unexpected -> fail "user_failed_login parsing failed"
+ _unexpected -> fail "user_failed_login parsing failed"
+
+instance FromJSON UserRename where
+ parseJSON =
+ withObject "UserRename" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ UserRenamed ->
+ UserRename
+ <$> v .: "event_name"
+ <*> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "name"
+ <*> v .: "email"
+ <*> v .: "user_id"
+ <*> v .: "username"
+ <*> v .: "old_username"
+ _unexpected -> fail "user_rename parsing failed"
+ _unexpected -> fail "user_rename parsing failed"
+
+instance FromJSON KeyCreate where
+ parseJSON =
+ withObject "KeyCreate" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ KeyCreated ->
+ KeyCreate
+ <$> v .: "event_name"
+ <*> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "username"
+ <*> v .: "key"
+ <*> v .: "id"
+ _unexpected -> fail "key_create parsing failed"
+ _unexpected -> fail "key_create parsing failed"
+
+instance FromJSON KeyRemove where
+ parseJSON =
+ withObject "KeyRemove" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ KeyRemoved ->
+ KeyRemove
+ <$> v .: "event_name"
+ <*> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "username"
+ <*> v .: "key"
+ <*> v .: "id"
+ _unexpected -> fail "key_destroy parsing failed"
+ _unexpected -> fail "key_destroy parsing failed"
+
+instance FromJSON GroupCreate where
+ parseJSON =
+ withObject "GroupCreate" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ GroupCreated ->
+ GroupCreate
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "name"
+ <*> v .: "owner_email"
+ <*> v .: "owner_name"
+ <*> v .: "path"
+ <*> v .: "group_id"
+ _unexpected -> fail "group_create parsing failed"
+ _unexpected -> fail "group_create parsing failed"
+
+instance FromJSON GroupRemove where
+ parseJSON =
+ withObject "GroupRemove" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ GroupRemoved ->
+ GroupRemove
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "name"
+ <*> v .: "owner_email"
+ <*> v .: "owner_name"
+ <*> v .: "path"
+ <*> v .: "group_id"
+ _unexpected -> fail "group_remove parsing failed"
+ _unexpected -> fail "group_remove parsing failed"
+
+instance FromJSON GroupRename where
+ parseJSON =
+ withObject "GroupRename" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ GroupRenamed ->
+ GroupRename
+ <$> v .: "event_name"
+ <*> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "name"
+ <*> v .: "path"
+ <*> v .: "full_path"
+ <*> v .: "group_id"
+ <*> v .: "owner_name"
+ <*> v .: "owner_email"
+ <*> v .: "old_path"
+ <*> v .: "old_full_path"
+ _unexpected -> fail "group_rename parsing failed"
+ _unexpected -> fail "group_rename parsing failed"
+
+instance FromJSON NewGroupMember where
+ parseJSON =
+ withObject "NewGroupMember" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ GroupMemberAdded ->
+ NewGroupMember
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "group_access"
+ <*> v .: "group_id"
+ <*> v .: "group_name"
+ <*> v .: "group_path"
+ <*> v .: "user_email"
+ <*> v .: "user_name"
+ <*> v .: "user_username"
+ <*> v .: "user_id"
+ _unexpected -> fail "user_add_to_group parsing failed"
+ _unexpected -> fail "user_add_to_group parsing failed"
+
+instance FromJSON GroupMemberRemove where
+ parseJSON =
+ withObject "GroupMemberRemove" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ GroupMemberRemoved ->
+ GroupMemberRemove
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "group_access"
+ <*> v .: "group_id"
+ <*> v .: "group_name"
+ <*> v .: "group_path"
+ <*> v .: "user_email"
+ <*> v .: "user_name"
+ <*> v .: "user_username"
+ <*> v .: "user_id"
+ _unexpected -> fail "user_remove_from_group parsing failed"
+ _unexpected -> fail "user_remove_from_group parsing failed"
+
+instance FromJSON GroupMemberUpdate where
+ parseJSON =
+ withObject "GroupMemberUpdate" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ GroupMemberUpdated ->
+ GroupMemberUpdate
+ <$> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> v .: "event_name"
+ <*> v .: "group_access"
+ <*> v .: "group_id"
+ <*> v .: "group_name"
+ <*> v .: "group_path"
+ <*> v .: "user_email"
+ <*> v .: "user_name"
+ <*> v .: "user_username"
+ <*> v .: "user_id"
+ _unexpected -> fail "user_update_for_group parsing failed"
+ _unexpected -> fail "user_update_for_group parsing failed"
+
+instance FromJSON Push where
+ parseJSON =
+ withObject "Push" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ Pushed ->
+ Push
+ <$> v .: "event_name"
+ <*> v .: "before"
+ <*> v .: "after"
+ <*> v .: "ref"
+ <*> v .: "checkout_sha"
+ <*> v .: "user_id"
+ <*> v .: "user_name"
+ <*> v .: "user_email"
+ <*> v .: "user_avatar"
+ <*> v .: "project_id"
+ <*> v .: "project"
+ <*> v .: "repository"
+ <*> v .: "commits"
+ <*> v .: "total_commits_count"
+ _unexpected -> fail "push parsing failed"
+ _unexpected -> fail "push parsing failed"
+
+instance FromJSON TagPush where
+ parseJSON =
+ withObject "Push" $ \v -> do
+ isProjectEvent <- v .:? "event_name"
+ case isProjectEvent of
+ Just theEvent ->
+ case theEvent of
+ TagPushed ->
+ TagPush
+ <$> v .: "event_name"
+ <*> v .: "before"
+ <*> v .: "after"
+ <*> v .: "ref"
+ <*> v .: "checkout_sha"
+ <*> v .: "user_id"
+ <*> v .: "user_name"
+ <*> v .: "user_avatar"
+ <*> v .: "project_id"
+ <*> v .: "project"
+ <*> v .: "repository"
+ <*> v .: "commits"
+ <*> v .: "total_commits_count"
+ _unexpected -> fail "tag_push parsing failed"
+ _unexpected -> fail "tag_push parsing failed"
+
+bodyNoPrefix :: String -> String
+bodyNoPrefix "projectEvent_name" = "name"
+bodyNoPrefix "projectEvent_description" = "description"
+bodyNoPrefix "projectEvent_web_url" = "web_url"
+bodyNoPrefix "projectEvent_avatar_url" = "avatar_url"
+bodyNoPrefix "projectEvent_git_ssh_url" = "git_ssh_url"
+bodyNoPrefix "projectEvent_git_http_url" = "git_http_url"
+bodyNoPrefix "projectEvent_namespace" = "namespace"
+bodyNoPrefix "projectEvent_visibility_level" = "visibility_level"
+bodyNoPrefix "projectEvent_path_with_namespace" = "path_with_namespace"
+bodyNoPrefix "projectEvent_default_branch" = "default_branch"
+-- bodyNoPrefix "projectEvent_ci_config_path" = "ci_config_path"
+bodyNoPrefix "projectEvent_homepage" = "homepage"
+bodyNoPrefix "projectEvent_url" = "url"
+bodyNoPrefix "projectEvent_ssh_url" = "ssh_url"
+bodyNoPrefix "projectEvent_http_url" = "http_url"
+bodyNoPrefix "repositoryEvent_name" = "name"
+bodyNoPrefix "repositoryEvent_url" = "url"
+bodyNoPrefix "repositoryEvent_description" = "description"
+bodyNoPrefix "repositoryEvent_homepage" = "homepage"
+bodyNoPrefix "repositoryEvent_git_http_url" = "git_http_url"
+bodyNoPrefix "repositoryEvent_git_ssh_url" = "git_ssh_url"
+bodyNoPrefix "repositoryEvent_visibility_level" = "visibility_level"
+bodyNoPrefix "commitEvent_id" = "id"
+bodyNoPrefix "commitEvent_message" = "message"
+bodyNoPrefix "commitEvent_timestamp" = "timestamp"
+bodyNoPrefix "commitEvent_url" = "url"
+bodyNoPrefix "commitEvent_author" = "author"
+bodyNoPrefix "commitAuthorEvent_name" = "name"
+bodyNoPrefix "commitAuthorEvent_email" = "email"
+bodyNoPrefix s = error s
+
+instance FromJSON ProjectEvent where
+ parseJSON =
+ genericParseJSON
+ ( defaultOptions
+ { fieldLabelModifier = bodyNoPrefix
+ }
+ )
+
+instance FromJSON CommitEvent where
+ parseJSON =
+ genericParseJSON
+ ( defaultOptions
+ { fieldLabelModifier = bodyNoPrefix
+ }
+ )
+
+instance FromJSON RepositoryEvent where
+ parseJSON =
+ genericParseJSON
+ ( defaultOptions
+ { fieldLabelModifier = bodyNoPrefix
+ }
+ )
+
+instance FromJSON CommitAuthorEvent where
+ parseJSON =
+ genericParseJSON
+ ( defaultOptions
+ { fieldLabelModifier = bodyNoPrefix
+ }
+ )
+
+instance FromJSON ProjectAction where
+ parseJSON (String "project_create") = return ProjectCreated
+ parseJSON (String "project_destroy") = return ProjectDestroyed
+ parseJSON (String "project_rename") = return ProjectRenamed
+ parseJSON (String "project_transfer") = return ProjectTransferred
+ parseJSON (String "project_update") = return ProjectUpdated
+ parseJSON (String "user_add_to_team") = return UserAddedToTeam
+ parseJSON (String "user_update_for_team") = return UserUpdatedForTeam
+ parseJSON (String "user_remove_from_team") = return UserRemovedFromTeam
+ parseJSON (String "user_create") = return UserCreated
+ parseJSON (String "user_destroy") = return UserRemoved
+ parseJSON (String "user_failed_login") = return UserFailedToLogin
+ parseJSON (String "user_rename") = return UserRenamed
+ parseJSON (String "key_create") = return KeyCreated
+ parseJSON (String "key_destroy") = return KeyRemoved
+ parseJSON (String "group_create") = return GroupCreated
+ parseJSON (String "group_destroy") = return GroupRemoved
+ parseJSON (String "group_rename") = return GroupRenamed
+ parseJSON (String "user_add_to_group") = return GroupMemberAdded
+ parseJSON (String "user_remove_from_group") = return GroupMemberRemoved
+ parseJSON (String "user_update_for_group") = return GroupMemberUpdated
+ parseJSON (String "push") = return Pushed
+ parseJSON (String "tag_push") = return TagPushed
+ parseJSON s = error (show s)
+
+instance FromJSON Visibility where
+ parseJSON (String "public") = return Public
+ parseJSON (String "private") = return Private
+ parseJSON (String "internal") = return Internal
+ parseJSON (Number 0) = return Private
+ parseJSON (Number 10) = return Internal
+ parseJSON (Number 20) = return Public
+ parseJSON n = error (show n)
diff --git a/src/GitLab/Types.hs b/src/GitLab/Types.hs
--- a/src/GitLab/Types.hs
+++ b/src/GitLab/Types.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
-- |
-- Module : GitLab.Types
@@ -21,11 +22,14 @@
Links (..),
Owner (..),
Permissions (..),
+ ProjectId,
Project (..),
ProjectStats (..),
User (..),
Milestone (..),
+ MilestoneState (..),
TimeStats (..),
+ IssueId,
Issue (..),
Pipeline (..),
Commit (..),
@@ -41,11 +45,13 @@
RepositoryFile (..),
MergeRequest (..),
Todo (..),
+ TodoProject (..),
TodoAction (..),
TodoTarget (..),
TodoState (..),
Version (..),
URL,
+ EditIssueReq (..),
)
where
@@ -53,31 +59,30 @@
import Data.Aeson
import Data.Aeson.Types
import Data.Text (Text)
+import qualified Data.Text as T
import Data.Time.Clock
import GHC.Generics
import Network.HTTP.Conduit
-- | type synonym for all GitLab actions.
-type GitLab m a = ReaderT GitLabState m a
+type GitLab a = ReaderT GitLabState IO a
-- | state used by GitLab actions, used internally.
-data GitLabState
- = GitLabState
- { serverCfg :: GitLabServerConfig,
- httpManager :: Manager
- }
+data GitLabState = GitLabState
+ { serverCfg :: GitLabServerConfig,
+ httpManager :: Manager
+ }
-- | configuration data specific to a GitLab server.
-data GitLabServerConfig
- = GitLabServerConfig
- { url :: Text,
- -- | personal access token, see
- token :: Text,
- -- | milliseconds
- timeout :: Int,
- -- | how many times to retry a HTTP request before giving up and returning an error.
- retries :: Int
- }
+data GitLabServerConfig = GitLabServerConfig
+ { url :: Text,
+ -- | personal access token, see
+ token :: Text,
+ -- | milliseconds
+ timeout :: Int,
+ -- | how many times to retry a HTTP request before giving up and returning an error.
+ retries :: Int
+ }
-- | default settings, the 'url' and 'token' values will need to be overwritten.
defaultGitLabServer :: GitLabServerConfig
@@ -123,138 +128,130 @@
show Zip = ".zip"
-- | member of a project.
-data Member
- = Member
- { member_id :: Int,
- member_name :: Text,
- member_username :: Text,
- member_state :: Text,
- member_avatar_uri :: Maybe Text,
- member_web_url :: Maybe Text,
- access_level :: Int,
- expires_at :: Maybe Text
- }
+data Member = Member
+ { member_id :: Int,
+ member_name :: Text,
+ member_username :: Text,
+ member_state :: Text,
+ member_avatar_uri :: Maybe Text,
+ member_web_url :: Maybe Text,
+ access_level :: Int,
+ expires_at :: Maybe Text
+ }
deriving (Generic, Show)
-- | namespaces.
-data Namespace
- = Namespace
- { namespace_id :: Int,
- namespace_name :: Text,
- namespace_path :: Text,
- kind :: Text,
- full_path :: Text,
- parent_id :: Maybe Int
- }
+data Namespace = Namespace
+ { namespace_id :: Int,
+ namespace_name :: Text,
+ namespace_path :: Text,
+ kind :: Text,
+ full_path :: Text,
+ parent_id :: Maybe Int
+ }
deriving (Generic, Show)
-- | links.
-data Links
- = Links
- { self :: Text,
- issues :: Text,
- merge_requests :: Text,
- repo_branches :: Text,
- link_labels :: Text,
- link_events :: Text,
- members :: Text
- }
+data Links = Links
+ { self :: Text,
+ issues :: Text,
+ merge_requests :: Text,
+ repo_branches :: Text,
+ link_labels :: Text,
+ link_events :: Text,
+ members :: Text
+ }
deriving (Generic, Show)
-- | owners.
-data Owner
- = Ownwer
- { owner_id :: Int,
- owner_name :: Text,
- owner_username :: Text,
- state :: Text,
- owner_avatar_url :: Maybe Text,
- owner_web_url :: Text
- }
+data Owner = Ownwer
+ { owner_id :: Int,
+ owner_name :: Text,
+ owner_username :: Text,
+ state :: Text,
+ owner_avatar_url :: Maybe Text,
+ owner_web_url :: Text
+ }
deriving (Generic, Show)
-- | permissions.
-data Permissions
- = Permissions
- { project_access :: Maybe Object,
- group_access :: Maybe Object
- }
+data Permissions = Permissions
+ { project_access :: Maybe Object,
+ group_access :: Maybe Object
+ }
deriving (Generic, Show)
-- | projects.
-data Project
- = Project
- { project_id :: Int,
- description :: Maybe Text,
- project_name :: Text,
- name_with_namespace :: Text,
- project_path :: Text,
- path_with_namespace :: Text,
- project_created_at :: Text,
- default_branch :: Maybe Text,
- tag_list :: [Text], -- check
- ssh_url_to_repo :: Text,
- http_url_to_repo :: Text,
- project_web_url :: Text,
- readme_url :: Maybe Text, -- check
- project_avatar_url :: Maybe Text, -- check
- star_count :: Int,
- forks_count :: Int,
- last_activity_at :: Text,
- namespace :: Namespace,
- _links :: Maybe Links,
- archived :: Maybe Bool,
- visibility :: Maybe Text,
- owner :: Maybe Owner,
- resolve_outdated_diff_discussions :: Maybe Bool,
- container_registry_enabled :: Maybe Bool,
- issues_enabled :: Maybe Bool,
- merge_requests_enabled :: Maybe Bool,
- wiki_enabled :: Maybe Bool,
- jobs_enabled :: Maybe Bool,
- snippets_enabled :: Maybe Bool,
- shared_runners_enabled :: Maybe Bool,
- lfs_enabled :: Maybe Bool,
- creator_id :: Maybe Int,
- forked_from_project :: Maybe Project,
- import_status :: Maybe String,
- open_issues_count :: Maybe Int,
- public_jobs :: Maybe Bool,
- ci_config_path :: Maybe Text, -- check null
- shared_with_groups :: Maybe [Object],
- only_allow_merge_if_pipeline_succeeds :: Maybe Bool,
- request_access_enabled :: Maybe Bool,
- only_allow_merge_if_all_discussions_are_resolved :: Maybe Bool,
- printing_merge_request_link_enabled :: Maybe Bool,
- merge_method :: Maybe Text,
- permissions :: Maybe Permissions,
- project_stats :: Maybe ProjectStats
- }
+data Project = Project
+ { project_id :: Int,
+ description :: Maybe Text,
+ project_name :: Text,
+ name_with_namespace :: Text,
+ project_path :: Text,
+ project_path_with_namespace :: Text,
+ project_created_at :: Text,
+ default_branch :: Maybe Text,
+ tag_list :: [Text], -- check
+ ssh_url_to_repo :: Text,
+ http_url_to_repo :: Text,
+ project_web_url :: Text,
+ readme_url :: Maybe Text, -- check
+ project_avatar_url :: Maybe Text, -- check
+ star_count :: Int,
+ forks_count :: Int,
+ last_activity_at :: Text,
+ namespace :: Namespace,
+ _links :: Maybe Links,
+ archived :: Maybe Bool,
+ visibility :: Maybe Text,
+ owner :: Maybe Owner,
+ resolve_outdated_diff_discussions :: Maybe Bool,
+ container_registry_enabled :: Maybe Bool,
+ issues_enabled :: Maybe Bool,
+ merge_requests_enabled :: Maybe Bool,
+ wiki_enabled :: Maybe Bool,
+ jobs_enabled :: Maybe Bool,
+ snippets_enabled :: Maybe Bool,
+ shared_runners_enabled :: Maybe Bool,
+ lfs_enabled :: Maybe Bool,
+ creator_id :: Maybe Int,
+ forked_from_project :: Maybe Project,
+ import_status :: Maybe String,
+ open_issues_count :: Maybe Int,
+ public_jobs :: Maybe Bool,
+ ci_config_path :: Maybe Text, -- check null
+ shared_with_groups :: Maybe [Object],
+ only_allow_merge_if_pipeline_succeeds :: Maybe Bool,
+ request_access_enabled :: Maybe Bool,
+ only_allow_merge_if_all_discussions_are_resolved :: Maybe Bool,
+ printing_merge_request_link_enabled :: Maybe Bool,
+ merge_method :: Maybe Text,
+ permissions :: Maybe Permissions,
+ project_stats :: Maybe ProjectStats
+ }
deriving (Generic, Show)
-- | project statistics.
-data ProjectStats
- = ProjectStats
- { commit_count :: Int,
- storage_size :: Int,
- repository_size :: Int,
- wiki_size :: Maybe Int,
- lfs_objects_size :: Maybe Int,
- job_artifacts_size :: Maybe Int,
- packages_size :: Maybe Int
- }
+data ProjectStats = ProjectStats
+ { commit_count :: Int,
+ storage_size :: Int,
+ repository_size :: Int,
+ wiki_size :: Maybe Int,
+ lfs_objects_size :: Maybe Int,
+ job_artifacts_size :: Maybe Int,
+ packages_size :: Maybe Int
+ }
deriving (Generic, Show)
-- | registered users.
-data User
- = User
- { user_id :: Int,
- user_username :: Text,
- user_name :: Text,
- user_state :: Text,
- user_avatar_uri :: Maybe Text,
- user_web_url :: Maybe Text
- }
+data User = User
+ { user_id :: Int,
+ user_username :: Text,
+ user_name :: Text,
+ user_state :: Text,
+ user_avatar_uri :: Maybe Text,
+ user_web_url :: Maybe Text
+ }
deriving (Generic, Show)
-- | milestone state.
@@ -269,282 +266,272 @@
parseJSON x = unexpected x
-- | milestones.
-data Milestone
- = Milestone
- { milestone_project_id :: Maybe Int,
- milestone_group_id :: Maybe Int,
- milestone_description :: Text,
- milestone_state :: MilestoneState,
- milestone_due_date :: Maybe UTCTime,
- milestone_iid :: Int,
- milestone_created_at :: Maybe UTCTime,
- milestone_title :: Text,
- milestone_id :: Int,
- milestone_updated_at :: UTCTime,
- milestone_web_url :: URL
- }
+data Milestone = Milestone
+ { milestone_project_id :: Maybe Int,
+ milestone_group_id :: Maybe Int,
+ milestone_description :: Text,
+ milestone_state :: MilestoneState,
+ milestone_due_date :: Maybe UTCTime,
+ milestone_iid :: Int,
+ milestone_created_at :: Maybe UTCTime,
+ milestone_title :: Text,
+ milestone_id :: Int,
+ milestone_updated_at :: UTCTime,
+ milestone_web_url :: URL
+ }
deriving (Generic, Show)
instance FromJSON Milestone where
parseJSON = genericParseJSON (defaultOptions {fieldLabelModifier = drop 10})
-- | time stats.
-data TimeStats
- = TimeStats
- { time_estimate :: Int,
- total_time_spent :: Int,
- humane_time_estimate :: Maybe Int,
- human_total_time_spent :: Maybe Int
- }
+data TimeStats = TimeStats
+ { time_estimate :: Int,
+ total_time_spent :: Int,
+ humane_time_estimate :: Maybe Int,
+ human_total_time_spent :: Maybe Int
+ }
deriving (Generic, Show)
+-- | alias for project id
+type ProjectId = Int
+
+-- | alias for issue id
+type IssueId = Int
+
-- | project issues.
-data Issue
- = Issue
- { issue_state :: Text,
- issue_description :: Text,
- issue_author :: User,
- milestone :: Maybe Milestone,
- issue_project_id :: Int,
- assignees :: Maybe [User],
- assignee :: Maybe User,
- updated_at :: Text,
- closed_at :: Maybe Text,
- closed_by :: Maybe User,
- issue_id :: Int,
- issue_title :: Text,
- issue_created_at :: Text,
- iid :: Int,
- issue_labels :: [Text],
- upvotes :: Int,
- downvotes :: Int,
- user_notes_count :: Int,
- issue_due_date :: Maybe Text,
- issue_web_url :: Text,
- confidential :: Bool,
- weight :: Maybe Text, -- Int?
- discussion_locked :: Maybe Bool,
- time_stats :: TimeStats
- }
+data Issue = Issue
+ { issue_state :: Text,
+ issue_description :: Maybe Text,
+ issue_author :: User,
+ milestone :: Maybe Milestone,
+ issue_project_id :: ProjectId,
+ assignees :: Maybe [User],
+ assignee :: Maybe User,
+ updated_at :: Text,
+ closed_at :: Maybe Text,
+ closed_by :: Maybe User,
+ issue_id :: IssueId,
+ issue_title :: Text,
+ issue_created_at :: Text,
+ iid :: Int,
+ issue_labels :: [Text],
+ upvotes :: Int,
+ downvotes :: Int,
+ user_notes_count :: Int,
+ issue_due_date :: Maybe Text,
+ issue_web_url :: Text,
+ confidential :: Bool,
+ weight :: Maybe Text, -- Int?
+ discussion_locked :: Maybe Bool,
+ time_stats :: TimeStats
+ }
deriving (Generic, Show)
-- | project pipelines
-data Pipeline
- = Pipeline
- { pipeline_id :: Int,
- sha :: Text,
- pipeline_ref :: Text,
- pipeline_status :: Text,
- pipeline_web_url :: Maybe Text
- }
+data Pipeline = Pipeline
+ { pipeline_id :: Int,
+ sha :: Text,
+ pipeline_ref :: Text,
+ pipeline_status :: Text,
+ pipeline_web_url :: Maybe Text
+ }
deriving (Generic, Show)
-- | code commits.
-data Commit
- = Commit
- { commit_id :: Text,
- short_id :: Text,
- title :: Text,
- author_name :: Text,
- author_email :: Text,
- authored_date :: Text,
- committer_name :: Text,
- committer_email :: Text,
- committed_date :: Text,
- commit_created_at :: Text,
- message :: Text,
- parent_ids :: Maybe [Int],
- last_pipeline :: Maybe Pipeline,
- commit_stats :: Maybe CommitStats,
- commit_status :: Maybe Text
- }
+data Commit = Commit
+ { commit_id :: Text,
+ short_id :: Text,
+ title :: Text,
+ author_name :: Text,
+ author_email :: Text,
+ authored_date :: Text,
+ committer_name :: Text,
+ committer_email :: Text,
+ committed_date :: Text,
+ commit_created_at :: Text,
+ message :: Text,
+ commit_parent_ids :: Maybe [String],
+ last_pipeline :: Maybe Pipeline,
+ commit_stats :: Maybe CommitStats,
+ commit_status :: Maybe Text
+ }
deriving (Generic, Show)
-- | summary of a code commit for TODOs.
-data CommitTodo
- = CommitTodo
- { todo_commit_id :: Text,
- todo_commit_short_id :: Text,
- todo_commit_created_at :: Text,
- todo_parent_ids :: Maybe [Int]
- }
+data CommitTodo = CommitTodo
+ { todo_commit_id :: Text,
+ todo_commit_short_id :: Text,
+ todo_commit_created_at :: Text,
+ todo_parent_ids :: Maybe [String]
+ }
deriving (Generic, Show)
-- | commit stats.
-data CommitStats
- = Stats
- { additions :: Int,
- deletions :: Int,
- total :: Int
- }
+data CommitStats = Stats
+ { additions :: Int,
+ deletions :: Int,
+ total :: Int
+ }
deriving (Generic, Show)
-- | diff between two commits.
-data Diff
- = Diff
- { diff :: Text,
- new_path :: Text,
- old_path :: Text,
- a_mode :: Maybe Text,
- b_mode :: Maybe Text,
- new_file :: Bool,
- renamed_file :: Bool,
- deleted_file :: Bool
- }
+data Diff = Diff
+ { diff :: Text,
+ new_path :: Text,
+ old_path :: Text,
+ a_mode :: Maybe Text,
+ b_mode :: Maybe Text,
+ new_file :: Bool,
+ renamed_file :: Bool,
+ deleted_file :: Bool
+ }
deriving (Generic, Show)
-- | repositories.
-data Repository
- = Repository
- { repository_id :: Text,
- repository_name :: Text,
- repository_type :: Text,
- repository_path :: Text,
- mode :: Text
- }
+data Repository = Repository
+ { repository_id :: Text,
+ repository_name :: Text,
+ repository_type :: Text,
+ repository_path :: Text,
+ mode :: Text
+ }
deriving (Generic, Show)
-- | jobs.
-data Job
- = Job
- { commit :: Commit,
- coverage :: Maybe Text, -- ?
- created_at :: Text,
- started_at :: Text,
- finished_at :: Text,
- duration :: Double,
- artifacts_expire_at :: Maybe Text,
- id :: Int,
- name :: Text,
- pipeline :: Pipeline,
- job_ref :: Text,
- artifacts :: [Artifact],
- -- , runner :: Maybe Text
- stage :: Text,
- status :: Text,
- tag :: Bool,
- job_web_url :: Text,
- user :: User
- }
+data Job = Job
+ { job_commit :: Commit,
+ job_coverage :: Maybe Text, -- ?
+ job_created_at :: Text,
+ job_started_at :: Text,
+ job_finished_at :: Text,
+ job_duration :: Double,
+ job_artifacts_expire_at :: Maybe Text,
+ job_id :: Int,
+ job_name :: Text,
+ job_pipeline :: Pipeline,
+ job_ref :: Text,
+ job_artifacts :: [Artifact],
+ -- , runner :: Maybe Text
+ job_stage :: Text,
+ job_status :: Text,
+ job_tag :: Bool,
+ job_web_url :: Text,
+ job_user :: User
+ }
deriving (Generic, Show)
-- | artifacts.
-data Artifact
- = Artifact
- { file_type :: Text,
- size :: Int,
- filename :: Text,
- file_format :: Maybe Text
- }
+data Artifact = Artifact
+ { file_type :: Text,
+ size :: Int,
+ filename :: Text,
+ file_format :: Maybe Text
+ }
deriving (Generic, Show)
-- | groups.
-data Group
- = Group
- { group_id :: Int,
- group_name :: Text,
- group_path :: Text,
- group_description :: Text,
- group_visibility :: Text,
- group_lfs_enabled :: Bool,
- group_avatar_url :: Maybe Text,
- group_web_url :: Text,
- group_request_access_enabled :: Bool,
- group_full_name :: Text,
- group_full_path :: Text,
- group_file_template_project_id :: Maybe Int,
- group_parent_id :: Maybe Int
- }
+data Group = Group
+ { group_id :: Int,
+ group_name :: Text,
+ group_path :: Text,
+ group_description :: Text,
+ group_visibility :: Text,
+ group_lfs_enabled :: Bool,
+ group_avatar_url :: Maybe Text,
+ group_web_url :: Text,
+ group_request_access_enabled :: Bool,
+ group_full_name :: Text,
+ group_full_path :: Text,
+ group_file_template_project_id :: Maybe Int,
+ group_parent_id :: Maybe Int
+ }
deriving (Generic, Show)
-- | response to sharing a project with a group.
-data GroupShare
- = GroupShare
- { share_id :: Int,
- share_project_id :: Int,
- share_group_id :: Int,
- share_group_access :: Int,
- share_expires_at :: Maybe Text
- }
+data GroupShare = GroupShare
+ { share_id :: Int,
+ share_project_id :: Int,
+ share_group_id :: Int,
+ share_group_access :: Int,
+ share_expires_at :: Maybe Text
+ }
deriving (Generic, Show)
-- | code branches.
-data Branch
- = Branch
- { branch_name :: Text,
- merged :: Bool,
- protected :: Bool,
- branch_default :: Bool,
- developers_can_push :: Bool,
- developers_can_merge :: Bool,
- can_push :: Bool,
- branch_commit :: Commit
- }
+data Branch = Branch
+ { branch_name :: Text,
+ merged :: Bool,
+ protected :: Bool,
+ branch_default :: Bool,
+ developers_can_push :: Bool,
+ developers_can_merge :: Bool,
+ can_push :: Bool,
+ branch_commit :: Commit
+ }
deriving (Generic, Show)
-- | files in a repository.
-data RepositoryFile
- = RepositoryFile
- { repository_file_file_name :: Text,
- repository_file_file_path :: Text,
- repository_file_size :: Int,
- encoding :: Text,
- content :: Text,
- content_sha256 :: Text,
- ref :: Text,
- blob_id :: Text,
- repository_file_commit_id :: Text,
- last_commit_id :: Text
- }
+data RepositoryFile = RepositoryFile
+ { repository_file_file_name :: Text,
+ repository_file_file_path :: Text,
+ repository_file_size :: Int,
+ encoding :: Text,
+ content :: Text,
+ content_sha256 :: Text,
+ ref :: Text,
+ blob_id :: Text,
+ repository_file_commit_id :: Text,
+ last_commit_id :: Text
+ }
deriving (Generic, Show)
-- | project merge requests.
-data MergeRequest
- = MergeRequest
- { merge_request_id :: Int,
- merge_request_iid :: Int,
- merge_request_project_id :: Int,
- merge_request_title :: Text,
- merge_request_description :: Text,
- merge_request_state :: Text,
- merge_request_merged_by :: Maybe User,
- merge_request_merged_at :: Maybe Text,
- merge_request_closed_by :: Maybe User,
- merge_request_closed_at :: Maybe Text,
- merge_request_created_at :: Text,
- merge_request_updated_at :: Text,
- merge_request_target_branch :: Text,
- merge_request_source_branch :: Text,
- merge_request_upvotes :: Int,
- merge_request_downvotes :: Int,
- merge_request_author :: User,
- merge_request_assignee :: Maybe User,
- merge_request_source_project_id :: Int,
- merge_request_target_project_id :: Int,
- merge_request_labels :: [Text],
- merge_request_work_in_progress :: Bool,
- merge_request_milestone :: Maybe Milestone,
- merge_request_merge_when_pipeline_succeeds :: Bool,
- merge_request_merge_status :: Text,
- merge_request_sha :: Text,
- merge_request_merge_commit_sha :: Maybe Text,
- merge_request_user_notes_count :: Int,
- merge_request_discussion_locked :: Maybe Bool,
- merge_request_should_remove_source_branch :: Maybe Bool,
- merge_request_force_remove_source_branch :: Maybe Bool,
- merge_request_allow_collaboration :: Maybe Bool,
- merge_request_allow_maintainer_to_push :: Maybe Bool,
- merge_request_web_url :: Text,
- merge_request_time_stats :: TimeStats,
- merge_request_squash :: Bool,
- merge_request_changes_count :: Maybe Int,
- merge_request_pipeline :: Maybe Pipeline,
- merge_request_diverged_commits_count :: Maybe Int,
- merge_request_rebase_in_progress :: Maybe Bool,
- merge_request_has_conflicts :: Bool,
- merge_request_blocking_discussions_resolved :: Maybe Bool,
- merge_request_approvals_before_merge :: Maybe Bool -- ?
- }
+data MergeRequest = MergeRequest
+ { merge_request_id :: Int,
+ merge_request_iid :: Int,
+ merge_request_project_id :: Int,
+ merge_request_title :: Text,
+ merge_request_description :: Text,
+ merge_request_state :: Text,
+ merge_request_merged_by :: Maybe User,
+ merge_request_merged_at :: Maybe Text,
+ merge_request_closed_by :: Maybe User,
+ merge_request_closed_at :: Maybe Text,
+ merge_request_created_at :: Text,
+ merge_request_updated_at :: Text,
+ merge_request_target_branch :: Text,
+ merge_request_source_branch :: Text,
+ merge_request_upvotes :: Int,
+ merge_request_downvotes :: Int,
+ merge_request_author :: User,
+ merge_request_assignee :: Maybe User,
+ merge_request_source_project_id :: Int,
+ merge_request_target_project_id :: Int,
+ merge_request_labels :: [Text],
+ merge_request_work_in_progress :: Bool,
+ merge_request_milestone :: Maybe Milestone,
+ merge_request_merge_when_pipeline_succeeds :: Bool,
+ merge_request_merge_status :: Text,
+ merge_request_sha :: Text,
+ merge_request_merge_commit_sha :: Maybe Text,
+ merge_request_user_notes_count :: Int,
+ merge_request_discussion_locked :: Maybe Bool,
+ merge_request_should_remove_source_branch :: Maybe Bool,
+ merge_request_force_remove_source_branch :: Maybe Bool,
+ merge_request_allow_collaboration :: Maybe Bool,
+ merge_request_allow_maintainer_to_push :: Maybe Bool,
+ merge_request_web_url :: Text,
+ merge_request_time_stats :: TimeStats,
+ merge_request_squash :: Bool,
+ merge_request_changes_count :: Maybe Int,
+ merge_request_pipeline :: Maybe Pipeline,
+ merge_request_diverged_commits_count :: Maybe Int,
+ merge_request_rebase_in_progress :: Maybe Bool,
+ merge_request_has_conflicts :: Bool,
+ merge_request_blocking_discussions_resolved :: Maybe Bool,
+ merge_request_approvals_before_merge :: Maybe Bool -- ?
+ }
deriving (Generic, Show)
-- | TODO actions.
@@ -589,34 +576,33 @@
parseJSON (String "done") = return TSDone
parseJSON x = unexpected x
-data TodoProject
- = TP
- { tp_id :: Int,
- tp_description :: Text,
- tp_name :: Text,
- tp_name_with_namespace :: Text,
- tp_path :: Text,
- tp_path_with_namespace :: Text,
- tp_created_at :: UTCTime
- }
+-- | A project TODO.
+data TodoProject = TP
+ { tp_id :: Int,
+ tp_description :: Text,
+ tp_name :: Text,
+ tp_name_with_namespace :: Text,
+ tp_path :: Text,
+ tp_path_with_namespace :: Text,
+ tp_created_at :: UTCTime
+ }
deriving (Generic, Show)
instance FromJSON TodoProject where
parseJSON = genericParseJSON (defaultOptions {fieldLabelModifier = drop 3})
-- | TODOs.
-data Todo
- = Todo
- { todo_id :: Int,
- todo_project :: TodoProject,
- todo_author :: User,
- todo_action_name :: TodoAction,
- todo_target :: TodoTarget,
- todo_target_url :: URL,
- todo_body :: Text,
- todo_state :: TodoState,
- todo_created_at :: UTCTime
- }
+data Todo = Todo
+ { todo_id :: Int,
+ todo_project :: TodoProject,
+ todo_author :: User,
+ todo_action_name :: TodoAction,
+ todo_target :: TodoTarget,
+ todo_target_url :: URL,
+ todo_body :: Text,
+ todo_state :: TodoState,
+ todo_created_at :: UTCTime
+ }
deriving (Show)
instance FromJSON Todo where
@@ -638,13 +624,32 @@
<*> v .: "created_at"
-- | version of the GitLab instance.
-data Version
- = Version
- { version :: Text,
- revision :: Text
- }
+data Version = Version
+ { version :: Text,
+ revision :: Text
+ }
deriving (Generic, Show)
+-- | An edit issue request.
+data EditIssueReq = EditIssueReq
+ { edit_issue_id :: ProjectId,
+ edit_issue_issue_iid :: IssueId,
+ edit_issue_title :: Maybe Text,
+ edit_issue_description :: Maybe Text,
+ edit_issue_confidential :: Maybe Bool,
+ edit_issue_assignee_ids :: Maybe [Int],
+ edit_issue_milestone_id :: Maybe Int,
+ edit_issue_labels :: Maybe [Text],
+ edit_issue_state_event :: Maybe Text,
+ edit_issue_updated_at :: Maybe Text,
+ edit_issue_due_date :: Maybe Text,
+ edit_issue_weight :: Maybe Int,
+ edit_issue_discussion_locked :: Maybe Bool,
+ edit_issue_epic_id :: Maybe Int,
+ edit_issue_epic_iid :: Maybe Int
+ }
+ deriving (Generic, Show)
+
-----------------------------
-- JSON GitLab parsers below
-----------------------------
@@ -653,6 +658,7 @@
bodyNoPrefix "commit_created_at" = "created_at"
bodyNoPrefix "commit_id" = "id"
bodyNoPrefix "commit_status" = "status"
+bodyNoPrefix "commit_parent_ids" = "parent_ids"
bodyNoPrefix "todo_commit_id" = "id"
bodyNoPrefix "todo_commit_short_id" = "short_id"
bodyNoPrefix "todo_commit_created_at" = "created_at"
@@ -667,7 +673,6 @@
bodyNoPrefix "issue_state" = "state"
bodyNoPrefix "issue_title" = "title"
bodyNoPrefix "issue_web_url" = "web_url"
-bodyNoPrefix "job_web_url" = "web_url"
bodyNoPrefix "link_events" = "events"
bodyNoPrefix "link_labels" = "labels"
bodyNoPrefix "member_avatar_url" = "avatar_url"
@@ -692,6 +697,7 @@
bodyNoPrefix "project_id" = "id"
bodyNoPrefix "project_name" = "name"
bodyNoPrefix "project_path" = "path"
+bodyNoPrefix "project_path_with_namespace" = "path_with_namespace"
bodyNoPrefix "project_web_url" = "web_url"
bodyNoPrefix "repository_id" = "id"
bodyNoPrefix "repository_name" = "name"
@@ -705,7 +711,6 @@
bodyNoPrefix "user_web_url" = "we_url"
bodyNoPrefix "event_title" = "title"
bodyNoPrefix "event_project_id" = "project_id"
-bodyNoPrefix "job_ref" = "ref"
bodyNoPrefix "pipeline_ref" = "ref"
bodyNoPrefix "branch_name" = "name"
bodyNoPrefix "branch_default" = "default"
@@ -778,6 +783,23 @@
bodyNoPrefix "group_full_path" = "full_path"
bodyNoPrefix "group_file_template_project_id" = "file_template_project_id"
bodyNoPrefix "group_parent_id" = "parent_id"
+bodyNoPrefix "job_commit" = "commit"
+bodyNoPrefix "job_coverage" = "coverage"
+bodyNoPrefix "job_created_at" = "created_at"
+bodyNoPrefix "job_started_at" = "started_at"
+bodyNoPrefix "job_finished_at" = "finished_at"
+bodyNoPrefix "job_duration" = "duration"
+bodyNoPrefix "job_artifacts_expire_at" = "artifacts_expire_at"
+bodyNoPrefix "job_id" = "id"
+bodyNoPrefix "job_name" = "name"
+bodyNoPrefix "job_pipeline" = "pipeline"
+bodyNoPrefix "job_ref" = "ref"
+bodyNoPrefix "job_artifacts" = "artifacts"
+bodyNoPrefix "job_stage" = "stage"
+bodyNoPrefix "job_status" = "status"
+bodyNoPrefix "job_tag" = "tag"
+bodyNoPrefix "job_web_url" = "web_url"
+bodyNoPrefix "job_user" = "user"
-- TODO field names for Issues data type
bodyNoPrefix s = s
@@ -972,3 +994,11 @@
{ fieldLabelModifier = bodyNoPrefix
}
)
+
+instance ToJSON EditIssueReq where
+ toEncoding =
+ genericToEncoding
+ defaultOptions
+ { fieldLabelModifier = drop (T.length "edit_issue_"),
+ omitNothingFields = True
+ }
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
@@ -8,10 +8,12 @@
gitlabWithAttrs,
gitlabWithAttrsUnsafe,
gitlabOne,
+ -- gitlabOneIO,
gitlabWithAttrsOne,
-- not currently used.
-- gitlabWithAttrsOneUnsafe,
gitlabPost,
+ gitlabPut,
gitlabReqText,
gitlabReqByteString,
)
@@ -31,6 +33,7 @@
import Network.HTTP.Conduit
import Network.HTTP.Types.Status
import Network.HTTP.Types.URI
+import Text.Read
newtype GitLabException = GitLabException String
deriving (Eq, Show)
@@ -41,12 +44,12 @@
-- error code responses, e.g. 404, 409.
gitlabPost ::
- (MonadIO m, FromJSON b) =>
+ (FromJSON b) =>
-- | the URL to post to
Text ->
-- | the data to post
Text ->
- GitLab m (Either Status b)
+ GitLab (Either Status b)
gitlabPost urlPath dataBody = do
cfg <- serverCfg <$> ask
manager <- httpManager <$> ask
@@ -71,6 +74,39 @@
)
else return (Left (responseStatus resp))
+gitlabPut ::
+ FromJSON b =>
+ -- | the URL to post to
+ Text ->
+ -- | the data to post
+ Text ->
+ GitLab (Either Status b)
+gitlabPut urlPath dataBody = do
+ cfg <- serverCfg <$> ask
+ manager <- httpManager <$> ask
+ let url' = url cfg <> "/api/v4" <> urlPath
+ let request' = parseRequest_ (T.unpack url')
+ request =
+ request'
+ { method = "PUT",
+ requestHeaders =
+ [ ("PRIVATE-TOKEN", T.encodeUtf8 (token cfg)),
+ ("content-type", "application/json")
+ ],
+ requestBody = RequestBodyBS (T.encodeUtf8 dataBody)
+ }
+ resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing
+ if successStatus (responseStatus resp)
+ then
+ return
+ ( case parseBSOne (responseBody resp) of
+ Just x -> Right x
+ Nothing ->
+ Left $
+ mkStatus 409 "unable to parse PUT response"
+ )
+ else return (Left (responseStatus resp))
+
tryGitLab ::
-- | the current retry count
Int ->
@@ -102,7 +138,7 @@
Left s -> Exception.throwIO $ GitLabException s
Right xs -> return xs
-gitlabReqJsonMany :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status [a])
+gitlabReqJsonMany :: (FromJSON a) => Text -> Text -> GitLab (Either Status [a])
gitlabReqJsonMany urlPath attrs =
go 1 []
where
@@ -135,7 +171,32 @@
else go (i + 1) accum'
else return (Left (responseStatus resp))
-gitlabReqOne :: (MonadIO m) => (BSL.ByteString -> output) -> Text -> Text -> GitLab m (Either Status output)
+-- not sure what this was planned for
+--
+-- gitlabReqOneIO :: Manager -> GitLabServerConfig -> (BSL.ByteString -> output) -> Text -> Text -> IO (Either Status output)
+-- gitlabReqOneIO manager cfg parser urlPath attrs = go
+-- where
+-- go = do
+-- let url' =
+-- url cfg
+-- <> "/api/v4"
+-- <> urlPath
+-- <> "?per_page=100"
+-- <> "&page=1"
+-- <> attrs
+-- let request' = parseRequest_ (T.unpack url')
+-- request =
+-- request'
+-- { requestHeaders =
+-- [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))],
+-- responseTimeout = responseTimeoutMicro (timeout cfg)
+-- }
+-- resp <- tryGitLab 0 request (retries cfg) manager Nothing
+-- if successStatus (responseStatus resp)
+-- then return (Right (parser (responseBody resp)))
+-- else return (Left (responseStatus resp))
+
+gitlabReqOne :: (BSL.ByteString -> output) -> Text -> Text -> GitLab (Either Status output)
gitlabReqOne parser urlPath attrs = go
where
go = do
@@ -160,38 +221,49 @@
then return (Right (parser (responseBody resp)))
else return (Left (responseStatus resp))
-gitlabReqJsonOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status (Maybe a))
+-- not sure what this was planned for
+--
+-- gitlabReqJsonOneIO :: (FromJSON a) => Manager -> GitLabServerConfig -> Text -> Text -> IO (Either Status (Maybe a))
+-- gitlabReqJsonOneIO mgr cfg urlPath attrs =
+-- gitlabReqOneIO mgr cfg parseBSOne urlPath attrs
+
+gitlabReqJsonOne :: (FromJSON a) => Text -> Text -> GitLab (Either Status (Maybe a))
gitlabReqJsonOne =
gitlabReqOne parseBSOne
-gitlabReqText :: (MonadIO m) => Text -> GitLab m (Either Status String)
+gitlabReqText :: Text -> GitLab (Either Status String)
gitlabReqText urlPath = gitlabReqOne C.unpack urlPath ""
-gitlabReqByteString :: (MonadIO m) => Text -> GitLab m (Either Status BSL.ByteString)
+gitlabReqByteString :: Text -> GitLab (Either Status BSL.ByteString)
gitlabReqByteString urlPath = gitlabReqOne Prelude.id urlPath ""
-gitlab :: (MonadIO m, FromJSON a) => Text -> GitLab m (Either Status [a])
+gitlab :: FromJSON a => Text -> GitLab (Either Status [a])
gitlab addr = gitlabReqJsonMany addr ""
-gitlabUnsafe :: (MonadIO m, FromJSON a) => Text -> GitLab m [a]
+gitlabUnsafe :: (FromJSON a) => Text -> GitLab [a]
gitlabUnsafe addr =
fromRight (error "gitlabUnsafe error") <$> gitlab addr
-gitlabOne :: (MonadIO m, FromJSON a) => Text -> GitLab m (Either Status (Maybe a))
+-- not sure what this was planned for
+--
+-- gitlabOneIO :: (FromJSON a) => Manager -> GitLabServerConfig -> Text -> IO (Either Status (Maybe a))
+-- gitlabOneIO mgr cfg addr = gitlabReqJsonOneIO mgr cfg addr ""
+
+gitlabOne :: (FromJSON a) => Text -> GitLab (Either Status (Maybe a))
gitlabOne addr = gitlabReqJsonOne addr ""
-gitlabWithAttrs :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status [a])
+gitlabWithAttrs :: (FromJSON a) => Text -> Text -> GitLab (Either Status [a])
gitlabWithAttrs = gitlabReqJsonMany
-gitlabWithAttrsUnsafe :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a]
+gitlabWithAttrsUnsafe :: (FromJSON a) => Text -> Text -> GitLab [a]
gitlabWithAttrsUnsafe gitlabURL attrs =
fromRight (error "gitlabWithAttrsUnsafe error") <$> gitlabReqJsonMany gitlabURL attrs
-gitlabWithAttrsOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status (Maybe a))
+gitlabWithAttrsOne :: (FromJSON a) => Text -> Text -> GitLab (Either Status (Maybe a))
gitlabWithAttrsOne = gitlabReqJsonOne
-- not currently used.
--- gitlabWithAttrsOneUnsafe :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a)
+-- gitlabWithAttrsOneUnsafe :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab (Maybe a)
-- gitlabWithAttrsOneUnsafe gitlabURL attrs =
-- fromRight (error "gitlabWithAttrsUnsafe error") <$> gitlabReqJsonOne gitlabURL attrs
@@ -201,7 +273,10 @@
in findPages hdrs
where
findPages [] = 1 -- error "cannot find X-Total-Pages in header"
- findPages (("X-Total-Pages", bs) : _) = read (T.unpack (T.decodeUtf8 bs))
+ findPages (("X-Total-Pages", bs) : _) =
+ case readMaybe (T.unpack (T.decodeUtf8 bs)) of
+ Just s -> s
+ Nothing -> error "cannot find X-Total-Pages in header"
findPages (_ : xs) = findPages xs
successStatus :: Status -> Bool
diff --git a/tests/SystemHookTests.hs b/tests/SystemHookTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/SystemHookTests.hs
@@ -0,0 +1,1392 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module SystemHookTests (systemHookTests) where
+
+import Control.Monad.IO.Class
+import Data.Aeson
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import GitLab
+import GitLab.SystemHooks.GitLabSystemHooks
+import GitLab.SystemHooks.Types
+import Test.Tasty
+import Test.Tasty.HUnit
+
+systemHookTests :: [TestTree]
+systemHookTests =
+ [parserTests, matchTests, matchIfTests, receiveTests]
+
+parserTests :: TestTree
+parserTests =
+ testGroup
+ "GitLab system hook rules"
+ [ testCase
+ "project-create-event"
+ ( readFile "data/system-hooks/project-created.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just projectCreatedHaskell
+ ),
+ testCase
+ "project-destroy-event"
+ ( readFile "data/system-hooks/project-destroyed.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just projectDestroyedHaskell
+ ),
+ testCase
+ "project-rename-event"
+ ( readFile "data/system-hooks/project-renamed.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just projectRenamedHaskell
+ ),
+ testCase
+ "project-transfer-event"
+ ( readFile "data/system-hooks/project-transferred.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just projectTransferredHaskell
+ ),
+ testCase
+ "project-update-event"
+ ( readFile "data/system-hooks/project-updated.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just projectUpdatedHaskell
+ ),
+ testCase
+ "new-team-member-event"
+ ( readFile "data/system-hooks/new-team-member.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just userAddedToTeamHaskell
+ ),
+ testCase
+ "team-member-removed-event"
+ ( readFile "data/system-hooks/team-member-removed.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just userRemovedFromTeamHaskell
+ ),
+ testCase
+ "team-member-updated-event"
+ ( readFile "data/system-hooks/team-member-updated.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just userUpdatedForTeamHaskell
+ ),
+ testCase
+ "user-created-event"
+ ( readFile "data/system-hooks/user-created.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just userCreatedHaskell
+ ),
+ testCase
+ "user-removed-event"
+ ( readFile "data/system-hooks/user-removed.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just userRemovedHaskell
+ ),
+ testCase
+ "user-failed-login-event"
+ ( readFile "data/system-hooks/user-failed-login.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just userFailedLoginHaskell
+ ),
+ testCase
+ "user-renamed-event"
+ ( readFile "data/system-hooks/user-renamed.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just userRenamedHaskell
+ ),
+ testCase
+ "key-added-event"
+ ( readFile "data/system-hooks/key-added.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just keyCreatedHaskell
+ ),
+ testCase
+ "key-removed-event"
+ ( readFile "data/system-hooks/key-removed.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just keyRemovedHaskell
+ ),
+ testCase
+ "group-created-event"
+ ( readFile "data/system-hooks/group-created.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just groupCreatedHaskell
+ ),
+ testCase
+ "group-removed-event"
+ ( readFile "data/system-hooks/group-removed.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just groupRemovedHaskell
+ ),
+ testCase
+ "group-renamed-event"
+ ( readFile "data/system-hooks/group-renamed.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just groupRenamedHaskell
+ ),
+ testCase
+ "new-group-member-event"
+ ( readFile "data/system-hooks/new-group-member.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just newGroupMemberHaskell
+ ),
+ testCase
+ "group-member-removed-event"
+ ( readFile "data/system-hooks/group-member-removed.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just groupMemberRemovedHaskell
+ ),
+ testCase
+ "group-member-updated-event"
+ ( readFile "data/system-hooks/group-member-updated.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just groupMemberUpdatedHaskell
+ ),
+ testCase
+ "push-event"
+ ( readFile "data/system-hooks/push.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just pushHaskell
+ ),
+ testCase
+ "tag-push-event"
+ ( readFile "data/system-hooks/tag-push.json"
+ >>= \eventJson -> parseEvent eventJson @?= Just tagPushHaskell
+ )
+ -- testCase
+ -- "merge-request-event"
+ -- ( readFile "data/system-hooks/merge-request.json"
+ -- >>= \eventJson -> parseEvent eventJson @?= Just mergeRequestHaskell
+ -- ),
+ -- testCase
+ -- "repository-update-event"
+ -- ( readFile "data/system-hooks/repository-update.json"
+ -- >>= \eventJson -> parseEvent eventJson @?= Just repositoryUpdateHaskell
+ -- )
+ ]
+
+matchTest :: String -> String -> Rule -> String -> Rule -> [TestTree]
+matchTest lbl jsonFilename rule wrongJson wrongRule =
+ [ testCase lbl $
+ runGitLabDbg
+ ( liftIO (readFile ("data/system-hooks/" <> jsonFilename))
+ >>= \eventJson -> tryFire eventJson rule
+ )
+ @? (lbl <> " failed"),
+ testCase (lbl <> "-wrong-json") $
+ not
+ <$> runGitLabDbg
+ ( liftIO (readFile ("data/system-hooks/" <> wrongJson))
+ >>= \eventJson -> tryFire eventJson rule
+ )
+ @? (lbl <> "-wrong-json failed"),
+ testCase (lbl <> "-wrong-rule") $
+ not
+ <$> runGitLabDbg
+ ( liftIO (readFile ("data/system-hooks/" <> jsonFilename))
+ >>= \eventJson -> tryFire eventJson wrongRule
+ )
+ @? (lbl <> "-wrong-rule failed")
+ ]
+
+matchIfTest :: String -> String -> Rule -> Rule -> [TestTree]
+matchIfTest lbl jsonFilename yesFire noFire =
+ [ testCase (lbl <> "-yes") $
+ runGitLabDbg
+ ( liftIO (readFile ("data/system-hooks/" <> jsonFilename))
+ >>= \eventJson -> tryFire eventJson yesFire
+ )
+ @? "project-create-fireIf-yes failed",
+ testCase (lbl <> "-no") $
+ not
+ <$> runGitLabDbg
+ ( liftIO (readFile ("data/system-hooks/" <> jsonFilename))
+ >>= \eventJson -> tryFire eventJson noFire
+ )
+ @? "project-create-fireIf-no failed"
+ ]
+
+-- [ testCase lbl $
+-- runGitLabDbg
+-- ( liftIO (readFile ("data/system-hooks/" <> jsonFilename))
+-- >>= \eventJson -> fire eventJson rule
+-- )
+-- @? (lbl <> " failed"),
+-- testCase (lbl <> "-wrong-json") $
+-- not
+-- <$> runGitLabDbg
+-- ( liftIO (readFile ("data/system-hooks/" <> wrongJson))
+-- >>= \eventJson -> fire eventJson rule
+-- )
+-- @? (lbl <> "-wrong-json failed"),
+-- testCase (lbl <> "-wrong-rule") $
+-- not
+-- <$> runGitLabDbg
+-- ( liftIO (readFile ("data/system-hooks/" <> jsonFilename))
+-- >>= \eventJson -> fire eventJson wrongRule
+-- )
+-- @? (lbl <> "-wrong-rule failed")
+-- ]
+
+matchTests :: TestTree
+matchTests =
+ testGroup "GitLab system hook match" $
+ matchTest "project-create" "project-created.json" projectCreateRule "project-destroyed.json" projectDestroyRule
+ <> matchTest "project-destroy" "project-destroyed.json" projectDestroyRule "project-created.json" projectCreateRule
+ <> matchTest "project-rename" "project-renamed.json" projectRenameRule "project-created.json" projectCreateRule
+ <> matchTest "project-transfer" "project-transferred.json" projectTransferRule "project-created.json" projectCreateRule
+ <> matchTest "project-update" "project-updated.json" projectUpdateRule "project-created.json" projectCreateRule
+ <> matchTest "user-add-to-team" "new-team-member.json" userAddToTeamRule "project-created.json" projectCreateRule
+ <> matchTest "user-update-for-team" "team-member-updated.json" userUpdateForTeamRule "project-created.json" projectCreateRule
+ <> matchTest "user-remove-from-team" "team-member-removed.json" userRemoveFromTeamRule "project-created.json" projectCreateRule
+ <> matchTest "user-create" "user-created.json" userCreateRule "project-created.json" projectCreateRule
+ <> matchTest "user-remove" "user-removed.json" userRemoveRule "project-created.json" projectCreateRule
+ <> matchTest "user-failed-login" "user-failed-login.json" userFailedLoginRule "project-created.json" projectCreateRule
+ <> matchTest "user-rename" "user-renamed.json" userRenameRule "project-created.json" projectCreateRule
+ <> matchTest "key-create" "key-added.json" keyCreateRule "project-created.json" projectCreateRule
+ <> matchTest "key-remove" "key-removed.json" keyRemoveRule "project-created.json" projectCreateRule
+ <> matchTest "group-create" "group-created.json" groupCreateRule "project-created.json" projectCreateRule
+ <> matchTest "group-remove" "group-removed.json" groupRemoveRule "project-created.json" projectCreateRule
+ <> matchTest "group-rename" "group-renamed.json" groupRenameRule "project-created.json" projectCreateRule
+ <> matchTest "new-group-member" "new-group-member.json" newGroupMemberRule "project-created.json" projectCreateRule
+ <> matchTest "group-member-remove" "group-member-removed.json" groupMemberRemoveRule "project-created.json" projectCreateRule
+ <> matchTest "group-member-update" "group-member-updated.json" groupMemberUpdateRule "project-created.json" projectCreateRule
+ <> matchTest "push" "push.json" pushRule "project-created.json" projectCreateRule
+ <> matchTest "tag-push" "tag-push.json" tagPushRule "project-created.json" projectCreateRule
+
+matchIfTests :: TestTree
+matchIfTests =
+ testGroup "GitLab system hook matchIf" $
+ matchIfTest "project-create" "project-created.json" projectCreateIfRuleYes projectCreateIfRuleNo
+ <> matchIfTest "project-destroy" "project-destroyed.json" projectDestroyIfRuleYes projectDestroyIfRuleNo
+ <> matchIfTest "project-rename" "project-renamed.json" projectRenameIfRuleYes projectRenameIfRuleNo
+ <> matchIfTest "project-transfer" "project-transferred.json" projectTransferIfRuleYes projectTransferIfRuleNo
+ <> matchIfTest "project-update" "project-updated.json" projectUpdateIfRuleYes projectUpdateIfRuleNo
+ <> matchIfTest "user-add-to-team" "new-team-member.json" userAddToTeamIfRuleYes userAddToTeamIfRuleNo
+ <> matchIfTest "user-update-for-team" "team-member-updated.json" userUpdateForTeamIfRuleYes userUpdateForTeamIfRuleNo
+ <> matchIfTest "user-remove-from-team" "team-member-removed.json" userRemoveFromTeamIfRuleYes userRemoveFromTeamIfRuleNo
+ <> matchIfTest "user-create" "user-created.json" userCreateIfRuleYes userCreateIfRuleNo
+ <> matchIfTest "user-remove" "user-removed.json" userRemoveIfRuleYes userRemoveIfRuleNo
+ <> matchIfTest "user-failed-login" "user-failed-login.json" userFailedLoginIfRuleYes userFailedLoginIfRuleNo
+ <> matchIfTest "user-rename" "user-renamed.json" userRenameIfRuleYes userRenameIfRuleNo
+ <> matchIfTest "key-create" "key-added.json" keyCreateIfRuleYes keyCreateIfRuleNo
+ <> matchIfTest "key-remove" "key-removed.json" keyRemoveIfRuleYes keyRemoveIfRuleNo
+ <> matchIfTest "group-create" "group-created.json" groupCreateIfRuleYes groupCreateIfRuleNo
+ <> matchIfTest "group-remove" "group-removed.json" groupRemoveIfRuleYes groupRemoveIfRuleNo
+ <> matchIfTest "group-rename" "group-renamed.json" groupRenameIfRuleYes groupRenameIfRuleNo
+ <> matchIfTest "new-group-member" "new-group-member.json" newGroupMemberIfRuleYes newGroupMemberIfRuleNo
+ <> matchIfTest "group-member-remove" "group-member-removed.json" groupMemberRemoveIfRuleYes groupMemberRemoveIfRuleNo
+ <> matchIfTest "group-member-update" "group-member-updated.json" groupMemberUpdateIfRuleYes groupMemberUpdateIfRuleNo
+ <> matchIfTest "push" "push.json" pushIfRuleYes pushIfRuleNo
+ <> matchIfTest "tag-push" "tag-push.json" tagPushIfRuleYes tagPushIfRuleNo
+
+receiveTests :: TestTree
+receiveTests =
+ testGroup
+ "GitLab system hooks receive"
+ [ testCase "1-rule-match"
+ $ runGitLabDbg
+ $ liftIO (readFile "data/system-hooks/project-created.json")
+ >>= \eventJson ->
+ receiveString
+ eventJson
+ [projectCreateRule],
+ testCase "1-rule-no-match"
+ $ runGitLabDbg
+ $ liftIO (readFile "data/system-hooks/project-created.json")
+ >>= \eventJson ->
+ receiveString
+ eventJson
+ [projectRenameRule],
+ testCase
+ "2-rules"
+ $ runGitLabDbg
+ $ liftIO (readFile "data/system-hooks/project-created.json")
+ >>= \eventJson ->
+ receiveString
+ eventJson
+ [ projectCreateRule,
+ projectDestroyRule
+ ]
+ ]
+
+projectCreateRule :: Rule
+projectCreateRule =
+ match
+ "projectCreate rule"
+ ( \ProjectCreate {} -> do
+ return ()
+ )
+
+projectCreateIfRuleYes :: Rule
+projectCreateIfRuleYes =
+ matchIf
+ "projectCreate-if rule"
+ ( \proj@ProjectCreate {} -> do
+ return (projectCreate_owner_email proj == "johnsmith@gmail.com")
+ )
+ ( \ProjectCreate {} -> do
+ return ()
+ )
+
+projectCreateIfRuleNo :: Rule
+projectCreateIfRuleNo =
+ matchIf
+ "projectCreate-if rule"
+ ( \proj@ProjectCreate {} -> do
+ return (projectCreate_owner_email proj == "johnsmith@hotmail.com")
+ )
+ ( \ProjectCreate {} -> do
+ return ()
+ )
+
+projectDestroyRule :: Rule
+projectDestroyRule =
+ match
+ "projectDestroy rule"
+ ( \ProjectDestroy {} -> do
+ return ()
+ )
+
+projectDestroyIfRuleYes :: Rule
+projectDestroyIfRuleYes =
+ matchIf
+ "projectDestroy rule-if yes"
+ ( \event@ProjectDestroy {} -> do
+ return
+ ( projectDestroy_owner_email event
+ == "johnsmith@gmail.com"
+ )
+ )
+ ( \ProjectDestroy {} -> do
+ return ()
+ )
+
+projectDestroyIfRuleNo :: Rule
+projectDestroyIfRuleNo =
+ matchIf
+ "projectDestroy rule-if no"
+ ( \event@ProjectDestroy {} -> do
+ return
+ ( projectDestroy_owner_email event
+ == "johnsmith@hotmail.com"
+ )
+ )
+ ( \ProjectDestroy {} -> do
+ return ()
+ )
+
+projectRenameRule :: Rule
+projectRenameRule =
+ match
+ "projectRename rule"
+ ( \ProjectRename {} -> do
+ return ()
+ )
+
+projectRenameIfRuleYes :: Rule
+projectRenameIfRuleYes =
+ matchIf
+ "projectRename rule-if yes"
+ ( \event@ProjectRename {} -> do
+ return
+ ( projectRename_created_at event
+ == "2012-07-21T07:30:58Z"
+ )
+ )
+ ( \ProjectRename {} -> do
+ return ()
+ )
+
+projectRenameIfRuleNo :: Rule
+projectRenameIfRuleNo =
+ matchIf
+ "projectRename rule-if no"
+ ( \event@ProjectRename {} -> do
+ return
+ ( projectRename_created_at event
+ == ""
+ )
+ )
+ ( \ProjectRename {} -> do
+ return ()
+ )
+
+projectTransferRule :: Rule
+projectTransferRule =
+ match
+ "projectTransfer rule"
+ ( \ProjectTransfer {} -> do
+ return ()
+ )
+
+projectTransferIfRuleYes :: Rule
+projectTransferIfRuleYes =
+ matchIf
+ "projectTransfer rule-if yes"
+ ( \event@ProjectTransfer {} -> do
+ return
+ ( projectTransfer_owner_name event
+ == "John Smith"
+ )
+ )
+ ( \ProjectTransfer {} -> do
+ return ()
+ )
+
+projectTransferIfRuleNo :: Rule
+projectTransferIfRuleNo =
+ matchIf
+ "projectTransfer rule-if no"
+ ( \event@ProjectTransfer {} -> do
+ return
+ ( projectTransfer_owner_name event
+ == ""
+ )
+ )
+ ( \ProjectTransfer {} -> do
+ return ()
+ )
+
+projectUpdateRule :: Rule
+projectUpdateRule =
+ match
+ "projectTransfer rule"
+ ( \ProjectUpdate {} -> do
+ return ()
+ )
+
+projectUpdateIfRuleYes :: Rule
+projectUpdateIfRuleYes =
+ matchIf
+ "projectTransfer rule-if yes"
+ ( \event@ProjectUpdate {} -> do
+ return
+ ( projectUpdate_path event
+ == "storecloud"
+ )
+ )
+ ( \ProjectUpdate {} -> do
+ return ()
+ )
+
+projectUpdateIfRuleNo :: Rule
+projectUpdateIfRuleNo =
+ matchIf
+ "projectTransfer rule-if no"
+ ( \event@ProjectUpdate {} -> do
+ return
+ ( projectUpdate_path event
+ == ""
+ )
+ )
+ ( \ProjectUpdate {} -> do
+ return ()
+ )
+
+groupMemberUpdateRule :: Rule
+groupMemberUpdateRule =
+ match
+ "groupMemberUpdate rule"
+ ( \GroupMemberUpdate {} -> do
+ return ()
+ )
+
+groupMemberUpdateIfRuleYes :: Rule
+groupMemberUpdateIfRuleYes =
+ matchIf
+ "groupMemberUpdate rule-if yes"
+ ( \event@GroupMemberUpdate {} -> do
+ return
+ ( groupMemberUpdate_user_email event
+ == "johnsmith@gmail.com"
+ )
+ )
+ ( \GroupMemberUpdate {} -> do
+ return ()
+ )
+
+groupMemberUpdateIfRuleNo :: Rule
+groupMemberUpdateIfRuleNo =
+ matchIf
+ "groupMemberUpdate rule-if no"
+ ( \event@GroupMemberUpdate {} -> do
+ return
+ ( groupMemberUpdate_user_email event
+ == "johnsmith@hotmail.com"
+ )
+ )
+ ( \GroupMemberUpdate {} -> do
+ return ()
+ )
+
+userAddToTeamRule :: Rule
+userAddToTeamRule =
+ match
+ "userAddToTeam rule"
+ ( \UserAddToTeam {} -> do
+ return ()
+ )
+
+userAddToTeamIfRuleYes :: Rule
+userAddToTeamIfRuleYes =
+ matchIf
+ "userAddToTeam rule-if yes"
+ ( \event@UserAddToTeam {} -> do
+ return
+ ( userAddTeam_user_email event
+ == "johnsmith@gmail.com"
+ )
+ )
+ ( \UserAddToTeam {} -> do
+ return ()
+ )
+
+userAddToTeamIfRuleNo :: Rule
+userAddToTeamIfRuleNo =
+ matchIf
+ "userAddToTeam rule-if no"
+ ( \event@UserAddToTeam {} ->
+ return
+ ( userAddTeam_user_email event
+ == "johnsmith@hotmail.com"
+ )
+ )
+ ( \UserAddToTeam {} -> do
+ return ()
+ )
+
+userUpdateForTeamRule :: Rule
+userUpdateForTeamRule =
+ match
+ "userUpdateForTeam rule"
+ ( \UserUpdateForTeam {} -> do
+ return ()
+ )
+
+userUpdateForTeamIfRuleYes :: Rule
+userUpdateForTeamIfRuleYes =
+ matchIf
+ "userUpdateForTeam rule-if yes"
+ ( \event@UserUpdateForTeam {} -> do
+ return
+ ( userUpdateTeam_project_path_with_namespace event
+ == "jsmith/storecloud"
+ )
+ )
+ ( \UserUpdateForTeam {} -> do
+ return ()
+ )
+
+userUpdateForTeamIfRuleNo :: Rule
+userUpdateForTeamIfRuleNo =
+ matchIf
+ "userUpdateForTeam rule-if no"
+ ( \event@UserUpdateForTeam {} -> do
+ return
+ ( userUpdateTeam_project_path_with_namespace event
+ == ""
+ )
+ )
+ ( \UserUpdateForTeam {} -> do
+ return ()
+ )
+
+userRemoveFromTeamRule :: Rule
+userRemoveFromTeamRule =
+ match
+ "userRemoveFromTeam rule"
+ ( \UserRemoveFromTeam {} -> do
+ return ()
+ )
+
+userRemoveFromTeamIfRuleYes :: Rule
+userRemoveFromTeamIfRuleYes =
+ matchIf
+ "userRemoveFromTeam rule-if yes"
+ ( \event@UserRemoveFromTeam {} -> do
+ return
+ ( userRemoveTeam_user_email event
+ == "johnsmith@gmail.com"
+ )
+ )
+ ( \UserRemoveFromTeam {} -> do
+ return ()
+ )
+
+userRemoveFromTeamIfRuleNo :: Rule
+userRemoveFromTeamIfRuleNo =
+ matchIf
+ "userRemoveFromTeam rule-if no"
+ ( \event@UserRemoveFromTeam {} -> do
+ return
+ ( userRemoveTeam_user_email event
+ == "js@gmail.com"
+ )
+ )
+ ( \UserRemoveFromTeam {} -> do
+ return ()
+ )
+
+userCreateRule :: Rule
+userCreateRule =
+ match
+ "userCreate rule"
+ ( \UserCreate {} -> do
+ return ()
+ )
+
+userCreateIfRuleYes :: Rule
+userCreateIfRuleYes =
+ matchIf
+ "userCreate rule-if yes"
+ ( \event@UserCreate {} -> do
+ return
+ ( userCreate_email event
+ == "js@gitlabhq.com"
+ )
+ )
+ ( \UserCreate {} -> do
+ return ()
+ )
+
+userCreateIfRuleNo :: Rule
+userCreateIfRuleNo =
+ matchIf
+ "userCreate rule-if no"
+ ( \event@UserCreate {} -> do
+ return
+ ( userCreate_email event
+ == "js@gmail.com"
+ )
+ )
+ ( \UserCreate {} -> do
+ return ()
+ )
+
+userRemoveRule :: Rule
+userRemoveRule =
+ match
+ "userRemove rule"
+ ( \UserRemove {} -> do
+ return ()
+ )
+
+userRemoveIfRuleYes :: Rule
+userRemoveIfRuleYes =
+ matchIf
+ "userRemove rule-if yes"
+ ( \event@UserRemove {} -> do
+ return
+ ( userRemove_email event
+ == "js@gitlabhq.com"
+ )
+ )
+ ( \UserRemove {} -> do
+ return ()
+ )
+
+userRemoveIfRuleNo :: Rule
+userRemoveIfRuleNo =
+ matchIf
+ "userRemove rule-if no"
+ ( \event@UserRemove {} -> do
+ return
+ ( userRemove_email event
+ == "js@gmail.com"
+ )
+ )
+ ( \UserRemove {} -> do
+ return ()
+ )
+
+userFailedLoginRule :: Rule
+userFailedLoginRule =
+ match
+ "userFailedLogin rule"
+ ( \UserFailedLogin {} -> do
+ return ()
+ )
+
+userFailedLoginIfRuleYes :: Rule
+userFailedLoginIfRuleYes =
+ matchIf
+ "userFailedLogin rule"
+ ( \event@UserFailedLogin {} -> do
+ return
+ ( userFailedLogin_email event
+ == "user4@example.com"
+ )
+ )
+ ( \UserFailedLogin {} -> do
+ return ()
+ )
+
+userFailedLoginIfRuleNo :: Rule
+userFailedLoginIfRuleNo =
+ matchIf
+ "userFailedLogin rule"
+ ( \event@UserFailedLogin {} -> do
+ return
+ ( userFailedLogin_email event
+ == "user4@gmail.com"
+ )
+ )
+ ( \UserFailedLogin {} -> do
+ return ()
+ )
+
+userRenameRule :: Rule
+userRenameRule =
+ match
+ "userRename rule"
+ ( \UserRename {} -> do
+ return ()
+ )
+
+userRenameIfRuleYes :: Rule
+userRenameIfRuleYes =
+ matchIf
+ "userRename rule-if yes"
+ ( \event@UserRename {} -> do
+ return
+ ( userRename_username event
+ == "new-exciting-name"
+ )
+ )
+ ( \UserRename {} -> do
+ return ()
+ )
+
+userRenameIfRuleNo :: Rule
+userRenameIfRuleNo =
+ matchIf
+ "userRename rule-if no"
+ ( \event@UserRename {} -> do
+ return
+ ( userRename_username event
+ == "old-boring-name"
+ )
+ )
+ ( \UserRename {} -> do
+ return ()
+ )
+
+keyCreateRule :: Rule
+keyCreateRule =
+ match
+ "keyCreate rule"
+ ( \KeyCreate {} -> do
+ return ()
+ )
+
+keyCreateIfRuleYes :: Rule
+keyCreateIfRuleYes =
+ matchIf
+ "keyCreate rule-if yes"
+ ( \event@KeyCreate {} -> do
+ return
+ ( keyCreate_updated_at event
+ == "2012-07-21T07:38:22Z"
+ )
+ )
+ ( \KeyCreate {} -> do
+ return ()
+ )
+
+keyCreateIfRuleNo :: Rule
+keyCreateIfRuleNo =
+ matchIf
+ "keyCreate rule-if no"
+ ( \event@KeyCreate {} -> do
+ return
+ ( keyCreate_updated_at event
+ == ""
+ )
+ )
+ ( \KeyCreate {} -> do
+ return ()
+ )
+
+keyRemoveRule :: Rule
+keyRemoveRule =
+ match
+ "keyRemove rule"
+ ( \KeyRemove {} -> do
+ return ()
+ )
+
+keyRemoveIfRuleYes :: Rule
+keyRemoveIfRuleYes =
+ matchIf
+ "keyRemove rule-if yes"
+ ( \event@KeyRemove {} -> do
+ return
+ ( keyRemove_updated_at event
+ == "2012-07-21T07:38:22Z"
+ )
+ )
+ ( \KeyRemove {} -> do
+ return ()
+ )
+
+keyRemoveIfRuleNo :: Rule
+keyRemoveIfRuleNo =
+ matchIf
+ "keyRemove rule-if no"
+ ( \event@KeyRemove {} -> do
+ return
+ ( keyRemove_updated_at event
+ == ""
+ )
+ )
+ ( \KeyRemove {} -> do
+ return ()
+ )
+
+groupCreateRule :: Rule
+groupCreateRule =
+ match
+ "groupCreate rule"
+ ( \GroupCreate {} -> do
+ return ()
+ )
+
+groupCreateIfRuleYes :: Rule
+groupCreateIfRuleYes =
+ matchIf
+ "groupCreate rule-if yes"
+ ( \event@GroupCreate {} -> do
+ return
+ ( groupCreate_name event
+ == "StoreCloud"
+ )
+ )
+ ( \GroupCreate {} -> do
+ return ()
+ )
+
+groupCreateIfRuleNo :: Rule
+groupCreateIfRuleNo =
+ matchIf
+ "groupCreate rule-if no"
+ ( \event@GroupCreate {} -> do
+ return
+ ( groupCreate_name event
+ == ""
+ )
+ )
+ ( \GroupCreate {} -> do
+ return ()
+ )
+
+groupRemoveRule :: Rule
+groupRemoveRule =
+ match
+ "groupRemove rule"
+ ( \GroupRemove {} -> do
+ return ()
+ )
+
+groupRemoveIfRuleYes :: Rule
+groupRemoveIfRuleYes =
+ matchIf
+ "groupRemove rule-if yes"
+ ( \event@GroupRemove {} -> do
+ return
+ ( groupRemove_name event
+ == "StoreCloud"
+ )
+ )
+ ( \GroupRemove {} -> do
+ return ()
+ )
+
+groupRemoveIfRuleNo :: Rule
+groupRemoveIfRuleNo =
+ matchIf
+ "groupRemove rule-if no"
+ ( \event@GroupRemove {} -> do
+ return
+ ( groupRemove_name event
+ == ""
+ )
+ )
+ ( \GroupRemove {} -> do
+ return ()
+ )
+
+groupRenameRule :: Rule
+groupRenameRule =
+ match
+ "groupRename rule"
+ ( \GroupRename {} -> do
+ return ()
+ )
+
+groupRenameIfRuleYes :: Rule
+groupRenameIfRuleYes =
+ matchIf
+ "groupRename rule-if yes"
+ ( \event@GroupRename {} -> do
+ return
+ ( groupRename_full_path event
+ == "parent-group/better-name"
+ )
+ )
+ ( \GroupRename {} -> do
+ return ()
+ )
+
+groupRenameIfRuleNo :: Rule
+groupRenameIfRuleNo =
+ matchIf
+ "groupRename rule-if no"
+ ( \event@GroupRename {} -> do
+ return
+ ( groupRename_full_path event
+ == "parent-group/wrong-name"
+ )
+ )
+ ( \GroupRename {} -> do
+ return ()
+ )
+
+newGroupMemberRule :: Rule
+newGroupMemberRule =
+ match
+ "newGroupMember rule"
+ ( \NewGroupMember {} -> do
+ return ()
+ )
+
+newGroupMemberIfRuleYes :: Rule
+newGroupMemberIfRuleYes =
+ matchIf
+ "newGroupMember rule-if yes"
+ ( \event@NewGroupMember {} -> do
+ return
+ ( newGroupMember_user_email event
+ == "johnsmith@gmail.com"
+ )
+ )
+ ( \NewGroupMember {} -> do
+ return ()
+ )
+
+newGroupMemberIfRuleNo :: Rule
+newGroupMemberIfRuleNo =
+ matchIf
+ "newGroupMember rule-if no"
+ ( \event@NewGroupMember {} -> do
+ return
+ ( newGroupMember_user_email event
+ == "johnsmith@hotmail.com"
+ )
+ )
+ ( \NewGroupMember {} -> do
+ return ()
+ )
+
+groupMemberRemoveRule :: Rule
+groupMemberRemoveRule =
+ match
+ "groupMemberRemove rule"
+ ( \GroupMemberRemove {} -> do
+ return ()
+ )
+
+groupMemberRemoveIfRuleYes :: Rule
+groupMemberRemoveIfRuleYes =
+ matchIf
+ "groupMemberRemove rule-if yes"
+ ( \event@GroupMemberRemove {} -> do
+ return
+ ( groupMemberRemove_user_email event
+ == "johnsmith@gmail.com"
+ )
+ )
+ ( \GroupMemberRemove {} -> do
+ return ()
+ )
+
+groupMemberRemoveIfRuleNo :: Rule
+groupMemberRemoveIfRuleNo =
+ matchIf
+ "groupMemberRemove rule-if no"
+ ( \event@GroupMemberRemove {} -> do
+ return
+ ( groupMemberRemove_user_email event
+ == "johnsmith@hotmail.com"
+ )
+ )
+ ( \GroupMemberRemove {} -> do
+ return ()
+ )
+
+pushRule :: Rule
+pushRule =
+ match
+ "push rule"
+ ( \Push {} -> do
+ return ()
+ )
+
+pushIfRuleYes :: Rule
+pushIfRuleYes =
+ matchIf
+ "push rule-if yes"
+ ( \event@Push {} -> do
+ return (push_checkout_sha event == "da1560886d4f094c3e6c9ef40349f7d38b5d27d7")
+ )
+ ( \Push {} -> do
+ return ()
+ )
+
+pushIfRuleNo :: Rule
+pushIfRuleNo =
+ matchIf
+ "push rule-if no"
+ ( \event@Push {} -> do
+ return (push_checkout_sha event == "")
+ )
+ ( \Push {} -> do
+ return ()
+ )
+
+tagPushRule :: Rule
+tagPushRule =
+ match
+ "tagPush rule"
+ ( \TagPush {} -> do
+ return ()
+ )
+
+tagPushIfRuleYes :: Rule
+tagPushIfRuleYes =
+ matchIf
+ "tagPush rule-if yes"
+ ( \event@TagPush {} -> do
+ return (tagPush_ref event == "refs/tags/v1.0.0")
+ )
+ ( \TagPush {} -> do
+ return ()
+ )
+
+tagPushIfRuleNo :: Rule
+tagPushIfRuleNo =
+ matchIf
+ "tagPush rule-if no"
+ ( \event@TagPush {} -> do
+ return (tagPush_ref event == "refs/tags/v2.0.0")
+ )
+ ( \TagPush {} -> do
+ return ()
+ )
+
+projectCreatedHaskell :: ProjectCreate
+projectCreatedHaskell =
+ ProjectCreate
+ { projectCreate_created_at = "2012-07-21T07:30:54Z",
+ projectCreate_updated_at = "2012-07-21T07:38:22Z",
+ projectCreate_action = "project_create",
+ projectCreate_name = "StoreCloud",
+ projectCreate_owner_email = "johnsmith@gmail.com",
+ projectCreate_owner_name = "John Smith",
+ projectCreate_path = "storecloud",
+ projectCreate_path_with_namespace = "jsmith/storecloud",
+ projectCreate_project_id = 74,
+ projectCreate_project_visibility = Private
+ }
+
+projectDestroyedHaskell :: ProjectDestroy
+projectDestroyedHaskell =
+ ProjectDestroy
+ { projectDestroy_created_at = "2012-07-21T07:30:58Z",
+ projectDestroy_updated_at = "2012-07-21T07:38:22Z",
+ projectDestroy_action = "project_destroy",
+ projectDestroy_name = "Underscore",
+ projectDestroy_owner_email = "johnsmith@gmail.com",
+ projectDestroy_owner_name = "John Smith",
+ projectDestroy_path = "underscore",
+ projectDestroy_path_with_namespace = "jsmith/underscore",
+ projectDestroy_project_id = 73,
+ projectDestroy_project_visibility = Internal
+ }
+
+projectRenamedHaskell :: ProjectRename
+projectRenamedHaskell =
+ ProjectRename
+ { projectRename_created_at = "2012-07-21T07:30:58Z",
+ projectRename_updated_at = "2012-07-21T07:38:22Z",
+ projectRename_event_name = "project_rename",
+ projectRename_name = "Underscore",
+ projectRename_path = "underscore",
+ projectRename_path_with_namespace = "jsmith/underscore",
+ projectRename_project_id = 73,
+ projectRename_owner_name = "John Smith",
+ projectRename_owner_email = "johnsmith@gmail.com",
+ projectRename_project_visibility = Internal,
+ projectRename_old_path_with_namespace = "jsmith/overscore"
+ }
+
+projectTransferredHaskell :: ProjectTransfer
+projectTransferredHaskell =
+ ProjectTransfer
+ { projectTransfer_created_at = "2012-07-21T07:30:58Z",
+ projectTransfer_updated_at = "2012-07-21T07:38:22Z",
+ projectTransfer_event_name = "project_transfer",
+ projectTransfer_name = "Underscore",
+ projectTransfer_path = "underscore",
+ projectTransfer_path_with_namespace = "scores/underscore",
+ projectTransfer_project_id = 73,
+ projectTransfer_owner_name = "John Smith",
+ projectTransfer_owner_email = "johnsmith@gmail.com",
+ projectTransfer_project_visibility = Internal,
+ projectTransfer_old_path_with_namespace = "jsmith/overscore"
+ }
+
+projectUpdatedHaskell :: ProjectUpdate
+projectUpdatedHaskell =
+ ProjectUpdate
+ { projectUpdate_created_at = "2012-07-21T07:30:54Z",
+ projectUpdate_updated_at = "2012-07-21T07:38:22Z",
+ projectUpdate_event_name = "project_update",
+ projectUpdate_name = "StoreCloud",
+ projectUpdate_owner_email = "johnsmith@gmail.com",
+ projectUpdate_owner_name = "John Smith",
+ projectUpdate_path = "storecloud",
+ projectUpdate_path_with_namespace = "jsmith/storecloud",
+ projectUpdate_project_id = 74,
+ projectUpdate_project_visibility = Private
+ }
+
+userAddedToTeamHaskell :: UserAddToTeam
+userAddedToTeamHaskell =
+ UserAddToTeam
+ { userAddTeam_created_at = "2012-07-21T07:30:56Z",
+ userAddTeam_updated_at = "2012-07-21T07:38:22Z",
+ userAddTeam_event_name = "user_add_to_team",
+ userAddTeam_access_level = "Maintainer",
+ userAddTeam_project_id = 74,
+ userAddTeam_project_name = "StoreCloud",
+ userAddTeam_project_path = "storecloud",
+ userAddTeam_project_path_with_namespace = "jsmith/storecloud",
+ userAddTeam_user_email = "johnsmith@gmail.com",
+ userAddTeam_user_name = "John Smith",
+ userAddTeam_user_username = "johnsmith",
+ userAddTeam_user_id = 41,
+ userAddTeam_project_visibility = Private
+ }
+
+userUpdatedForTeamHaskell :: UserUpdateForTeam
+userUpdatedForTeamHaskell =
+ UserUpdateForTeam
+ { userUpdateTeam_created_at = "2012-07-21T07:30:56Z",
+ userUpdateTeam_updated_at = "2012-07-21T07:38:22Z",
+ userUpdateTeam_event_name = "user_update_for_team",
+ userUpdateTeam_access_level = "Maintainer",
+ userUpdateTeam_project_id = 74,
+ userUpdateTeam_project_name = "StoreCloud",
+ userUpdateTeam_project_path = "storecloud",
+ userUpdateTeam_project_path_with_namespace = "jsmith/storecloud",
+ userUpdateTeam_user_email = "johnsmith@gmail.com",
+ userUpdateTeam_user_name = "John Smith",
+ userUpdateTeam_user_username = "johnsmith",
+ userUpdateTeam_user_id = 41,
+ userUpdateTeam_project_visibility = Private
+ }
+
+userRemovedFromTeamHaskell :: UserRemoveFromTeam
+userRemovedFromTeamHaskell =
+ UserRemoveFromTeam
+ { userRemoveTeam_created_at = "2012-07-21T07:30:56Z",
+ userRemoveTeam_updated_at = "2012-07-21T07:38:22Z",
+ userRemoveTeam_event_name = "user_remove_from_team",
+ userRemoveTeam_access_level = "Maintainer",
+ userRemoveTeam_project_id = 74,
+ userRemoveTeam_project_name = "StoreCloud",
+ userRemoveTeam_project_path = "storecloud",
+ userRemoveTeam_project_path_with_namespace = "jsmith/storecloud",
+ userRemoveTeam_user_email = "johnsmith@gmail.com",
+ userRemoveTeam_user_name = "John Smith",
+ userRemoveTeam_user_username = "johnsmith",
+ userRemoveTeam_user_id = 41,
+ userRemoveTeam_project_visibility = Private
+ }
+
+userCreatedHaskell :: UserCreate
+userCreatedHaskell =
+ UserCreate
+ { userCreate_created_at = "2012-07-21T07:44:07Z",
+ userCreate_updated_at = "2012-07-21T07:38:22Z",
+ userCreate_email = "js@gitlabhq.com",
+ userCreate_event_name = "user_create",
+ userCreate_name = "John Smith",
+ userCreate_username = "js",
+ userCreate_user_id = 41
+ }
+
+userRemovedHaskell :: UserRemove
+userRemovedHaskell =
+ UserRemove
+ { userRemove_created_at = "2012-07-21T07:44:07Z",
+ userRemove_updated_at = "2012-07-21T07:38:22Z",
+ userRemove_email = "js@gitlabhq.com",
+ userRemove_event_name = "user_destroy",
+ userRemove_name = "John Smith",
+ userRemove_username = "js",
+ userRemove_user_id = 41
+ }
+
+userFailedLoginHaskell :: UserFailedLogin
+userFailedLoginHaskell =
+ UserFailedLogin
+ { userFailedLogin_event_name = "user_failed_login",
+ userFailedLogin_created_at = "2017-10-03T06:08:48Z",
+ userFailedLogin_updated_at = "2018-01-15T04:52:06Z",
+ userFailedLogin_name = "John Smith",
+ userFailedLogin_email = "user4@example.com",
+ userFailedLogin_user_id = 26,
+ userFailedLogin_username = "user4",
+ userFailedLogin_state = "blocked"
+ }
+
+userRenamedHaskell :: UserRename
+userRenamedHaskell =
+ UserRename
+ { userRename_event_name = "user_rename",
+ userRename_created_at = "2017-11-01T11:21:04Z",
+ userRename_updated_at = "2017-11-01T14:04:47Z",
+ userRename_name = "new-name",
+ userRename_email = "best-email@example.tld",
+ userRename_user_id = 58,
+ userRename_username = "new-exciting-name",
+ userRename_old_username = "old-boring-name"
+ }
+
+keyCreatedHaskell :: KeyCreate
+keyCreatedHaskell =
+ KeyCreate
+ { keyCreate_event_name = "key_create",
+ keyCreate_created_at = "2014-08-18 18:45:16 UTC",
+ keyCreate_updated_at = "2012-07-21T07:38:22Z",
+ keyCreate_username = "root",
+ keyCreate_key = "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC58FwqHUbebw2SdT7SP4FxZ0w+lAO/erhy2ylhlcW/tZ3GY3mBu9VeeiSGoGz8hCx80Zrz+aQv28xfFfKlC8XQFpCWwsnWnQqO2Lv9bS8V1fIHgMxOHIt5Vs+9CAWGCCvUOAurjsUDoE2ALIXLDMKnJxcxD13XjWdK54j6ZXDB4syLF0C2PnAQSVY9X7MfCYwtuFmhQhKaBussAXpaVMRHltie3UYSBUUuZaB3J4cg/7TxlmxcNd+ppPRIpSZAB0NI6aOnqoBCpimscO/VpQRJMVLr3XiSYeT6HBiDXWHnIVPfQc03OGcaFqOit6p8lYKMaP/iUQLm+pgpZqrXZ9vB john@localhost",
+ keyCreate_id = 4
+ }
+
+keyRemovedHaskell :: KeyRemove
+keyRemovedHaskell =
+ KeyRemove
+ { keyRemove_event_name = "key_destroy",
+ keyRemove_created_at = "2014-08-18 18:45:16 UTC",
+ keyRemove_updated_at = "2012-07-21T07:38:22Z",
+ keyRemove_username = "root",
+ keyRemove_key = "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC58FwqHUbebw2SdT7SP4FxZ0w+lAO/erhy2ylhlcW/tZ3GY3mBu9VeeiSGoGz8hCx80Zrz+aQv28xfFfKlC8XQFpCWwsnWnQqO2Lv9bS8V1fIHgMxOHIt5Vs+9CAWGCCvUOAurjsUDoE2ALIXLDMKnJxcxD13XjWdK54j6ZXDB4syLF0C2PnAQSVY9X7MfCYwtuFmhQhKaBussAXpaVMRHltie3UYSBUUuZaB3J4cg/7TxlmxcNd+ppPRIpSZAB0NI6aOnqoBCpimscO/VpQRJMVLr3XiSYeT6HBiDXWHnIVPfQc03OGcaFqOit6p8lYKMaP/iUQLm+pgpZqrXZ9vB john@localhost",
+ keyRemove_id = 4
+ }
+
+groupCreatedHaskell :: GroupCreate
+groupCreatedHaskell =
+ GroupCreate
+ { groupCreate_created_at = "2012-07-21T07:30:54Z",
+ groupCreate_updated_at = "2012-07-21T07:38:22Z",
+ groupCreate_event_name = "group_create",
+ groupCreate_name = "StoreCloud",
+ groupCreate_owner_email = Nothing,
+ groupCreate_owner_name = Nothing,
+ groupCreate_path = "storecloud",
+ groupCreate_group_id = 78
+ }
+
+groupRemovedHaskell :: GroupRemove
+groupRemovedHaskell =
+ GroupRemove
+ { groupRemove_created_at = "2012-07-21T07:30:54Z",
+ groupRemove_updated_at = "2012-07-21T07:38:22Z",
+ groupRemove_event_name = "group_destroy",
+ groupRemove_name = "StoreCloud",
+ groupRemove_owner_email = Nothing,
+ groupRemove_owner_name = Nothing,
+ groupRemove_path = "storecloud",
+ groupRemove_group_id = 78
+ }
+
+groupRenamedHaskell :: GroupRename
+groupRenamedHaskell =
+ GroupRename
+ { groupRename_event_name = "group_rename",
+ groupRename_created_at = "2017-10-30T15:09:00Z",
+ groupRename_updated_at = "2017-11-01T10:23:52Z",
+ groupRename_name = "Better Name",
+ groupRename_path = "better-name",
+ groupRename_full_path = "parent-group/better-name",
+ groupRename_group_id = 64,
+ groupRename_owner_name = Nothing,
+ groupRename_owner_email = Nothing,
+ groupRename_old_path = "old-name",
+ groupRename_old_full_path = "parent-group/old-name"
+ }
+
+newGroupMemberHaskell :: NewGroupMember
+newGroupMemberHaskell =
+ NewGroupMember
+ { newGroupMember_created_at = "2012-07-21T07:30:56Z",
+ newGroupMember_updated_at = "2012-07-21T07:38:22Z",
+ newGroupMember_event_name = "user_add_to_group",
+ newGroupMember_group_access = "Maintainer",
+ newGroupMember_group_id = 78,
+ newGroupMember_group_name = "StoreCloud",
+ newGroupMember_group_path = "storecloud",
+ newGroupMember_user_email = "johnsmith@gmail.com",
+ newGroupMember_user_name = "John Smith",
+ newGroupMember_user_username = "johnsmith",
+ newGroupMember_user_id = 41
+ }
+
+groupMemberRemovedHaskell :: GroupMemberRemove
+groupMemberRemovedHaskell =
+ GroupMemberRemove
+ { groupMemberRemove_created_at = "2012-07-21T07:30:56Z",
+ groupMemberRemove_updated_at = "2012-07-21T07:38:22Z",
+ groupMemberRemove_event_name = "user_remove_from_group",
+ groupMemberRemove_group_access = "Maintainer",
+ groupMemberRemove_group_id = 78,
+ groupMemberRemove_group_name = "StoreCloud",
+ groupMemberRemove_group_path = "storecloud",
+ groupMemberRemove_user_email = "johnsmith@gmail.com",
+ groupMemberRemove_user_name = "John Smith",
+ groupMemberRemove_user_username = "johnsmith",
+ groupMemberRemove_user_id = 41
+ }
+
+groupMemberUpdatedHaskell :: GroupMemberUpdate
+groupMemberUpdatedHaskell =
+ GroupMemberUpdate
+ { groupMemberUpdate_created_at = "2012-07-21T07:30:56Z",
+ groupMemberUpdate_updated_at = "2012-07-21T07:38:22Z",
+ groupMemberUpdate_event_name = "user_update_for_group",
+ groupMemberUpdate_group_access = "Maintainer",
+ groupMemberUpdate_group_id = 78,
+ groupMemberUpdate_group_name = "StoreCloud",
+ groupMemberUpdate_group_path = "storecloud",
+ groupMemberUpdate_user_email = "johnsmith@gmail.com",
+ groupMemberUpdate_user_name = "John Smith",
+ groupMemberUpdate_user_username = "johnsmith",
+ groupMemberUpdate_user_id = 41
+ }
+
+pushHaskell :: Push
+pushHaskell =
+ Push
+ { push_event_name = "push",
+ push_before = "95790bf891e76fee5e1747ab589903a6a1f80f22",
+ push_after = "da1560886d4f094c3e6c9ef40349f7d38b5d27d7",
+ push_ref = "refs/heads/master",
+ push_checkout_sha = "da1560886d4f094c3e6c9ef40349f7d38b5d27d7",
+ push_user_id = 4,
+ push_user_name = "John Smith",
+ push_user_email = "john@example.com",
+ push_user_avatar = "https://s.gravatar.com/avatar/d4c74594d841139328695756648b6bd6?s=8://s.gravatar.com/avatar/d4c74594d841139328695756648b6bd6?s=80",
+ push_project_id = 15,
+ push_project = ProjectEvent {projectEvent_name = "Diaspora", projectEvent_description = "", projectEvent_web_url = "http://example.com/mike/diaspora", projectEvent_avatar_url = Nothing, projectEvent_git_ssh_url = "git@example.com:mike/diaspora.git", projectEvent_git_http_url = "http://example.com/mike/diaspora.git", projectEvent_namespace = "Mike", projectEvent_visibility_level = Private, projectEvent_path_with_namespace = "mike/diaspora", projectEvent_default_branch = "master", projectEvent_homepage = Just "http://example.com/mike/diaspora", projectEvent_url = "git@example.com:mike/diaspora.git", projectEvent_ssh_url = "git@example.com:mike/diaspora.git", projectEvent_http_url = "http://example.com/mike/diaspora.git"},
+ push_repository = RepositoryEvent {repositoryEvent_name = "Diaspora", repositoryEvent_url = "git@example.com:mike/diaspora.git", repositoryEvent_description = "", repositoryEvent_homepage = Just "http://example.com/mike/diaspora", repositoryEvent_git_http_url = "http://example.com/mike/diaspora.git", repositoryEvent_git_ssh_url = "git@example.com:mike/diaspora.git", repositoryEvent_visibility_level = Private},
+ push_commits = [CommitEvent {commitEvent_id = "c5feabde2d8cd023215af4d2ceeb7a64839fc428", commitEvent_message = "Add simple search to projects in public area", commitEvent_timestamp = "2013-05-13T18:18:08+00:00", commitEvent_url = "https://dev.gitlab.org/gitlab/gitlabhq/commit/c5feabde2d8cd023215af4d2ceeb7a64839fc428", commitEvent_author = CommitAuthorEvent {commitAuthorEvent_name = "Example User", commitAuthorEvent_email = "user@example.com"}}],
+ push_total_commits_count = 1
+ }
+
+tagPushHaskell :: TagPush
+tagPushHaskell =
+ TagPush
+ { tagPush_event_name = "tag_push",
+ tagPush_before = "0000000000000000000000000000000000000000",
+ tagPush_after = "82b3d5ae55f7080f1e6022629cdb57bfae7cccc7",
+ tagPush_ref = "refs/tags/v1.0.0",
+ tagPush_checkout_sha = "5937ac0a7beb003549fc5fd26fc247adbce4a52e",
+ tagPush_user_id = 1,
+ tagPush_user_name = "John Smith",
+ tagPush_user_avatar = "https://s.gravatar.com/avatar/d4c74594d841139328695756648b6bd6?s=8://s.gravatar.com/avatar/d4c74594d841139328695756648b6bd6?s=80",
+ tagPush_project_id = 1,
+ tagPush_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"},
+ tagPush_repository = RepositoryEvent {repositoryEvent_name = "Example", repositoryEvent_url = "ssh://git@example.com/jsmith/example.git", repositoryEvent_description = "", repositoryEvent_homepage = Just "http://example.com/jsmith/example", repositoryEvent_git_http_url = "http://example.com/jsmith/example.git", repositoryEvent_git_ssh_url = "git@example.com:jsmith/example.git", repositoryEvent_visibility_level = Private},
+ tagPush_commits = [],
+ tagPush_total_commits_count = 0
+ }
diff --git a/tests/Tests.hs b/tests/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Tests.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Data.Maybe (fromJust)
+import SystemHookTests
+import Test.Tasty
+
+main :: IO ()
+main = do
+ defaultMain
+ ( testGroup
+ "gitlab system hook tests"
+ systemHookTests
+ )