From 128f7fc9249fe629bb18e18b1fbe50e2e41a2469 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Sun, 2 Nov 2025 16:34:31 +0100 Subject: [PATCH 01/12] Add flake ... and direnv .envrc --- .envrc | 1 + .gitignore | 3 +- cabal.project | 4 ++- flake.lock | 77 +++++++++++++++++++++++++++++++++++++++++++++++++++ flake.nix | 22 +++++++++++++++ 5 files changed, 105 insertions(+), 2 deletions(-) create mode 100644 .envrc create mode 100644 flake.lock create mode 100644 flake.nix diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..3550a30 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake diff --git a/.gitignore b/.gitignore index 206c660..5b717a9 100644 --- a/.gitignore +++ b/.gitignore @@ -36,4 +36,5 @@ cabal.project.local~ examples/Main examples/FileHook examples/GitLabCommit -examples/UserProjects \ No newline at end of file +examples/UserProjects +.direnv/ diff --git a/cabal.project b/cabal.project index e37cc48..1564495 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,3 @@ -packages: . examples +packages: + . + examples diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..c17c848 --- /dev/null +++ b/flake.lock @@ -0,0 +1,77 @@ +{ + "nodes": { + "flake-parts": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib" + }, + "locked": { + "lastModified": 1762040540, + "narHash": "sha256-z5PlZ47j50VNF3R+IMS9LmzI5fYRGY/Z5O5tol1c9I4=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "0010412d62a25d959151790968765a70c436598b", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "haskell-flake": { + "locked": { + "lastModified": 1762053606, + "narHash": "sha256-OJ4O4K8GxazjdwoTajbk6ZbzkhNgC2Y2398zhkFSCCY=", + "owner": "srid", + "repo": "haskell-flake", + "rev": "eec1a47a9b453ab882650b0d426065615da99453", + "type": "github" + }, + "original": { + "owner": "srid", + "repo": "haskell-flake", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1761907660, + "narHash": "sha256-kJ8lIZsiPOmbkJypG+B5sReDXSD1KGu2VEPNqhRa/ew=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "2fb006b87f04c4d3bdf08cfdbc7fab9c13d94a15", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-lib": { + "locked": { + "lastModified": 1761765539, + "narHash": "sha256-b0yj6kfvO8ApcSE+QmA6mUfu8IYG6/uU28OFn4PaC8M=", + "owner": "nix-community", + "repo": "nixpkgs.lib", + "rev": "719359f4562934ae99f5443f20aa06c2ffff91fc", + "type": "github" + }, + "original": { + "owner": "nix-community", + "repo": "nixpkgs.lib", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-parts": "flake-parts", + "haskell-flake": "haskell-flake", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..1ec381d --- /dev/null +++ b/flake.nix @@ -0,0 +1,22 @@ +{ + description = "A Haskell library for the GitLab web API"; + + inputs = { + nixpkgs.url = "github:nixos/nixpkgs/nixos-unstable"; + flake-parts.url = "github:hercules-ci/flake-parts"; + haskell-flake.url = "github:srid/haskell-flake"; + }; + + outputs = inputs: + inputs.flake-parts.lib.mkFlake { inherit inputs; } { + systems = [ "x86_64-linux" "aarch64-linux" "x86_64-darwin" "aarch64-darwin" ]; + imports = [ inputs.haskell-flake.flakeModule ]; + + perSystem = { self', ... }: { + haskellProjects.default = { + }; + + packages.default = self'.packages.gitlab-haskell; + }; + }; +} From 43faa41d01b74be5577e13bd0cce644105fa48e2 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 3 Nov 2025 11:50:27 +0100 Subject: [PATCH 02/12] Add integration test suite --- .gitignore | 8 ++ cabal.project | 1 + flake.nix | 136 ++++++++++++++++-- integration/README.md | 64 +++++++++ integration/gitlab-module.nix | 114 +++++++++++++++ integration/nixos-test.nix | 59 ++++++++ integration/suite/README.md | 130 +++++++++++++++++ integration/suite/integration-suite.cabal | 30 ++++ integration/suite/src/Main.hs | 50 +++++++ .../suite/src/Test/GitLab/API/Projects.hs | 112 +++++++++++++++ .../suite/src/Test/GitLab/API/Users.hs | 109 ++++++++++++++ .../suite/src/Test/GitLab/API/Version.hs | 24 ++++ .../suite/src/Test/Helpers/Assertions.hs | 66 +++++++++ .../suite/src/Test/Helpers/Environment.hs | 65 +++++++++ .../suite/src/Test/Helpers/Fixtures.hs | 81 +++++++++++ 15 files changed, 1039 insertions(+), 10 deletions(-) create mode 100644 integration/README.md create mode 100644 integration/gitlab-module.nix create mode 100644 integration/nixos-test.nix create mode 100644 integration/suite/README.md create mode 100644 integration/suite/integration-suite.cabal create mode 100644 integration/suite/src/Main.hs create mode 100644 integration/suite/src/Test/GitLab/API/Projects.hs create mode 100644 integration/suite/src/Test/GitLab/API/Users.hs create mode 100644 integration/suite/src/Test/GitLab/API/Version.hs create mode 100644 integration/suite/src/Test/Helpers/Assertions.hs create mode 100644 integration/suite/src/Test/Helpers/Environment.hs create mode 100644 integration/suite/src/Test/Helpers/Fixtures.hs diff --git a/.gitignore b/.gitignore index 5b717a9..3f73ac1 100644 --- a/.gitignore +++ b/.gitignore @@ -37,4 +37,12 @@ examples/Main examples/FileHook examples/GitLabCommit examples/UserProjects + +# direnv (.envrc) .direnv/ + +# nix +result + +# integration test vm +gitlab-dev.qcow2 diff --git a/cabal.project b/cabal.project index 1564495..4b2f309 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,4 @@ packages: . examples + integration/suite diff --git a/flake.nix b/flake.nix index 1ec381d..40f906a 100644 --- a/flake.nix +++ b/flake.nix @@ -7,16 +7,132 @@ haskell-flake.url = "github:srid/haskell-flake"; }; - outputs = inputs: - inputs.flake-parts.lib.mkFlake { inherit inputs; } { - systems = [ "x86_64-linux" "aarch64-linux" "x86_64-darwin" "aarch64-darwin" ]; - imports = [ inputs.haskell-flake.flakeModule ]; + outputs = + inputs: + # https://flake.parts + inputs.flake-parts.lib.mkFlake { inherit inputs; } ( + { lib, withSystem, ... }: + { + systems = [ + "x86_64-linux" + "aarch64-linux" + "x86_64-darwin" + "aarch64-darwin" + ]; + imports = [ inputs.haskell-flake.flakeModule ]; - perSystem = { self', ... }: { - haskellProjects.default = { - }; + # https://flake.parts/options/flake-parts.html#opt-perSystem + perSystem = + { + self', + pkgs, + system, + ... + }: + { + # haskell-flake configuration + # Docs: https://flake.parts/options/haskell-flake.html + # Implicitly defines devShells.default + haskellProjects.default = { + }; + + checks = { + # Sandboxed VM test that runs the integration test suite against + # an ephemeral instance over a virtual network. + # This is mostly for CI, because the VM does not survive the build + # sandbox. Run with `nix build .#integrationTest`, thanks to alias + # in `packages`. + integrationTest = pkgs.testers.runNixOSTest { + imports = [ ./integration/nixos-test.nix ]; + _module.args.withSystem = withSystem; + }; + }; + + packages = { + default = self'.packages.gitlab-haskell; + + # Convenience for nix build .#integrationTest + integrationTest = self'.checks.integrationTest; + }; + + apps = { + gitlab-dev-vm = { + type = "app"; + program = "${lib.getExe inputs.self.nixosConfigurations.gitlab-dev.config.system.build.vm}"; + meta.description = '' + Runs a GitLab instance in a local VM + Leaves a nixos.qcow2 file in the working directory. + Run with: + + nix run .#gitlab-dev-vm + ''; + }; + }; + }; + + flake.nixosConfigurations = { + + # NixOS configuration for VM with GitLab instance in it, for local dev. + gitlab-dev = inputs.nixpkgs.lib.nixosSystem { + system = "x86_64-linux"; + modules = [ + ( + { modulesPath, ... }: + { + imports = [ + "${modulesPath}/virtualisation/qemu-vm.nix" + ./integration/gitlab-module.nix + ]; - packages.default = self'.packages.gitlab-haskell; - }; - }; + # Appears in window name + networking.hostName = "gitlab-dev"; + + # Passwordless root login for local development + users.users.root.initialHashedPassword = ""; + services.getty.autologinUser = "root"; + + # Install GitLab startup monitor script + environment.systemPackages = [ + (inputs.nixpkgs.legacyPackages.x86_64-linux.writeShellScriptBin "wait-for-gitlab" '' + echo "Waiting for GitLab to become ready..." + while ! curl -sf http://localhost/users/sign_in > /dev/null 2>&1; do + sleep 2 + done + echo "GitLab is ready!" + '') + ]; + + # Add hint to MOTD + users.motd = '' + GitLab development VM + + Run 'wait-for-gitlab' to monitor GitLab startup. + Once ready, run tests from the host with: cabal run integration-suite + ''; + + # Forward GitLab HTTP and SSH ports to host (localhost only) + virtualisation.forwardPorts = [ + { + from = "host"; + host.address = "127.0.0.1"; + host.port = 8427; + guest.port = 80; + } + { + from = "host"; + host.address = "127.0.0.1"; + host.port = 8422; + guest.port = 22; + } + ]; + + # Larger disk for development + virtualisation.diskSize = 8192; + } + ) + ]; + }; + }; + } + ); } diff --git a/integration/README.md b/integration/README.md new file mode 100644 index 0000000..a38242f --- /dev/null +++ b/integration/README.md @@ -0,0 +1,64 @@ +# Integration Tests + +This directory contains integration tests for the gitlab-haskell library. + +## Test Environment + +The integration tests use a NixOS VM running GitLab for testing. The VM configuration is defined in `flake.nix` (`nixosConfigurations.gitlab-dev`) and `gitlab-module.nix`. + +### VM Configuration + +- **Root password**: `glhs-insecure-test-password` (configured via `GITLAB_ROOT_PASSWORD`) +- **Default user**: root +- **Port forwarding**: VM binds to host ports + - 8427 on the host for HTTP + - 8422 on the host for SSH (may / may not be used) + +### Running the VM + +From the repository root: + +```bash +nix run .#gitlab-dev-vm +``` + +The VM will: +1. Start up and initialize GitLab +2. Wait for GitLab to become ready +3. Display "GitLab is ready!" when initialization is complete + +The VM creates and/or uses `nixos.qcow2` in the working directory. +Maybe it could be made to be stateless. + +### Running the Tests + +When the VM is running, you can run the tests outside the VM, to iterate quickly without gitlab startup overhead, which is significant. +In a separate terminal, once the VM is ready: + +```bash +cabal run integration-suite +``` + +The tests will: +1. Check for `GITLAB_TOKEN` environment variable +2. If not set, obtain an OAuth token via password grant flow +3. Run the test suite against the GitLab instance + +### Environment Variables + +- `GITLAB_URL`: GitLab instance URL (default: `http://localhost:8427`) +- `GITLAB_TOKEN`: OAuth access token (if not set, automatically obtained) +- `GITLAB_PASSWORD`: Root password (default: `glhs-insecure-test-password`) + +### Nix sandboxed + +You may also run the tests in the Nix build sandbox. +This has the overhead of having to start GitLab, but proves that the test is self-contained, and is useful for CI. + +```bash +nix build .#integrationTest +``` + +## Test Suite Structure + +See [suite](suite/README.md). diff --git a/integration/gitlab-module.nix b/integration/gitlab-module.nix new file mode 100644 index 0000000..a4abc32 --- /dev/null +++ b/integration/gitlab-module.nix @@ -0,0 +1,114 @@ +# NixOS module with GitLab for gitlab-haskell integration tests +# This is included in the `nix run .#gitlab-dev-vm` VM as well as the sandboxed +# NixOS VM test (`nix build .#integrationTest`) + +{ + config, + lib, + pkgs, + ... +}: + +let + cfg = config.services.gitlab; +in + +{ + # https://search.nixos.org/options + _class = "nixos"; + + config = { + # Guest-level firewall + networking.firewall.allowedTCPPorts = [ 80 ]; + + virtualisation.memorySize = lib.mkDefault 6144; + virtualisation.cores = lib.mkDefault 8; + virtualisation.useNixStoreImage = lib.mkDefault true; + virtualisation.writableStore = lib.mkDefault false; + + # Generate GitLab secrets before services start + systemd.services.install-gitlab-files = { + path = [ pkgs.libressl ]; + before = [ + "gitlab.service" + "gitaly.service" + "gitlab-workhorse.service" + "gitlab-sidekiq.service" + ]; + wantedBy = [ "multi-user.target" ]; + script = '' + mkdir -p /var/lib/gitlab-secrets + [ -f /var/lib/gitlab-secrets/secret ] || tr -cd a-zA-Z0-9 /var/lib/gitlab-secrets/secret + [ -f /var/lib/gitlab-secrets/db ] || tr -cd a-zA-Z0-9 /var/lib/gitlab-secrets/db + [ -f /var/lib/gitlab-secrets/otp ] || tr -cd a-zA-Z0-9 /var/lib/gitlab-secrets/otp + [ -f /var/lib/gitlab-secrets/jws ] || openssl genrsa 2048 > /var/lib/gitlab-secrets/jws + [ -f /var/lib/gitlab-secrets/active-record-primary ] || tr -cd a-zA-Z0-9 /var/lib/gitlab-secrets/active-record-primary + [ -f /var/lib/gitlab-secrets/active-record-deterministic ] || tr -cd a-zA-Z0-9 /var/lib/gitlab-secrets/active-record-deterministic + [ -f /var/lib/gitlab-secrets/active-record-salt ] || tr -cd a-zA-Z0-9 /var/lib/gitlab-secrets/active-record-salt + ''; + }; + + # GitLab configuration + # https://nixos.org/manual/nixos/unstable/#module-services-gitlab + # https://search.nixos.org/options?query=services.gitlab + services.postgresql.package = pkgs.postgresql_16; + services.gitlab.enable = true; + services.gitlab.https = false; + services.gitlab.port = if cfg.https then 443 else 80; + services.gitlab.initialRootPasswordFile = pkgs.writeText "unsafe-root-pass" "glhs-insecure-test-password"; + services.gitlab.secrets.secretFile = "/var/lib/gitlab-secrets/secret"; + services.gitlab.secrets.dbFile = "/var/lib/gitlab-secrets/db"; + services.gitlab.secrets.otpFile = "/var/lib/gitlab-secrets/otp"; + services.gitlab.secrets.jwsFile = "/var/lib/gitlab-secrets/jws"; + services.gitlab.secrets.activeRecordPrimaryKeyFile = "/var/lib/gitlab-secrets/active-record-primary"; + services.gitlab.secrets.activeRecordDeterministicKeyFile = "/var/lib/gitlab-secrets/active-record-deterministic"; + services.gitlab.secrets.activeRecordSaltFile = "/var/lib/gitlab-secrets/active-record-salt"; + services.gitlab.extraEnv = { + # Reduce log verbosity + GITLAB_LOG_LEVEL = "warn"; + }; + systemd.services.gitlab-sidekiq.serviceConfig.LogFilterPatterns = [ + "~wiki/Best-Practices" + ''~"severity":"INFO"'' + ''~"message":"No existing merge request to be cleaned up."'' + ]; + systemd.services.gitlab-workhorse.serviceConfig.LogFilterPatterns = [ + ''~ HTTP/1.1" 2'' + ]; + systemd.services.gitaly.serviceConfig.LogFilterPatterns = [ + "~ level=info " + ]; + + # Nginx reverse proxy + # https://search.nixos.org/options?query=services.nginx + services.nginx = { + enable = true; + recommendedGzipSettings = true; + recommendedOptimisation = true; + recommendedProxySettings = true; + recommendedTlsSettings = true; + virtualHosts."localhost" = { + locations."/" = { + proxyPass = "http://unix:/run/gitlab/gitlab-workhorse.socket"; + extraConfig = lib.mkIf cfg.https '' + proxy_set_header X-Forwarded-Proto https; + proxy_set_header X-Forwarded-Ssl on; + ''; + }; + }; + }; + + # Stub sendmail to silence email errors + security.wrappers.sendmail = { + source = pkgs.writeShellScript "sendmail" '' + # Discard all mail silently + cat > /dev/null + ''; + owner = "root"; + group = "root"; + }; + + # No package manager needed + nix.enable = lib.mkDefault false; + }; +} diff --git a/integration/nixos-test.nix b/integration/nixos-test.nix new file mode 100644 index 0000000..3a5f43d --- /dev/null +++ b/integration/nixos-test.nix @@ -0,0 +1,59 @@ +# Run with: +# nix build .#integrationTest + +{ + # Access `perSystem` + # https://flake.parts/module-arguments#withsystem + withSystem, + ... +}: + +{ + # https://nixos.org/manual/nixos/unstable/#sec-nixos-tests + _class = "nixosTest"; + + name = "gitlab-haskell-integration"; + + # https://nixos.org/manual/nixos/unstable/#test-opt-nodes + nodes = { + gitlab = + # https://search.nixos.org/options + { pkgs, ... }: + { + imports = [ ./gitlab-module.nix ]; + + networking.firewall.allowedTCPPorts = [ 80 ]; + }; + + tester = + # https://search.nixos.org/options + { pkgs, ... }: + { + environment.systemPackages = [ + # Get the test suite for the guest system (pkgs), e.g. still linux even on darwin host + (withSystem pkgs.stdenv.hostPlatform.system ( + # Module args of https://flake.parts/options/flake-parts.html#opt-perSystem + { config, ... }: config.packages.integration-suite + )) + ]; + environment.variables.GITLAB_URL = "http://gitlab"; + }; + }; + + # https://nixos.org/manual/nixos/unstable/#test-opt-testScript + testScript = '' + start_all() + + # Wait for GitLab services to be ready + gitlab.wait_for_unit("gitaly.service") + gitlab.wait_for_unit("gitlab-workhorse.service") + gitlab.wait_for_unit("gitlab.service") + gitlab.wait_for_unit("gitlab-sidekiq.service") + gitlab.wait_for_file("/run/gitlab/gitlab-workhorse.socket") + gitlab.wait_until_succeeds("curl -v --fail http://localhost/users/sign_in") + + # Run the integration test suite (it will obtain its own OAuth token) + tester.wait_for_unit("multi-user.target") + tester.succeed("integration-suite") + ''; +} diff --git a/integration/suite/README.md b/integration/suite/README.md new file mode 100644 index 0000000..7b7dd83 --- /dev/null +++ b/integration/suite/README.md @@ -0,0 +1,130 @@ +# GitLab Haskell Integration Test Suite + +This directory contains integration tests for the `gitlab-haskell` library. + +Information about the test environment can be found in [the parent README](../README.md). + +## Running Tests + +**Note**: These integration tests are **not** run by `cabal test`. They must be run explicitly with `cabal run integration-suite` as shown below. + +The tests require a running GitLab instance. A NixOS lightweight VM is provided for this purpose. + +```bash +# From the repository root +nix run .#gitlab-dev-vm +``` + +In another terminal: + +```bash +cd integration/suite +cabal run integration-suite +``` + +## Test suite structure + +The test suite is organized into modules mirroring the GitLab API: + +- `Test.GitLab.API.Version`: Version and basic connectivity tests +- `Test.GitLab.API.Users`: User CRUD operations and error handling +- `Test.GitLab.API.Projects`: Project CRUD operations and error handling + +### Helper modules + +- `Test.Helpers.Environment`: GitLab environment configuration (URL, password, OAuth token) +- `Test.Helpers.Assertions`: Test assertion helpers (`expectRight`, `expectLeft`, `expectJust`, `showing`, `shouldBe*`) +- `Test.Helpers.Fixtures`: Test fixtures for resource management (`withProject`, `withUser`, `generateRandomName`) + +## Testing Guidelines + +### Assert Types on Ignored Values + +**Rule**: When using pattern matching or helper functions that ignore a value (like `_`), always assert the type with a type annotation. + +**Rationale**: This prevents silent type mismatches that can hide bugs. For example, if an API changes from `Either a (Maybe b)` to `Either a (Either c (Maybe b))`, a test using `_` will still compile but may not be testing what you think. + +**Examples**: + +```haskell +-- Good: Type annotation makes the expected structure explicit +deleteProject project = do + result <- GitLab.runGitLab cfg $ GitLab.deleteProject project + parsedOrHttpError <- expectRight "Failed to delete project" result + (_ :: Maybe ()) <- expectRight "HTTP error during delete" parsedOrHttpError + return () + +-- Bad: Type is implicit, could silently accept wrong structure +deleteProject project = do + result <- GitLab.runGitLab cfg $ GitLab.deleteProject project + parsedOrHttpError <- expectRight "Failed to delete project" result + _ <- expectRight "HTTP error during delete" parsedOrHttpError + return () +``` + +### Use Helper Functions Consistently + +- `expectRight`: Extract a Right value or fail the test +- `expectLeft`: Extract a Left value or fail the test +- `expectJust`: Extract a Just value or fail the test +- `showing`: Annotate assertions with context that will be shown on failure + +### Use `showing` for Context on Failure + +**Rule**: Use `showing` when assertions don't reveal the full object being tested. + +**When to use**: + +Whenever assertion statements will not report the full object. + +- Asserting on individual fields of a response object (User, Project, etc.) +- Asserting on HTTP responses where only the status is checked, because a bad response may have important info that's not in the status. + +**When NOT to use**: +- With `expectRight`, `expectLeft`, `expectJust` - these already provide good error messages +- With `shouldBe` on the entire value instead of just a field. Then `shouldBe` reports the whole unexpected value. + +**Examples**: + +```haskell +-- Good: Assertions on fields don't show full object +user <- expectRight "Could not get user" userOrError +showing user $ do + GitLab.user_id user `shouldSatisfy` (> 0) + GitLab.user_username user `shouldBe` "root" + +-- Good: HTTP response status doesn't show full response +httpResponse <- expectLeft "Expected 404" parsedOrHttpError +showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + +-- Bad: expectRight already shows both sides on failure +showing userOrError $ do + user <- expectRight "Could not get user" userOrError + -- ... +``` + +### Domain-Specific Assertions + +Use domain-specific helpers for common assertions: + +- `shouldBePositive`: Assert that an Int is positive (> 0) +- `shouldBeNonEmpty`: Assert that a Text is non-empty + +### Resource Cleanup + +Use the bracket pattern for resources that need cleanup: + +- `withProject`: Creates a project, runs a test, and cleans up +- `withUser`: Creates a user, runs a test, and cleans up + +**Important**: Cleanup failures MUST fail the test. This ensures test isolation and prevents resource leaks. + +## GitLab Soft-Delete Behavior + +GitLab uses "soft deletes" for some resources: + +- **Projects**: Marked for deletion with `marked_for_deletion_at` timestamp, may still be accessible +- **Users**: Blocked with `state = "blocked"` instead of being fully deleted + +Tests should account for both soft-delete and hard-delete responses when verifying deletion. diff --git a/integration/suite/integration-suite.cabal b/integration/suite/integration-suite.cabal new file mode 100644 index 0000000..e890d06 --- /dev/null +++ b/integration/suite/integration-suite.cabal @@ -0,0 +1,30 @@ +cabal-version: 2.4 +name: integration-suite +version: 1 +synopsis: Integration test suite for gitlab-haskell +description: Integration tests for gitlab-haskell library +category: Testing +build-type: Simple + +executable integration-suite + main-is: Main.hs + other-modules: Test.Helpers.Assertions + , Test.Helpers.Environment + , Test.Helpers.Fixtures + , Test.GitLab.API.Projects + , Test.GitLab.API.Users + , Test.GitLab.API.Version + hs-source-dirs: src + build-depends: base >=4.7 && <5 + , gitlab-haskell + , aeson >= 2.0.0.0 + , text >= 2.1 + , http-client + , http-types + , bytestring + , hspec + , HUnit + , random + , deepseq + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N diff --git a/integration/suite/src/Main.hs b/integration/suite/src/Main.hs new file mode 100644 index 0000000..1a7ce0c --- /dev/null +++ b/integration/suite/src/Main.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Test.Hspec ( describe, parallel, Spec ) +import qualified GitLab +import Test.Helpers.Environment ( getGitLabURL, getGitLabToken ) +import qualified Test.GitLab.API.Projects +import qualified Test.GitLab.API.Users +import qualified Test.GitLab.API.Version +import qualified Test.Hspec.Runner as R +import System.Environment (getArgs) +import Data.Maybe (fromMaybe) +import GHC.Conc (getNumCapabilities) + +main :: IO () +main = do + gitlabUrl <- getGitLabURL + token <- getGitLabToken + + let cfg = GitLab.defaultGitLabServer + { GitLab.url = gitlabUrl + , GitLab.token = GitLab.AuthMethodOAuth token + } + + testCfg <- do + let defConfig = R.defaultConfig { + -- Show execution time + R.configTimes = True + } + parsedCfg <- getArgs >>= R.readConfig defConfig + + numCores <- getNumCapabilities + -- Be considerate of the GitLab VM size if test runner is large machine + -- Over approx 2× the number of VM cores we get diminishing returns and + -- even more unreliable test case timings due to high load. + let limit = 16 + defaultJobs = min limit numCores + pure parsedCfg { + R.configConcurrentJobs = Just $ fromMaybe defaultJobs $ R.configConcurrentJobs parsedCfg + } + + R.hspecWith testCfg $ parallel $ spec cfg + +spec :: GitLab.GitLabServerConfig -> Spec +spec cfg = do + describe "GitLab API calls" $ do + Test.GitLab.API.Version.spec cfg + Test.GitLab.API.Users.spec cfg + Test.GitLab.API.Projects.spec cfg diff --git a/integration/suite/src/Test/GitLab/API/Projects.hs b/integration/suite/src/Test/GitLab/API/Projects.hs new file mode 100644 index 0000000..c2f0973 --- /dev/null +++ b/integration/suite/src/Test/GitLab/API/Projects.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.GitLab.API.Projects (spec) where + +import Test.Hspec +import qualified GitLab +import Test.Helpers.Assertions +import Test.Helpers.Fixtures +import Network.HTTP.Client (responseStatus) +import Network.HTTP.Types (status404) + +spec :: GitLab.GitLabServerConfig -> Spec +spec cfg = do + describe "Project operations" $ do + it "handles 404 for non-existent project" $ do + responseOrError <- GitLab.runGitLab cfg $ GitLab.project 999999999 + parsedOrHttpError <- expectRight "Could not query non-existent project" responseOrError + httpResponse <- expectLeft "Expected 404 for non-existent project" parsedOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + + it "handles invalid project ID (0)" $ do + responseOrError <- GitLab.runGitLab cfg $ GitLab.project 0 + parsedOrHttpError <- expectRight "Could not query project with ID 0" responseOrError + httpResponse <- expectLeft "Expected 404 for invalid project ID" parsedOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + + it "can create, read, and delete a project" $ do + deletedProject <- withProject cfg $ \project -> do + showing project $ do + -- Force full evaluation via Show + length (show project) `shouldSatisfy` (> 0) + -- Asserted fields (out of 80+): + shouldBePositive (GitLab.project_id project) + shouldBeNonEmpty (GitLab.project_name project) + + -- Read the project back + responseOrError <- GitLab.runGitLab cfg $ + GitLab.project (GitLab.project_id project) + parsedOrHttpError <- expectRight "Could not read back new project" responseOrError + projectOrNotFound <- expectRight "Could not read back new project (HTTP error)" parsedOrHttpError + readProject <- expectJust "Could not read back new project (not found)" projectOrNotFound + showing readProject $ do + -- Force full evaluation via Show + length (show readProject) `shouldSatisfy` (> 0) + -- Asserted fields (out of 80+): + GitLab.project_id readProject `shouldBe` GitLab.project_id project + GitLab.project_name readProject `shouldBe` GitLab.project_name project + GitLab.project_path readProject `shouldBe` GitLab.project_path project + + return project + + -- Verify project is deleted (GitLab marks projects for deletion) + deletedResponseOrError <- GitLab.runGitLab cfg $ + GitLab.project (GitLab.project_id deletedProject) + case deletedResponseOrError of + Right (Right (Just markedProject)) -> + showing markedProject $ do + -- Project still accessible but marked for deletion + GitLab.project_marked_for_deletion_at markedProject `shouldSatisfy` (/= Nothing) + Right (Left response) -> + responseStatus response `shouldBe` status404 + other -> + expectationFailure $ "Unexpected response when querying deleted project: " ++ show other + + it "can update a project" $ do + withProject cfg $ \project -> do + -- Update project description + let attrs = (GitLab.defaultProjectAttrs (GitLab.project_id project)) + { GitLab.project_edit_description = Just "Updated description" } + responseOrError <- GitLab.runGitLab cfg $ + GitLab.editProject project attrs + projectOrHttpError <- expectRight "Could not update project" responseOrError + updatedProject <- expectRight "Could not update project (HTTP error)" projectOrHttpError + showing updatedProject $ do + -- Force full evaluation via Show + length (show updatedProject) `shouldSatisfy` (> 0) + -- Asserted fields (out of 80+): + GitLab.project_id updatedProject `shouldBe` GitLab.project_id project + GitLab.project_description updatedProject `shouldBe` Just "Updated description" + + it "can list projects" $ do + -- Use simple=true to avoid GitLab 500 error with statistics + withProject cfg $ \_project -> do + let attrs = GitLab.defaultProjectSearchAttrs + { GitLab.projectSearchFilter_simple = Just True + } + responseOrError <- GitLab.runGitLab cfg (GitLab.projects attrs) + projectList <- expectRight "Could not list projects" responseOrError + showing projectList $ do + -- Should contain at least the project we just created + length projectList `shouldSatisfy` (>= 1) + + it "can search for a project by name" $ do + -- Use simple=true to avoid GitLab 500 error with statistics + withProject cfg $ \project -> do + let projectName = GitLab.project_name project + attrs = GitLab.defaultProjectSearchAttrs + { GitLab.projectSearchFilter_simple = Just True + , GitLab.projectSearchFilter_search = Just projectName + } + responseOrError <- GitLab.runGitLab cfg (GitLab.projects attrs) + projectList <- expectRight "Could not search for project" responseOrError + showing projectList $ do + -- Should find exactly the one project we created + length projectList `shouldBe` 1 + case projectList of + [foundProject] -> do + GitLab.project_id foundProject `shouldBe` GitLab.project_id project + GitLab.project_name foundProject `shouldBe` projectName + _ -> expectationFailure "Expected exactly one project in search results" diff --git a/integration/suite/src/Test/GitLab/API/Users.hs b/integration/suite/src/Test/GitLab/API/Users.hs new file mode 100644 index 0000000..e4adb45 --- /dev/null +++ b/integration/suite/src/Test/GitLab/API/Users.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.GitLab.API.Users (spec) where + +import Test.Hspec +import qualified GitLab +import Test.Helpers.Assertions +import Test.Helpers.Fixtures +import Network.HTTP.Client (responseStatus) +import Network.HTTP.Types (status404) + +spec :: GitLab.GitLabServerConfig -> Spec +spec cfg = do + describe "User operations" $ do + it "handles 404 for non-existent user" $ do + responseOrError <- GitLab.runGitLab cfg $ GitLab.user 999999999 + parsedOrHttpError <- expectRight "Could not query non-existent user" responseOrError + httpResponse <- expectLeft "Expected 404 for non-existent user" parsedOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + + it "handles invalid user ID (0)" $ do + responseOrError <- GitLab.runGitLab cfg $ GitLab.user 0 + parsedOrHttpError <- expectRight "Could not query user with ID 0" responseOrError + httpResponse <- expectLeft "Expected 404 for invalid user ID" parsedOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + + it "can get current user" $ do + userOrError <- GitLab.runGitLab cfg GitLab.currentUser + user <- expectRight "Could not get current user" userOrError + showing user $ do + -- Force full evaluation via Show + length (show user) `shouldSatisfy` (> 0) + -- Asserted fields (7 of 30+): + shouldBePositive (GitLab.user_id user) + GitLab.user_username user `shouldBe` "root" + GitLab.user_name user `shouldBe` "Administrator" + GitLab.user_state user `shouldBe` Just "active" + GitLab.user_can_create_group user `shouldBe` Just True + GitLab.user_can_create_project user `shouldBe` Just True + GitLab.user_bot user `shouldBe` Just False + -- Unasserted fields: user_bio, user_two_factor_enabled, user_last_sign_in_at, + -- user_current_sign_in_at, user_last_activity_on, user_skype, user_twitter, + -- user_website_url, user_theme_id, user_color_scheme_id, user_external, + -- user_private_profile, user_projects_limit, user_public_email, user_organization, + -- user_job_title, user_pronouns, user_linkedin, user_confirmed_at, user_identities, + -- user_email, user_followers, user_following, user_avatar_url, user_web_url, + -- user_location, user_extern_uid, user_group_id_for_saml, user_discussion_locked, + -- user_created_at, user_note, user_password + + it "can create, read, update, and delete a user" $ do + deletedUser <- withUser cfg $ \user -> do + showing user $ do + -- Force full evaluation via Show + length (show user) `shouldSatisfy` (> 0) + -- Asserted fields (3 of 30+): + shouldBePositive (GitLab.user_id user) + shouldBeNonEmpty (GitLab.user_username user) + GitLab.user_name user `shouldBe` "Test User" + + -- Read user back + readResponseOrError <- GitLab.runGitLab cfg $ + GitLab.user (GitLab.user_id user) + readParsedOrHttpError <- expectRight "Could not read user" readResponseOrError + readUserOrNotFound <- expectRight "Could not read user (HTTP error)" readParsedOrHttpError + readUser <- expectJust "Could not read user (not found)" readUserOrNotFound + showing readUser $ do + -- Force full evaluation via Show + length (show readUser) `shouldSatisfy` (> 0) + -- Asserted fields (3 of 30+): + GitLab.user_id readUser `shouldBe` GitLab.user_id user + GitLab.user_username readUser `shouldBe` GitLab.user_username user + GitLab.user_name readUser `shouldBe` GitLab.user_name user + + -- Update user + let updateAttrs = GitLab.defaultUserFilters + { GitLab.userFilter_bio = Just "Updated bio" + } + updateResponseOrError <- GitLab.runGitLab cfg $ + GitLab.modifyUser (GitLab.user_id user) updateAttrs + updateParsedOrHttpError <- expectRight "Could not update user" updateResponseOrError + updatedUserOrNotFound <- expectRight "Could not update user (HTTP error)" updateParsedOrHttpError + updatedUser <- expectJust "Could not update user (not found)" updatedUserOrNotFound + showing updatedUser $ do + -- Force full evaluation via Show + length (show updatedUser) `shouldSatisfy` (> 0) + -- Asserted fields (4 of 30+): + GitLab.user_id updatedUser `shouldBe` GitLab.user_id user + GitLab.user_username updatedUser `shouldBe` GitLab.user_username user + GitLab.user_name updatedUser `shouldBe` GitLab.user_name user + GitLab.user_bio updatedUser `shouldBe` Just "Updated bio" + + return updatedUser + + -- Verify user is deleted (GitLab blocks users asynchronously, or returns 404) + deletedResponseOrError <- GitLab.runGitLab cfg $ + GitLab.user (GitLab.user_id deletedUser) + case deletedResponseOrError of + Right (Right (Just queriedUser)) -> + showing queriedUser $ do + -- User may still be accessible, possibly blocked or in transition to blocked + -- Note: GitLab blocks users asynchronously, so state may be "active" or "blocked" + GitLab.user_state queriedUser `shouldSatisfy` (\s -> s == Just "blocked" || s == Just "active") + Right (Left response) -> + -- User may return 404 if fully deleted + responseStatus response `shouldBe` status404 + other -> + expectationFailure $ "Unexpected response when querying deleted user: " ++ show other diff --git a/integration/suite/src/Test/GitLab/API/Version.hs b/integration/suite/src/Test/GitLab/API/Version.hs new file mode 100644 index 0000000..d1ca207 --- /dev/null +++ b/integration/suite/src/Test/GitLab/API/Version.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.GitLab.API.Version (spec) where + +import Test.Hspec +import qualified GitLab +import qualified Data.Text +import Test.Helpers.Assertions + +spec :: GitLab.GitLabServerConfig -> Spec +spec cfg = do + describe "Version operations" $ do + it "can fetch GitLab version" $ do + responseOrError <- GitLab.runGitLab cfg GitLab.gitlabVersion + parsedOrHttpError <- expectRight "Could not fetch GitLab version" responseOrError + versionOrNotFound <- expectRight "Could not fetch GitLab version (HTTP error)" parsedOrHttpError + version <- expectJust "Could not fetch GitLab version (not found)" versionOrNotFound + showing version $ do + -- Force full evaluation via Show + length (show version) `shouldSatisfy` (> 0) + -- Asserted fields (all): + GitLab.version_version version `shouldSatisfy` (not . Data.Text.null) + GitLab.version_revision version `shouldSatisfy` (not . Data.Text.null) + diff --git a/integration/suite/src/Test/Helpers/Assertions.hs b/integration/suite/src/Test/Helpers/Assertions.hs new file mode 100644 index 0000000..ad34078 --- /dev/null +++ b/integration/suite/src/Test/Helpers/Assertions.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Helpers.Assertions + ( shouldBePositive + , shouldBeNonEmpty + , showing + , expectRight + , expectLeft + , expectJust + ) where + +import qualified Data.Text as T +import Control.Exception (catch, throwIO) +import Test.HUnit.Lang (HUnitFailure(..), FailureReason(..)) +import Test.Hspec (expectationFailure, shouldSatisfy) + +-- | Assert that an Int is positive (> 0) +shouldBePositive :: Int -> IO () +shouldBePositive n = n `shouldSatisfy` (> 0) + +-- | Assert that a Text is non-empty +shouldBeNonEmpty :: T.Text -> IO () +shouldBeNonEmpty t = t `shouldSatisfy` (not . T.null) + +-- | Annotate test assertions with a value that will be shown on failure. +-- This provides context when assertions fail, showing the full value being tested. +-- +-- Example: +-- @ +-- showing project $ do +-- GitLab.project_id project \`shouldSatisfy\` (> 0) +-- GitLab.project_name project \`shouldNotBe\` "" +-- @ +showing :: (Show a) => a -> IO r -> IO r +showing value assertion = + assertion `catch` \(HUnitFailure loc reason) -> + let valueStr = "Context value:\n" ++ show value + newReason = case reason of + Reason msg -> Reason (msg ++ "\n\n" ++ valueStr) + ExpectedButGot preface expected actual -> + let newPreface = case preface of + Nothing -> Just valueStr + Just p -> Just (p ++ "\n\n" ++ valueStr) + in ExpectedButGot newPreface expected actual + in throwIO $ HUnitFailure loc newReason + +-- | Extract a Right value from an Either, or fail with a meaningful error message. +expectRight :: (Show e) => String -> Either e a -> IO a +expectRight _ (Right value) = return value +expectRight context (Left err) = do + expectationFailure $ context ++ ": " ++ show err + error "expectRight: unreachable" + +-- | Extract a Left value from an Either, or fail with a meaningful error message. +expectLeft :: (Show a) => String -> Either e a -> IO e +expectLeft _ (Left value) = return value +expectLeft context (Right val) = do + expectationFailure $ context ++ ": Expected Left, got Right: " ++ show val + error "expectLeft: unreachable" + +-- | Extract a Just value from a Maybe, or fail with a meaningful error message. +expectJust :: String -> Maybe a -> IO a +expectJust _ (Just value) = return value +expectJust context Nothing = do + expectationFailure $ context ++ ": Got Nothing" + error "expectJust: unreachable" diff --git a/integration/suite/src/Test/Helpers/Environment.hs b/integration/suite/src/Test/Helpers/Environment.hs new file mode 100644 index 0000000..9f6e997 --- /dev/null +++ b/integration/suite/src/Test/Helpers/Environment.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Helpers.Environment + ( getGitLabURL + , getGitLabPassword + , getGitLabToken + ) where + +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as BS +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KM +import Network.HTTP.Client (defaultManagerSettings, httpLbs, method, newManager, parseRequest, requestBody, requestHeaders, responseBody, RequestBody(..)) +import System.Environment (lookupEnv) +import Data.Maybe (fromMaybe) + +getGitLabURL :: IO T.Text +getGitLabURL = T.pack . fromMaybe "http://localhost:8427" <$> lookupEnv "GITLAB_URL" + +getGitLabPassword :: IO String +getGitLabPassword = fromMaybe "glhs-insecure-test-password" <$> lookupEnv "GITLAB_PASSWORD" + +getGitLabToken :: IO T.Text +getGitLabToken = lookupEnv "GITLAB_TOKEN" >>= \case + Just t -> return (T.pack t) + Nothing -> do + -- Try to get OAuth token using password grant + putStrLn "No GITLAB_TOKEN set, obtaining OAuth token via password grant..." + gitlabUrl <- getGitLabURL + password <- getGitLabPassword + result <- getOAuthToken (T.unpack gitlabUrl) "root" password + case result of + Just token -> do + putStrLn "Successfully obtained OAuth token" + return token + Nothing -> do + putStrLn "Failed to obtain OAuth token" + error "GITLAB_TOKEN not set and OAuth token acquisition failed" + +-- | Get an OAuth access token using password grant flow. +-- Note: OAuth tokens empirically expire after 2 hours (7200 seconds) as indicated +-- by the expires_in field in the response. A fresh token is obtained on each test run. +getOAuthToken :: String -> String -> String -> IO (Maybe T.Text) +getOAuthToken baseUrl username password = do + manager <- newManager defaultManagerSettings + let tokenUrl = baseUrl ++ "/oauth/token" + body = BS.concat + [ "grant_type=password" + , "&username=", BS.pack username + , "&password=", BS.pack password + ] + req <- parseRequest tokenUrl + let req' = req + { method = "POST" + , requestBody = RequestBodyBS body + , requestHeaders = [("Content-Type", "application/x-www-form-urlencoded")] + } + response <- httpLbs req' manager + case Aeson.decode (responseBody response) of + Just (Aeson.Object obj) -> + case KM.lookup "access_token" obj of + Just (Aeson.String token) -> return (Just token) + _ -> return Nothing + _ -> return Nothing diff --git a/integration/suite/src/Test/Helpers/Fixtures.hs b/integration/suite/src/Test/Helpers/Fixtures.hs new file mode 100644 index 0000000..976dcaa --- /dev/null +++ b/integration/suite/src/Test/Helpers/Fixtures.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Helpers.Fixtures + ( generateRandomName + , withProject + , withUser + ) where + +import qualified Data.Text as T +import qualified GitLab +import System.Random (randomRIO) +import Control.Exception (bracket) +import Control.Monad (replicateM) +import Test.Helpers.Assertions (expectRight, expectJust) + +generateRandomName :: String -> IO T.Text +generateRandomName prefix = do + suffix <- T.pack <$> replicateM 5 randomAlphaNum + return $ T.pack prefix <> "-" <> suffix + where + chars = T.pack (['a'..'z'] ++ ['0'..'9']) + randomAlphaNum = do + idx <- randomRIO (0, T.length chars - 1) + return (T.index chars idx) + +-- | Helper to create a project, run an action with it, and clean up. +-- Uses bracket to ensure cleanup happens even if the action fails. +withProject :: GitLab.GitLabServerConfig -> (GitLab.Project -> IO a) -> IO a +withProject cfg action = do + projectName <- generateRandomName "test-project" + projectPath <- generateRandomName "test-project" + + bracket + (createProject projectName projectPath) + deleteProject + action + where + createProject name projectPath = do + createResult <- GitLab.runGitLab cfg $ GitLab.createProject name projectPath + parsedOrHttpError <- expectRight ("Failed to create project '" ++ T.unpack name ++ "'") createResult + projectOrNotFound <- expectRight ("Failed to create project '" ++ T.unpack name ++ "' (HTTP error)") parsedOrHttpError + expectJust ("Failed to create project '" ++ T.unpack name ++ "' (not found)") projectOrNotFound + + deleteProject project = do + result <- GitLab.runGitLab cfg $ GitLab.deleteProject project + parsedOrHttpError <- expectRight ("Failed to delete project " ++ show (GitLab.project_id project)) result + (_ :: Maybe ()) <- expectRight ("Failed to delete project " ++ show (GitLab.project_id project) ++ " (HTTP error)") parsedOrHttpError + -- Note: Both Just () and Nothing indicate success (2xx status code) + -- Just () means the response body parsed as (), Nothing means parse failed (e.g., empty body) + return () + +-- | Helper to create a user, run an action with it, and clean up. +-- Uses bracket to ensure cleanup happens even if the action fails. +withUser :: GitLab.GitLabServerConfig -> (GitLab.User -> IO a) -> IO a +withUser cfg action = do + username <- generateRandomName "testuser" + email <- (\n -> n <> "@example.com") <$> generateRandomName "test" + + bracket + (createUser username email) + deleteUser + action + where + createUser username email = do + let attrs = GitLab.defaultUserFilters + { GitLab.userFilter_password = Just "xK9#mP2$vL8@qW5!" + , GitLab.userFilter_skip_confirmation = Just True + } + createResult <- GitLab.runGitLab cfg $ GitLab.createUser email "Test User" username attrs + parsedOrHttpError <- expectRight ("Failed to create user '" ++ T.unpack username ++ "'") createResult + userOrNotFound <- expectRight ("Failed to create user '" ++ T.unpack username ++ "' (HTTP error)") parsedOrHttpError + expectJust ("Failed to create user '" ++ T.unpack username ++ "' (not found)") userOrNotFound + + deleteUser user = do + result <- GitLab.runGitLab cfg $ GitLab.deleteUser user + parsedOrHttpError <- expectRight ("Failed to delete user " ++ show (GitLab.user_id user)) result + (_ :: Maybe ()) <- expectRight ("Failed to delete user " ++ show (GitLab.user_id user) ++ " (HTTP error)") parsedOrHttpError + -- Note: Both Just () and Nothing indicate success (2xx status code) + -- Just () means the response body parsed as (), Nothing means parse failed (e.g., empty body) + return () From b9c554a73013a1845b30c2f478b607c0a258636c Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 3 Nov 2025 11:58:03 +0100 Subject: [PATCH 03/12] Add Groups integration test --- integration/suite/integration-suite.cabal | 1 + integration/suite/src/Main.hs | 2 + .../suite/src/Test/GitLab/API/Groups.hs | 111 ++++++++++++++++++ .../suite/src/Test/Helpers/Fixtures.hs | 28 +++++ 4 files changed, 142 insertions(+) create mode 100644 integration/suite/src/Test/GitLab/API/Groups.hs diff --git a/integration/suite/integration-suite.cabal b/integration/suite/integration-suite.cabal index e890d06..29dd205 100644 --- a/integration/suite/integration-suite.cabal +++ b/integration/suite/integration-suite.cabal @@ -11,6 +11,7 @@ executable integration-suite other-modules: Test.Helpers.Assertions , Test.Helpers.Environment , Test.Helpers.Fixtures + , Test.GitLab.API.Groups , Test.GitLab.API.Projects , Test.GitLab.API.Users , Test.GitLab.API.Version diff --git a/integration/suite/src/Main.hs b/integration/suite/src/Main.hs index 1a7ce0c..e8a92b6 100644 --- a/integration/suite/src/Main.hs +++ b/integration/suite/src/Main.hs @@ -5,6 +5,7 @@ module Main where import Test.Hspec ( describe, parallel, Spec ) import qualified GitLab import Test.Helpers.Environment ( getGitLabURL, getGitLabToken ) +import qualified Test.GitLab.API.Groups import qualified Test.GitLab.API.Projects import qualified Test.GitLab.API.Users import qualified Test.GitLab.API.Version @@ -48,3 +49,4 @@ spec cfg = do Test.GitLab.API.Version.spec cfg Test.GitLab.API.Users.spec cfg Test.GitLab.API.Projects.spec cfg + Test.GitLab.API.Groups.spec cfg diff --git a/integration/suite/src/Test/GitLab/API/Groups.hs b/integration/suite/src/Test/GitLab/API/Groups.hs new file mode 100644 index 0000000..ccc8774 --- /dev/null +++ b/integration/suite/src/Test/GitLab/API/Groups.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.GitLab.API.Groups (spec) where + +import Test.Hspec +import qualified GitLab +import Test.Helpers.Assertions +import Test.Helpers.Fixtures +import Network.HTTP.Client (responseStatus) +import Network.HTTP.Types (status404) + +spec :: GitLab.GitLabServerConfig -> Spec +spec cfg = do + describe "Group operations" $ do + it "handles 404 for non-existent group" $ do + responseOrError <- GitLab.runGitLab cfg $ GitLab.group 999999999 + parsedOrHttpError <- expectRight "Could not query non-existent group" responseOrError + httpResponse <- expectLeft "Expected 404 for non-existent group" parsedOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + + it "handles invalid group ID (0)" $ do + responseOrError <- GitLab.runGitLab cfg $ GitLab.group 0 + parsedOrHttpError <- expectRight "Could not query group with ID 0" responseOrError + httpResponse <- expectLeft "Expected 404 for invalid group ID" parsedOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + + it "can create, read, update, and delete a group" $ do + deletedGroup <- withGroup cfg $ \group -> do + showing group $ do + -- Force full evaluation via Show + length (show group) `shouldSatisfy` (> 0) + -- Asserted fields (2 of 30+): + shouldBePositive (GitLab.group_id group) + shouldBeNonEmpty (GitLab.group_name group) + + -- Read group back + readResponseOrError <- GitLab.runGitLab cfg $ + GitLab.group (GitLab.group_id group) + readParsedOrHttpError <- expectRight "Could not read group" readResponseOrError + readGroupOrNotFound <- expectRight "Could not read group (HTTP error)" readParsedOrHttpError + readGroup <- expectJust "Could not read group (not found)" readGroupOrNotFound + showing readGroup $ do + -- Force full evaluation via Show + length (show readGroup) `shouldSatisfy` (> 0) + -- Asserted fields (2 of 30+): + GitLab.group_id readGroup `shouldBe` GitLab.group_id group + GitLab.group_name readGroup `shouldBe` GitLab.group_name group + + -- Update group + let updateAttrs = GitLab.defaultGroupFilters + { GitLab.groupFilter_description = Just "Updated description" + } + updateResponseOrError <- GitLab.runGitLab cfg $ + GitLab.updateGroup (GitLab.group_id group) updateAttrs + updateParsedOrHttpError <- expectRight "Could not update group" updateResponseOrError + updatedGroupOrNotFound <- expectRight "Could not update group (HTTP error)" updateParsedOrHttpError + updatedGroup <- expectJust "Could not update group (not found)" updatedGroupOrNotFound + showing updatedGroup $ do + -- Force full evaluation via Show + length (show updatedGroup) `shouldSatisfy` (> 0) + -- Asserted fields (3 of 30+): + GitLab.group_id updatedGroup `shouldBe` GitLab.group_id group + GitLab.group_name updatedGroup `shouldBe` GitLab.group_name group + GitLab.group_description updatedGroup `shouldBe` Just "Updated description" + + return updatedGroup + + -- Verify group is deleted (GitLab may soft-delete groups or return 404) + deletedResponseOrError <- GitLab.runGitLab cfg $ + GitLab.group (GitLab.group_id deletedGroup) + case deletedResponseOrError of + Right (Right (Just _queriedGroup)) -> + -- Group may still be accessible, possibly marked for deletion + -- GitLab soft-deletes groups asynchronously + return () + Right (Left response) -> + -- Group may return 404 if fully deleted + responseStatus response `shouldBe` status404 + other -> + expectationFailure $ "Unexpected response when querying deleted group: " ++ show other + + it "can list groups" $ do + withGroup cfg $ \_group -> do + let attrs = GitLab.defaultListGroupsFilters + groupsOrError <- GitLab.runGitLab cfg $ GitLab.groups attrs + groups <- expectRight "Could not list groups" groupsOrError + showing groups $ do + -- Should contain at least the group we just created + length groups `shouldSatisfy` (>= 1) + + it "can search for a group by name" $ do + withGroup cfg $ \group -> do + let groupName = GitLab.group_name group + attrs = GitLab.defaultListGroupsFilters + { GitLab.listGroupsFilter_search = Just groupName + } + groupsOrError <- GitLab.runGitLab cfg $ GitLab.groups attrs + groups <- expectRight "Could not search for group" groupsOrError + showing groups $ do + -- Should find the one group we created + length groups `shouldSatisfy` (>= 1) + -- Find our group in the results + let foundGroups = filter (\g -> GitLab.group_id g == GitLab.group_id group) groups + case foundGroups of + [foundGroup] -> do + GitLab.group_id foundGroup `shouldBe` GitLab.group_id group + GitLab.group_name foundGroup `shouldBe` groupName + [] -> expectationFailure "Expected to find the created group in search results" + _ -> expectationFailure "Expected exactly one matching group in search results" diff --git a/integration/suite/src/Test/Helpers/Fixtures.hs b/integration/suite/src/Test/Helpers/Fixtures.hs index 976dcaa..a381f44 100644 --- a/integration/suite/src/Test/Helpers/Fixtures.hs +++ b/integration/suite/src/Test/Helpers/Fixtures.hs @@ -5,6 +5,7 @@ module Test.Helpers.Fixtures ( generateRandomName , withProject , withUser + , withGroup ) where import qualified Data.Text as T @@ -79,3 +80,30 @@ withUser cfg action = do -- Note: Both Just () and Nothing indicate success (2xx status code) -- Just () means the response body parsed as (), Nothing means parse failed (e.g., empty body) return () + +-- | Helper to create a group, run an action with it, and clean up. +-- Uses bracket to ensure cleanup happens even if the action fails. +withGroup :: GitLab.GitLabServerConfig -> (GitLab.Group -> IO a) -> IO a +withGroup cfg action = do + groupName <- generateRandomName "test-group" + groupPath <- generateRandomName "test-group" + + bracket + (createGroup groupName groupPath) + deleteGroup + action + where + createGroup name path = do + let attrs = GitLab.defaultGroupFilters + createResult <- GitLab.runGitLab cfg $ GitLab.newGroup name path attrs + parsedOrHttpError <- expectRight ("Failed to create group '" ++ T.unpack name ++ "'") createResult + groupOrNotFound <- expectRight ("Failed to create group '" ++ T.unpack name ++ "' (HTTP error)") parsedOrHttpError + expectJust ("Failed to create group '" ++ T.unpack name ++ "' (not found)") groupOrNotFound + + deleteGroup group = do + result <- GitLab.runGitLab cfg $ GitLab.removeGroup (GitLab.group_id group) + parsedOrHttpError <- expectRight ("Failed to delete group " ++ show (GitLab.group_id group)) result + (_ :: Maybe ()) <- expectRight ("Failed to delete group " ++ show (GitLab.group_id group) ++ " (HTTP error)") parsedOrHttpError + -- Note: Both Just () and Nothing indicate success (2xx status code) + -- Just () means the response body parsed as (), Nothing means parse failed (e.g., empty body) + return () From 57dbab058a48dfbea38172450537eedab5f3b6d3 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 3 Nov 2025 12:32:20 +0100 Subject: [PATCH 04/12] Expose IssueFilterAttrs and Issues integration test --- integration/suite/integration-suite.cabal | 1 + integration/suite/src/Main.hs | 2 + .../suite/src/Test/GitLab/API/Issues.hs | 351 ++++++++++++++++++ .../suite/src/Test/Helpers/Fixtures.hs | 29 ++ src/GitLab/API/Issues.hs | 1 + 5 files changed, 384 insertions(+) create mode 100644 integration/suite/src/Test/GitLab/API/Issues.hs diff --git a/integration/suite/integration-suite.cabal b/integration/suite/integration-suite.cabal index 29dd205..7cba287 100644 --- a/integration/suite/integration-suite.cabal +++ b/integration/suite/integration-suite.cabal @@ -12,6 +12,7 @@ executable integration-suite , Test.Helpers.Environment , Test.Helpers.Fixtures , Test.GitLab.API.Groups + , Test.GitLab.API.Issues , Test.GitLab.API.Projects , Test.GitLab.API.Users , Test.GitLab.API.Version diff --git a/integration/suite/src/Main.hs b/integration/suite/src/Main.hs index e8a92b6..a711621 100644 --- a/integration/suite/src/Main.hs +++ b/integration/suite/src/Main.hs @@ -6,6 +6,7 @@ import Test.Hspec ( describe, parallel, Spec ) import qualified GitLab import Test.Helpers.Environment ( getGitLabURL, getGitLabToken ) import qualified Test.GitLab.API.Groups +import qualified Test.GitLab.API.Issues import qualified Test.GitLab.API.Projects import qualified Test.GitLab.API.Users import qualified Test.GitLab.API.Version @@ -50,3 +51,4 @@ spec cfg = do Test.GitLab.API.Users.spec cfg Test.GitLab.API.Projects.spec cfg Test.GitLab.API.Groups.spec cfg + Test.GitLab.API.Issues.spec cfg diff --git a/integration/suite/src/Test/GitLab/API/Issues.hs b/integration/suite/src/Test/GitLab/API/Issues.hs new file mode 100644 index 0000000..70ad6cb --- /dev/null +++ b/integration/suite/src/Test/GitLab/API/Issues.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.GitLab.API.Issues (spec) where + +import Test.Hspec +import qualified GitLab +import Test.Helpers.Assertions +import Test.Helpers.Fixtures +import Network.HTTP.Client (responseStatus) +import Network.HTTP.Types (status404, status304) + +spec :: GitLab.GitLabServerConfig -> Spec +spec cfg = do + describe "Issue operations" $ do + it "handles 404 for non-existent issue" $ do + responseOrError <- GitLab.runGitLab cfg $ GitLab.issue 999999999 + parsedOrHttpError <- expectRight "Could not query non-existent issue" responseOrError + httpResponse <- expectLeft "Expected 404 for non-existent issue" parsedOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + + it "can create, read, update, and delete an issue" $ do + withProject cfg $ \project -> do + deletedIssue <- withIssue cfg project $ \issue -> do + showing issue $ do + -- Force full evaluation via Show + length (show issue) `shouldSatisfy` (> 0) + -- Asserted fields (3 of 30+): + shouldBePositive (GitLab.issue_id issue) + shouldBeNonEmpty (GitLab.issue_title issue) + GitLab.issue_state issue `shouldBe` "opened" + + -- Read issue back (using iid, the project-internal issue ID) + readResponseOrError <- GitLab.runGitLab cfg $ + GitLab.projectIssue project (GitLab.issue_iid issue) + readParsedOrHttpError <- expectRight "Could not read issue" readResponseOrError + readIssueOrNotFound <- expectRight "Could not read issue (HTTP error)" readParsedOrHttpError + readIssue <- expectJust "Could not read issue (not found)" readIssueOrNotFound + showing readIssue $ do + -- Force full evaluation via Show + length (show readIssue) `shouldSatisfy` (> 0) + -- Asserted fields (3 of 30+): + GitLab.issue_id readIssue `shouldBe` GitLab.issue_id issue + GitLab.issue_title readIssue `shouldBe` GitLab.issue_title issue + GitLab.issue_state readIssue `shouldBe` "opened" + + -- Update issue (using iid, the project-internal issue ID) + let updateAttrs = (GitLab.defaultIssueAttrs (GitLab.project_id project)) + { GitLab.set_issue_description = Just "Updated description" + } + updateResponseOrError <- GitLab.runGitLab cfg $ + GitLab.editIssue project (GitLab.issue_iid issue) updateAttrs + updatedIssueOrHttpError <- expectRight "Could not update issue" updateResponseOrError + updatedIssue <- expectRight "Could not update issue (HTTP error)" updatedIssueOrHttpError + showing updatedIssue $ do + -- Force full evaluation via Show + length (show updatedIssue) `shouldSatisfy` (> 0) + -- Asserted fields (4 of 30+): + GitLab.issue_id updatedIssue `shouldBe` GitLab.issue_id issue + GitLab.issue_title updatedIssue `shouldBe` GitLab.issue_title issue + GitLab.issue_description updatedIssue `shouldBe` Just "Updated description" + GitLab.issue_state updatedIssue `shouldBe` "opened" + + return updatedIssue + + -- Verify issue is deleted (should return 404, using iid) + deletedResponseOrError <- GitLab.runGitLab cfg $ + GitLab.projectIssue project (GitLab.issue_iid deletedIssue) + parsedOrHttpError <- expectRight "Could not query deleted issue" deletedResponseOrError + httpResponse <- expectLeft "Expected 404 for deleted issue" parsedOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + + it "can list project issues" $ do + withProject cfg $ \project -> do + withIssue cfg project $ \_issue -> do + let attrs = GitLab.defaultIssueFilters + issuesOrError <- GitLab.runGitLab cfg $ GitLab.projectIssues project attrs + issues <- expectRight "Could not list project issues" issuesOrError + showing issues $ do + -- Should contain at least the issue we just created + length issues `shouldSatisfy` (>= 1) + + it "can filter issues by state" $ do + withProject cfg $ \project -> do + withIssue cfg project $ \issue -> do + -- Close the issue first (using iid, the project-internal issue ID) + let closeAttrs = (GitLab.defaultIssueAttrs (GitLab.project_id project)) + { GitLab.set_issue_state_event = Just "close" + } + closeResponseOrError <- GitLab.runGitLab cfg $ + GitLab.editIssue project (GitLab.issue_iid issue) closeAttrs + closeOrHttpError <- expectRight "Could not close issue" closeResponseOrError + closedIssue <- expectRight "Could not close issue (HTTP error)" closeOrHttpError + + showing closedIssue $ do + GitLab.issue_state closedIssue `shouldBe` "closed" + + -- List closed issues + let attrs = GitLab.defaultIssueFilters + { GitLab.issueFilter_state = Just GitLab.IssueClosed + } + issuesOrError <- GitLab.runGitLab cfg $ GitLab.projectIssues project attrs + issues <- expectRight "Could not list closed issues" issuesOrError + showing issues $ do + length issues `shouldSatisfy` (>= 1) + -- All issues should be closed + all (\i -> GitLab.issue_state i == "closed") issues `shouldBe` True + + it "can reopen a closed issue" $ do + withProject cfg $ \project -> do + withIssue cfg project $ \issue -> do + -- Close the issue + let closeAttrs = (GitLab.defaultIssueAttrs (GitLab.project_id project)) + { GitLab.set_issue_state_event = Just "close" + } + closeOrHttpError <- GitLab.runGitLab cfg $ + GitLab.editIssue project (GitLab.issue_iid issue) closeAttrs + closedIssueOrHttpError <- expectRight "Could not close issue" closeOrHttpError + closedIssue <- expectRight "Could not close issue (HTTP error)" closedIssueOrHttpError + showing closedIssue $ do + GitLab.issue_state closedIssue `shouldBe` "closed" + + -- Reopen the issue + let reopenAttrs = (GitLab.defaultIssueAttrs (GitLab.project_id project)) + { GitLab.set_issue_state_event = Just "reopen" + } + reopenOrHttpError <- GitLab.runGitLab cfg $ + GitLab.editIssue project (GitLab.issue_iid issue) reopenAttrs + reopenedIssueOrHttpError <- expectRight "Could not reopen issue" reopenOrHttpError + reopenedIssue <- expectRight "Could not reopen issue (HTTP error)" reopenedIssueOrHttpError + showing reopenedIssue $ do + GitLab.issue_state reopenedIssue `shouldBe` "opened" + + it "can assign issues to users" $ do + withProject cfg $ \project -> do + withIssue cfg project $ \issue -> do + -- Get current user to assign to + currentUserOrError <- GitLab.runGitLab cfg GitLab.currentUser + currentUser <- expectRight "Could not get current user" currentUserOrError + + -- Assign issue to current user + let assignAttrs = (GitLab.defaultIssueAttrs (GitLab.project_id project)) + { GitLab.set_issue_assignee_id = Just (GitLab.user_id currentUser) + } + assignOrHttpError <- GitLab.runGitLab cfg $ + GitLab.editIssue project (GitLab.issue_iid issue) assignAttrs + assignedIssueOrHttpError <- expectRight "Could not assign issue" assignOrHttpError + assignedIssue <- expectRight "Could not assign issue (HTTP error)" assignedIssueOrHttpError + showing assignedIssue $ do + -- Check that assignee is set + GitLab.issue_assignee assignedIssue `shouldSatisfy` (/= Nothing) + case GitLab.issue_assignee assignedIssue of + Just assignee -> GitLab.user_id assignee `shouldBe` GitLab.user_id currentUser + Nothing -> expectationFailure "Expected assignee to be set" + + it "can add labels to issues" $ do + withProject cfg $ \project -> do + withIssue cfg project $ \issue -> do + -- Add labels to issue + let labelAttrs = (GitLab.defaultIssueAttrs (GitLab.project_id project)) + { GitLab.set_issue_labels = Just ["bug", "urgent"] + } + labelOrHttpError <- GitLab.runGitLab cfg $ + GitLab.editIssue project (GitLab.issue_iid issue) labelAttrs + labeledIssueOrHttpError <- expectRight "Could not add labels to issue" labelOrHttpError + labeledIssue <- expectRight "Could not add labels to issue (HTTP error)" labeledIssueOrHttpError + showing labeledIssue $ do + GitLab.issue_labels labeledIssue `shouldBe` Just ["bug", "urgent"] + + -- Update labels + let newLabelAttrs = (GitLab.defaultIssueAttrs (GitLab.project_id project)) + { GitLab.set_issue_labels = Just ["bug", "documentation"] + } + updatedLabelOrHttpError <- GitLab.runGitLab cfg $ + GitLab.editIssue project (GitLab.issue_iid issue) newLabelAttrs + updatedLabelIssueOrHttpError <- expectRight "Could not update labels" updatedLabelOrHttpError + updatedLabelIssue <- expectRight "Could not update labels (HTTP error)" updatedLabelIssueOrHttpError + showing updatedLabelIssue $ do + GitLab.issue_labels updatedLabelIssue `shouldBe` Just ["bug", "documentation"] + + it "can subscribe and unsubscribe from issues" $ do + withProject cfg $ \project -> do + withIssue cfg project $ \issue -> do + -- First unsubscribe (user is auto-subscribed when creating an issue) + unsubscribeResponseOrError <- GitLab.runGitLab cfg $ + GitLab.unsubscribeIssue project (GitLab.issue_iid issue) + unsubscribedOrHttpError <- expectRight "Could not unsubscribe from issue" unsubscribeResponseOrError + unsubscribedIssueOrNotFound <- expectRight "Could not unsubscribe from issue (HTTP error)" unsubscribedOrHttpError + unsubscribedIssue <- expectJust "Could not unsubscribe from issue (not found)" unsubscribedIssueOrNotFound + showing unsubscribedIssue $ do + GitLab.issue_subscribed unsubscribedIssue `shouldBe` Just False + + -- Verify by reading the issue back + readAfterUnsubscribeOrError <- GitLab.runGitLab cfg $ + GitLab.projectIssue project (GitLab.issue_iid issue) + readUnsubscribedOrHttpError <- expectRight "Could not read issue after unsubscribe" readAfterUnsubscribeOrError + readUnsubscribedIssue <- expectRight "Could not read issue after unsubscribe (HTTP error)" readUnsubscribedOrHttpError + verifiedUnsubscribed <- expectJust "Issue not found after unsubscribe" readUnsubscribedIssue + showing verifiedUnsubscribed $ do + GitLab.issue_subscribed verifiedUnsubscribed `shouldBe` Just False + + -- Now subscribe to issue + subscribeResponseOrError <- GitLab.runGitLab cfg $ + GitLab.subscribeIssue project (GitLab.issue_iid issue) + subscribedOrHttpError <- expectRight "Could not subscribe to issue" subscribeResponseOrError + subscribedIssueOrNotFound <- expectRight "Could not subscribe to issue (HTTP error)" subscribedOrHttpError + subscribedIssue <- expectJust "Could not subscribe to issue (not found)" subscribedIssueOrNotFound + showing subscribedIssue $ do + GitLab.issue_subscribed subscribedIssue `shouldBe` Just True + + -- Verify by reading the issue back + readAfterSubscribeOrError <- GitLab.runGitLab cfg $ + GitLab.projectIssue project (GitLab.issue_iid issue) + readSubscribedOrHttpError <- expectRight "Could not read issue after subscribe" readAfterSubscribeOrError + readSubscribedIssue <- expectRight "Could not read issue after subscribe (HTTP error)" readSubscribedOrHttpError + verifiedSubscribed <- expectJust "Issue not found after subscribe" readSubscribedIssue + showing verifiedSubscribed $ do + GitLab.issue_subscribed verifiedSubscribed `shouldBe` Just True + + it "handles 304 when subscribing to already-subscribed issue" $ do + withProject cfg $ \project -> do + withIssue cfg project $ \issue -> do + -- User is auto-subscribed when creating an issue + -- GitLab returns 304 (Not Modified) when subscribing again + subscribeResponseOrError <- GitLab.runGitLab cfg $ + GitLab.subscribeIssue project (GitLab.issue_iid issue) + parsedOrHttpError <- expectRight "Could not subscribe to issue" subscribeResponseOrError + + -- GitLab returns Left (HTTP response) with 304 status for "already subscribed" + case parsedOrHttpError of + Left response -> do + showing response $ do + responseStatus response `shouldBe` status304 + Right _ -> do + expectationFailure "Expected 304 Not Modified for already-subscribed issue, but got success response" + + it "can move an issue to a different project" $ do + withProject cfg $ \sourceProject -> do + withProject cfg $ \targetProject -> do + withIssue cfg sourceProject $ \issue -> do + let originalIssueId = GitLab.issue_id issue + originalTitle = GitLab.issue_title issue + + -- Move issue to target project + moveResponseOrError <- GitLab.runGitLab cfg $ + GitLab.moveIssue sourceProject (GitLab.issue_iid issue) (GitLab.project_id targetProject) + movedOrHttpError <- expectRight "Could not move issue" moveResponseOrError + movedIssueOrNotFound <- expectRight "Could not move issue (HTTP error)" movedOrHttpError + movedIssue <- expectJust "Could not move issue (not found)" movedIssueOrNotFound + + showing movedIssue $ do + -- GitLab creates a new issue with a new ID when moving + GitLab.issue_id movedIssue `shouldSatisfy` (/= originalIssueId) + -- Title should be preserved + GitLab.issue_title movedIssue `shouldBe` originalTitle + -- Issue should be in target project + GitLab.issue_project_id movedIssue `shouldBe` Just (GitLab.project_id targetProject) + + -- Verify original issue is closed in source project (GitLab closes it, doesn't delete) + sourceCheckOrError <- GitLab.runGitLab cfg $ + GitLab.projectIssue sourceProject (GitLab.issue_iid issue) + sourceParsedOrHttpError <- expectRight "Could not check source project" sourceCheckOrError + sourceIssueOrNotFound <- expectRight "Could not check source project (HTTP error)" sourceParsedOrHttpError + sourceIssue <- expectJust "Original issue not found in source project" sourceIssueOrNotFound + showing sourceIssue $ do + -- Original issue should be closed after move + GitLab.issue_state sourceIssue `shouldBe` "closed" + -- Should still have the same ID and title + GitLab.issue_id sourceIssue `shouldBe` originalIssueId + GitLab.issue_title sourceIssue `shouldBe` originalTitle + + -- Verify issue exists in target project by listing + targetIssuesOrError <- GitLab.runGitLab cfg $ + GitLab.projectIssues targetProject GitLab.defaultIssueFilters + targetIssues <- expectRight "Could not list target project issues" targetIssuesOrError + showing targetIssues $ do + -- Find the moved issue by title in the target project + let foundIssues = filter (\i -> GitLab.issue_title i == originalTitle) targetIssues + length foundIssues `shouldBe` 1 + case foundIssues of + [foundIssue] -> GitLab.issue_id foundIssue `shouldBe` GitLab.issue_id movedIssue + _ -> expectationFailure "Expected exactly one moved issue in target project" + + it "can clone an issue to a different project" $ do + withProject cfg $ \sourceProject -> do + withProject cfg $ \targetProject -> do + withIssue cfg sourceProject $ \issue -> do + let originalIssueId = GitLab.issue_id issue + originalTitle = GitLab.issue_title issue + + -- Clone issue to target project + cloneResponseOrError <- GitLab.runGitLab cfg $ + GitLab.cloneIssue sourceProject (GitLab.issue_iid issue) (GitLab.project_id targetProject) + clonedOrHttpError <- expectRight "Could not clone issue" cloneResponseOrError + clonedIssueOrNotFound <- expectRight "Could not clone issue (HTTP error)" clonedOrHttpError + clonedIssue <- expectJust "Could not clone issue (not found)" clonedIssueOrNotFound + + showing clonedIssue $ do + -- Cloned issue should have a new ID + GitLab.issue_id clonedIssue `shouldSatisfy` (/= originalIssueId) + -- Title should be preserved + GitLab.issue_title clonedIssue `shouldBe` originalTitle + -- Should be in target project + GitLab.issue_project_id clonedIssue `shouldBe` Just (GitLab.project_id targetProject) + + -- Verify original issue still exists and is OPEN in source project (unlike move) + sourceCheckOrError <- GitLab.runGitLab cfg $ + GitLab.projectIssue sourceProject (GitLab.issue_iid issue) + sourceParsedOrHttpError <- expectRight "Could not check source project" sourceCheckOrError + sourceIssueOrNotFound <- expectRight "Could not check source project (HTTP error)" sourceParsedOrHttpError + sourceIssue <- expectJust "Original issue not found in source project" sourceIssueOrNotFound + showing sourceIssue $ do + -- Original issue should still be open after clone (unlike move which closes it) + GitLab.issue_state sourceIssue `shouldBe` "opened" + -- Should still have the same ID and title + GitLab.issue_id sourceIssue `shouldBe` originalIssueId + GitLab.issue_title sourceIssue `shouldBe` originalTitle + + -- Verify cloned issue exists in target project + targetIssuesOrError <- GitLab.runGitLab cfg $ + GitLab.projectIssues targetProject GitLab.defaultIssueFilters + targetIssues <- expectRight "Could not list target project issues" targetIssuesOrError + showing targetIssues $ do + -- Find the cloned issue by title in the target project + let foundIssues = filter (\i -> GitLab.issue_title i == originalTitle) targetIssues + length foundIssues `shouldBe` 1 + case foundIssues of + [foundIssue] -> GitLab.issue_id foundIssue `shouldBe` GitLab.issue_id clonedIssue + _ -> expectationFailure "Expected exactly one cloned issue in target project" + + -- TODO: Add tests for issue milestones + -- Blocked on: No GitLab.API.Milestones module exists + -- Would test: set_issue_milestone_id, create milestone, assign to issue + + -- TODO: Add tests for merge request relationships + -- Blocked on: No GitLab.API.MergeRequests module or MR test infrastructure + -- Would test: issueMergeRequests, issueMergeRequestsThatClose + + -- TODO: Add tests for issue statistics + -- Blocked on: Nothing - APIs exist (issueStatisticsProject, issueStatisticsGroup) + -- Would test: Get issue counts/statistics for projects and groups + + -- TODO: Add tests for issue participants + -- Blocked on: No comment/note API integration tests yet + -- Would test: issueParticipants after multiple users comment + + -- TODO: Add tests for userIssues + -- Blocked on: Authenticating as different users (need API tokens for created users) + -- Would test: Create users with auth tokens, create issues as those users, query by user ID + -- Note: withUser creates users but we use root's token - can't create issues as them diff --git a/integration/suite/src/Test/Helpers/Fixtures.hs b/integration/suite/src/Test/Helpers/Fixtures.hs index a381f44..49cbe7f 100644 --- a/integration/suite/src/Test/Helpers/Fixtures.hs +++ b/integration/suite/src/Test/Helpers/Fixtures.hs @@ -6,6 +6,7 @@ module Test.Helpers.Fixtures , withProject , withUser , withGroup + , withIssue ) where import qualified Data.Text as T @@ -107,3 +108,31 @@ withGroup cfg action = do -- Note: Both Just () and Nothing indicate success (2xx status code) -- Just () means the response body parsed as (), Nothing means parse failed (e.g., empty body) return () + +-- | Helper to create an issue within a project, run an action with it, and clean up. +-- Uses bracket to ensure cleanup happens even if the action fails. +withIssue :: GitLab.GitLabServerConfig -> GitLab.Project -> (GitLab.Issue -> IO a) -> IO a +withIssue cfg project action = do + issueTitle <- generateRandomName "test-issue" + + bracket + (createIssue issueTitle) + deleteIssue + action + where + createIssue title = do + let attrs = GitLab.defaultIssueAttrs (GitLab.project_id project) + createResult <- GitLab.runGitLab cfg $ + GitLab.newIssue project title "Test issue description" attrs + parsedOrHttpError <- expectRight ("Failed to create issue '" ++ T.unpack title ++ "'") createResult + issueOrNotFound <- expectRight ("Failed to create issue '" ++ T.unpack title ++ "' (HTTP error)") parsedOrHttpError + expectJust ("Failed to create issue '" ++ T.unpack title ++ "' (not found)") issueOrNotFound + + deleteIssue issue = do + -- Use iid (project-internal ID) for project-scoped operations + result <- GitLab.runGitLab cfg $ GitLab.deleteIssue project (GitLab.issue_iid issue) + parsedOrHttpError <- expectRight ("Failed to delete issue " ++ show (GitLab.issue_iid issue)) result + (_ :: Maybe ()) <- expectRight ("Failed to delete issue " ++ show (GitLab.issue_iid issue) ++ " (HTTP error)") parsedOrHttpError + -- Note: Both Just () and Nothing indicate success (2xx status code) + -- Just () means the response body parsed as (), Nothing means parse failed (e.g., empty body) + return () diff --git a/src/GitLab/API/Issues.hs b/src/GitLab/API/Issues.hs index 97a0d19..3695bfc 100644 --- a/src/GitLab/API/Issues.hs +++ b/src/GitLab/API/Issues.hs @@ -80,6 +80,7 @@ module GitLab.API.Issues defaultIssueFilters, defaultIssueAttrs, IssueAttrs (..), + IssueFilterAttrs (..), DueDate (..), IssueState (..), ) From a08463215d4d4ae87d3042def296acc95d0cfc77 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 3 Nov 2025 12:35:00 +0100 Subject: [PATCH 05/12] Update integration suite README --- integration/suite/README.md | 39 ++++++++++++++++++++++++------------- 1 file changed, 26 insertions(+), 13 deletions(-) diff --git a/integration/suite/README.md b/integration/suite/README.md index 7b7dd83..5a04a55 100644 --- a/integration/suite/README.md +++ b/integration/suite/README.md @@ -24,17 +24,13 @@ cabal run integration-suite ## Test suite structure -The test suite is organized into modules mirroring the GitLab API: +Tests are organized in `src/Test/GitLab/API/` mirroring the GitLab API structure. -- `Test.GitLab.API.Version`: Version and basic connectivity tests -- `Test.GitLab.API.Users`: User CRUD operations and error handling -- `Test.GitLab.API.Projects`: Project CRUD operations and error handling - -### Helper modules +Helper modules provide reusable test infrastructure: - `Test.Helpers.Environment`: GitLab environment configuration (URL, password, OAuth token) - `Test.Helpers.Assertions`: Test assertion helpers (`expectRight`, `expectLeft`, `expectJust`, `showing`, `shouldBe*`) -- `Test.Helpers.Fixtures`: Test fixtures for resource management (`withProject`, `withUser`, `generateRandomName`) +- `Test.Helpers.Fixtures`: Resource management with bracket pattern (`withProject`, `withUser`, `withGroup`, `withIssue`) ## Testing Guidelines @@ -117,14 +113,31 @@ Use the bracket pattern for resources that need cleanup: - `withProject`: Creates a project, runs a test, and cleans up - `withUser`: Creates a user, runs a test, and cleans up +- `withGroup`: Creates a group, runs a test, and cleans up +- `withIssue`: Creates an issue within a project, runs a test, and cleans up + +**Important principles**: + +1. **Cleanup MUST succeed**: All `with*` fixtures require successful deletion. This tests delete operations and ensures proper cleanup. +2. **No lenient cleanup by default**: We do not accept 404s or ignore errors during cleanup. This means: + - Fixtures actively test that delete operations work + - If you need to test delete explicitly within the fixture scope, return the resource and continue testing after the fixture completes + - If future tests need alternate deletion flows (e.g., multi-step deletion), consider adding explicit lenient variants like `withIssueLenient` rather than changing the default behavior +3. **Test isolation**: Each test gets fresh resources and must clean up completely to avoid interfering with other tests. + +### Testing Both Success and Failure -**Important**: Cleanup failures MUST fail the test. This ensures test isolation and prevents resource leaks. +Test both positive and negative cases: -## GitLab Soft-Delete Behavior +- **404 handling**: Test that non-existent resources return appropriate errors +- **Invalid IDs**: Test edge cases like ID 0 or negative IDs +- **State verification**: After mutations, read back the resource to verify changes persisted +- **Unexpected responses are opportunities**: When the API returns something unexpected (like 304 instead of 200), add a test for it rather than changing the test. These edge cases document important API behavior. -GitLab uses "soft deletes" for some resources: +### Multi-Resource Tests -- **Projects**: Marked for deletion with `marked_for_deletion_at` timestamp, may still be accessible -- **Users**: Blocked with `state = "blocked"` instead of being fully deleted +For tests requiring multiple resources (e.g., moving issues between projects): -Tests should account for both soft-delete and hard-delete responses when verifying deletion. +- Nest `with*` fixtures: `withProject $ \project1 -> withProject $ \project2 -> ...` +- Each fixture manages its own lifecycle independently +- Cleanup happens in reverse order (LIFO) From 4d8be4aa397a4ce1851b049ce574c46aca74c9e7 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 3 Nov 2025 12:54:36 +0100 Subject: [PATCH 06/12] Document selective integration test running --- integration/suite/README.md | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/integration/suite/README.md b/integration/suite/README.md index 5a04a55..78c99d9 100644 --- a/integration/suite/README.md +++ b/integration/suite/README.md @@ -22,6 +22,38 @@ cd integration/suite cabal run integration-suite ``` +### Running Tests Selectively + +The test suite uses hspec, which supports filtering tests via command-line options. + +**How `--match` works**: Substring matching on the full test path (e.g., `"Issue operations/can move an issue to a different project"`). + +Examples: +```bash +# Match by describe block +cabal run integration-suite -- --match "Issue operations" + +# Match by test name substring +cabal run integration-suite -- --match "can create" + +# Match across path boundaries using / +cabal run integration-suite -- --match "Issue operations/move" +cabal run integration-suite -- --match "operations/can" + +# Exact test path (useful for rerunning a single test) +cabal run integration-suite -- --match "/GitLab API calls/Issue operations/can move an issue to a different project/" + +# Other useful options +cabal run integration-suite -- --skip "404" # Skip matching tests +cabal run integration-suite -- --dry-run # Show what would run +cabal run integration-suite -- --fail-fast # Stop on first failure +cabal run integration-suite -- --rerun # Rerun failed tests +cabal run integration-suite -- -j4 # Run with 4 parallel jobs +cabal run integration-suite -- --help # Show all options +``` + +Patterns are case-sensitive. The `/` is a literal character in the path, not special syntax. + ## Test suite structure Tests are organized in `src/Test/GitLab/API/` mirroring the GitLab API structure. From 4508570189f8945f8ea927c614abd28557e318d3 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 3 Nov 2025 12:56:11 +0100 Subject: [PATCH 07/12] Add RepositoryFiles integration test --- integration/suite/integration-suite.cabal | 1 + integration/suite/src/Main.hs | 2 + .../src/Test/GitLab/API/RepositoryFiles.hs | 83 +++++++++++++++++++ 3 files changed, 86 insertions(+) create mode 100644 integration/suite/src/Test/GitLab/API/RepositoryFiles.hs diff --git a/integration/suite/integration-suite.cabal b/integration/suite/integration-suite.cabal index 7cba287..fc52f59 100644 --- a/integration/suite/integration-suite.cabal +++ b/integration/suite/integration-suite.cabal @@ -14,6 +14,7 @@ executable integration-suite , Test.GitLab.API.Groups , Test.GitLab.API.Issues , Test.GitLab.API.Projects + , Test.GitLab.API.RepositoryFiles , Test.GitLab.API.Users , Test.GitLab.API.Version hs-source-dirs: src diff --git a/integration/suite/src/Main.hs b/integration/suite/src/Main.hs index a711621..ba391d7 100644 --- a/integration/suite/src/Main.hs +++ b/integration/suite/src/Main.hs @@ -8,6 +8,7 @@ import Test.Helpers.Environment ( getGitLabURL, getGitLabToken ) import qualified Test.GitLab.API.Groups import qualified Test.GitLab.API.Issues import qualified Test.GitLab.API.Projects +import qualified Test.GitLab.API.RepositoryFiles import qualified Test.GitLab.API.Users import qualified Test.GitLab.API.Version import qualified Test.Hspec.Runner as R @@ -52,3 +53,4 @@ spec cfg = do Test.GitLab.API.Projects.spec cfg Test.GitLab.API.Groups.spec cfg Test.GitLab.API.Issues.spec cfg + Test.GitLab.API.RepositoryFiles.spec cfg diff --git a/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs new file mode 100644 index 0000000..707d8c0 --- /dev/null +++ b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.GitLab.API.RepositoryFiles (spec) where + +import Test.Hspec +import qualified GitLab +import Test.Helpers.Assertions +import Test.Helpers.Fixtures +import Network.HTTP.Client (responseStatus) +import Network.HTTP.Types (status404) +import qualified Data.Text as T + +spec :: GitLab.GitLabServerConfig -> Spec +spec cfg = do + describe "Repository file operations" $ do + it "can create, read, update, and delete a file" $ do + withProject cfg $ \project -> do + let filePath = "README.md" + branchName = "main" -- GitLab default branch + initialContent = "# Test Project\n\nThis is a test." + createCommitMsg = "Add README" + updatedContent = "# Test Project\n\nUpdated content." + updateCommitMsg = "Update README" + deleteCommitMsg = "Delete README" + + -- Create file + createResponseOrError <- GitLab.runGitLab cfg $ + GitLab.createRepositoryFile project filePath branchName initialContent createCommitMsg + createOrHttpError <- expectRight "Could not create file" createResponseOrError + createdFileOrNotFound <- expectRight "Could not create file (HTTP error)" createOrHttpError + createdFile <- expectJust "Could not create file (not found)" createdFileOrNotFound + showing createdFile $ do + GitLab.repository_file_simple_file_path createdFile `shouldBe` filePath + GitLab.repository_file_simple_branch createdFile `shouldBe` branchName + + -- Read file back + readResponseOrError <- GitLab.runGitLab cfg $ + GitLab.repositoryFile project filePath branchName + readOrHttpError <- expectRight "Could not read file" readResponseOrError + readFileOrNotFound <- expectRight "Could not read file (HTTP error)" readOrHttpError + fileInfo <- expectJust "Could not read file (not found)" readFileOrNotFound + showing fileInfo $ do + GitLab.repository_file_file_path fileInfo `shouldBe` filePath + GitLab.repository_file_file_name fileInfo `shouldBe` "README.md" + GitLab.repository_file_size fileInfo `shouldSatisfy` (> 0) + -- Content is Base64 encoded + GitLab.repository_file_content fileInfo `shouldSatisfy` (\c -> T.length c > 0) + + -- Update file + updateResponseOrError <- GitLab.runGitLab cfg $ + GitLab.updateRepositoryFile project filePath branchName updatedContent updateCommitMsg + updateOrHttpError <- expectRight "Could not update file" updateResponseOrError + updatedFileOrNotFound <- expectRight "Could not update file (HTTP error)" updateOrHttpError + updatedFile <- expectJust "Could not update file (not found)" updatedFileOrNotFound + showing updatedFile $ do + GitLab.repository_file_simple_file_path updatedFile `shouldBe` filePath + + -- Verify update by reading file back + updatedReadResponseOrError <- GitLab.runGitLab cfg $ + GitLab.repositoryFile project filePath branchName + updatedReadOrHttpError <- expectRight "Could not read updated file" updatedReadResponseOrError + updatedFileInfoOrNotFound <- expectRight "Could not read updated file (HTTP error)" updatedReadOrHttpError + updatedFileInfo <- expectJust "Could not read updated file (not found)" updatedFileInfoOrNotFound + showing updatedFileInfo $ do + GitLab.repository_file_file_path updatedFileInfo `shouldBe` filePath + -- Content is Base64 encoded - just verify it's non-empty + GitLab.repository_file_content updatedFileInfo `shouldSatisfy` (\c -> T.length c > 0) + + -- Delete file + deleteResponseOrError <- GitLab.runGitLab cfg $ + GitLab.deleteRepositoryFile project filePath branchName deleteCommitMsg + deleteOrHttpError <- expectRight "Could not delete file" deleteResponseOrError + (_ :: Maybe ()) <- expectRight "Could not delete file (HTTP error)" deleteOrHttpError + return () + + -- Verify file is deleted (should return 404) + deletedResponseOrError <- GitLab.runGitLab cfg $ + GitLab.repositoryFile project filePath branchName + deletedOrHttpError <- expectRight "Could not check deleted file" deletedResponseOrError + httpResponse <- expectLeft "Expected 404 for deleted file" deletedOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 From 4f645bb6599d35b9ad25f52f9c984c23ef09feeb Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 3 Nov 2025 13:19:46 +0100 Subject: [PATCH 08/12] Integration test Repository files with empty/missing files --- .../src/Test/GitLab/API/RepositoryFiles.hs | 55 +++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs index 707d8c0..1bd0384 100644 --- a/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs +++ b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs @@ -81,3 +81,58 @@ spec cfg = do httpResponse <- expectLeft "Expected 404 for deleted file" deletedOrHttpError showing httpResponse $ do responseStatus httpResponse `shouldBe` status404 + + it "handles 404 for non-existent files" $ do + withProject cfg $ \project -> do + let filePath = "does-not-exist.txt" + branchName = "main" + + -- Try to read non-existent file with repositoryFile + readResponseOrError <- GitLab.runGitLab cfg $ + GitLab.repositoryFile project filePath branchName + readOrHttpError <- expectRight "Could not read non-existent file" readResponseOrError + httpResponse <- expectLeft "Expected 404 for non-existent file" readOrHttpError + showing httpResponse $ do + responseStatus httpResponse `shouldBe` status404 + + -- Try to read non-existent file with repositoryFileRawFile + rawResponseOrError <- GitLab.runGitLab cfg $ + GitLab.repositoryFileRawFile project filePath branchName + rawOrHttpError <- expectRight "Could not read non-existent raw file" rawResponseOrError + rawHttpResponse <- expectLeft "Expected 404 for non-existent raw file" rawOrHttpError + showing rawHttpResponse $ do + responseStatus rawHttpResponse `shouldBe` status404 + + it "can handle empty files" $ do + withProject cfg $ \project -> do + let filePath = "empty.txt" + branchName = "main" + emptyContent = "" + commitMsg = "Add empty file" + + -- Create empty file + createResponseOrError <- GitLab.runGitLab cfg $ + GitLab.createRepositoryFile project filePath branchName emptyContent commitMsg + createOrHttpError <- expectRight "Could not create empty file" createResponseOrError + createdFileOrNotFound <- expectRight "Could not create empty file (HTTP error)" createOrHttpError + createdFile <- expectJust "Could not create empty file (not found)" createdFileOrNotFound + + let createdBranch = GitLab.repository_file_simple_branch createdFile + + -- Read back via repositoryFile (Base64-encoded) + readResponseOrError <- GitLab.runGitLab cfg $ + GitLab.repositoryFile project filePath createdBranch + readOrHttpError <- expectRight "Could not read empty file" readResponseOrError + readFileOrNotFound <- expectRight "Could not read empty file (HTTP error)" readOrHttpError + fileInfo <- expectJust "Could not read empty file (not found)" readFileOrNotFound + showing fileInfo $ do + GitLab.repository_file_file_path fileInfo `shouldBe` filePath + GitLab.repository_file_size fileInfo `shouldBe` 0 + + -- Read back via repositoryFileRawFile + rawResponseOrError <- GitLab.runGitLab cfg $ + GitLab.repositoryFileRawFile project filePath createdBranch + rawOrHttpError <- expectRight "Could not read empty raw file" rawResponseOrError + rawContent <- expectRight "Could not read empty raw file (HTTP error)" rawOrHttpError + showing rawContent $ do + rawContent `shouldBe` mempty From 8184fea2cf3792f63c6daed35ac19ad3430bddb3 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 3 Nov 2025 13:14:24 +0100 Subject: [PATCH 09/12] Fix repositoryFileRawFile It tried to parse as JSON, which doesn't work for a raw response. I've made the status check stricter, requiring 200. A different status risks silently accepting wrong semantics, e.g. partial response. So this is a breaking change, but that's the only sensible course of action, and I expect it to impact nobody, because I don't expect anyone to use this on files that are JSON strings. Nobody has "JSON string" files and they aren't even valid JSON files according to some definitions. So dead code seems plausible. I have changed the signature, so any (implausible) breakage won't go unnoticed at compile time. --- .../src/Test/GitLab/API/RepositoryFiles.hs | 32 ++++++++++++++++--- src/GitLab/API/RepositoryFiles.hs | 9 ++++-- 2 files changed, 34 insertions(+), 7 deletions(-) diff --git a/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs index 1bd0384..b558df2 100644 --- a/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs +++ b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs @@ -10,6 +10,8 @@ import Test.Helpers.Fixtures import Network.HTTP.Client (responseStatus) import Network.HTTP.Types (status404) import qualified Data.Text as T +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Encoding as TE spec :: GitLab.GitLabServerConfig -> Spec spec cfg = do @@ -34,7 +36,7 @@ spec cfg = do GitLab.repository_file_simple_file_path createdFile `shouldBe` filePath GitLab.repository_file_simple_branch createdFile `shouldBe` branchName - -- Read file back + -- Read file back (Base64-encoded metadata) readResponseOrError <- GitLab.runGitLab cfg $ GitLab.repositoryFile project filePath branchName readOrHttpError <- expectRight "Could not read file" readResponseOrError @@ -45,7 +47,18 @@ spec cfg = do GitLab.repository_file_file_name fileInfo `shouldBe` "README.md" GitLab.repository_file_size fileInfo `shouldSatisfy` (> 0) -- Content is Base64 encoded - GitLab.repository_file_content fileInfo `shouldSatisfy` (\c -> T.length c > 0) + GitLab.repository_file_content fileInfo `shouldSatisfy` (\c -> not (T.null c)) + + -- Read raw file content + -- Note: We use the branch from the create response because a new project + -- might not have a default branch yet until the first file is created + let createdBranch = GitLab.repository_file_simple_branch createdFile + rawResponseOrGitLabError <- GitLab.runGitLab cfg $ + GitLab.repositoryFileRawFile project filePath createdBranch + rawOrHttpError <- expectRight "Could not read raw file" rawResponseOrGitLabError + rawContent <- expectRight "Could not read raw file (HTTP error)" rawOrHttpError + showing rawContent $ do + rawContent `shouldBe` lazyUtf8 initialContent -- Update file updateResponseOrError <- GitLab.runGitLab cfg $ @@ -56,7 +69,7 @@ spec cfg = do showing updatedFile $ do GitLab.repository_file_simple_file_path updatedFile `shouldBe` filePath - -- Verify update by reading file back + -- Verify update by reading file back (Base64-encoded metadata) updatedReadResponseOrError <- GitLab.runGitLab cfg $ GitLab.repositoryFile project filePath branchName updatedReadOrHttpError <- expectRight "Could not read updated file" updatedReadResponseOrError @@ -65,7 +78,15 @@ spec cfg = do showing updatedFileInfo $ do GitLab.repository_file_file_path updatedFileInfo `shouldBe` filePath -- Content is Base64 encoded - just verify it's non-empty - GitLab.repository_file_content updatedFileInfo `shouldSatisfy` (\c -> T.length c > 0) + GitLab.repository_file_content updatedFileInfo `shouldSatisfy` (\c -> not (T.null c)) + + -- Verify update by reading raw content + updatedRawResponseOrGitLabError <- GitLab.runGitLab cfg $ + GitLab.repositoryFileRawFile project filePath branchName + updatedRawOrHttpError <- expectRight "Could not read updated file (raw)" updatedRawResponseOrGitLabError + updatedRawContent <- expectRight "Could not read updated file (raw HTTP error)" updatedRawOrHttpError + showing updatedRawContent $ do + updatedRawContent `shouldBe` lazyUtf8 updatedContent -- Delete file deleteResponseOrError <- GitLab.runGitLab cfg $ @@ -136,3 +157,6 @@ spec cfg = do rawContent <- expectRight "Could not read empty raw file (HTTP error)" rawOrHttpError showing rawContent $ do rawContent `shouldBe` mempty + +lazyUtf8 :: T.Text -> BL.ByteString +lazyUtf8 = BL.fromStrict . TE.encodeUtf8 diff --git a/src/GitLab/API/RepositoryFiles.hs b/src/GitLab/API/RepositoryFiles.hs index ad5c4bc..a2cd085 100644 --- a/src/GitLab/API/RepositoryFiles.hs +++ b/src/GitLab/API/RepositoryFiles.hs @@ -72,9 +72,12 @@ repositoryFileRawFile :: -- | The name of branch, tag or commit. Default is the HEAD of the -- project. Text -> - GitLab (Either (Response BSL.ByteString) (Maybe Text)) -repositoryFileRawFile prj filePath reference = - gitlabGetOne addr [("ref", Just (T.encodeUtf8 reference))] + GitLab (Either (Response BSL.ByteString) BSL.ByteString) +repositoryFileRawFile prj filePath reference = do + resp <- gitlabGetByteStringResponse addr [("ref", Just (T.encodeUtf8 reference))] + if responseStatus resp == status200 + then return (Right (responseBody resp)) + else return (Left resp) where addr = "/projects/" From 7a3a34947c9dc95eafba59d2535e49592f25a168 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 3 Nov 2025 13:56:24 +0100 Subject: [PATCH 10/12] Test that file reading passes branch parameter --- .../src/Test/GitLab/API/RepositoryFiles.hs | 25 ++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs index b558df2..c927ed4 100644 --- a/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs +++ b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs @@ -49,6 +49,9 @@ spec cfg = do -- Content is Base64 encoded GitLab.repository_file_content fileInfo `shouldSatisfy` (\c -> not (T.null c)) + -- Get the commit SHA of the initial version (for testing ref parameter later) + let initialCommitSha = GitLab.repository_file_last_commit_id fileInfo + -- Read raw file content -- Note: We use the branch from the create response because a new project -- might not have a default branch yet until the first file is created @@ -80,7 +83,7 @@ spec cfg = do -- Content is Base64 encoded - just verify it's non-empty GitLab.repository_file_content updatedFileInfo `shouldSatisfy` (\c -> not (T.null c)) - -- Verify update by reading raw content + -- Verify update by reading raw content from branch head updatedRawResponseOrGitLabError <- GitLab.runGitLab cfg $ GitLab.repositoryFileRawFile project filePath branchName updatedRawOrHttpError <- expectRight "Could not read updated file (raw)" updatedRawResponseOrGitLabError @@ -88,6 +91,26 @@ spec cfg = do showing updatedRawContent $ do updatedRawContent `shouldBe` lazyUtf8 updatedContent + -- Test ref parameter with repositoryFileRawFile: read from the initial commit SHA + oldRawResponseOrError <- GitLab.runGitLab cfg $ + GitLab.repositoryFileRawFile project filePath initialCommitSha + oldRawOrHttpError <- expectRight "Could not read old version (raw)" oldRawResponseOrError + oldRawContent <- expectRight "Could not read old version (raw HTTP error)" oldRawOrHttpError + showing oldRawContent $ do + oldRawContent `shouldBe` lazyUtf8 initialContent + -- Verify the versions are different + oldRawContent `shouldNotBe` updatedRawContent + + -- Test ref parameter with repositoryFile: read from the initial commit SHA + oldReadResponseOrError <- GitLab.runGitLab cfg $ + GitLab.repositoryFile project filePath initialCommitSha + oldReadOrHttpError <- expectRight "Could not read old version (base64)" oldReadResponseOrError + oldFileInfoOrNotFound <- expectRight "Could not read old version (base64 HTTP error)" oldReadOrHttpError + oldFileInfo <- expectJust "Could not read old version (base64 not found)" oldFileInfoOrNotFound + showing oldFileInfo $ do + GitLab.repository_file_file_path oldFileInfo `shouldBe` filePath + GitLab.repository_file_last_commit_id oldFileInfo `shouldBe` initialCommitSha + -- Delete file deleteResponseOrError <- GitLab.runGitLab cfg $ GitLab.deleteRepositoryFile project filePath branchName deleteCommitMsg From ec3762c2875e6063f7478b2619d72f24e1e23529 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 1 Dec 2025 00:55:04 +0100 Subject: [PATCH 11/12] Add hercules-ci-effects and configure ciSystems hercules-ci-effects might be overkill for just ciSystems but ok. --- flake.lock | 68 +++++++++++++++++++++++++++++++++++++++++++++++++----- flake.nix | 7 +++++- 2 files changed, 68 insertions(+), 7 deletions(-) diff --git a/flake.lock b/flake.lock index c17c848..ed326f9 100644 --- a/flake.lock +++ b/flake.lock @@ -18,6 +18,26 @@ "type": "github" } }, + "flake-parts_2": { + "inputs": { + "nixpkgs-lib": [ + "hercules-ci-effects", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1762980239, + "narHash": "sha256-8oNVE8TrD19ulHinjaqONf9QWCKK+w4url56cdStMpM=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "52a2caecc898d0b46b2b905f058ccc5081f842da", + "type": "github" + }, + "original": { + "id": "flake-parts", + "type": "indirect" + } + }, "haskell-flake": { "locked": { "lastModified": 1762053606, @@ -33,17 +53,36 @@ "type": "github" } }, + "hercules-ci-effects": { + "inputs": { + "flake-parts": "flake-parts_2", + "nixpkgs": "nixpkgs" + }, + "locked": { + "lastModified": 1763182882, + "narHash": "sha256-jZi+9yKmeTMsJ4ZNqRei/wL16+QwYGrCl4EJ3QHfoDU=", + "owner": "hercules-ci", + "repo": "hercules-ci-effects", + "rev": "b0585849abe7d02a774a853f7952d07bb910fd9e", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "hercules-ci-effects", + "type": "github" + } + }, "nixpkgs": { "locked": { - "lastModified": 1761907660, - "narHash": "sha256-kJ8lIZsiPOmbkJypG+B5sReDXSD1KGu2VEPNqhRa/ew=", - "owner": "nixos", + "lastModified": 1762977756, + "narHash": "sha256-4PqRErxfe+2toFJFgcRKZ0UI9NSIOJa+7RXVtBhy4KE=", + "owner": "NixOS", "repo": "nixpkgs", - "rev": "2fb006b87f04c4d3bdf08cfdbc7fab9c13d94a15", + "rev": "c5ae371f1a6a7fd27823bc500d9390b38c05fa55", "type": "github" }, "original": { - "owner": "nixos", + "owner": "NixOS", "ref": "nixos-unstable", "repo": "nixpkgs", "type": "github" @@ -64,11 +103,28 @@ "type": "github" } }, + "nixpkgs_2": { + "locked": { + "lastModified": 1761907660, + "narHash": "sha256-kJ8lIZsiPOmbkJypG+B5sReDXSD1KGu2VEPNqhRa/ew=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "2fb006b87f04c4d3bdf08cfdbc7fab9c13d94a15", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, "root": { "inputs": { "flake-parts": "flake-parts", "haskell-flake": "haskell-flake", - "nixpkgs": "nixpkgs" + "hercules-ci-effects": "hercules-ci-effects", + "nixpkgs": "nixpkgs_2" } } }, diff --git a/flake.nix b/flake.nix index 40f906a..2256e37 100644 --- a/flake.nix +++ b/flake.nix @@ -5,6 +5,7 @@ nixpkgs.url = "github:nixos/nixpkgs/nixos-unstable"; flake-parts.url = "github:hercules-ci/flake-parts"; haskell-flake.url = "github:srid/haskell-flake"; + hercules-ci-effects.url = "github:hercules-ci/hercules-ci-effects"; }; outputs = @@ -19,7 +20,11 @@ "x86_64-darwin" "aarch64-darwin" ]; - imports = [ inputs.haskell-flake.flakeModule ]; + herculesCI.ciSystems = [ "x86_64-linux" ]; + imports = [ + inputs.haskell-flake.flakeModule + inputs.hercules-ci-effects.flakeModule + ]; # https://flake.parts/options/flake-parts.html#opt-perSystem perSystem = From 400828ddcb0cb0a7f0b36f9670f5b20f8db51e9c Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 1 Dec 2025 01:57:26 +0100 Subject: [PATCH 12/12] Add active filter for listing groups --- integration/suite/src/Test/GitLab/API/Groups.hs | 16 ++++++++++++++++ src/GitLab/API/Groups.hs | 10 +++++++--- 2 files changed, 23 insertions(+), 3 deletions(-) diff --git a/integration/suite/src/Test/GitLab/API/Groups.hs b/integration/suite/src/Test/GitLab/API/Groups.hs index ccc8774..2f18245 100644 --- a/integration/suite/src/Test/GitLab/API/Groups.hs +++ b/integration/suite/src/Test/GitLab/API/Groups.hs @@ -109,3 +109,19 @@ spec cfg = do GitLab.group_name foundGroup `shouldBe` groupName [] -> expectationFailure "Expected to find the created group in search results" _ -> expectationFailure "Expected exactly one matching group in search results" + + it "can filter groups by active status" $ do + -- Create and delete a group (marking it for deletion) + deletedGroupId <- withGroup cfg $ \group -> do + return (GitLab.group_id group) + + -- List only active groups - deleted group should NOT appear + let activeAttrs = GitLab.defaultListGroupsFilters + { GitLab.listGroupsFilter_active = Just True + } + activeGroupsOrError <- GitLab.runGitLab cfg $ GitLab.groups activeAttrs + activeGroups <- expectRight "Could not list active groups" activeGroupsOrError + showing activeGroups $ do + -- Deleted group should NOT be in active groups + let foundDeleted = filter (\g -> GitLab.group_id g == deletedGroupId) activeGroups + length foundDeleted `shouldBe` 0 diff --git a/src/GitLab/API/Groups.hs b/src/GitLab/API/Groups.hs index 80b50bf..cee8d60 100644 --- a/src/GitLab/API/Groups.hs +++ b/src/GitLab/API/Groups.hs @@ -301,7 +301,10 @@ data ListGroupsAttrs = ListGroupsAttrs listGroupsFilter_sort :: Maybe SortBy, listGroupsFilter_owned :: Maybe Bool, listGroupsFilter_min_access_level :: Maybe AccessLevel, - listGroupsFilter_top_level_only :: Maybe Bool + listGroupsFilter_top_level_only :: Maybe Bool, + -- | Limit by active status. 'Just' 'True' excludes groups marked for + -- deletion and archived groups. + listGroupsFilter_active :: Maybe Bool } -- | The order of groups in search results. @@ -327,7 +330,8 @@ listGroupsAttrs filters = (\sortBy -> Just ("sort", textToBS (T.pack (show sortBy)))) =<< listGroupsFilter_sort filters, (\b -> Just ("owned", textToBS (showBool b))) =<< listGroupsFilter_owned filters, (\accLevel -> Just ("min_access_level", textToBS (T.pack (show accLevel)))) =<< listGroupsFilter_min_access_level filters, - (\b -> Just ("top_level_only", textToBS (showBool b))) =<< listGroupsFilter_top_level_only filters + (\b -> Just ("top_level_only", textToBS (showBool b))) =<< listGroupsFilter_top_level_only filters, + (\b -> Just ("active", textToBS (showBool b))) =<< listGroupsFilter_active filters ] where textToBS = Just . T.encodeUtf8 @@ -338,7 +342,7 @@ listGroupsAttrs filters = -- | No group filters applied, thereby returning all groups. defaultListGroupsFilters :: ListGroupsAttrs defaultListGroupsFilters = - ListGroupsAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + ListGroupsAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -- | Attributes related to a group data GroupAttrs = GroupAttrs