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..3f73ac1 100644 --- a/.gitignore +++ b/.gitignore @@ -36,4 +36,13 @@ cabal.project.local~ examples/Main examples/FileHook examples/GitLabCommit -examples/UserProjects \ No newline at end of file +examples/UserProjects + +# direnv (.envrc) +.direnv/ + +# nix +result + +# integration test vm +gitlab-dev.qcow2 diff --git a/cabal.project b/cabal.project index e37cc48..4b2f309 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,4 @@ -packages: . examples +packages: + . + examples + integration/suite diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..ed326f9 --- /dev/null +++ b/flake.lock @@ -0,0 +1,133 @@ +{ + "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" + } + }, + "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, + "narHash": "sha256-OJ4O4K8GxazjdwoTajbk6ZbzkhNgC2Y2398zhkFSCCY=", + "owner": "srid", + "repo": "haskell-flake", + "rev": "eec1a47a9b453ab882650b0d426065615da99453", + "type": "github" + }, + "original": { + "owner": "srid", + "repo": "haskell-flake", + "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": 1762977756, + "narHash": "sha256-4PqRErxfe+2toFJFgcRKZ0UI9NSIOJa+7RXVtBhy4KE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "c5ae371f1a6a7fd27823bc500d9390b38c05fa55", + "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" + } + }, + "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", + "hercules-ci-effects": "hercules-ci-effects", + "nixpkgs": "nixpkgs_2" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..2256e37 --- /dev/null +++ b/flake.nix @@ -0,0 +1,143 @@ +{ + 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"; + hercules-ci-effects.url = "github:hercules-ci/hercules-ci-effects"; + }; + + 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" + ]; + 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 = + { + 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 + ]; + + # 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..78c99d9 --- /dev/null +++ b/integration/suite/README.md @@ -0,0 +1,175 @@ +# 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 +``` + +### 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. + +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`: Resource management with bracket pattern (`withProject`, `withUser`, `withGroup`, `withIssue`) + +## 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 +- `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 + +Test both positive and negative cases: + +- **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. + +### Multi-Resource Tests + +For tests requiring multiple resources (e.g., moving issues between projects): + +- Nest `with*` fixtures: `withProject $ \project1 -> withProject $ \project2 -> ...` +- Each fixture manages its own lifecycle independently +- Cleanup happens in reverse order (LIFO) diff --git a/integration/suite/integration-suite.cabal b/integration/suite/integration-suite.cabal new file mode 100644 index 0000000..fc52f59 --- /dev/null +++ b/integration/suite/integration-suite.cabal @@ -0,0 +1,33 @@ +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.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 + 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..ba391d7 --- /dev/null +++ b/integration/suite/src/Main.hs @@ -0,0 +1,56 @@ +{-# 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.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 +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 + 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/Groups.hs b/integration/suite/src/Test/GitLab/API/Groups.hs new file mode 100644 index 0000000..2f18245 --- /dev/null +++ b/integration/suite/src/Test/GitLab/API/Groups.hs @@ -0,0 +1,127 @@ +{-# 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" + + 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/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/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/RepositoryFiles.hs b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs new file mode 100644 index 0000000..c927ed4 --- /dev/null +++ b/integration/suite/src/Test/GitLab/API/RepositoryFiles.hs @@ -0,0 +1,185 @@ +{-# 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 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Encoding as TE + +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 (Base64-encoded metadata) + 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 -> 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 + 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 $ + 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 (Base64-encoded metadata) + 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 -> not (T.null c)) + + -- 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 + updatedRawContent <- expectRight "Could not read updated file (raw HTTP error)" updatedRawOrHttpError + 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 + 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 + + 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 + +lazyUtf8 :: T.Text -> BL.ByteString +lazyUtf8 = BL.fromStrict . TE.encodeUtf8 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..49cbe7f --- /dev/null +++ b/integration/suite/src/Test/Helpers/Fixtures.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Helpers.Fixtures + ( generateRandomName + , withProject + , withUser + , withGroup + , withIssue + ) 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 () + +-- | 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 () + +-- | 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/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 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 (..), ) 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/"