gitlab-haskell 1.4.1.0 → 1.5.0.0

raw patch · 10 files changed

+250/−62 lines, 10 filesdep +exceptionsdep +safe-exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, safe-exceptions

API changes (from Hackage documentation)

Files

• data/api/merge-requests/single-merge-request2.json +125/−0
• gitlab-haskell.cabal +7/−1
• src/GitLab.hs +10/−1
• src/GitLab/API/Boards.hs +15/−12
• src/GitLab/API/Branches.hs +3/−3
• src/GitLab/API/Commits.hs +8/−5
• src/GitLab/API/Pipelines.hs +2/−1
• src/GitLab/API/Users.hs +1/−1
• src/GitLab/Types.hs +21/−2
• src/GitLab/WebRequests/GitLabWebCalls.hs +58/−36

@@ -0,0 +1,125 @@+{+  "id": 18468,+  "iid": 16018,+  "project_id": 1,+  "title": "users-guide: Fix weird notation in \"Summary of stolen syntax\"",+  "description": "Fixes #26869",+  "state": "closed",+  "created_at": "2026-05-11T18:43:41.85Z",+  "updated_at": "2026-05-18T14:22:27.43Z",+  "merged_by": null,+  "merge_user": null,+  "merged_at": null,+  "closed_by": {+    "id": 94751,+    "username": "meritamen",+    "public_email": "meritamen@sdf.org",+    "name": "Mrjtjmn",+    "state": "active",+    "locked": false,+    "avatar_url": "https://gitlab.haskell.org/uploads/-/system/user/avatar/94751/avatar.png",+    "web_url": "https://gitlab.haskell.org/meritamen"+  },+  "closed_at": "2026-05-18T13:16:33.016Z",+  "target_branch": "master",+  "source_branch": "master",+  "user_notes_count": 6,+  "upvotes": 1,+  "downvotes": 0,+  "author": {+    "id": 94751,+    "username": "meritamen",+    "public_email": "meritamen@sdf.org",+    "name": "Mrjtjmn",+    "state": "active",+    "locked": false,+    "avatar_url": "https://gitlab.haskell.org/uploads/-/system/user/avatar/94751/avatar.png",+    "web_url": "https://gitlab.haskell.org/meritamen"+  },+  "assignees": [+    {+      "id": 94751,+      "username": "meritamen",+      "public_email": "meritamen@sdf.org",+      "name": "Mrjtjmn",+      "state": "active",+      "locked": false,+      "avatar_url": "https://gitlab.haskell.org/uploads/-/system/user/avatar/94751/avatar.png",+      "web_url": "https://gitlab.haskell.org/meritamen"+    }+  ],+  "assignee": {+    "id": 94751,+    "username": "meritamen",+    "public_email": "meritamen@sdf.org",+    "name": "Mrjtjmn",+    "state": "active",+    "locked": false,+    "avatar_url": "https://gitlab.haskell.org/uploads/-/system/user/avatar/94751/avatar.png",+    "web_url": "https://gitlab.haskell.org/meritamen"+  },+  "reviewers": [],+  "source_project_id": null,+  "target_project_id": 1,+  "labels": [+    "documentation",+    "no-changelog"+  ],+  "draft": false,+  "imported": false,+  "imported_from": "none",+  "work_in_progress": false,+  "milestone": null,+  "merge_when_pipeline_succeeds": false,+  "merge_status": "can_be_merged",+  "detailed_merge_status": "not_open",+  "merge_after": null,+  "sha": "8cfc3a9241d9a178437ea10804384cd7125cd4e9",+  "merge_commit_sha": null,+  "squash_commit_sha": null,+  "discussion_locked": null,+  "should_remove_source_branch": null,+  "force_remove_source_branch": null,+  "prepared_at": "2026-05-11T18:43:55.731Z",+  "allow_collaboration": false,+  "allow_maintainer_to_push": false,+  "reference": "!16018",+  "references": {+    "short": "!16018",+    "relative": "!16018",+    "full": "ghc/ghc!16018"+  },+  "web_url": "https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16018",+  "time_stats": {+    "time_estimate": 0,+    "total_time_spent": 0,+    "human_time_estimate": null,+    "human_total_time_spent": null+  },+  "squash": false,+  "squash_on_merge": false,+  "task_completion_status": {+    "count": 0,+    "completed_count": 0+  },+  "has_conflicts": false,+  "blocking_discussions_resolved": true,+  "approvals_before_merge": null,+  "subscribed": false,+  "changes_count": "2",+  "latest_build_started_at": null,+  "latest_build_finished_at": null,+  "first_deployed_to_production_at": null,+  "pipeline": null,+  "head_pipeline": null,+  "diff_refs": {+    "base_sha": "1e60023bfac04260fa6f22a9a9bfb0774fb3ee4c",+    "head_sha": "8cfc3a9241d9a178437ea10804384cd7125cd4e9",+    "start_sha": "1e60023bfac04260fa6f22a9a9bfb0774fb3ee4c"+  },+  "merge_error": null,+  "first_contribution": true,+  "user": {+    "can_merge": false+  }+}

@@ -1,7 +1,7 @@ cabal-version: 3.0 name:           gitlab-haskell category:       Git-version:        1.4.1.0+version:        1.5.0.0 synopsis:       A Haskell library for the GitLab web API description:             This library lifts the GitLab REST API into Haskell: <https://docs.gitlab.com/ee/api/>@@ -155,6 +155,7 @@   , data/api/merge-requests/time-estimate-merge-request.json   , data/api/merge-requests/list-merge-request-pipelines.json   , data/api/merge-requests/single-merge-request.json+  , data/api/merge-requests/single-merge-request2.json   , data/api/merge-requests/merge-to-default-merge-path.json   , data/api/merge-requests/single-merge-request-diff-version.json   , data/api/merge-requests/comments-on-merge-requests.json@@ -195,6 +196,9 @@                 , GitLab.SystemHooks.Rules   other-modules:                   GitLab.WebRequests.GitLabWebCalls+                  Paths_gitlab_haskell+  autogen-modules:+                  Paths_gitlab_haskell   hs-source-dirs:                  src   build-depends:@@ -212,6 +216,8 @@               , unix-compat               , mtl >= 2.2.2               , data-default+              , safe-exceptions+              , exceptions   default-language: Haskell2010   ghc-options: -Wall                -- the following two for the stan static analysis tool

@@ -142,5 +142,14 @@ runGitLabDbg (GitLabT action) = do   liftIO $ hSetBuffering stdout LineBuffering   manager <- liftIO $ newManager (mkManagerSettings def Nothing)-  let cfg = GitLabServerConfig {url = "", authMethod = AuthMethodToken "", retries = 1, delayBetweenRetries = 1, debugSystemHooks = Nothing}+  let+    cfg =+      GitLabServerConfig+        { url = ""+        , authMethod = AuthMethodToken ""+        , retries = 1+        , delayBetweenRetries = 1+        , debugSystemHooks = Nothing+        , userAgent = ""+        }   runExceptT (runReaderT action (GitLabState cfg manager))

@@ -45,9 +45,9 @@   ) where +import Control.Monad.Except import qualified Data.ByteString.Lazy as BSL import Data.Default-import Data.Either import Data.Maybe import Data.Text (Text) import qualified Data.Text as T@@ -63,8 +63,9 @@   GitLab [IssueBoard] projectIssueBoards project = do   result <- projectIssueBoards' (project_id project)-  -- return an empty list if the repository could not be found.-  return (fromRight [] result)+  case result of+    Left resp -> throwError (httpResponseError "projectIssueBoards" resp)+    Right xs -> return xs  -- | returns all issue boards for a project given its project ID. projectIssueBoards' ::@@ -111,7 +112,9 @@   GitLab (Maybe IssueBoard) createIssueBoard project boardName = do   result <- createIssueBoard' (project_id project) boardName-  return (fromRight Nothing result)+  case result of+    Left resp -> throwError (httpResponseError "createIssueBoard" resp)+    Right xs -> return xs  -- | Creates a project issue board. createIssueBoard' ::@@ -182,8 +185,9 @@   GitLab [BoardIssue] projectBoardLists project board = do   result <- projectBoardLists' (project_id project) (board_id board)-  -- return an empty list if the repository could not be found.-  return (fromRight [] result)+  case result of+    Left resp -> throwError (httpResponseError "projectBoardLists" resp)+    Right xs -> return xs  -- | Get a list of the board’s lists. Does not include open and closed lists. projectBoardLists' ::@@ -207,11 +211,9 @@   IssueBoard ->   -- | list ID   Int ->-  GitLab (Maybe BoardIssue)+  GitLab (Either (Response BSL.ByteString) (Maybe BoardIssue)) boardList project board listId = do-  result <- boardList' (project_id project) (board_id board) listId-  -- return an empty list if the repository could not be found.-  return (fromRight Nothing result)+  boardList' (project_id project) (board_id board) listId  -- | Get a single board list. Does not include open and closed lists. boardList' ::@@ -240,8 +242,9 @@   GitLab (Maybe BoardIssue) createBoardList project board attrs = do   result <- createBoardList' (project_id project) (board_id board) attrs-  -- return an empty list if the repository could not be found.-  return (fromRight Nothing result)+  case result of+    Left resp -> throwError (httpResponseError "createBoardList" resp)+    Right xs -> return xs  -- | Creates a new issue board list. createBoardList' ::

@@ -27,7 +27,6 @@  import Control.Monad.Except import qualified Data.ByteString.Lazy as BSL-import Data.Either import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -106,8 +105,9 @@   GitLab (Maybe Branch) createRepositoryBranch project branchName branchFrom = do   result <- createRepositoryBranch' (project_id project) branchName branchFrom-  -- return an empty list if the repository could not be found.-  return (fromRight Nothing result)+  case result of+    Left resp -> throwError (httpResponseError "createRepositoryBranch" resp)+    Right br -> return br  -- | Create a new branch in the repository. createRepositoryBranch' ::

@@ -59,7 +59,6 @@  import Control.Monad.Except import qualified Data.ByteString.Lazy as BSL-import Data.Either import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -75,7 +74,9 @@ repoCommits prj = do   -- return an empty list if the repository could not be found.   result <- gitlabGetMany (commitsAddr (project_id prj)) [("with_stats", Just "true")]-  return (fromRight [] result)+  case result of+    Left resp -> throwError (httpResponseError "repoCommits" resp)+    Right xs -> return xs   where     commitsAddr :: Int -> Text     commitsAddr projId =@@ -189,7 +190,9 @@   GitLab (Maybe Commit) singleCommit project theHash = do   result <- gitlabGetOne (commitsAddr (project_id project)) []-  return (fromRight Nothing result)+  case result of+    Left resp -> throwError (httpResponseError "singleCommit" resp)+    Right c -> return c   where     commitsAddr :: Int -> Text     commitsAddr projId =@@ -216,7 +219,7 @@       [ ("branch", Just (T.encodeUtf8 branchName))       ]   case result of-    Left _ -> return Nothing+    Left resp -> throwError (httpResponseError "cherryPickCommit" resp)     Right x -> return x   where     commitsAddr :: Text@@ -244,7 +247,7 @@       [ ("branch", Just (T.encodeUtf8 branchName))       ]   case result of-    Left _ -> return Nothing+    Left resp -> throwError (httpResponseError "revertCommit" resp)     Right x -> return x   where     commitsAddr :: Text

@@ -37,6 +37,7 @@   ) where +import Control.Monad.Except import qualified Data.ByteString.Lazy as BSL import Data.Default import Data.Maybe@@ -60,8 +61,8 @@ pipelines p attrs = do   result <- pipelines' (project_id p) attrs   case result of+    Left resp -> throwError (httpResponseError "pipelines" resp)     Right ps -> return (Just ps)-    Left _err -> return Nothing -- perhaps throwError (GitLabError ..)  -- | returns the pipelines for a project given its project ID. pipelines' ::

@@ -649,6 +649,6 @@       params = [("username", Just (T.encodeUtf8 username))]   result <- gitlabGetMany pathUser params   case result of-    Left _err -> return Nothing+    Left resp -> throwError (httpResponseError "searchUser" resp)     Right [] -> return Nothing     Right (x : _) -> return (Just x)

@@ -112,6 +112,7 @@   ) where +import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Except import Control.Monad.IO.Class import qualified Control.Monad.IO.Class as MIO@@ -124,9 +125,11 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock+import Data.Version (showVersion) import Network.HTTP.Conduit import Network.HTTP.Types.Header (ResponseHeaders) import Network.HTTP.Types.Status (Status)+import Paths_gitlab_haskell (version)  -- | The monad in which the GitLab operations can be run. -- Contains the 'GitLabState' to run the requests with.@@ -141,9 +144,15 @@ instance (MIO.MonadIO m) => MIO.MonadIO (GitLabT m) where   liftIO = GitLabT . MIO.liftIO +deriving instance (MonadThrow m) => MonadThrow (GitLabT m)++deriving instance (MonadCatch m) => MonadCatch (GitLabT m)+ data GitLabError   = -- | A general error, e.g. a JSON parsing failure.     GitLabError Text+  | -- | A repeated HTTP attempt has exhausted the maximum retries+    GitLabMaxRetriesError HttpException   | -- | A non-success HTTP response from the GitLab server, including response     -- headers.     GitLabHttpError HttpResponseError@@ -178,7 +187,9 @@     -- | delay between HTTP request retries in seconds     delayBetweenRetries :: Int,     -- | write system hook events to files in the system temporary directory.-    debugSystemHooks :: Maybe DebugSystemHooks+    debugSystemHooks :: Maybe DebugSystemHooks,+    -- | The user-agent string+    userAgent :: Text   }  data DebugSystemHooks@@ -192,7 +203,15 @@  -- | default settings are https://gitlab.com with 'AuthMethodNone', the 'url' and 'authMethod' values may need to be overwritten. instance Default GitLabServerConfig where-  def = GitLabServerConfig {url = "https://gitlab.com", authMethod = AuthMethodNone, retries = 5, delayBetweenRetries = 1, debugSystemHooks = Nothing}+  def =+      GitLabServerConfig+        { url = "https://gitlab.com"+        , authMethod = AuthMethodNone+        , retries = 5+        , delayBetweenRetries = 1+        , debugSystemHooks = Nothing+        , userAgent = T.pack ("gitlab-haskell/" <> showVersion version)+        }  -- | personal access token, see <https://docs.gitlab.com/ee/user/profile/personal_access_tokens.html> data AuthMethod

@@ -18,13 +18,14 @@  import Control.Concurrent (threadDelay) import qualified Control.Exception as Exception+import Control.Exception.Safe (try) import Control.Monad.Except import Control.Monad.IO.Class import qualified Control.Monad.Reader as MR import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL-import Data.Maybe (isJust)+import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -209,12 +210,22 @@           { method = httpMethod,             requestHeaders =               authHeaders-                <> [ ("content-type", contentType)+                <> [ ("content-type", contentType) ]+                <> [ ("User-Agent", T.encodeUtf8 agentString)+                   | let agentString = userAgent cfg+                   , not $ T.null agentString                    ],             requestBody = RequestBodyBS (renderQuery False contentParams)           }-  liftIO $ tryGitLab 0 request (retries cfg) (delayBetweenRetries cfg) manager Nothing+  tryGitLab 0 request (retries cfg) (delayBetweenRetries cfg) manager Nothing +-- Tricky corner, when to return "Nothing"?+-- Currently if:++-- * explicit 204++-- * 2xx code with no response body+ gitlabHTTPOne ::   (FromJSON a) =>   -- | HTTP method (PUT, POST, DELETE, GET)@@ -238,7 +249,15 @@       urlParams       contentParams   if successStatus (responseStatus response)-    then return (Right (parseOne (responseBody response)))+    then+      let code = responseStatus response+       in if code == status204+            || code >= status200 && code < status300 && BSL.null (responseBody response) -- Deliberately nothing+            -- Success status with no body+            then pure $ Right Nothing+            else pure $ case eitherDecode (responseBody response) of+              Left _ -> Left response+              Right r -> Right r     else return (Left response)  gitlabHTTPMany ::@@ -268,27 +287,32 @@           (urlParams <> [("per_page", Just "100"), ("page", Just (T.encodeUtf8 (T.pack (show pageNum))))])           contentParams       if successStatus (responseStatus response)-        then do-          case eitherDecode (responseBody response) of-            Left decodeErr -> do-              liftIO $-                hPutStrLn stderr $-                  "[gitlab-haskell] JSON decode error for "-                    <> T.unpack urlPath-                    <> " (page "-                    <> show pageNum-                    <> "): "-                    <> decodeErr-              liftIO $-                hPutStrLn stderr $-                  "[gitlab-haskell] Raw response body: "-                    <> show (BSL.take 2000 (responseBody response))-              return (Right accum)-            Right moreResults -> do-              let accum' = accum <> moreResults-              if hasNextPage response-                then go (pageNum + 1) accum'-                else return (Right accum')+        then+          let code = responseStatus response+           in if code == status204+                || code >= status200 && code < status300 && BSL.null (responseBody response) -- Deliberately nothing+                -- Success status with no body+                then pure $ Right []+                else case eitherDecode (responseBody response) of+                  Left decodeErr -> do+                    liftIO $+                      hPutStrLn stderr $+                        "[gitlab-haskell] JSON decode error for "+                          <> T.unpack urlPath+                          <> " (page "+                          <> show pageNum+                          <> "): "+                          <> decodeErr+                    liftIO $+                      hPutStrLn stderr $+                        "[gitlab-haskell] Raw response body: "+                          <> show (BSL.take 2000 (responseBody response))+                    return (Left response)+                  Right moreResults -> do+                    let accum' = accum <> moreResults+                    if hasNextPage response+                      then go (pageNum + 1) accum'+                      else return (Right accum')         else return (Left response)  hasNextPage :: Response a -> Bool@@ -319,15 +343,13 @@   Manager ->   -- | the exception to report if maximum retries met   Maybe HttpException ->-  IO (Response BSL.ByteString)+  GitLab (Response BSL.ByteString) tryGitLab i request maxRetries delaySeconds manager lastException-  | i == maxRetries = error (show lastException)-  | otherwise =-      httpLbs request manager-        `Exception.catch` \ex -> threadDelay delaySeconds >> tryGitLab (i + 1) request maxRetries delaySeconds manager (Just ex)--parseOne :: (FromJSON a) => BSL.ByteString -> Maybe a-parseOne bs =-  case eitherDecode bs of-    Left _err -> Nothing-    Right x -> Just x+  | i == maxRetries + 1 = throwError (GitLabMaxRetriesError (fromJust lastException))+  | otherwise = do+      tried <- try $ httpLbs request manager+      case tried of+        Left ex -> do+          liftIO (threadDelay delaySeconds)+          tryGitLab (i + 1) request maxRetries delaySeconds manager (Just ex)+        Right theResp -> return theResp