packages feed

gitlab-haskell (empty) → 0.1.0.0

raw patch · 19 files changed

+1747/−0 lines, 19 filesdep +aesondep +arraydep +asyncsetup-changed

Dependencies added: aeson, array, async, base, bytestring, connection, containers, http-conduit, http-types, random, text, time, transformers, unliftio, unliftio-core

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gitlab-haskell.cabal view
@@ -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: <https://docs.gitlab.com/ee/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: <https://gitlab.com/robstewart57/gitlab-haskell>+ +                +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
+ src/GitLab.hs view
@@ -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)
+ src/GitLab/API/Branches.hs view
@@ -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"+
+ src/GitLab/API/Commits.hs view
@@ -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
+ src/GitLab/API/Groups.hs view
@@ -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"+
+ src/GitLab/API/Issues.hs view
@@ -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"
+ src/GitLab/API/Jobs.hs view
@@ -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"
+ src/GitLab/API/Members.hs view
@@ -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 <https://docs.gitlab.com/ee/user/permissions.html#project-members-permissions>+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)+
+ src/GitLab/API/MergeRequests.hs view
@@ -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"
+ src/GitLab/API/Pipelines.hs view
@@ -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"
+ src/GitLab/API/Projects.hs view
@@ -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))
+ src/GitLab/API/Repositories.hs view
@@ -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"
+ src/GitLab/API/RepositoryFiles.hs view
@@ -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
+ src/GitLab/API/Users.hs view
@@ -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))
+ src/GitLab/Types.hs view
@@ -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 <https://docs.gitlab.com/ee/user/profile/personal_access_tokens.html>+  , 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 })
+ src/GitLab/WebRequests/GitLabWebCalls.hs view
@@ -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