diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +# A Haskell library for the GitLab web API + +A library that interacts with a GitLab server's API. It supports +queries about and updates to: + +* Branches +* Commits +* Groups +* Issues +* Jobs +* Members +* Merge requests +* Pipelines +* Projects +* Repositories +* Repository files +* Users + +The library parses JSON results into Haskell data types in the +`GitLab.Types` module. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gitlab-haskell.cabal b/gitlab-haskell.cabal new file mode 100644 --- /dev/null +++ b/gitlab-haskell.cabal @@ -0,0 +1,73 @@ +cabal-version: 1.12 +name: gitlab-haskell +category: Git +version: 0.1.0.0 +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: + . + An example that returns projects for which issue creation is enabled is: + . + > projectsWithIssuesEnabled :: IO [Project] + > projectsWithIssuesEnabled = runGitLab myConfig $ filter (issueEnabled . issues_enabled) <$> allProjects + > where myConfig = defaultGitLabServer + > { url = "https://gitlab.example.com" + > , token = "my_access_token" } + > issueEnabled Nothing = False + > issueEnabled (Just t) = t + . + Unsurprisingly, GitLab hosts this Haskell library: + + +homepage: https://gitlab.com/robstewart57/gitlab-haskell +bug-reports: https://gitlab.com/robstewart57/gitlab-haskell/issues +author: Rob Stewart +maintainer: robstewart57@gmail.com +copyright: 2019 Rob Stewart, Heriot-Watt University +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://gitlab.com/robstewart57/gitlab-haskell + +library + exposed-modules: + GitLab + , GitLab.Types + , GitLab.API.Groups + , GitLab.API.Members + , GitLab.API.Commits + , GitLab.API.Projects + , GitLab.API.Users + , GitLab.API.Issues + , GitLab.API.Pipelines + , GitLab.API.Branches + , GitLab.API.Jobs + , GitLab.API.Repositories + , GitLab.API.MergeRequests + , GitLab.API.RepositoryFiles + other-modules: + GitLab.WebRequests.GitLabWebCalls + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , http-conduit >= 2.3.4 + , connection + , aeson + , bytestring + , text + , async + , http-types + , containers + , random + , array + , time + , transformers + , unliftio + , unliftio-core + default-language: Haskell2010 diff --git a/src/GitLab.hs b/src/GitLab.hs new file mode 100644 --- /dev/null +++ b/src/GitLab.hs @@ -0,0 +1,71 @@ + +{-| +Module : GitLab +Description : Contains the 'runGitLab' function to run GitLab actions +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab + ( runGitLab + , module GitLab.Types + , module GitLab.API.Pipelines + , module GitLab.API.Groups + , module GitLab.API.Members + , module GitLab.API.Commits + , module GitLab.API.Projects + , module GitLab.API.Users + , module GitLab.API.Issues + , module GitLab.API.Branches + , module GitLab.API.Jobs + , module GitLab.API.MergeRequests + , module GitLab.API.Repositories + , module GitLab.API.RepositoryFiles + ) where + +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift +import Control.Monad.Trans.Reader +import Network.Connection (TLSSettings (..)) +import Network.HTTP.Conduit +import System.IO + +import GitLab.API.Branches +import GitLab.API.Commits +import GitLab.API.Groups +import GitLab.API.Issues +import GitLab.API.Jobs +import GitLab.API.Members +import GitLab.API.MergeRequests +import GitLab.API.Pipelines +import GitLab.API.Projects +import GitLab.API.Repositories +import GitLab.API.RepositoryFiles +import GitLab.API.Users +import GitLab.Types + +-- | runs a GitLab action. +-- +-- Internally, this creates a single 'Manager', whichs keeps track of +-- open connections for keep-alive and which is shared between +-- multiple threads and requests. +-- +-- An example of its use is: +-- +-- > projectsWithIssuesEnabled :: IO [Project] +-- > projectsWithIssuesEnabled = +-- > runGitLab myConfig $ 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 cfg action = do + liftIO $ hSetBuffering stdout LineBuffering + let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing + manager <- liftIO $ newManager settings + runReaderT action (GitLabState cfg manager) diff --git a/src/GitLab/API/Branches.hs b/src/GitLab/API/Branches.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Branches.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Branches +Description : Queries about repository branches +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Branches where + +import qualified Data.Text as T +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls +import Control.Monad.IO.Unlift + + +-- | Get a list of repository branches from a project, sorted by name +-- alphabetically. +branches :: (MonadIO m) => Project -> GitLab m [Branch] +branches project = branches' (project_id project) + +-- | Get a list of repository branches from a project given its +-- project ID, sorted by name alphabetically. +branches' :: (MonadIO m) => Int -> GitLab m [Branch] +branches' projectId = + gitlab addr + where + addr = + "/projects/" + <> T.pack (show projectId) + <> "/repository" + <> "/branches" + diff --git a/src/GitLab/API/Commits.hs b/src/GitLab/API/Commits.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Commits.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Commits +Description : Queries about commits in repositories +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Commits where + +import Control.Monad.IO.Unlift +import Data.Text (Text) +import qualified Data.Text as T + +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | returns all commits for a project. +projectCommits :: (MonadIO m) + => Project -- ^ the project + -> GitLab m [Commit] +projectCommits project = projectCommits' (project_id project) + +-- | returns all commits for a project given its project ID. +projectCommits' :: (MonadIO m) + => Int -- ^ project ID + -> GitLab m [Commit] +projectCommits' projectId = + gitlab (commitsAddr projectId) + where + commitsAddr :: Int -> Text + commitsAddr projectId = + "/projects/" <> T.pack (show projectId) <> "/repository" <> "/commits" + +-- | returns a commit for the given project and commit hash, if such +-- a commit exists. +commitDetails :: (MonadIO m) + => Project -- ^ the project + -> Text -- ^ the commit hash + -> GitLab m (Maybe Commit) +commitDetails project = commitDetails' (project_id project) + +-- | returns a commit for the given project ID and commit hash, if +-- such a commit exists. +commitDetails' :: (MonadIO m) + => Int -- ^ project ID + -> Text -- ^ the commit hash + -> GitLab m (Maybe Commit) +commitDetails' projectId hash = + gitlabOne (commitsAddr projectId) + where + commitsAddr :: Int -> Text + commitsAddr projectId = + "/projects/" + <> T.pack (show projectId) + <> "/repository" + <> "/commits" + <> "/" <> hash diff --git a/src/GitLab/API/Groups.hs b/src/GitLab/API/Groups.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Groups.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Groups +Description : Queries about and updates to groups +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Groups where + +import Control.Concurrent.Async +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Data.Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHC.Generics +import Network.HTTP.Conduit +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI + +import GitLab.API.Members +import GitLab.API.Users +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | adds all registered users to a group. +addAllUsersToGroup :: + (MonadIO m) + => Text -- ^ group name + -> AccessLevel -- ^ level of access granted + -> GitLab m [Either Status Member] +addAllUsersToGroup groupName access = do + allRegisteredUsers <- allUsers + let allUserIds = map user_username allRegisteredUsers + addUsersToGroup groupName access allUserIds + +-- | adds a user to a group. +addUserToGroup :: + (MonadIO m) + => Text -- ^ group name + -> AccessLevel -- ^ level of access granted + -> User -- ^ the user + -> GitLab m (Either Status Member) +addUserToGroup groupName access user = addUserToGroup' groupName access (user_id user) + +-- | adds a list of users to a group. +addUsersToGroup :: + (MonadIO m) + => Text -- ^ group name + -> AccessLevel -- ^ level of access granted + -> [Text] -- ^ list of usernames to be added to the group + -> GitLab m [Either Status Member] +addUsersToGroup groupName access usernames = do + users <- catMaybes <$> mapM searchUser usernames + mapM (addUserToGroup' groupName access . user_id) users + +-- | adds a user with a given user ID to a group. +addUserToGroup' :: + (MonadIO m) + => Text -- ^ group name + -> AccessLevel -- ^ level of access granted + -> Int -- ^ user ID + -> GitLab m (Either Status Member) +addUserToGroup' groupName access userId = gitlabPost addr dataBody + where + dataBody :: Text + dataBody = + "user_id=" <> T.pack (show userId) <> "&access_level=" <> + T.pack (show access) + addr = "/groups/" <> groupName <> "/members" + diff --git a/src/GitLab/API/Issues.hs b/src/GitLab/API/Issues.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Issues.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Issues +Description : Queries about issues created against projects +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Issues where + +import Control.Concurrent.Async +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift +import Control.Monad.Trans.Reader +import Data.Array.IO +import Data.List +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar +import Network.HTTP.Types.Status +import System.IO +import System.Random +import UnliftIO.Async + +import GitLab.WebRequests.GitLabWebCalls +import GitLab.Types + +-- | returns all issues against a project. +projectOpenedIssues :: + (MonadIO m) + => Project -- ^ the project + -> GitLab m [Issue] +projectOpenedIssues = projectOpenedIssues' . project_id + +-- | returns all issues against a project given its project ID. +projectOpenedIssues' :: + (MonadIO m) + => Int -- ^ the project ID + -> GitLab m [Issue] +projectOpenedIssues' projectId = do + let path = "/projects/" <> T.pack (show projectId) <> "/issues" + gitlab path + -- gitlabReq path "&state=opened" + +-- | gets all issues create by a user. +userIssues :: + (MonadIO m) + => User -- ^ the user + -> GitLab m [Issue] +userIssues user = + gitlabWithAttrs addr attrs + where + addr = "/issues" + attrs = T.pack $ + "&author_id=" + <> show (user_id user) + <> "&scope=all" diff --git a/src/GitLab/API/Jobs.hs b/src/GitLab/API/Jobs.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Jobs.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Jobs +Description : Queries about jobs ran on projects +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Jobs where + +import Control.Monad.IO.Unlift +import qualified Data.Text as T + +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | returns all jobs ran on a project. +jobs :: + (MonadIO m) + => Project -- ^ the project + -> GitLab m [Job] +jobs project = jobs' (project_id project) + +-- | returns all jobs ran on a project given its project ID. +jobs' :: + (MonadIO m) + => Int -- ^ the project ID + -> GitLab m [Job] +jobs' projectId = + gitlab addr + where + addr = + "/projects/" + <> T.pack (show projectId) + <> "/jobs" diff --git a/src/GitLab/API/Members.hs b/src/GitLab/API/Members.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Members.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Members +Description : Queries about and updates to members of projects +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Members where + +import Control.Concurrent.Async +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Data.List +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar +import Network.HTTP.Types.Status +import System.IO + +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | the access levels for project members. See +data AccessLevel = + Guest + | Reporter + | Developer + | Maintainer + | Owner + +instance Show AccessLevel where + show Guest = "10" + show Reporter = "20" + show Developer = "30" + show Maintainer = "40" + show Owner = "50" + +-- | the members of a project. +membersOfProject :: (MonadIO m) => Project -> GitLab m [Member] +membersOfProject = membersOfProject' . project_id + +-- | the members of a project given its ID. +membersOfProject' :: (MonadIO m) => Int -> GitLab m [Member] +membersOfProject' projectId = + gitlab addr + where + addr = + "/projects/" <> T.pack (show projectId) <> "/members" + +-- | adds a user to a project with the given access level. Returns +-- 'Right Member' for each successful action, otherwise it returns +-- 'Left Status'. +addMemberToProject :: + (MonadIO m) + => Project -- ^ the project + -> AccessLevel -- ^ level of access + -> User -- ^ the user + -> GitLab m (Either Status Member) +addMemberToProject project access user = + addMemberToProject' (project_id project) access (user_id user) + +-- | adds a user to a project with the given access level, given the +-- project's ID and the user's ID. Returns @Right Member@ for each +-- successful action, otherwise it returns @Left Status@. +addMemberToProject' :: + (MonadIO m) + => Int -- ^ project ID + -> AccessLevel -- ^ level of access + -> Int -- ^ user ID + -> GitLab m (Either Status Member) +addMemberToProject' projectId access userId = + gitlabPost addr dataBody + where + dataBody :: Text + dataBody = + "user_id=" <> T.pack (show userId) <> "&access_level=" <> T.pack (show access) + addr = + "/projects/" <> T.pack (show projectId) <> "/members" + + +-- | adds a list of users to a project with the given access +-- level. Returns 'Right Member' for each successful action, otherwise +-- it returns 'Left Status'. +addMembersToProject :: + (MonadIO m) + => Project -- ^ the project + -> AccessLevel -- ^ level of access + -> [User] -- ^ users to add to the project + -> GitLab m [Either Status Member] +addMembersToProject project access = + mapM (addMemberToProject project access) + +-- | adds a list of users to a project with the given access level, +-- given the project's ID and the user IDs. Returns @Right Member@ for +-- each successful action, otherwise it returns @Left Status@. +addMembersToProject' :: + (MonadIO m) + => Int -- ^ project ID + -> AccessLevel -- ^ level of acces + -> [Int] -- ^ IDs of users to add to the project + -> GitLab m [Either Status Member] +addMembersToProject' projectId access = + mapM (addMemberToProject' projectId access) + diff --git a/src/GitLab/API/MergeRequests.hs b/src/GitLab/API/MergeRequests.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/MergeRequests.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : MergeRequests +Description : Queries about merge requests against projects +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.MergeRequests where + +import Control.Monad.IO.Unlift +import qualified Data.Text as T + +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | returns the merge requests for a project. +mergeRequests :: (MonadIO m) + => Project -- ^ the project + -> GitLab m [MergeRequest] +mergeRequests = mergeRequests' . project_id + +-- | returns the merge requests for a project given its project ID. +mergeRequests' :: (MonadIO m) + => Int -- ^ project ID + -> GitLab m [MergeRequest] +mergeRequests' projectId = + gitlabWithAttrs addr "&scope=all" + where + addr = + "/projects/" + <> T.pack (show projectId) + <> "/merge_requests" diff --git a/src/GitLab/API/Pipelines.hs b/src/GitLab/API/Pipelines.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Pipelines.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Pipelines +Description : Queries about project pipelines +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Pipelines where + +import Control.Monad.IO.Unlift +import qualified Data.Text as T + +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | returns the pipelines for a project. +pipelines :: (MonadIO m) + => Project -- ^ the project + -> GitLab m [Pipeline] +pipelines = pipelines' . project_id + +-- | returns the pipelines for a project given its project ID. +pipelines' :: (MonadIO m) + => Int -- ^ the project ID + -> GitLab m [Pipeline] +pipelines' projectId = + gitlabWithAttrs + addr + "&sort=desc" -- most recent first + where + addr = + "/projects/" + <> T.pack (show projectId) + <> "/pipelines" diff --git a/src/GitLab/API/Projects.hs b/src/GitLab/API/Projects.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Projects.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Projects +Description : Queries about projects +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Projects where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift +import Control.Monad.Trans.Reader +import Data.Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock +import GHC.Generics +import Network.HTTP.Conduit +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI +import System.IO +import UnliftIO.Async + +import GitLab.API.Commits +import GitLab.API.Issues +import GitLab.API.Pipelines +import GitLab.API.Users +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | gets all projects. +allProjects :: (MonadIO m) => GitLab m [Project] +allProjects = + gitlab "/projects" + +-- | gets all forks of a project. Supports use of namespaces. +-- +-- > projectForks "project1" +-- > projectForks "group1/project1" +projectForks :: (MonadUnliftIO m, MonadIO m) + => Text -- ^ name or namespace of the project + -> GitLab m [Project] +projectForks projectName = do + let path = + "/projects/" <> + T.decodeUtf8 (urlEncode False (T.encodeUtf8 projectName)) <> + "/forks" + gitlab path + +-- | searches for a 'Project' with the given project ID, returns +-- 'Nothing' if a project with the given ID is not found. +searchProjectId :: (MonadIO m) + => Int -- ^ project ID + -> GitLab m (Maybe Project) +searchProjectId projectId = do + let path = T.pack ("/projects/" <> show projectId) + gitlabOne path + +-- | gets all projects with the given project name. +-- +-- > projectsWithName "project1" +projectsWithName :: (MonadUnliftIO m, MonadIO m) + => Text -- ^ project name being searched for. + -> GitLab m [Project] +projectsWithName projectName = + filter (\project -> projectName == project_path project) <$> + gitlabWithAttrs "/projects" ("&search=" <> projectName) + +-- | gets a project with the given name for the given username. E.g. +-- +-- > projectsNamespaceName "user1" "project1" +-- +-- looks for "user1/project1" +projectsWithNameAndUser :: + (MonadUnliftIO m, MonadIO m) => Text -> Text -> GitLab m (Maybe Project) +projectsWithNameAndUser username projectName = + gitlabOne + ("/projects/" <> + T.decodeUtf8 + (urlEncode False (T.encodeUtf8 (username <> "/" <> projectName)))) + +-- | 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 = 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 = commitsEmailAddresses' . project_id + +-- | 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 [Text] +commitsEmailAddresses' projectId = do + (commits :: [Commit]) <- projectCommits' projectId + return (map author_email commits) + +-- | gets all projects for a user's username. +-- +-- > userProjects "harry" +userProjects :: + (MonadUnliftIO m, MonadIO m) => Text -> GitLab m (Maybe [Project]) +userProjects username = do + userMaybe <- searchUser username + case userMaybe of + Nothing -> return Nothing + Just user -> Just <$> gitlab (path (user_id user)) + where + path userId = "/users/" <> T.pack (show userId) <> "/projects" + +-- | gets the 'GitLab.Types.Project' against which the given 'Issue' +-- was created. +projectOfIssue :: (MonadIO m) => Issue -> GitLab m Project +projectOfIssue issue = + fromJust <$> searchProjectId (issue_project_id issue) + +-- | finds all issues created by a user. +-- +-- > issuesCreatedByUser "user1" +-- +-- 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 username = do + user <- searchUser username + case user of + Nothing -> return Nothing + Just usr -> do + issues <- userIssues usr + projects <- mapConcurrently projectOfIssue issues + return (Just (usr, projects)) + +-- | searches for all projects with the given name, and returns a list +-- 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) + => Text -- ^ name or namespace of the project + -> GitLab m [(Project, [Issue], [User])] +issuesOnForks projectName = do + projects <- projectsWithName projectName + mapM processProject projects + where + processProject proj = do + issues <- projectOpenedIssues proj + let authors = map issue_author issues + return (proj, issues, authors) + +-- | returns a (namespace,members) tuple for the given 'Project', +-- 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 = do + friends <- count + return (namespace_name (namespace project), friends) + where + count = do + let addr = + "/projects/" <> T.pack (show (project_id project)) <> "/members/all" + (res :: [Member]) <- gitlab addr + return (map (\x -> (member_username x, member_name x)) res) + +-- | returns 'True' is the last commit for a project passes all +-- continuous integration tests. +projectCISuccess :: + (MonadIO m) + => Project -- ^ the name or namespace of the project + -> GitLab m Bool +projectCISuccess project = do + pipes <- pipelines project + case pipes of + [] -> return False + (x:xs) -> return (pipeline_status x == "success") + +-- | searches for a username, and returns a user ID for that user, or +-- 'Nothing' if a user cannot be found. +namespacePathToUserId :: (MonadIO m) + => Text -- ^ name or namespace of project + -> GitLab m (Maybe Int) +namespacePathToUserId namespacePath = do + user <- searchUser namespacePath + case user of + Nothing -> return Nothing + Just user -> return (Just (user_id user)) diff --git a/src/GitLab/API/Repositories.hs b/src/GitLab/API/Repositories.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Repositories.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Repositories +Description : Queries about project repositories +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Repositories where + +import Control.Monad.IO.Unlift +import qualified Data.Text as T + +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | returns a list of repository files and directories in a project. +repositories :: (MonadIO m) + => Project -- ^ the project + -> GitLab m [Repository] +repositories project = repositories' (project_id project) + +-- | returns a list of repository files and directories in a project +-- given its project ID. +repositories' :: (MonadIO m) + => Int -- ^ the project ID + -> GitLab m [Repository] +repositories' projectId = + gitlab addr + where + addr = + "/projects/" + <> T.pack (show projectId) + <> "/repository" + <> "/tree" diff --git a/src/GitLab/API/RepositoryFiles.hs b/src/GitLab/API/RepositoryFiles.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/RepositoryFiles.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : RepositoryFiles +Description : Queries about project repository files +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.RepositoryFiles where + +import Control.Monad.IO.Unlift +import Data.Text (Text) +import qualified Data.Text as T + +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | Get a list of repository files and directories in a project. +repositoryFiles :: (MonadIO m) + => Project -- ^ the project + -> Text -- ^ the file path + -> Text -- ^ name of the branch, tag or commit + -> GitLab m (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) + => Int -- ^ project ID + -> Text -- ^ the file path + -> Text -- ^ name of the branch, tag or commit + -> GitLab m (Maybe RepositoryFile) +repositoryFiles' projectId filePath ref = + gitlabWithAttrsOne addr ("&ref=" <> ref) + where + addr = + "/projects/" + <> T.pack (show projectId) + <> "/repository" + <> "/files" + <> "/" + <> filePath diff --git a/src/GitLab/API/Users.hs b/src/GitLab/API/Users.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Users.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Users +Description : Queries about registered users +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.API.Users where + +import Control.Concurrent.Async +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Data.Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock +import GHC.Generics +import Network.HTTP.Conduit +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI +import System.IO + +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls + +-- | all registered users. +allUsers :: (MonadIO m) => GitLab m [User] +allUsers = do + let path = "/users" + gitlab path + +-- | searches for a user given a username. Returns @Just User@ if the +-- user is found, otherwise @Nothing@. +searchUser :: (MonadIO m) + => Text -- ^ username to search for + -> GitLab m (Maybe User) +searchUser username = do + let path = "/users" + attrs = "&username=" <> username + res <- gitlabWithAttrs path attrs + if null res + then return Nothing + else return (Just (head res)) + +-- | searches for users given a list of usernames, returns them in +-- alphabetical order of their usernames. +orderedUsers :: (MonadIO m) + => [Text] -- ^ usernames to search for + -> GitLab m [User] +orderedUsers usernames = do + users <- catMaybes <$> mapM searchUser usernames + return (orderUsersByName users) + where + orderUsersByName :: [User] -> [User] + orderUsersByName = + sortBy (\u1 u2 -> compare (user_name u1) (user_name u2)) diff --git a/src/GitLab/Types.hs b/src/GitLab/Types.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/Types.hs @@ -0,0 +1,603 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GitLab.Types +Description : Haskell records corresponding to JSON data from GitLab API calls +Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +License : BSD3 +Maintainer : robstewart57@gmail.com +Stability : stable +-} +module GitLab.Types + ( + GitLab + , GitLabState(..) + , GitLabServerConfig(..) + , defaultGitLabServer + , Member(..) + , Namespace(..) + , Links(..) + , Owner(..) + , Permissions(..) + , Project(..) + , User(..) + , Milestone(..) + , TimeStats(..) + , Issue(..) + , Pipeline(..) + , Commit(..) + , Stats(..) + , Repository(..) + , Job(..) + , Artifact(..) + , Branch(..) + , RepositoryFile(..) + , MergeRequest(..) + ) where + +import qualified Data.ByteString.Lazy as BSL +import Data.Aeson +import Data.Text (Text) +import GHC.Generics +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Conduit +-- import APICalls +import Control.Monad.Trans.Reader +import Network.Connection (TLSSettings (..)) + +-- | type synonym for all GitLab actions. +type GitLab m a = ReaderT GitLabState m a + +-- | state used by GitLab actions, used internally. +data GitLabState = + GitLabState + { serverCfg :: GitLabServerConfig + , httpManager :: Manager + } + +-- | configuration data specific to a GitLab server. +data GitLabServerConfig = + GitLabServerConfig + { url :: Text + , token :: Text -- ^ personal access token, see + , timeout :: Int -- ^ milliseconds + , retries :: Int -- ^ how many times to retry a HTTP request before giving up and returning an error. + } + +-- | default settings, the 'url' and 'token' values will need to be overwritten. +defaultGitLabServer :: GitLabServerConfig +defaultGitLabServer = + GitLabServerConfig + { url = "https://gitlab.com" + , token = "" + , timeout = 15000000 -- 15 seconds + , retries = 5 + } + +-- | 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 + } deriving (Generic, Show) + +-- | namespaces. +data Namespace = + Namespace + { namespace_id :: Int + , namespace_name :: Text + , namespace_path :: Text + , kind :: Text + , full_path :: Text + , parent_id :: Maybe Text + } deriving (Generic, Show, Eq) + +-- | links. +data Links = + Links + { self :: Text + , issues :: Text + , merge_requests :: Text + , repo_branches :: Text + , link_labels :: Text + , link_events :: Text + , members :: Text + } deriving (Generic, Show, Eq) + +-- | owners. +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, Eq) + +-- | permissions. +data Permissions = + Permissions + { project_access :: Maybe Object + , group_access :: Maybe Object + } deriving (Generic, Show, Eq) + +-- | 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 + } deriving (Generic, Show, Eq) + +-- | 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 + } deriving (Generic, Show, Eq) + +-- | project milestones. +data Milestone = + Milestone + { milestone_project_id :: Int + , milestone_description :: Text + , milestone_state :: Text + , due_date :: Maybe Text + , milestone_iid :: Int + , milestone_created_at :: Maybe Text + , milestone_title :: Text + , milestone_id :: Int + , milestone_updated_at :: Text + } deriving (Generic, Show, Eq) + +-- | time stats. +data TimeStats = + TimeStats + { time_estimate :: Int + , total_time_spent :: Int + , humane_time_estimate :: Maybe Int + , human_total_time_spent :: Maybe Int + } deriving (Generic, Show, Eq) + +-- | 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 + } deriving (Generic, Show, Eq) + +-- | project pipelines +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 [Text] + , last_pipeline :: Maybe Pipeline + , stats :: Maybe Stats + , commit_status :: Maybe Text + } deriving (Generic, Show) + +-- | commit stats. +data Stats = + Stats + { additions :: Int + , deletions :: Int + , total :: Int + } deriving (Generic, Show) + +-- | repositories. +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 + } deriving (Generic, Show) + +-- | artifacts. +data Artifact = + Artifact + { file_type :: Text + , size :: Int + , filename :: Text + , file_format :: 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 + } 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 + } 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 :: Bool + -- , merge_request_allow_maintainer_to_push :: Bool + , merge_request_web_url :: Text + , merge_request_time_stats :: TimeStats + , merge_request_squash :: Bool + , merge_request_approvals_before_merge :: Maybe Bool -- ? + } deriving (Generic, Show) + +----------------------------- +-- JSON GitLab parsers below +----------------------------- + +bodyNoPrefix :: String -> String +bodyNoPrefix "project_id" = "id" +bodyNoPrefix "namespace_id" = "id" +bodyNoPrefix "owner_id" = "id" +bodyNoPrefix "user_id" = "id" +bodyNoPrefix "repository_id" = "id" +bodyNoPrefix "project_name" = "name" +bodyNoPrefix "repository_name" = "name" +bodyNoPrefix "project_path" = "path" +bodyNoPrefix "namespace_name" = "name" +bodyNoPrefix "user_name" = "name" +bodyNoPrefix "namespace_path" = "path" +bodyNoPrefix "owner_name" = "name" +bodyNoPrefix "owner_avatar_url" = "avatar_url" +bodyNoPrefix "user_avatar_url" = "avatar_url" +bodyNoPrefix "owner_web_url" = "web_url" +bodyNoPrefix "job_web_url" = "web_url" +bodyNoPrefix "project_avatar_url" = "avatar_url" +bodyNoPrefix "project_web_url" = "web_url" +bodyNoPrefix "member_id" = "id" +bodyNoPrefix "member_name" = "name" +bodyNoPrefix "member_avatar_url" = "avatar_url" +bodyNoPrefix "member_web_url" = "we_url" +bodyNoPrefix "user_web_url" = "we_url" +bodyNoPrefix "member_username" = "username" +bodyNoPrefix "owner_username" = "username" +bodyNoPrefix "user_username" = "username" +bodyNoPrefix "pipeline_id" = "id" +bodyNoPrefix "pipeline_web_url" = "web_url" +bodyNoPrefix "commit_id" = "id" +bodyNoPrefix "member_state" = "state" +bodyNoPrefix "user_state" = "state" +bodyNoPrefix "issue_state" = "state" +bodyNoPrefix "issue_description" = "description" +bodyNoPrefix "issue_author" = "author" +bodyNoPrefix "issue_project_id" = "project_id" +bodyNoPrefix "issue_id" = "id" +bodyNoPrefix "issue_title" = "title" +bodyNoPrefix "issue_due_date" = "due_date" +bodyNoPrefix "issue_web_url" = "web_url" +bodyNoPrefix "commit_status" = "status" +bodyNoPrefix "pipeline_status" = "status" +bodyNoPrefix "issue_labels" = "labels" +bodyNoPrefix "link_labels" = "labels" +bodyNoPrefix "issue_created_at" = "created_at" +bodyNoPrefix "commit_created_at" = "created_at" +bodyNoPrefix "project_created_at" = "created_at" +bodyNoPrefix "milestone_created_at" = "created_at" +bodyNoPrefix "link_events" = "events" +bodyNoPrefix "repository_type" = "type" +bodyNoPrefix "repository_path" = "path" + +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" +bodyNoPrefix "branch_commit" = "commit" + +bodyNoPrefix "repository_file_file_name" = "file_name" +bodyNoPrefix "repository_file_file_path" = "file_path" +bodyNoPrefix "repository_file_size" = "size" +bodyNoPrefix "repository_file_commit_id" = "commit_id" + +bodyNoPrefix "merge_request_id" = "id" +bodyNoPrefix "merge_request_iid" = "iid" +bodyNoPrefix "merge_request_project_id" = "project_id" +bodyNoPrefix "merge_request_title" = "title" +bodyNoPrefix "merge_request_description" = "description" +bodyNoPrefix "merge_request_state" = "state" +bodyNoPrefix "merge_request_merged_by" = "merged_by" +bodyNoPrefix "merge_request_merged_at" = "merged_at" +bodyNoPrefix "merge_request_closed_by" = "closed_by" +bodyNoPrefix "merge_request_closed_at" = "closed_at" +bodyNoPrefix "merge_request_created_at" = "created_at" +bodyNoPrefix "merge_request_updated_at" = "updated_at" +bodyNoPrefix "merge_request_target_branch" = "target_branch" +bodyNoPrefix "merge_request_source_branch" = "source_branch" +bodyNoPrefix "merge_request_upvotes" = "upvotes" +bodyNoPrefix "merge_request_downvotes" = "downvotes" +bodyNoPrefix "merge_request_author" = "author" +bodyNoPrefix "merge_request_assignee" = "assignee" +bodyNoPrefix "merge_request_source_project_id" = "source_project_id" +bodyNoPrefix "merge_request_target_project_id" = "target_project_id" +bodyNoPrefix "merge_request_labels" = "labels" +bodyNoPrefix "merge_request_work_in_progress" = "work_in_progress" +bodyNoPrefix "merge_request_milestone" = "milestone" +bodyNoPrefix "merge_request_merge_when_pipeline_succeeds" = "merge_when_pipeline_succeeds" +bodyNoPrefix "merge_request_merge_status" = "merge_status" +bodyNoPrefix "merge_request_sha" = "sha" +bodyNoPrefix "merge_request_merge_commit_sha" = "merge_commit_sha" +bodyNoPrefix "merge_request_user_notes_count" = "user_notes_count" +bodyNoPrefix "merge_request_discussion_locked" = "discussion_locked" +bodyNoPrefix "merge_request_should_remove_source_branch" = "should_remove_source_branch" +bodyNoPrefix "merge_request_force_remove_source_branch" = "force_remove_source_branch" +bodyNoPrefix "merge_request_allow_collaboration" = "allow_collaboration" +bodyNoPrefix "merge_request_allow_maintainer_to_push" = "allow_maintainer_to_push" +bodyNoPrefix "merge_request_web_url" = "web_url" +bodyNoPrefix "merge_request_time_stats" = "time_stats" +bodyNoPrefix "merge_request_squash" = "squash" +bodyNoPrefix "merge_request_approvals_before_merge" = "approvals_before_merge" + + + +-- TODO field names for Issues data type +bodyNoPrefix s = s + +instance FromJSON TimeStats where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Milestone where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Issue where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON User where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Commit where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Stats where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Pipeline where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Member where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Permissions where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Owner where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Links where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Namespace where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Project where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Repository where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Job where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Artifact where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON Branch where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON RepositoryFile where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) + +instance FromJSON MergeRequest where + parseJSON = genericParseJSON + (defaultOptions + { fieldLabelModifier = bodyNoPrefix }) diff --git a/src/GitLab/WebRequests/GitLabWebCalls.hs b/src/GitLab/WebRequests/GitLabWebCalls.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/WebRequests/GitLabWebCalls.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | internal module to support modules in GitLab.API +module GitLab.WebRequests.GitLabWebCalls + ( + gitlab + , gitlabWithAttrs + , gitlabOne + , gitlabWithAttrsOne + , gitlabPost + ) where + +import Network.Connection (TLSSettings (..)) +import Network.HTTP.Conduit +import qualified Data.ByteString.Lazy as BSL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Aeson +import qualified Control.Exception as E +import System.IO +import Network.HTTP.Types.Status +import GitLab.Types +import Control.Monad.Trans.Reader +import Control.Monad.IO.Class + +gitlabPost :: + (MonadIO m, FromJSON b) => + Text -- ^ the URL to post to + -> Text -- ^ the data to post + -> GitLab m (Either Status b) +gitlabPost 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 = "POST" + , requestHeaders = + [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))] + , requestBody = RequestBodyBS (T.encodeUtf8 dataBody) } + res <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing + case responseStatus res of + status@(Status 404 msg) -> return (Left status) + status@(Status 409 msg) -> return (Left status) + _ -> return (case parseBSOne (responseBody res) of + Just x -> Right x) + +tryGitLab :: + Int -- ^ the current retry count + -> Request -- ^ the GitLab request + -> Int -- ^ maximum number of retries permitted + -> Manager -- ^ HTTP manager + -> Maybe HttpException -- ^ the exception to report if maximum retries met + -> IO (Response BSL.ByteString) +tryGitLab i request retries manager ex + | i == retries = error (show ex) + | otherwise = + httpLbs request manager + `E.catch` + \ex -> tryGitLab (i+1) request retries manager (Just ex) + +parseBSOne :: FromJSON a => BSL.ByteString -> Maybe a +parseBSOne bs = + case eitherDecode bs of + Left s -> error (show s) + Right xs -> Just xs + +parseBSMany :: FromJSON a => BSL.ByteString -> [a] +parseBSMany bs = + case eitherDecode bs of + Left s -> error s + Right xs -> xs + +gitlabReq :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a] +gitlabReq urlPath attrs = + go 1 [] + where + go i accum = do + cfg <- serverCfg <$> ask + manager <- httpManager <$> ask + let url' = + url cfg + <> "/api/v4" + <> urlPath + <> "?per_page=100" + <> "&page=" + <> T.pack (show i) + <> attrs + let request' = parseRequest_ (T.unpack url') + request = request' + { requestHeaders = + [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))] + , responseTimeout = responseTimeoutMicro (timeout cfg) + } + res <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing + let numPages = totalPages res + accum' = accum ++ parseBSMany (responseBody res) + if numPages == i + then return accum' + else go (i+1) accum' + +gitlabReqOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a) +gitlabReqOne urlPath attrs = + go + where + go = do + cfg <- serverCfg <$> ask + manager <- httpManager <$> ask + 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) + } + res <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing + return (parseBSOne (responseBody res)) + +gitlab :: (MonadIO m, FromJSON a) => Text -> GitLab m [a] +gitlab addr = gitlabReq addr "" + +gitlabOne :: (MonadIO m, FromJSON a) => Text -> GitLab m (Maybe a) +gitlabOne addr = gitlabReqOne addr "" + +gitlabWithAttrs :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a] +gitlabWithAttrs = gitlabReq + +gitlabWithAttrsOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a) +gitlabWithAttrsOne = gitlabReqOne + +totalPages :: Response a -> Int +totalPages resp = + let hdrs = responseHeaders resp + in findPages hdrs + where + findPages [] = 1 -- error "cannot find X-Total-Pages in header" + findPages (("X-Total-Pages",bs):xs) = read (T.unpack (T.decodeUtf8 bs)) + findPages (_:xs) = findPages xs