diff --git a/.github/ISSUE_TEMPLATE/bug-report.yaml b/.github/ISSUE_TEMPLATE/bug-report.yaml index 0935e44db..23581f9eb 100644 --- a/.github/ISSUE_TEMPLATE/bug-report.yaml +++ b/.github/ISSUE_TEMPLATE/bug-report.yaml @@ -64,7 +64,6 @@ body: - primer - primer-api - primer-service - - primer-rel8 - primer-selda - primer-benchmark - Primer language prelude diff --git a/Makefile b/Makefile index 31b0d09f2..2141bf247 100644 --- a/Makefile +++ b/Makefile @@ -8,7 +8,6 @@ targets = build configure check test bench generate-fixtures docs clean realclea $(targets): $(MAKE) -C primer $@ $(MAKE) -C primer-api $@ - $(MAKE) -C primer-rel8 $@ $(MAKE) -C primer-selda $@ $(MAKE) -C primer-service $@ $(MAKE) -C primer-benchmark $@ diff --git a/bugreport.sh b/bugreport.sh index 13d256d83..1b0a7b534 100755 --- a/bugreport.sh +++ b/bugreport.sh @@ -244,26 +244,4 @@ else fi echo "" -PSQL_COMMAND="$(command -v psql)" -echo "PostgreSQL:" -if ! [ -x "$PSQL_COMMAND" ]; then - echo "psql is not in the PATH." -else - echo "psql path is: " "$PSQL_COMMAND" - PSQL_VERSION=$(psql --version) - echo "psql version is: " "$PSQL_VERSION" -fi -echo "" - -COLIMA_COMMAND="$(command -v colima)" -echo "Colima:" -if ! [ -x "$COLIMA_COMMAND" ]; then - echo "colima is not in the PATH." -else - echo "colima path is: " "$COLIMA_COMMAND" - COLIMA_VERSION=$(colima version) - echo "colima version is: " "$COLIMA_VERSION" -fi - - exit 0 diff --git a/cabal.project b/cabal.project index 6256a2729..ea1f07388 100644 --- a/cabal.project +++ b/cabal.project @@ -3,7 +3,6 @@ index-state: 2023-05-20T00:00:00Z packages: primer primer-api - primer-rel8 primer-selda primer-service primer-benchmark diff --git a/docs/database.md b/docs/database.md index ab47f68b0..133af435d 100644 --- a/docs/database.md +++ b/docs/database.md @@ -1,23 +1,9 @@ # Database ops We use [Sqitch](https://sqitch.org/about/) to manage our database -schemas, both for PostgreSQL and SQLite. Because these database -engines are quite different, we require separate schemas for each. For -general help on how to use Sqitch and a bit about how it works, see -[the `sqitch` PostgreSQL -tutorial](https://sqitch.org/docs/manual/sqitchtutorial/). - -Note: we do not use Sqitch for any PostgreSQL user or group -permissions, nor any database-wide security settings in general. The -reason for this is because we assume that for some -PostgreSQL-compatible cloud database offerings, user provisioning and -security settings may be managed out of band using the cloud -provider's own APIs. Therefore, our Sqitch scripts assume that the -PostgreSQL user who's running the scripts has all the permissions -required to perform any operations included in those scripts, and that -a [secure schema usage -pattern](https://www.postgresql.org/docs/current/ddl-schemas.html#DDL-SCHEMAS-PATTERNS) -has been configured out-of-band. +schemas. For general help on how to use Sqitch and a bit about how it +works, see [the `sqitch` SQLite +tutorial](https://sqitch.org/docs/manual/sqitchtutorial-sqlite/). The following guide assumes you're running `sqitch` and the `primer-sqitch` helper script from the `nix develop` shell. diff --git a/docs/developing.md b/docs/developing.md index f1f5bc777..521076d1a 100644 --- a/docs/developing.md +++ b/docs/developing.md @@ -138,12 +138,3 @@ yourself. `primer-service` doesn't know how to deploy or migrate the database on its own. See the [`primer-service-entrypoint.sh`](../nix/pkgs/scripts/primer-service-entrypoint.sh) shell script for the commands that the Docker entrypoint runs. - -## Local development with PostgreSQL - -In addition to SQLite, `primer-service` also supports PostgreSQL for -its program store. Though we recommend using SQLite for local -development due to its much simpler setup, we do provide a collection -of Nix-based tooling to make local PostgreSQL development as easy as -we can. See the [PostgreSQL development documentation](postgresql.md) -for details. diff --git a/docs/development-guide-toc.md b/docs/development-guide-toc.md index d460ef149..890ec830a 100644 --- a/docs/development-guide-toc.md +++ b/docs/development-guide-toc.md @@ -25,6 +25,5 @@ the various packages' Haddocks. ## Advanced or specialized topics * [Primitives](primitives.md) -* [Developing Primer with PostgreSQL](postgresql.md) * [Database ops](database.md) * [Benchmarking](benchmarking.md) diff --git a/docs/postgresql.md b/docs/postgresql.md deleted file mode 100644 index aa07b752f..000000000 --- a/docs/postgresql.md +++ /dev/null @@ -1,183 +0,0 @@ -# Local development with PostgreSQL - -Running the Primer API server locally with a PostgreSQL database -backend is much more involved than with [SQLite](developing.md), but -we do provide some Nix tooling to make it a bit easier. - -Note that most of the PostgreSQL development tooling we provide -assumes you want to spin up a local development PostgreSQL server -that's dedicated to testing Primer, rather than using an existing -remote (or local) server. The tooling should be reasonably easy to -adapt to use any PostgreSQL server, but we don't have the resources to -support these development workflows, unfortunately. - -## Initial setup - -The first time you want to do local Primer development on a particular -host, you'll need to run the following commands from the top-level -directory in this repo: - -```sh -nix run .#deploy-postgresql-container -nix run .#create-local-db -``` - -This sequence of commands will do the following: - -1. Create a new [Colima](https://github.com/abiosoft/colima) profile named `primer`. -2. Run a PostgreSQL container in the `primer` profile, using Colima's - Docker-compatible runtime. The PostgreSQL service running on the - container listens on the default PostgreSQL TCP port, `5432`. -3. Create a PostgreSQL database named `primer`. - -In general, you should only need to run this sequence of commands the -first time you do any Primer development on a new development machine, -or if you want to start over with a completely new PostgreSQL -container for some reason. The container & database those commands -create will persist across reboots, and will remain on your system -until you delete them. However, it's safe to run these commands -multiple times, as they will create only a single container and -`primer` database. - -## Development workflow - -Your usual Primer development workflow will look something like this: - -```sh -nix run .#run-primer-postgresql -``` - -By default, this command will: - -1. Deploy the Primer database schema to the default local PostgreSQL - instance. -2. Run `primer-service` on your host machine and configure it to - listen on TCP port `8081` on all network interfaces. - -This command uses the same script to launch the service as our -production Docker container uses, and therefore, in typical Docker -entrypoint style, it takes no command-line arguments. Instead, you can -override the server's default configuration by setting any of the -following environment variables (shown along with their default -values): - -| Environment variable | Purpose | Default | -|----------------------|-------------------------------------------------------|--------------------------------------------------------| -| `DATABASE_URL` | The PostgreSQL-style URI of the database | `postgres://postgres:primer-dev@localhost:5432/primer` | -| `SERVICE_PORT` | TCP port on which the service listens for connections | `8081` | - -Note that you'll also need to run the `start-postgresql-container` Nix -flake app if the `primer-postgres` container is not already running; -see below for details. Typically, this will only happen after a -reboot, or if you've manually stopped the container. To determine -whether the container is running, use this command from the project's -Nix shell: - -```sh -docker --context colima-primer ps -``` - -If it's running, you should see something like this: - -``` -CONTAINER ID IMAGE COMMAND CREATED STATUS PORTS NAMES -a818e6d5f3ef postgres:13.4-alpine3.14 "docker-entrypoint.s…" 29 hours ago Up 2 minutes 0.0.0.0:5432->5432/tcp, :::5432->5432/tcp postgres-primer -``` - -If it's not, then perform the following steps from the project's `nix develop` shell: - -```sh -colima start --runtime docker --profile primer -nix run .#start-postgresql-container -``` - -## PostgreSQL helper scripts - -The following helper scripts are also available for the PostgreSQL -development workflow. These can be run in the `nix develop` shell, or -as Nix flake apps via `nix run`. Typically, you'll just need to run -the higher-level commands described above for a local development -workflow with PostgreSQL, but if you'd like a comprehensive -understanding of what those higher-level commands are doing under the -hood, read on. - -### `deploy-postgresql-container` - -This script does the following: - -* Uses Colima to configure a Docker-compatible Linux container runtime - on your system. -* Downloads the official PostgreSQL Docker image for the version of - PostgreSQL that we support. -* Creates a persistent Docker volume named `postgres-primer` to ensure - the database is preserved across container restarts and upgrades. -* Creates a Docker container that runs PostgreSQL and listens on - `localhost:5432`. - -Note that you do *not* need to install or run Docker in order to use -this or any other script in this repo, as Colima provides the required -container functionality. The scripts do use the `docker` command-line -utility, but only to manage the container, images, and persistent -volumes. - -If you're already running Docker, Colima works alongside it without -conflict. The scripts in this repo will run all containers in a -separate `colima-primer` Docker context, in order to keep the Primer -development environment from affecting any other Docker contexts you -may be using. - -### `start-postgresql-container` - -This script starts the `primer-postgres` container, assuming that it's -previously been deployed by the `deploy-postgresql-container` command. -The container will keep running until you reboot your host machine, or -you stop the container yourself. - -### `stop-postgresql-container` - -This script stops the `primer-postgres` container. - -### `create-local-db` - -This script creates the `primer` database in the local PostgreSQL -instance. This database must have been created before Primer can -connect to it. - -### `deploy-local-db` - -This script ensures your local database is using the latest schema. -You'll need to run it anytime there's a schema change. We'll do our -best to broadcast when this is necessary. - -Note that this script is safe to run at any time, even if the database -is already using the latest schema. - -## Other helper scripts - -You'll probably use these additional scripts less often than the -others, but they're available if you need them: - -* `delete-local-db` drops the Primer database from the local - PostgreSQL instance. **Warning**: this script will delete all of the - Primer programs in your local database. - -* `dump-local-db` dumps the Primer database from the local PostgreSQL - instance. It's mainly useful in combination with the - `restore-local-db` script. - -* `restore-local-db` restores a Primer database dump by dropping the - existing Primer database (**warning**: the existing database - contents will not be saved!), creating a fresh, empty Primer - database, and then loading the dump into the new database. This - script is most useful in combination with the `dump-local-db` - script. - -* `verify-local-db` reports the differences between the latest schema - and the schema your local database is using. - -* `revert-local-db` reverts the local database to a previous schema. - Note that this may not always be successful. You should generally - only need to run this command if you're testing database schema - migrations. You can specify which git commit to revert to by passing - the following flags: `-- --to `. For example, to revert any - changes made since `HEAD`, run `nix run .#revert-local-db -- --to @HEAD`. diff --git a/docs/project-overview.md b/docs/project-overview.md index dc09dc72d..e36fa16b5 100644 --- a/docs/project-overview.md +++ b/docs/project-overview.md @@ -61,10 +61,8 @@ together implement a Primer language service: the two evaluators, and an API that exposes these features to other Haskell programs. -* `primer-rel8` and `primer-selda` implement, respectively, - [PostgreSQL](https://www.postgresql.org) and - [SQLite](https://www.sqlite.org/) database bindings for the Primer - language server's program store. +* `primer-selda` implements [SQLite](https://www.sqlite.org/) database + bindings for the Primer language server's program store. * `primer-service` adapts the `primer` Haskell API to an HTTP API (actually, [two different HTTP API's](http-apis.md)), so that it can diff --git a/flake.nix b/flake.nix index 0e0f9c03d..f42720253 100644 --- a/flake.nix +++ b/flake.nix @@ -112,9 +112,6 @@ # This should go in `primer-sqitch.passthru.tests`, but # those don't work well with flakes. - # - # Note that the equivalent PostgreSQL tests need some tear - # up/tear down, so we test that backend using NixOS tests. primer-sqitch-test-sqlite = pkgs.runCommand "primer-sqitch-sqlite-test" { } '' ${pkgs.primer-sqitch}/bin/primer-sqitch deploy --verify db:sqlite:primer.db ${pkgs.primer-sqitch}/bin/primer-sqitch revert db:sqlite:primer.db @@ -235,29 +232,10 @@ inherit (pkgs) primer-service primer-client primer-openapi-spec; inherit (pkgs) primer-benchmark; inherit (pkgs) - run-primer-postgresql run-primer-sqlite primer-service-entrypoint - - create-local-db - deploy-local-db - verify-local-db - revert-local-db - status-local-db - log-local-db - delete-local-db - dump-local-db - restore-local-db - connect-local-db - delete-all-local-sessions - sqitch - primer-sqitch - primer-pg-prove - - deploy-postgresql-container - start-postgresql-container - stop-postgresql-container; + primer-sqitch; } // (pkgs.lib.optionalAttrs (system == "x86_64-linux") { inherit (pkgs) primer-service-docker-image; @@ -313,27 +291,10 @@ inherit (pkgs) primer-benchmark; inherit (pkgs) - run-primer-postgresql run-primer-sqlite primer-service-entrypoint - create-local-db - deploy-local-db - verify-local-db - revert-local-db - status-local-db - log-local-db - delete-local-db - dump-local-db - restore-local-db - connect-local-db - delete-all-local-sessions - - primer-sqitch - - deploy-postgresql-container - start-postgresql-container - stop-postgresql-container; + primer-sqitch; }) // primerFlake.apps; @@ -382,12 +343,7 @@ { overlays.default = (final: prev: let - postgres-dev-password = "primer-dev"; - postgres-dev-base-url = "postgres://postgres:${postgres-dev-password}@localhost:5432"; - postgres-dev-primer-url = "${postgres-dev-base-url}/primer"; - sqitch = final.callPackage ./nix/pkgs/sqitch { - postgresqlSupport = true; sqliteSupport = true; }; @@ -423,17 +379,9 @@ ghcOptions = [ "-Werror" ]; preCheck = preCheckTasty; }; - primer-rel8 = { - ghcOptions = [ "-Werror" ]; - preCheck = preCheckTasty; - }; primer-service = { ghcOptions = [ "-Werror" ]; - - # The tests need PostgreSQL binaries. - preCheck = '' - export PATH="${final.postgresql}/bin:${"$PATH"}" - '' + preCheckTasty; + preCheck = preCheckTasty; }; primer-benchmark = { ghcOptions = [ "-Werror" ]; @@ -465,18 +413,12 @@ #TODO This shouldn't be necessary - see the commented-out `build-tool-depends` in primer.cabal. packages.primer.components.tests.primer-test.build-tools = [ (final.haskell-nix.tool ghcVersion "tasty-discover" { }) ]; packages.primer-api.components.tests.primer-api-test.build-tools = [ (final.haskell-nix.tool ghcVersion "tasty-discover" { }) ]; - packages.primer-rel8.components.tests.primer-rel8-test.build-tools = [ - (final.haskell-nix.tool ghcVersion "tasty-discover" { }) - final.postgresql - final.primer-sqitch - ]; packages.primer-selda.components.tests.primer-selda-test.build-tools = [ (final.haskell-nix.tool ghcVersion "tasty-discover" { }) final.primer-sqitch ]; packages.primer-service.components.tests.service-test.build-tools = [ (final.haskell-nix.tool ghcVersion "tasty-discover" { }) - final.postgresql final.primer-sqitch ]; } @@ -492,7 +434,6 @@ packages.primer.components.tests.primer-test.testFlags = hide-successes ++ size-cutoff; packages.primer-api.components.tests.primer-api-test.testFlags = hide-successes ++ size-cutoff; packages.primer-service.components.tests.service-test.testFlags = hide-successes ++ size-cutoff; - packages.primer-rel8.components.tests.primer-rel8-test.testFlags = hide-successes; packages.primer-selda.components.tests.primer-selda-test.testFlags = hide-successes; packages.primer-benchmark.components.tests.primer-benchmark-test.testFlags = hide-successes; } @@ -530,15 +471,9 @@ buildInputs = (with final; [ nixpkgs-fmt - postgresql sqlite openapi-generator-cli - # For Docker support. - docker - lima - colima - # For Language Server support. nodejs-18_x @@ -546,20 +481,6 @@ nix-generate-from-cpan sqitch primer-sqitch - primer-pg-prove - - # Local scripts. - create-local-db - deploy-local-db - verify-local-db - revert-local-db - status-local-db - log-local-db - delete-local-db - dump-local-db - restore-local-db - connect-local-db - delete-all-local-sessions ]); shellHook = '' @@ -627,8 +548,9 @@ # entrypoint with reasonable default values. # # Note that we do not provide default values or - # otherwise set either DATABASE_URL or - # SQLITE_DB. + # otherwise set SQLITE_DB, which is required by + # the entrypoint script, so you must set this + # yourself in the container environment. "SERVICE_PORT=${toString port}" "PRIMER_VERSION=${version}" @@ -680,32 +602,13 @@ primer = (prev.lib.primer or { }) // { defaultServicePort = 8081; inherit version; - inherit postgres-dev-password; - inherit postgres-dev-base-url; - inherit postgres-dev-primer-url; }; }; inherit sqitch; inherit (scripts) - deploy-postgresql-container - start-postgresql-container - stop-postgresql-container - create-local-db - deploy-local-db - verify-local-db - revert-local-db - status-local-db - log-local-db - delete-local-db - dump-local-db - restore-local-db primer-sqitch - primer-pg-prove - connect-local-db - delete-all-local-sessions - run-primer-postgresql run-primer-sqlite primer-service-entrypoint; diff --git a/nix/pkgs/scripts/default.nix b/nix/pkgs/scripts/default.nix index 4189874b2..bc606e35e 100644 --- a/nix/pkgs/scripts/default.nix +++ b/nix/pkgs/scripts/default.nix @@ -3,24 +3,14 @@ , version , makeWrapper , writeShellApplication -, postgresql , sqitch , coreutils -, colima -, docker -, gnugrep , sqitchDir , sqlite , primer-service -, perlPackages }: let - dockerContext = "colima-primer"; - postgresImageTag = "postgres:14.4-alpine3.16"; - postgresVolume = "postgres-primer"; - postgresContainer = "postgres-primer"; - # Run any sqitch command using the Primer schema. primer-sqitch = stdenv.mkDerivation { pname = "primer-sqitch"; @@ -45,36 +35,11 @@ let mkdir -p $out/bin makeWrapper "${sqitch}/bin/sqitch" "$out/bin/primer-sqitch" \ - --prefix PATH : "${lib.makeBinPath [postgresql sqlite]}" \ + --prefix PATH : "${lib.makeBinPath [sqlite]}" \ --set SQITCH_CONFIG "$out/libexec/sqitch/sqitch.conf" ''; }; - # Bundle our PostgreSQL unit tests, to be used via `pgtap`/`pg_prove`. - primer-pgtap-tests = stdenv.mkDerivation { - pname = "primer-pgtap-tests"; - version = "1.0"; - src = "${sqitchDir}/pg/test"; - - buildPhase = ""; - - installPhase = '' - mkdir -p $out/libexec/pgtap/test - mv * $out/libexec/pgtap/test - ''; - }; - - pg_prove = perlPackages.TAPParserSourceHandlerpgTAP; - primer-pg-prove = writeShellApplication { - name = "primer-pg-prove"; - runtimeInputs = [ - pg_prove - ]; - text = '' - pg_prove -v -d primer --ext .sql ${primer-pgtap-tests}/libexec/pgtap/test/ - ''; - }; - # The entrypoint for `primer-service` containers. See the shell # script source for details. primer-service-entrypoint = writeShellApplication { @@ -88,33 +53,13 @@ let text = builtins.readFile ./primer-service-entrypoint.sh; }; - # Run `primer-service` locally against the default local PostgreSQL - # database. This script sets the expected environment variables, - # deploys the database, and execs `primer-service-entrypoint`. - run-primer-postgresql = writeShellApplication { - name = "run-primer-postgresql"; - runtimeInputs = [ - primer-sqitch - primer-service-entrypoint - ]; - text = '' - export SERVICE_PORT="''${SERVICE_PORT:-${toString lib.primer.defaultServicePort}}" - export DATABASE_URL="''${DATABASE_URL:-${lib.primer.postgres-dev-primer-url}}" - export PRIMER_VERSION="''${PRIMER_VERSION:-${version}}" - - primer-sqitch deploy --verify "db:$DATABASE_URL" - primer-service-entrypoint - ''; - }; - # Run `primer-service` locally against a SQLite database. This # script sets the expected environment variables, deploys the # database, and execs `primer-service-entrypoint`. # - # Note that, unlike the PostgreSQL equivalent script, this script - # does not need to perform a database deployment before running the - # entrypoint, because the entrypoint does that for us when running - # against a SQLite database. + # Note that this script does not need to perform a database + # deployment before running the entrypoint, because the entrypoint + # does that for us when running against a SQLite database. run-primer-sqlite = writeShellApplication { name = "run-primer-sqlite"; runtimeInputs = [ @@ -134,163 +79,6 @@ let in { inherit primer-sqitch; - inherit primer-pg-prove; inherit primer-service-entrypoint; - inherit run-primer-postgresql; inherit run-primer-sqlite; - - deploy-postgresql-container = writeShellApplication { - name = "deploy-postgresql-container"; - runtimeInputs = [ - colima - docker - ]; - text = '' - colima start --runtime docker --profile primer - docker --context ${dockerContext} pull ${postgresImageTag} - docker volume create postgres-primer - docker --context ${dockerContext} run --detach --name=${postgresContainer} --publish 5432:5432 --volume ${postgresVolume}:/var/lib/postgresql/data -e POSTGRES_PASSWORD="${lib.primer.postgres-dev-password}" ${postgresImageTag} - ''; - }; - - start-postgresql-container = writeShellApplication { - name = "start-postgresql-container"; - runtimeInputs = [ - docker - ]; - text = '' - docker --context ${dockerContext} start ${postgresContainer} - ''; - }; - - stop-postgresql-container = writeShellApplication { - name = "stop-postgresql-container"; - runtimeInputs = [ - docker - ]; - text = '' - docker --context ${dockerContext} stop ${postgresContainer} - ''; - }; - - create-local-db = writeShellApplication { - name = "create-local-db"; - runtimeInputs = [ - postgresql - ]; - text = '' - psql ${lib.primer.postgres-dev-base-url} --command="CREATE DATABASE primer;" - ''; - }; - - deploy-local-db = writeShellApplication { - name = "deploy-local-db"; - runtimeInputs = [ - primer-sqitch - ]; - text = '' - primer-sqitch deploy --verify db:${lib.primer.postgres-dev-primer-url} - ''; - }; - - verify-local-db = writeShellApplication { - name = "verify-local-db"; - runtimeInputs = [ - primer-sqitch - ]; - text = '' - primer-sqitch verify db:${lib.primer.postgres-dev-primer-url} - ''; - }; - - revert-local-db = writeShellApplication { - name = "revert-local-db"; - runtimeInputs = [ - primer-sqitch - ]; - text = '' - primer-sqitch revert db:${lib.primer.postgres-dev-primer-url} "$@" - ''; - }; - - status-local-db = writeShellApplication { - name = "status-local-db"; - runtimeInputs = [ - primer-sqitch - ]; - text = '' - primer-sqitch status db:${lib.primer.postgres-dev-primer-url} - ''; - }; - - log-local-db = writeShellApplication { - name = "log-local-db"; - runtimeInputs = [ - primer-sqitch - ]; - text = '' - primer-sqitch log db:${lib.primer.postgres-dev-primer-url} - ''; - }; - - delete-local-db = writeShellApplication { - name = "delete-local-db"; - runtimeInputs = [ - postgresql - ]; - text = '' - psql ${lib.primer.postgres-dev-base-url} --command="DROP DATABASE primer;" - ''; - }; - - dump-local-db = writeShellApplication { - name = "dump-local-db"; - runtimeInputs = [ - coreutils - postgresql - ]; - text = '' - timestamp=$(date --utc --iso-8601=seconds) - dumpfile="primer-$timestamp.sql" - pg_dump ${lib.primer.postgres-dev-primer-url} > "$dumpfile" - echo "Dumped local Primer database to $dumpfile" - ''; - }; - - restore-local-db = writeShellApplication { - name = "restore-local-db"; - runtimeInputs = [ - postgresql - ]; - text = '' - if [[ $# -ne 1 ]]; then - echo "usage: restore-local-db db.sql" >&2 - exit 2 - fi - psql ${lib.primer.postgres-dev-base-url} --command="DROP DATABASE primer;" || true - psql ${lib.primer.postgres-dev-base-url} --command="CREATE DATABASE primer;" - psql ${lib.primer.postgres-dev-primer-url} < "$1" - ''; - }; - - connect-local-db = writeShellApplication { - name = "connect-local-db"; - runtimeInputs = [ - postgresql - ]; - text = '' - psql ${lib.primer.postgres-dev-primer-url} "$@" - ''; - }; - - delete-all-local-sessions = writeShellApplication { - name = "delete-all-local-sessions"; - runtimeInputs = [ - postgresql - ]; - text = '' - psql ${lib.primer.postgres-dev-primer-url} --command "DELETE FROM primer.sessions;" - ''; - }; - } diff --git a/nix/pkgs/scripts/primer-service-entrypoint.sh b/nix/pkgs/scripts/primer-service-entrypoint.sh index d81fc6e5b..e9553b3c9 100644 --- a/nix/pkgs/scripts/primer-service-entrypoint.sh +++ b/nix/pkgs/scripts/primer-service-entrypoint.sh @@ -7,9 +7,6 @@ This script accepts no command-line arguments, and will fail if any are provided. All options to primer-service are provided via specific environment variables: -- DATABASE_URL: A PostgreSQL-style connection URI. See - https://www.postgresql.org/docs/14/libpq-connect.html#LIBPQ-CONNSTRING - - SQLITE_DB: A path to a SQLite database file. - CORS_ALLOW_ORIGIN: A comma-separated list of one or more CORS @@ -28,10 +25,6 @@ environment variables: - PRIMER_VERSION: The version reported by Primer's API. This variable is required. - -Note that exactly one of DATABASE_URL or SQLITE_DB must be set, -otherwise the entrypoint script will fail; i.e., these two variables -are mutually exclusive. EOF ) @@ -59,46 +52,16 @@ fi EXTRA_PRIMER_SERVICE_ARGS="" -if [ -z "${DATABASE_URL+x}" ]; then - - # DATABASE_URL is not set. - - if [ -z "${SQLITE_DB+x}" ]; then - echo "Neither DATABASE_URL nor SQLITE_DB is set, exiting." >&2 - exit 4 - else - EXTRA_PRIMER_SERVICE_ARGS="--sqlite-db $SQLITE_DB" - - # Ensure any required database migrations are performed before - # starting the service. This is safe in the case of a SQLite - # target, because we rely on the container orchestrator to - # guarantee that we are the only instance that has mounted - # the volume containing the database. - SQITCH_TARGET="db:sqlite:$SQLITE_DB" primer-sqitch deploy --verify - fi - +if [ -z "${SQLITE_DB+x}" ]; then + echo "SQLITE_DB is not set, exiting." >&2 + exit 4 else - - # DATABASE_URL is set. - # - # Note that DATABASE_URL probably contains a secret, so don't - # convert it to a command-line argument. We use the SQITCH_TARGET - # env var for sqitch, and primer-service will look for - # DATABASE_URL of its own accord. - - if [ -z "${SQLITE_DB+x}" ]; then - # Note: we do not deploy when the target is PostgreSQL, only - # verify. This is because concurrent migrations are not safe, - # and we cannot guarantee that we are the only container that - # is starting. - # - # See: - # https://github.com/sqitchers/sqitch/discussions/646 - SQITCH_TARGET="db:$DATABASE_URL" primer-sqitch verify - else - echo "Both DATABASE_URL and SQLITE_DB are set, but you must provide only one. Exiting." >&2 - exit 5 - fi + # Ensure any required database migrations are performed before + # starting the service. This is safe in the case of a SQLite + # target, because we rely on the container orchestrator to + # guarantee that we are the only instance that has mounted + # the volume containing the database. + SQITCH_TARGET="db:sqlite:$SQLITE_DB" primer-sqitch deploy --verify fi if [ -n "${CORS_ALLOW_ORIGIN+x}" ]; then @@ -106,4 +69,4 @@ if [ -n "${CORS_ALLOW_ORIGIN+x}" ]; then fi # shellcheck disable=SC2086 -exec primer-service serve "$PRIMER_VERSION" --port "$SERVICE_PORT" $EXTRA_PRIMER_SERVICE_ARGS +RTS -T +exec primer-service serve "$PRIMER_VERSION" "$SQLITE_DB" --port "$SERVICE_PORT" $EXTRA_PRIMER_SERVICE_ARGS +RTS -T diff --git a/nix/pkgs/sqitch/default.nix b/nix/pkgs/sqitch/default.nix index 1de5e3502..c737cd2e1 100644 --- a/nix/pkgs/sqitch/default.nix +++ b/nix/pkgs/sqitch/default.nix @@ -11,7 +11,6 @@ , makeWrapper , shortenPerlShebang , mysqlSupport ? false -, postgresqlSupport ? false , sqliteSupport ? false }: @@ -167,7 +166,6 @@ let modules = with perlPackages; [ ] ++ lib.optional mysqlSupport DBDmysql - ++ lib.optional postgresqlSupport DBDPg ++ lib.optional sqliteSupport DBDSQLite; in diff --git a/nixos-tests/db-postgresql-tests.nix b/nixos-tests/db-postgresql-tests.nix deleted file mode 100644 index 2791d3b96..000000000 --- a/nixos-tests/db-postgresql-tests.nix +++ /dev/null @@ -1,60 +0,0 @@ -{ hostPkgs -, ... -}: -{ - nodes = { - server = { pkgs, config, ... }: { - services.postgresql = { - enable = true; - package = pkgs.postgresql; - - extraPlugins = [ pkgs.postgresqlPackages.pgtap ]; - - # Note: this may look odd, but keep in mind that Sqitch does - # not create the database, only its schema. In a hosted - # PostgreSQL service (Fly.io, Google Cloud SQL, AWS Aurora, - # etc.), the database would be created out-of-band. - ensureDatabases = [ "primer" ]; - ensureUsers = [ - { - name = "primer"; - ensurePermissions = { - "DATABASE primer" = "ALL PRIVILEGES"; - }; - } - ]; - }; - - # This is essential, or else Sqitch will fail. - time.timeZone = "UTC"; - - users.users.primer = - { - name = "primer"; - group = "nobody"; - description = "Primer PostgreSQL user"; - isSystemUser = true; - }; - - environment.systemPackages = with pkgs; [ - primer-sqitch - primer-pg-prove - ]; - }; - }; - - testScript = { nodes, ... }: - let - pkgs = nodes.server.pkgs; - in - '' - start_all() - server.wait_for_unit("postgresql") - server.succeed( - "sudo -u primer primer-sqitch deploy --verify db:pg:primer" - ) - server.succeed( - "sudo -u primer primer-pg-prove" - ) - ''; -} diff --git a/nixos-tests/docker-image-postgresql.nix b/nixos-tests/docker-image-postgresql.nix deleted file mode 100644 index 382786bdd..000000000 --- a/nixos-tests/docker-image-postgresql.nix +++ /dev/null @@ -1,154 +0,0 @@ -{ hostPkgs -, ... -}: -let - dbPassword = "foopass"; - dbUser = "primer"; - dbName = "primer"; - dbUrl = "postgres://${dbUser}:${dbPassword}@postgres:5432/${dbName}"; - - port = toString hostPkgs.lib.primer.defaultServicePort; - version = hostPkgs.lib.primer.version; - - altPort = toString (hostPkgs.lib.primer.defaultServicePort + 1); - altVersion = "alt-primer"; -in -{ - nodes = { - postgres = { pkgs, config, ... }: { - services.postgresql = { - enable = true; - package = pkgs.postgresql; - enableTCPIP = true; - authentication = '' - hostnossl ${dbName} ${dbUser} 192.168.0.0/16 md5 - ''; - initialScript = pkgs.writeText "postgresql-init.sql" '' - CREATE DATABASE ${dbName} TEMPLATE template0 ENCODING UTF8; - CREATE USER ${dbUser} WITH PASSWORD '${dbPassword}'; - GRANT ALL PRIVILEGES ON DATABASE ${dbName} TO ${dbUser}; - ''; - }; - - # This is essential, or else Sqitch will fail. - time.timeZone = "UTC"; - - networking.firewall.allowedTCPPorts = [ 5432 ]; - - environment.systemPackages = with pkgs; [ - primer-sqitch - ]; - }; - - primer = { pkgs, config, ... }: - let - versionCheck = pkgs.writeShellApplication { - name = "primer-version-check"; - text = '' - PORT="$1" - VERSION="$2" - RESULT=$(curl http://localhost:"$PORT"/api/version | jq -r) - if [ "$RESULT" != "$VERSION" ]; then - echo "Expected primer-service version $VERSION, but got $RESULT" >& 2 - exit 1 - fi - ''; - }; - in - { - # This is essential, or else Sqitch will fail. - time.timeZone = "UTC"; - - # Default VM size is too small for our container. - virtualisation = { - diskSize = 3072; - memorySize = 1024; - }; - - virtualisation.oci-containers = { - containers.primer-service = { - image = "primer-service:${pkgs.primer-service-docker-image.imageTag}"; - imageFile = pkgs.primer-service-docker-image; - - ports = [ "${port}:${port}" ]; - extraOptions = [ "--network=host" ]; - environment = { - DATABASE_URL = dbUrl; - }; - }; - - # Ensure we can override the default PRIMER_VERSION and - # SERVICE_PORT environment variables. - containers.primer-service-alt = { - image = "primer-service:${pkgs.primer-service-docker-image.imageTag}"; - imageFile = pkgs.primer-service-docker-image; - - ports = [ "${altPort}:${altPort}" ]; - extraOptions = [ "--network=host" ]; - environment = { - DATABASE_URL = dbUrl; - SERVICE_PORT = toString altPort; - PRIMER_VERSION = altVersion; - }; - }; - }; - - # If the container doesn't start cleanly, the test has failed. - systemd.services.podman-primer-service.serviceConfig.Restart = pkgs.lib.mkForce "no"; - systemd.services.podman-primer-service-alt.serviceConfig.Restart = pkgs.lib.mkForce "no"; - - # Make sure we can see container failures. - systemd.services.podman-primer-service.serviceConfig.StandardOutput = pkgs.lib.mkForce "journal"; - systemd.services.podman-primer-service.serviceConfig.StandardError = pkgs.lib.mkForce "journal"; - systemd.services.podman-primer-service-alt.serviceConfig.StandardOutput = pkgs.lib.mkForce "journal"; - systemd.services.podman-primer-service-alt.serviceConfig.StandardError = pkgs.lib.mkForce "journal"; - - # We want to manually start and stop the container. - systemd.services.podman-primer-service.wantedBy = pkgs.lib.mkForce [ ]; - systemd.services.podman-primer-service-alt.wantedBy = pkgs.lib.mkForce [ ]; - - environment.systemPackages = with pkgs; [ - curl - jq - podman - versionCheck - ]; - }; - }; - - testScript = { nodes, ... }: - '' - postgres.start(); - postgres.wait_for_unit("postgresql.service") - - primer.start(); - primer.systemctl("start podman-primer-service.service") - primer.wait_for_unit("podman-primer-service.service") - - with subtest("fails if the database hasn't been deployed"): - primer.sleep(5) - primer.fail("podman healthcheck run primer-service") - primer.systemctl("stop podman-primer-service.service") - - postgres.succeed( - "primer-sqitch deploy --verify db:${dbUrl}" - ) - - primer.systemctl("start podman-primer-service.service") - primer.wait_for_unit("podman-primer-service.service") - primer.wait_for_open_port(${port}) - - with subtest("version check"): - primer.succeed("primer-version-check ${port} ${version}") - - primer.systemctl("start podman-primer-service-alt.service") - primer.wait_for_unit("podman-primer-service-alt.service") - primer.wait_for_open_port(${altPort}) - - with subtest("alt version check"): - primer.succeed("primer-version-check ${altPort} ${altVersion}") - ''; - - # Don't wait forever in the event of a problem. - meta.timeout = 600; -} diff --git a/nixos-tests/docker-image-sqlite.nix b/nixos-tests/docker-image-sqlite.nix index 186276a30..522f3b1f4 100644 --- a/nixos-tests/docker-image-sqlite.nix +++ b/nixos-tests/docker-image-sqlite.nix @@ -95,16 +95,6 @@ in }; }; - # Note: one major difference between this test and the equivalent - # PostgreSQL test is that when the container is running against a - # PostgreSQL database, it does not perform the database deployment - # automatically, deployments/migrations are not atomic, and we don't - # want to depend on container rollout synchronization to guarantee - # that. - # - # However, when running against a SQLite database, the container - # *can* safely do a deployment/migration, because no other container - # will be (or should be, anyway) mounting the same database volume. testScript = { nodes, ... }: '' primer.start(); diff --git a/primer-rel8/COPYING b/primer-rel8/COPYING deleted file mode 100644 index be3f7b28e..000000000 --- a/primer-rel8/COPYING +++ /dev/null @@ -1,661 +0,0 @@ - GNU AFFERO GENERAL PUBLIC LICENSE - Version 3, 19 November 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU Affero General Public License is a free, copyleft license for -software and other kinds of works, specifically designed to ensure -cooperation with the community in the case of network server software. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -our General Public Licenses are intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - Developers that use our General Public Licenses protect your rights -with two steps: (1) assert copyright on the software, and (2) offer -you this License which gives you legal permission to copy, distribute -and/or modify the software. - - A secondary benefit of defending all users' freedom is that -improvements made in alternate versions of the program, if they -receive widespread use, become available for other developers to -incorporate. Many developers of free software are heartened and -encouraged by the resulting cooperation. However, in the case of -software used on network servers, this result may fail to come about. -The GNU General Public License permits making a modified version and -letting the public access it on a server without ever releasing its -source code to the public. - - The GNU Affero General Public License is designed specifically to -ensure that, in such cases, the modified source code becomes available -to the community. It requires the operator of a network server to -provide the source code of the modified version running there to the -users of that server. Therefore, public use of a modified version, on -a publicly accessible server, gives the public access to the source -code of the modified version. - - An older license, called the Affero General Public License and -published by Affero, was designed to accomplish similar goals. This is -a different license, not a version of the Affero GPL, but Affero has -released a new version of the Affero GPL which permits relicensing under -this license. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU Affero General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Remote Network Interaction; Use with the GNU General Public License. - - Notwithstanding any other provision of this License, if you modify the -Program, your modified version must prominently offer all users -interacting with it remotely through a computer network (if your version -supports such interaction) an opportunity to receive the Corresponding -Source of your version by providing access to the Corresponding Source -from a network server at no charge, through some standard or customary -means of facilitating copying of software. This Corresponding Source -shall include the Corresponding Source for any work covered by version 3 -of the GNU General Public License that is incorporated pursuant to the -following paragraph. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the work with which it is combined will remain governed by version -3 of the GNU General Public License. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU Affero General Public License from time to time. Such new versions -will be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU Affero General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU Affero General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU Affero General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU Affero General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Affero General Public License for more details. - - You should have received a copy of the GNU Affero General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If your software can interact with users remotely through a computer -network, you should also make sure that it provides a way for users to -get its source. For example, if your program is a web application, its -interface could display a "Source" link that leads users to an archive -of the code. There are many ways you could offer source, and different -solutions will be better for different programs; see section 13 for the -specific requirements. - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU AGPL, see -. diff --git a/primer-rel8/Makefile b/primer-rel8/Makefile deleted file mode 100644 index 3eb72da32..000000000 --- a/primer-rel8/Makefile +++ /dev/null @@ -1,29 +0,0 @@ -# NOTE: -# -# Most commands assume you're running this from the top-level `nix -# develop` shell. - -build: - cabal build - -configure: - cabal configure - -check: test - -test: - cabal test - -docs: - cabal haddock - -clean: - cabal clean - -bench: - -realclean: - -deps: - -.PHONY: build bench configure test docs clean realclean deps diff --git a/primer-rel8/primer-rel8.cabal b/primer-rel8/primer-rel8.cabal deleted file mode 100644 index d6ffc99d6..000000000 --- a/primer-rel8/primer-rel8.cabal +++ /dev/null @@ -1,142 +0,0 @@ -cabal-version: 3.0 -name: primer-rel8 -version: 0.7.2.0 -license: AGPL-3.0-or-later -license-file: COPYING -copyright: (c) 2023 Hackworth Ltd -maintainer: src@hackworthltd.com -author: Hackworth Ltd -stability: experimental -synopsis: Rel8 bindings for the Primer database -category: Database - -library - exposed-modules: - Primer.Database.Rel8 - Primer.Database.Rel8.Orphans - Primer.Database.Rel8.Rel8Db - Primer.Database.Rel8.Schema - - hs-source-dirs: src - default-language: GHC2021 - default-extensions: - NoImplicitPrelude - DataKinds - DeriveAnyClass - DerivingStrategies - DerivingVia - LambdaCase - OverloadedStrings - - ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wcompat -Widentities -Wredundant-constraints - -Wmissing-deriving-strategies -fhide-source-paths - - build-depends: - , aeson >=2.0 && <2.2 - , base >=4.12 && <4.18 - , bytestring >=0.10.8.2 && <0.12.0 - , containers >=0.6.0.1 && <0.7.0 - , exceptions >=0.10.4 && <0.11.0 - , hasql ^>=1.6 - , hasql-pool ^>=0.9 - , logging-effect ^>=1.4 - , mtl >=2.2.2 && <2.4.0 - , optics >=0.4 && <0.5.0 - , primer ^>=0.7.2 - , rel8 ^>=1.4 - , text ^>=2.0 - , time >=1.11 && <1.13 - , uuid ^>=1.3.15 - -library primer-rel8-testlib - visibility: public - exposed-modules: Primer.Database.Rel8.Test.Util - hs-source-dirs: testlib - default-language: GHC2021 - default-extensions: - NoImplicitPrelude - DataKinds - DerivingStrategies - DerivingVia - LambdaCase - OverloadedStrings - - ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wcompat -Widentities -Wredundant-constraints - -Wmissing-deriving-strategies -fhide-source-paths - - build-depends: - , base - , bytestring - , hasql - , hasql-pool - , logging-effect - , port-utils ^>=0.2.1 - , postgres-options ^>=0.2 - , primer - , primer-rel8 - , rel8 - , temporary ^>=1.3 - , time - , tmp-postgres ^>=1.34.1.0 - , typed-process ^>=0.2.11 - , utf8-string ^>=1.0 - , uuid - -test-suite primer-rel8-test - type: exitcode-stdio-1.0 - main-is: Test.hs - hs-source-dirs: test - other-modules: - Tests.DeleteSession - Tests.FindSessions - Tests.InsertSession - Tests.ListSessions - Tests.QuerySessionId - Tests.UpdateSessionApp - Tests.UpdateSessionName - - default-language: GHC2021 - default-extensions: - NoImplicitPrelude - DataKinds - DerivingStrategies - DerivingVia - LambdaCase - OverloadedStrings - - ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wcompat -Widentities -Wredundant-constraints - -Wmissing-deriving-strategies -fhide-source-paths -threaded - -rtsopts -with-rtsopts=-N - - if impl(ghcjs) - buildable: False - - else - build-depends: - , aeson - , base - , containers - , exceptions - , filepath - , hasql - , hasql-pool - , logging-effect - , primer-rel8:{primer-rel8, primer-rel8-testlib} - , primer:{primer, primer-testlib} - , rel8 - , tasty ^>=1.4.2.1 - , tasty-discover ^>=5.0 - , tasty-hunit ^>=0.10.0 - , text - , time - , uuid - ---TODO This currently breaks with haskell.nix, so we manually add it to `flake.nix` instead. --- See: https://github.com/input-output-hk/haskell.nix/issues/839 --- build-tool-depends: tasty-discover:tasty-discover ^>=5.0 diff --git a/primer-rel8/src/Primer/Database/Rel8.hs b/primer-rel8/src/Primer/Database/Rel8.hs deleted file mode 100644 index 5b154dd53..000000000 --- a/primer-rel8/src/Primer/Database/Rel8.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Primer.Database.Rel8 ( - module Schema, - module Rel8Db, -) where - -import Primer.Database.Rel8.Rel8Db as Rel8Db -import Primer.Database.Rel8.Schema as Schema diff --git a/primer-rel8/src/Primer/Database/Rel8/Orphans.hs b/primer-rel8/src/Primer/Database/Rel8/Orphans.hs deleted file mode 100644 index b57bbf8bc..000000000 --- a/primer-rel8/src/Primer/Database/Rel8/Orphans.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- This module exists so that we don't need a dependency on "Rel8" in --- Primer core. - -module Primer.Database.Rel8.Orphans () where - -import Primer.App (App) -import Rel8 ( - DBType, - JSONBEncoded (..), - ) - -deriving via JSONBEncoded App instance DBType App diff --git a/primer-rel8/src/Primer/Database/Rel8/Rel8Db.hs b/primer-rel8/src/Primer/Database/Rel8/Rel8Db.hs deleted file mode 100644 index fd37ded61..000000000 --- a/primer-rel8/src/Primer/Database/Rel8/Rel8Db.hs +++ /dev/null @@ -1,470 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Primer.Database.Rel8.Rel8Db --- Description : A database adapter for Primer using "Rel8". --- Copyright : (c) 2022, Hackworth Ltd --- License : AGPL 3.0 or later --- Stability : experimental --- Portability : portable --- --- A "Rel8"- and @Hasql@-based implementation of 'MonadDb'. -module Primer.Database.Rel8.Rel8Db ( - -- * The "Rel8" database adapter - MonadRel8Db, - Rel8DbT (..), - Rel8Db, - runRel8DbT, - - -- * Logging - Rel8DbLogMessage (..), - - -- * Exceptions - Rel8DbException (..), -) where - -import Foreword hiding (filter) - -import Control.Monad.Cont (MonadCont) -import Control.Monad.Fix (MonadFix) -import Control.Monad.Log ( - MonadLog, - WithSeverity (..), - ) -import Control.Monad.Trans (MonadTrans) -import Control.Monad.Writer (MonadWriter) -import Control.Monad.Zip (MonadZip) -import Data.Functor.Contravariant ((>$<)) -import Data.Text qualified as T -import Data.Time.Clock (UTCTime) -import Data.UUID (UUID) -import Hasql.Connection ( - ConnectionError, - ) -import Hasql.Pool ( - Pool, - UsageError (..), - use, - ) -import Hasql.Session ( - QueryError, - statement, - ) -import Hasql.Statement (Statement) -import Optics ( - view, - _2, - _3, - ) -import Primer.Database ( - DbError (SessionIdNotFound), - LastModified (..), - MonadDb (..), - OffsetLimit (OL), - Page (Page, pageContents, total), - Session (Session), - SessionData (..), - SessionId, - fromSessionName, - safeMkSessionName, - ) -import Primer.Database.Rel8.Schema as Schema ( - SessionRow (..), - sessionRowSchema, - ) -import Primer.Log ( - ConvertLogMessage (..), - logError, - ) -import Rel8 ( - Delete (..), - Expr, - Insert (Insert, into, onConflict, returning, rows), - OnConflict (Abort), - Query, - Returning (NumberOfRowsAffected), - Update (Update, from, returning, set, target, updateWhere), - asc, - countRows, - delete, - desc, - each, - filter, - ilike, - insert, - limit, - lit, - litExpr, - offset, - orderBy, - select, - update, - values, - (==.), - ) - --- | A wrapper type for managing Rel8 operations. -newtype Rel8DbT m a = Rel8DbT {unRel8DbT :: ReaderT Pool m a} - deriving newtype - ( Functor - , Applicative - , Alternative - , Monad - , MonadError e - , MonadThrow - , MonadCatch - , MonadMask - , MonadReader Pool - , MonadIO - , MonadFail - , MonadFix - , MonadPlus - , MonadTrans - , MonadState s - , MonadWriter w - , MonadZip - , MonadCont - , MonadLog msg - ) - --- | The 'Rel8DbT' monad transformer applied to 'IO'. -type Rel8Db a = Rel8DbT IO a - --- | Run an action in the 'Rel8DbT' monad with the given 'Pool'. -runRel8DbT :: Rel8DbT m a -> Pool -> m a -runRel8DbT m = runReaderT (unRel8DbT m) - --- | A convenient type alias. --- --- Note that 'MonadLog' has a functional dependency from 'm' to 'l'. -type MonadRel8Db m l = (ConvertLogMessage Rel8DbLogMessage l, MonadCatch m, MonadThrow m, MonadIO m, MonadLog (WithSeverity l) m) - --- A helper function for creating a 'Session' from a database query. --- --- Note that we have 2 choices here if the session name that was --- fetched from the database isn't a valid 'SessionName': either we --- can return a failure, or we can convert it to a valid --- 'SessionName'. This situation can only ever happen if we've made a --- mistake (e.g., we've changed the rules on what's a valid --- 'SessionName' and didn't run a migration), or if someone has edited --- the database directly, without going through the API. In either --- case, it would be bad if a student can't load their session just --- because a session name was invalid, so we opt for "convert it to a --- valid 'SessionName'". --- --- It might be helpful if this function returned an indication of --- whether the original name was safe, but for now, we convert --- silently. -safeMkSession :: (SessionId, Text, UTCTime) -> Session -safeMkSession (s, n, t) = Session s (safeMkSessionName n) (LastModified t) - --- | A 'MonadDb' instance for 'Rel8DbT'. --- --- This monad throws unexpected database-related exceptions via its --- 'MonadThrow' instance. These exceptions are represented via the --- 'Rel8DbException' type. It's the responsibility of the caller to --- handle them, as opposed to run-of-the-mill exceptions that may --- occur; e.g., looking up a session ID that doesn't exist in the --- database. The latter sorts of exceptions are expressed via the --- types of the 'MonadDb' methods and are handled by Primer --- internally. -instance MonadRel8Db m l => MonadDb (Rel8DbT m) where - insertSession v s a n t = do - nr <- - runStatement (InsertError s) $ - insert - Insert - { into = Schema.sessionRowSchema - , rows = - values - [ lit - Schema.SessionRow - { Schema.uuid = s - , Schema.gitversion = v - , Schema.app = a - , Schema.name = fromSessionName n - , Schema.lastmodified = utcTime t - } - ] - , onConflict = Abort - , returning = NumberOfRowsAffected - } - -- This operation should affect exactly one row. - case nr of - 0 -> throwM $ InsertZeroRowsAffected s - 1 -> pure () - _ -> throwM $ InsertConsistencyError s - - updateSessionApp v s a t = do - nr <- - runStatement (UpdateAppError s) $ - update - Update - { target = Schema.sessionRowSchema - , from = allSessions - , set = \_ row -> - row - { Schema.gitversion = lit v - , Schema.app = lit a - , Schema.lastmodified = lit $ utcTime t - } - , updateWhere = \_ row -> Schema.uuid row ==. litExpr s - , returning = NumberOfRowsAffected - } - - -- This operation should affect exactly one row. - case nr of - 0 -> throwM $ UpdateAppNonExistentSession s - 1 -> pure () - _ -> throwM $ UpdateAppConsistencyError s - - updateSessionName v s n t = do - nr <- - runStatement (UpdateNameError s) $ - update - Update - { target = Schema.sessionRowSchema - , from = allSessions - , set = \_ row -> - row - { Schema.gitversion = lit v - , Schema.name = lit $ fromSessionName n - , Schema.lastmodified = lit $ utcTime t - } - , updateWhere = \_ row -> Schema.uuid row ==. litExpr s - , returning = NumberOfRowsAffected - } - - -- This operation should affect exactly one row. - case nr of - 0 -> throwM $ UpdateNameNonExistentSession s - 1 -> pure () - _ -> throwM $ UpdateNameConsistencyError s - - listSessions ol = do - n' <- runStatement ListSessionsError $ select numSessions - n <- case n' of - -- Currently, our page size is 'Int', but Rel8 gives - -- 'Int64'. This needs fixing, but has implications for API - -- clients, so for now we downcast, as we will not hit 2 - -- billion rows anytime soon. See: - -- https://github.com/hackworthltd/primer/issues/238 - [n''] -> pure $ fromIntegral n'' - -- This case should never occur, as 'countRows' (used by - -- 'numSessions' above) should never return the empty list: - -- https://hackage.haskell.org/package/rel8-1.3.1.0/docs/Rel8.html#v:countRows - _ -> throwM ListSessionsRel8Error - ss :: [(UUID, Text, UTCTime)] <- - runStatement ListSessionsError $ - select $ - paginatedSessionMeta ol (sessionMeta <$> allSessions) - pure $ Page{total = n, pageContents = safeMkSession <$> ss} - - findSessions substr ol = do - -- This is very inefficient, as we run the same query later to - -- paginated it, but fixing it will take some refactoring work, - -- and this is not currently a priority. - -- - -- https://github.com/hackworthltd/primer/issues/1037 - n' <- runStatement FindSessionsError $ select $ countRows $ sessionByNameSubstr substr - n <- case n' of - -- See: - -- https://github.com/hackworthltd/primer/issues/238 - [n''] -> pure $ fromIntegral n'' - -- This case should never occur, see note in 'listSessions'. - _ -> throwM FindSessionsRel8Error - ss :: [(UUID, Text, UTCTime)] <- - runStatement FindSessionsError $ - select $ - paginatedSessionMeta ol (sessionMeta <$> sessionByNameSubstr substr) - pure $ Page{total = n, pageContents = safeMkSession <$> ss} - - querySessionId sid = do - result <- runStatement (LoadSessionError sid) $ select $ sessionById sid - case result of - [] -> pure $ Left $ SessionIdNotFound sid - (s : _) -> do - -- See comment on 'safeMkSessionName' regarding how we use - -- 'safeMkSessionName' here. - let dbSessionName = Schema.name s - sessionName = safeMkSessionName dbSessionName - lastModified = LastModified $ Schema.lastmodified s - when (fromSessionName sessionName /= dbSessionName) $ - logError $ - IllegalSessionName sid dbSessionName - pure $ Right (SessionData (Schema.app s) sessionName lastModified) - - deleteSession sid = do - nr <- - runStatement (DeleteSessionError sid) $ - delete - Delete - { from = Schema.sessionRowSchema - , using = pure () - , deleteWhere = \_ row -> Schema.uuid row ==. litExpr sid - , returning = NumberOfRowsAffected - } - - -- This operation should affect at most one row. Note that not - -- matching any rows is not necessarily indicative of a critcal - -- error: it could easily occur in a multiplayer situation where - -- there's a race to delete the session, for example. - case nr of - 0 -> pure $ Left $ SessionIdNotFound sid - 1 -> pure $ Right () - _ -> throwM $ DeleteSessionConsistencyError sid - --- | Exceptions that can be thrown by 'Rel8DbT' computations. --- --- These exceptions are thrown only for truly exceptional errors. --- Generally speaking, these will not be recoverable by the handler, --- though in some cases it may be possible to keep retrying the --- operation until the exceptional condition has been resolved; e.g., --- when the connection to the database is temporarily severed. -data Rel8DbException - = -- | A connection-related error. - ConnectionFailed ConnectionError - | -- | A connection timeout occurred. - TimeoutError - | -- | An error occurred during an 'Insert' operation on the given - -- 'SessionId'. - InsertError SessionId QueryError - | -- | An 'Insert' operation succeeded on the given 'SessionId', but - -- the database claimed that zero rows were actually inserted. - InsertZeroRowsAffected SessionId - | -- | A database consistency error was detected during an 'Insert' - -- operation on the given 'SessionId'. - InsertConsistencyError SessionId - | -- | An error occurred during a 'DeleteSession' operation on the - -- given 'SessionId'. - DeleteSessionError SessionId QueryError - | -- | A database consistency error was deletected during a - -- | 'DeleteSession' operation on the given 'SessionId'. - DeleteSessionConsistencyError SessionId - | -- | An error occurred during an 'UpdateApp' operation on the - -- given 'SessionId'. - UpdateAppError SessionId QueryError - | -- | An attempt was made to 'UpdateApp' using a 'SessionId' that - -- doesn't exist in the database. (It must be inserted before it - -- can be updated.) - UpdateAppNonExistentSession SessionId - | -- | A database consistency error was detected during an - -- 'UpdateApp' operation on the given 'SessionId'. - UpdateAppConsistencyError SessionId - | -- | An error occurred during an 'UpdateName' operation on the - -- given 'SessionId'. - UpdateNameError SessionId QueryError - | -- | An attempt was made to 'UpdateName' using a 'SessionId' that - -- doesn't exist in the database. (It must be inserted before it - -- can be updated.) - UpdateNameNonExistentSession SessionId - | -- | A database consistency error was detected during an - -- 'UpdateName' operation on the given 'SessionId'. - UpdateNameConsistencyError SessionId - | -- | An error occurred during a 'LoadSession' operation on the - -- given 'SessionId'. - LoadSessionError SessionId QueryError - | -- | An error occurred during a 'ListSessions' operation. - ListSessionsError QueryError - | -- | 'Rel8' returned an unexpected result during a 'ListSessions' - -- operation. This should never occur unless there's a bug in - -- 'Rel8'. - ListSessionsRel8Error - | -- | An error occurred during a 'FindSessions' operation. - FindSessionsError QueryError - | -- | 'Rel8' returned an unexpected result during a 'FindSessions' - -- operation. This should never occur unless there's a bug in - -- 'Rel8'. - FindSessionsRel8Error - deriving stock (Eq, Show, Generic) - -instance Exception Rel8DbException - --- | 'Rel8DbT'-related log messages. -data Rel8DbLogMessage - = -- | An illegal session name was found in the database. This is - -- probably an indication that a database migration wasn't run - -- properly, but may also indicate that the database has been - -- modified outside the API. - IllegalSessionName SessionId Text - | -- | A 'Rel8DBException' occurred. - LogRel8DbException Rel8DbException - deriving stock (Eq, Show, Generic) - --- Helpers to make dealing with "Hasql.Session" easier. --- --- See the note on 'Rel8DbT's 'MonadDb' instance for an explanation of --- why we handle "Hasql.Session" exceptions the way we do. - -runStatement :: (MonadIO m, MonadThrow m, MonadReader Pool m) => (QueryError -> Rel8DbException) -> Statement () a -> m a -runStatement exc s = do - pool <- ask - result <- liftIO $ use pool $ statement () s - case result of - Left e -> - -- Something went wrong with the database or database - -- connection. This is the responsibility of the caller to - -- handle. - throwM $ err e - Right r -> pure r - where - -- Convert a 'UsageError' to a 'Rel8DbException'. - err :: UsageError -> Rel8DbException - err (ConnectionUsageError e) = ConnectionFailed e - err AcquisitionTimeoutUsageError = TimeoutError - err (SessionUsageError e) = exc e - --- "Rel8" queries and other operations. - --- All sessions in the database. -allSessions :: Query (Schema.SessionRow Expr) -allSessions = each Schema.sessionRowSchema - --- Select a session by session ID. The session ID is unique, so this --- should only return at most 1 session, though Hasql's types are not --- robust enough to represent this invariant. -sessionById :: UUID -> Query (Schema.SessionRow Expr) -sessionById sid = - allSessions >>= filter \p -> Schema.uuid p ==. litExpr sid - --- Select all sessions whose name contains the given substring. -sessionByNameSubstr :: Text -> Query (Schema.SessionRow Expr) -sessionByNameSubstr substr = - -- N.B. the arguments to 'ilike' are reversed from what you might expect. - filter (ilike (litExpr ("%" <> escape substr <> "%")) . Schema.name) =<< allSessions - where - -- Escape @%@ and @_@ characters in the given string, as these are - -- wildcards in SQL. Note that the backslash is the default escape - -- character, and therefore must also be escaped. Make sure we do - -- backslash first, as otherwise we'll double-escape the other two - -- replacements! - escape :: Text -> Text - escape = T.replace "%" "\\%" . T.replace "_" "\\_" . T.replace "\\" "\\\\" - --- Return the number of sessions in the database. -numSessions :: Query (Expr Int64) -numSessions = countRows allSessions - --- Paginate a query. --- --- Note: the order of operations here is important. --- --- TODO: review use of 'fromIntegral' here and --- https://github.com/hackworthltd/primer/issues/238 -paginate :: OffsetLimit -> Query a -> Query a -paginate (OL o (Just l)) = limit (fromIntegral l) . offset (fromIntegral o) -paginate (OL o _) = offset (fromIntegral o) - -type SessionMeta = (Expr UUID, Expr Text, Expr UTCTime) - -sessionMeta :: Schema.SessionRow Expr -> SessionMeta -sessionMeta s = (Schema.uuid s, Schema.name s, Schema.lastmodified s) - --- Paginated session metadata, sorted by session name (primary) and --- last-modified (secondary, newest to oldest). -paginatedSessionMeta :: OffsetLimit -> Query SessionMeta -> Query SessionMeta -paginatedSessionMeta ol sm = - paginate ol $ - orderBy (mconcat [view _2 >$< asc, view _3 >$< desc]) sm diff --git a/primer-rel8/src/Primer/Database/Rel8/Schema.hs b/primer-rel8/src/Primer/Database/Rel8/Schema.hs deleted file mode 100644 index dbfbce2d2..000000000 --- a/primer-rel8/src/Primer/Database/Rel8/Schema.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module Primer.Database.Rel8.Schema ( - SessionRow (..), - sessionRowSchema, -) where - -import Foreword - -import Data.String (String) -import Data.Time.Clock (UTCTime) -import Data.UUID (UUID) -import Primer.App (App) -import Primer.Database ( - Version, - ) -import Primer.Database.Rel8.Orphans () -import Rel8 ( - Column, - Name, - Rel8able, - Result, - namesFromLabels, - ) -import Rel8 qualified ( - TableSchema (..), - ) - --- | A Primer session, as represented in the database. -data SessionRow f = SessionRow - { uuid :: Column f UUID - -- ^ The session's UUID. - , gitversion :: Column f Version - -- ^ Primer's git version. We would prefer that this were a git - -- rev, but for technical reasons, it may also be the last-modified - -- date of the project. - , app :: Column f App - -- ^ The session's 'App'. - , name :: Column f Text - -- ^ The session's name. - , lastmodified :: Column f UTCTime - -- ^ The session's last-modified time. - } - deriving stock (Generic) - deriving anyclass (Rel8able) - -deriving stock instance f ~ Result => Show (SessionRow f) - --- Our database schema name. We need to provide this to Rel8. -dbSchema :: Maybe String -dbSchema = Just "primer" - -sessionRowSchema :: Rel8.TableSchema (SessionRow Name) -sessionRowSchema = - Rel8.TableSchema - { Rel8.name = "sessions" - , Rel8.schema = dbSchema - , Rel8.columns = namesFromLabels @(SessionRow Name) - } diff --git a/primer-rel8/test/Test.hs b/primer-rel8/test/Test.hs deleted file mode 100644 index 8aa5c097d..000000000 --- a/primer-rel8/test/Test.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-TODO We should be able to pass `-optF --modules=Tests/*` to stop the preprocessor from wasting time searching elsewhere: -https://github.com/haskell-works/tasty-discover/issues/12#issuecomment-947689298 --} -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/primer-rel8/test/Tests/DeleteSession.hs b/primer-rel8/test/Tests/DeleteSession.hs deleted file mode 100644 index 90d31f05d..000000000 --- a/primer-rel8/test/Tests/DeleteSession.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE BlockArguments #-} - -module Tests.DeleteSession where - -import Foreword - -import Primer.App ( - newApp, - ) -import Primer.Database ( - DbError (SessionIdNotFound), - SessionId, - deleteSession, - getCurrentTime, - insertSession, - newSessionId, - querySessionId, - safeMkSessionName, - updateSessionApp, - ) -import Primer.Database.Rel8 ( - Rel8DbException (UpdateAppNonExistentSession), - ) -import Primer.Database.Rel8.Test.Util ( - runTmpDb, - ) -import Primer.Test.Util ( - assertException, - (@?=), - ) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) - -expectedError :: SessionId -> Rel8DbException -> Bool -expectedError id_ (UpdateAppNonExistentSession s) = s == id_ -expectedError _ _ = False - -test_deleteSession :: TestTree -test_deleteSession = testCaseSteps "deleteSession" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - - step "Insert program" - now <- getCurrentTime - let version = "git123" - let name = safeMkSessionName "test deleteSession" - sessionId <- liftIO newSessionId - insertSession version sessionId newApp name now - - step "Delete the session" - r1 <- deleteSession sessionId - r1 @?= Right () - - step "Ensure the session has been deleted" - r2 <- querySessionId sessionId - r2 @?= Left (SessionIdNotFound sessionId) - - step "Try to delete the session again" - r3 <- deleteSession sessionId - r3 @?= Left (SessionIdNotFound sessionId) - - step "Try to delete a non-existent session" - nonexistentSessionId <- liftIO newSessionId - r4 <- deleteSession nonexistentSessionId - r4 @?= Left (SessionIdNotFound nonexistentSessionId) - - step "Insert another new program" - let name2 = safeMkSessionName "test deleteSession 2" - sessionId2 <- liftIO newSessionId - insertSession version sessionId2 newApp name2 now - - step "Delete the new session" - r5 <- deleteSession sessionId2 - r5 @?= Right () - - step "Attempt to update the deleted session" - now' <- getCurrentTime - assertException "deleteSession" (expectedError sessionId2) $ updateSessionApp version sessionId2 newApp now' diff --git a/primer-rel8/test/Tests/FindSessions.hs b/primer-rel8/test/Tests/FindSessions.hs deleted file mode 100644 index 924fb568a..000000000 --- a/primer-rel8/test/Tests/FindSessions.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE RecordWildCards #-} - -module Tests.FindSessions where - -import Foreword - -import Data.Text qualified as Text -import Primer.App (newApp) -import Primer.Database ( - LastModified (..), - OffsetLimit (OL, limit, offset), - Page (pageContents, total), - Session (Session), - findSessions, - fromSessionName, - insertSession, - safeMkSessionName, - ) -import Primer.Database.Rel8 ( - SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid), - ) -import Primer.Database.Rel8.Test.Util ( - mkSessionRow, - mkSessionRow', - runTmpDb, - ) -import Primer.Test.Util ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) - -test_findSessions_several :: TestTree -test_findSessions_several = testCaseSteps "findSessions several hits" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "-30" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse mkSessionRow [1 .. 400] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = filter (\(Session _ n _) -> substr `Text.isInfixOf` fromSessionName n) $ map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - total pAll @?= 11 - pageContents pAll @?= expectedRows - step $ "Find first 5 occurrences of " <> show substr <> " in session names" - p5 <- findSessions substr $ OL{offset = 0, limit = Just 5} - total p5 @?= 11 - pageContents p5 @?= take 5 expectedRows - step $ "Find occurrences 6-10 of " <> show substr <> " in session names" - p10 <- findSessions substr $ OL{offset = 5, limit = Just 5} - total p10 @?= 11 - pageContents p10 @?= take 5 (drop 5 expectedRows) - step $ "Find last occurrence of " <> show substr <> " in session names, crossing end" - pLast <- findSessions substr $ OL{offset = 10, limit = Just 5} - total pLast @?= 11 - pageContents pLast @?= drop 10 expectedRows - -test_findSessions_exactly_1 :: TestTree -test_findSessions_exactly_1 = testCaseSteps "findSessions exactly 1 hit" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "-300" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse mkSessionRow [1 .. 400] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = filter (\(Session _ n _) -> substr `Text.isInfixOf` fromSessionName n) $ map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - total pAll @?= 1 - pageContents pAll @?= expectedRows - step $ "Find all occurrences of " <> show substr <> " in session names (limit 50)" - p50 <- findSessions substr $ OL{offset = 0, limit = Just 50} - total p50 @?= 1 - pageContents p50 @?= expectedRows - -test_findSessions_none :: TestTree -test_findSessions_none = testCaseSteps "findSessions no hits" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "-401" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse mkSessionRow [1 .. 400] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = filter (\(Session _ n _) -> substr `Text.isInfixOf` fromSessionName n) $ map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - total pAll @?= 0 - pageContents pAll @?= expectedRows - step $ "Find all occurrences of " <> show substr <> " in session names (limit 50)" - p50 <- findSessions substr $ OL{offset = 0, limit = Just 50} - total p50 @?= 0 - pageContents p50 @?= expectedRows - -test_findSessions_case_insensitive :: TestTree -test_findSessions_case_insensitive = testCaseSteps "findSessions is case-insensitive" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "name" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse (mkSessionRow' mkName) [1 .. 6] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - -- See comment below. - -- let expectedRows = map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - -- This is disabled due to a difference in the sort order that - -- PostgreSQL returns depending on which platorm it's running on. See: - -- - -- https://github.com/hackworthltd/primer/issues/1044 - -- pageContents pAll @?= expectedRows - total pAll @?= 6 - where - mkName n = if even n then "name-" <> show n else "NaMe-" <> show n - -test_findSessions_unicode :: TestTree -test_findSessions_unicode = testCaseSteps "findSessions supports Unicode" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "ありがとう" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse (mkSessionRow' mkName) [1 .. 5] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = filter (\(Session _ n _) -> substr `Text.isInfixOf` fromSessionName n) $ map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - total pAll @?= 2 - pageContents pAll @?= expectedRows - where - mkName 0 = "Thank you" - mkName 1 = "ありがとう" - mkName 3 = "Merci" - mkName 4 = "ありがとうございます" - mkName 5 = "Danke" - mkName _ = "Gracias" - -test_findSessions_emoji :: TestTree -test_findSessions_emoji = testCaseSteps "findSessions supports emoji" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "🤗😂" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse (mkSessionRow' mkName) [1 .. 7] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = filter (\(Session _ n _) -> substr `Text.isInfixOf` fromSessionName n) $ map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - total pAll @?= 3 - pageContents pAll @?= expectedRows - where - mkName 1 = "🤗" - mkName 2 = "😂" - mkName 3 = "🤗😂" - mkName 4 = "😄😂🤣🤗 🦊 🦈" - mkName 5 = "🤗😂😂" - mkName 6 = "🤗🤗😂" - mkName 7 = "🤗🤗😄" - mkName _ = "👍🏽" - -test_findSessions_escapes_percent :: TestTree -test_findSessions_escapes_percent = testCaseSteps "findSessions escapes % in the substring" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "%abc%" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse (mkSessionRow' mkName) [1 .. 4] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = filter (\(Session _ n _) -> substr `Text.isInfixOf` fromSessionName n) $ map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - total pAll @?= 2 - pageContents pAll @?= expectedRows - where - mkName 1 = "should %abc%% match" - mkName 2 = "should %abc% match" - mkName 3 = "abc% should not match" - mkName 4 = "%abc % should not match" - mkName _ = "no match" - -test_findSessions_escapes_underscore :: TestTree -test_findSessions_escapes_underscore = testCaseSteps "findSessions escapes _ in the substring" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "_abc_" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse (mkSessionRow' mkName) [1 .. 4] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = filter (\(Session _ n _) -> substr `Text.isInfixOf` fromSessionName n) $ map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - total pAll @?= 2 - pageContents pAll @?= expectedRows - where - mkName 1 = "should _abc__ match" - mkName 2 = "should _abc_ match" - mkName 3 = "abc_ should not match" - mkName 4 = "_abc _ should not match" - mkName _ = "no match" - -test_findSessions_escapes_backslash :: TestTree -test_findSessions_escapes_backslash = testCaseSteps "findSessions escapes backslash in the substring" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "\\abc\\" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse (mkSessionRow' mkName) [1 .. 4] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = filter (\(Session _ n _) -> substr `Text.isInfixOf` fromSessionName n) $ map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - total pAll @?= 2 - pageContents pAll @?= expectedRows - where - mkName 1 = "should \\abc\\\\ match" - mkName 2 = "should \\abc\\ match" - mkName 3 = "abc\\ should not match" - mkName 4 = "\\abc \\ should not match" - mkName _ = "no match" - -test_findSessions_escapes_all_specials :: TestTree -test_findSessions_escapes_all_specials = testCaseSteps "findSessions escapes all specials in the substring" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let substr = "\\ _ %" - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse (mkSessionRow' mkName) [1 .. 4] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = filter (\(Session _ n _) -> substr `Text.isInfixOf` fromSessionName n) $ map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step $ "Find all occurrences of " <> show substr <> " in session names (no limit)" - pAll <- findSessions substr $ OL{offset = 0, limit = Nothing} - total pAll @?= 2 - pageContents pAll @?= expectedRows - where - mkName 1 = "should \\ _ % match" - mkName 2 = "should _\\ _ %% match" - mkName 3 = "_ % should not match" - mkName 4 = "\\ % should not match" - mkName _ = "no match" diff --git a/primer-rel8/test/Tests/InsertSession.hs b/primer-rel8/test/Tests/InsertSession.hs deleted file mode 100644 index 53216297b..000000000 --- a/primer-rel8/test/Tests/InsertSession.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE BlockArguments #-} - -module Tests.InsertSession where - -import Foreword - -import Primer.App ( - newApp, - newEmptyApp, - ) -import Primer.Database ( - SessionData (..), - SessionId, - insertSession, - newSessionId, - querySessionId, - safeMkSessionName, - ) -import Primer.Database.Rel8.Rel8Db ( - Rel8DbException (InsertError), - ) -import Primer.Database.Rel8.Test.Util ( - lowPrecisionCurrentTime, - runTmpDb, - ) -import Primer.Test.App ( - comprehensive, - ) -import Primer.Test.Util ( - assertException, - (@?=), - ) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) - -expectedError :: SessionId -> Rel8DbException -> Bool -expectedError id_ (InsertError s _) = s == id_ -expectedError _ _ = False - -test_insertSession_roundtrip :: TestTree -test_insertSession_roundtrip = testCaseSteps "insertSession database round-tripping" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - step "Insert comprehensive" - now <- lowPrecisionCurrentTime - let version = "git123" - let name = safeMkSessionName "comprehensive" - sessionId <- liftIO newSessionId - insertSession version sessionId comprehensive name now - - step "Retrieve it" - result <- querySessionId sessionId - result @?= Right (SessionData comprehensive name now) - - let jpName = safeMkSessionName "サンプルプログラム" - step "Insert app with Japanese name" - sid1 <- liftIO newSessionId - insertSession version sid1 comprehensive jpName now - r1 <- querySessionId sid1 - r1 @?= Right (SessionData comprehensive jpName now) - - let cnName = safeMkSessionName "示例程序" - step "Insert app with simplified Chinese name" - sid2 <- liftIO newSessionId - insertSession version sid2 comprehensive cnName now - r2 <- querySessionId sid2 - r2 @?= Right (SessionData comprehensive cnName now) - - let arName = safeMkSessionName "برنامج مثال" - step "Insert app with Arabic name" - sid3 <- liftIO newSessionId - insertSession version sid3 comprehensive arName now - r3 <- querySessionId sid3 - r3 @?= Right (SessionData comprehensive arName now) - - let emName = safeMkSessionName "😄😂🤣🤗 🦊 🦈" - step "Insert app with emoji name" - sid4 <- liftIO newSessionId - insertSession version sid4 comprehensive emName now - r4 <- querySessionId sid4 - r4 @?= Right (SessionData comprehensive emName now) - -test_insertSession_failure :: TestTree -test_insertSession_failure = testCaseSteps "insertSession failure modes" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - - step "Insert program" - now <- lowPrecisionCurrentTime - let version = "git123" - let name = safeMkSessionName "testNewApp" - sessionId <- liftIO newSessionId - insertSession version sessionId newApp name now - - step "Attempt to insert the same program and metadata again" - assertException "insertSession" (expectedError sessionId) $ insertSession version sessionId newApp name now - - step "Attempt to insert a different program with the same metadata" - assertException "insertSession" (expectedError sessionId) $ insertSession version sessionId newEmptyApp name now - - step "Attempt to insert the same program with a different version" - let newVersion = "new-" <> version - assertException "insertSession" (expectedError sessionId) $ insertSession newVersion sessionId newApp name now - - step "Attempt to insert the same program with a different name" - let newName = safeMkSessionName "new name" - assertException "insertSession" (expectedError sessionId) $ insertSession version sessionId newApp newName now - - step "Attempt to insert the same program with a different timestamp" - now' <- lowPrecisionCurrentTime - assertException "insertSession" (expectedError sessionId) $ insertSession version sessionId newApp newName now' diff --git a/primer-rel8/test/Tests/ListSessions.hs b/primer-rel8/test/Tests/ListSessions.hs deleted file mode 100644 index 777a4c904..000000000 --- a/primer-rel8/test/Tests/ListSessions.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE RecordWildCards #-} - -module Tests.ListSessions where - -import Foreword - -import Primer.App (newApp) -import Primer.Database ( - LastModified (..), - OffsetLimit (OL, limit, offset), - Page (pageContents, total), - Session (Session), - insertSession, - listSessions, - safeMkSessionName, - ) -import Primer.Database.Rel8 ( - SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid), - ) -import Primer.Database.Rel8.Test.Util ( - mkSessionRow, - runTmpDb, - ) -import Primer.Test.Util ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) - -test_listSessions :: TestTree -test_listSessions = testCaseSteps "listSessions" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - let m = 345 - step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse mkSessionRow [1 .. m] - forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) - let expectedRows = map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows - step "Get all, offset+limit" - pAll <- listSessions $ OL{offset = 0, limit = Nothing} - total pAll @?= m - pageContents pAll @?= expectedRows - step "Get 25" - p25 <- listSessions $ OL{offset = 0, limit = Just 25} - total p25 @?= m - pageContents p25 @?= map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) (take 25 rows) - step "Get 76-100" - p75 <- listSessions $ OL{offset = 75, limit = Just 25} - total p75 @?= m - pageContents p75 @?= map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) (take 25 $ drop 75 rows) - step "Get crossing end" - pLast <- listSessions $ OL{offset = m - 10, limit = Just 25} - total pLast @?= m - pageContents pLast @?= map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) (drop (m - 10) rows) diff --git a/primer-rel8/test/Tests/QuerySessionId.hs b/primer-rel8/test/Tests/QuerySessionId.hs deleted file mode 100644 index 202be6aae..000000000 --- a/primer-rel8/test/Tests/QuerySessionId.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE BlockArguments #-} - -module Tests.QuerySessionId where - -import Foreword - -import Primer.App ( - newApp, - ) -import Primer.Database ( - DbError (SessionIdNotFound), - LastModified (..), - SessionData (..), - defaultSessionName, - insertSession, - newSessionId, - querySessionId, - safeMkSessionName, - ) -import Primer.Database.Rel8.Schema qualified as Schema ( - SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid), - ) -import Primer.Database.Rel8.Test.Util ( - insertSessionRow, - lowPrecisionCurrentTime, - runTmpDbWithPool, - ) -import Primer.Test.Util ((@?=)) -import Rel8 (lit) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) - --- Note: 'querySessionId' gets plenty of coverage in our other unit --- tests by virtue of the fact we use it to retrieve results that we --- insert into the database using 'insertSession' etc. Therefore, --- these tests are focused on finding corner cases and testing for --- particular failure modes. --- --- Note that several of these corner cases are things that should --- "never happen" because our types make them impossible, but we test --- them anyway (using the raw database interface to circumvent our --- types) to ensure we can handle database corruption, bugs, schema --- migration issues, etc. - -test_querySessionId :: TestTree -test_querySessionId = testCaseSteps "querySessionId corner cases" $ \step' -> - runTmpDbWithPool $ \pool -> do - let step = liftIO . step' - - step "Insert program" - now <- lowPrecisionCurrentTime - let version = "git123" - let name = safeMkSessionName "test querySessionId" - sessionId <- liftIO newSessionId - insertSession version sessionId newApp name now - - step "Attempt to look up a session that doesn't exist" - nonexistentSessionId <- liftIO newSessionId - r1 <- querySessionId nonexistentSessionId - r1 @?= Left (SessionIdNotFound nonexistentSessionId) - - step "Attempt to fetch a session whose name is invalid" - invalidNameSessionId <- liftIO newSessionId - let invalidName = "" - let invalidNameRow = - lit - Schema.SessionRow - { Schema.uuid = invalidNameSessionId - , Schema.gitversion = version - , Schema.app = newApp - , Schema.name = invalidName - , Schema.lastmodified = utcTime now - } - liftIO $ insertSessionRow invalidNameRow pool - r3 <- querySessionId invalidNameSessionId - -- In this scenario, we should get the program back with the - -- default session name, rather than the invalid name we used to - -- store it in the database. - r3 @?= Right (SessionData newApp defaultSessionName now) diff --git a/primer-rel8/test/Tests/UpdateSessionApp.hs b/primer-rel8/test/Tests/UpdateSessionApp.hs deleted file mode 100644 index 6b59cf1bb..000000000 --- a/primer-rel8/test/Tests/UpdateSessionApp.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE BlockArguments #-} - -module Tests.UpdateSessionApp where - -import Foreword - -import Primer.App ( - newApp, - newEmptyApp, - ) -import Primer.Database ( - SessionData (..), - SessionId, - insertSession, - newSessionId, - querySessionId, - safeMkSessionName, - updateSessionApp, - ) -import Primer.Database.Rel8 ( - Rel8DbException (UpdateAppNonExistentSession), - ) -import Primer.Database.Rel8.Test.Util ( - lowPrecisionCurrentTime, - runTmpDb, - ) -import Primer.Test.App ( - comprehensive, - ) -import Primer.Test.Util ( - assertException, - (@?=), - ) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) - -expectedError :: SessionId -> Rel8DbException -> Bool -expectedError id_ (UpdateAppNonExistentSession s) = s == id_ -expectedError _ _ = False - -test_updateSessionApp_roundtrip :: TestTree -test_updateSessionApp_roundtrip = testCaseSteps "updateSessionApp database round-tripping" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - - step "Insert a new session" - let version = "git123" - let name = safeMkSessionName "new app" - now <- lowPrecisionCurrentTime - sessionId <- liftIO newSessionId - insertSession version sessionId newEmptyApp name now - - step "Update it with the same version and app" - updateSessionApp version sessionId newEmptyApp now - r1 <- querySessionId sessionId - r1 @?= Right (SessionData newEmptyApp name now) - - step "Update it with a new version, but the same app" - let newVersion = "new-" <> version - updateSessionApp newVersion sessionId newEmptyApp now - r2 <- querySessionId sessionId - r2 @?= Right (SessionData newEmptyApp name now) - - step "Update it with a new app" - updateSessionApp newVersion sessionId comprehensive now - r3 <- querySessionId sessionId - r3 @?= Right (SessionData comprehensive name now) - - step "Update it with a new time" - now' <- lowPrecisionCurrentTime - updateSessionApp newVersion sessionId comprehensive now' - r4 <- querySessionId sessionId - r4 @?= Right (SessionData comprehensive name now') - -test_updateSessionApp_failure :: TestTree -test_updateSessionApp_failure = testCaseSteps "updateSessionApp failure modes" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - - step "Attempt to update a session that hasn't yet been inserted" - let version = "git123" - now <- lowPrecisionCurrentTime - sessionId <- liftIO newSessionId - assertException "updateSessionApp" (expectedError sessionId) $ updateSessionApp version sessionId newApp now diff --git a/primer-rel8/test/Tests/UpdateSessionName.hs b/primer-rel8/test/Tests/UpdateSessionName.hs deleted file mode 100644 index 803f4ea8e..000000000 --- a/primer-rel8/test/Tests/UpdateSessionName.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE BlockArguments #-} - -module Tests.UpdateSessionName where - -import Foreword - -import Primer.App ( - newEmptyApp, - ) -import Primer.Database ( - SessionData (..), - SessionId, - insertSession, - newSessionId, - querySessionId, - safeMkSessionName, - updateSessionName, - ) -import Primer.Database.Rel8 ( - Rel8DbException (UpdateNameNonExistentSession), - ) -import Primer.Database.Rel8.Test.Util ( - lowPrecisionCurrentTime, - runTmpDb, - ) -import Primer.Test.Util ( - assertException, - (@?=), - ) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) - -expectedError :: SessionId -> Rel8DbException -> Bool -expectedError id_ (UpdateNameNonExistentSession s) = s == id_ -expectedError _ _ = False - -test_updateSessionName_roundtrip :: TestTree -test_updateSessionName_roundtrip = testCaseSteps "updateSessionName database round-tripping" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - - step "Insert a new session" - let version = "git123" - let name = safeMkSessionName "new app" - now <- lowPrecisionCurrentTime - sessionId <- liftIO newSessionId - insertSession version sessionId newEmptyApp name now - - step "Update it with the same version and name" - updateSessionName version sessionId name now - r1 <- querySessionId sessionId - r1 @?= Right (SessionData newEmptyApp name now) - - step "Update it with a new version, but the same name" - let newVersion = "new-" <> version - updateSessionName newVersion sessionId name now - r2 <- querySessionId sessionId - r2 @?= Right (SessionData newEmptyApp name now) - - step "Update it with a new name" - let newName = safeMkSessionName "new new app" - updateSessionName newVersion sessionId newName now - r3 <- querySessionId sessionId - r3 @?= Right (SessionData newEmptyApp newName now) - - step "Update it with a new time" - now' <- lowPrecisionCurrentTime - updateSessionName newVersion sessionId newName now' - r4 <- querySessionId sessionId - r4 @?= Right (SessionData newEmptyApp newName now') - - step "Update it with a Japanese name" - let jpName = safeMkSessionName "サンプルプログラム" - updateSessionName newVersion sessionId jpName now' - r5 <- querySessionId sessionId - r5 @?= Right (SessionData newEmptyApp jpName now') - - step "Update it with a simplified Chinese name" - let cnName = safeMkSessionName "示例程序" - updateSessionName newVersion sessionId cnName now' - r6 <- querySessionId sessionId - r6 @?= Right (SessionData newEmptyApp cnName now') - - step "Update it with an Arabic name" - let arName = safeMkSessionName "برنامج مثال" - updateSessionName newVersion sessionId arName now' - r7 <- querySessionId sessionId - r7 @?= Right (SessionData newEmptyApp arName now') - - step "Update it with an emoji name" - let emName = safeMkSessionName "😄😂🤣🤗 🦊 🦈" - updateSessionName newVersion sessionId emName now' - r8 <- querySessionId sessionId - r8 @?= Right (SessionData newEmptyApp emName now') - -test_updateSessionName_failure :: TestTree -test_updateSessionName_failure = testCaseSteps "updateSessionName failure modes" $ \step' -> - runTmpDb $ do - let step = liftIO . step' - - step "Attempt to update a session that hasn't yet been inserted" - let version = "git123" - let name = safeMkSessionName "this session doesn't exist" - now <- lowPrecisionCurrentTime - sessionId <- liftIO newSessionId - assertException "updateSessionName" (expectedError sessionId) $ updateSessionName version sessionId name now diff --git a/primer-rel8/testlib/Primer/Database/Rel8/Test/Util.hs b/primer-rel8/testlib/Primer/Database/Rel8/Test/Util.hs deleted file mode 100644 index 9f0d72827..000000000 --- a/primer-rel8/testlib/Primer/Database/Rel8/Test/Util.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Primer.Database.Rel8.Test.Util ( - deployDb, - insertSessionRow, - mkSessionRow, - mkSessionRow', - withDbSetup, - lowPrecisionCurrentTime, - runTmpDb, - runTmpDbWithPool, -) where - -import Foreword - -import Control.Monad.Log ( - DiscardLoggingT, - WithSeverity, - discardLogging, - ) -import Data.ByteString.Lazy.UTF8 as BL -import Data.String (String) -import Data.Time ( - UTCTime (..), - diffTimeToPicoseconds, - picosecondsToDiffTime, - secondsToDiffTime, - ) -import Data.UUID.V4 (nextRandom) -import Database.PostgreSQL.Simple.Options qualified as Options -import Database.Postgres.Temp ( - DB, - DirectoryType (Temporary), - cacheAction, - cacheConfig, - cacheDirectoryType, - cacheTemporaryDirectory, - defaultCacheConfig, - optionsToDefaultConfig, - toConnectionString, - withConfig, - withDbCacheConfig, - ) -import GHC.Err (error) -import Hasql.Pool ( - Pool, - acquire, - release, - use, - ) -import Hasql.Session (statement) -import Network.Socket.Free (getFreePort) -import Primer.App (newApp) -import Primer.Database ( - LastModified (..), - getCurrentTime, - ) -import Primer.Database.Rel8 ( - Rel8DbT, - SessionRow (..), - runRel8DbT, - ) -import Primer.Database.Rel8.Schema as Schema hiding (app) -import Rel8 ( - Expr, - Insert (Insert, into, onConflict, returning, rows), - OnConflict (Abort), - Result, - Returning (NumberOfRowsAffected), - insert, - values, - ) -import System.IO.Temp (withSystemTempDirectory) -import System.Process.Typed ( - proc, - readProcessStdout, - runProcess_, - ) - --- The PostgreSQL host, username, and password can be chosen --- statically, but we need to choose the port dynamically in order to --- accommodate multiple simultaneous PostgreSQL instances. - -host :: String -host = "localhost" - -user :: String -user = "postgres" - -password :: String -password = "primer" - --- | This action requires that the Sqitch script @primer-sqitch@ is in --- the process's path. If you run this test via Nix, Nix will --- guarantee that precondition. -deployDb :: Int -> DB -> IO () -deployDb port _ = - let url = "db:postgres://" <> user <> ":" <> password <> "@" <> host <> ":" <> show port - in runProcess_ $ proc "primer-sqitch" ["deploy", "--verify", url] - --- | This action requires that the Sqitch script @primer-sqitch@ is in --- the process's path. If you run this test via Nix, Nix will --- guarantee that precondition. -sqitchEventChangeId :: IO String -sqitchEventChangeId = do - (status, output) <- readProcessStdout $ proc "primer-sqitch" ["plan", "--max-count=1", "--format=format:%h", "--no-headers"] - case status of - ExitFailure n -> error $ "`primer-sqitch plan` failed with exit code " <> show n - _ -> pure $ takeWhile (/= '\n') $ BL.toString output - -withDbSetup :: (Pool -> IO ()) -> IO () -withDbSetup f = do - -- NOTE: there's a race where the returned port could be opened by - -- another process before we can use it, but it's extremely unlikely - -- to be triggered. - port <- getFreePort - let throwEither x = either throwIO pure =<< x - dbConfig = - optionsToDefaultConfig - mempty - { Options.port = pure port - , Options.user = pure user - , Options.password = pure password - , Options.host = pure host - } - throwEither $ do - withSystemTempDirectory "primer-tmp-postgres" $ \tmpdir -> - let cc = - defaultCacheConfig - { cacheTemporaryDirectory = tmpdir - , cacheDirectoryType = Temporary - } - in withDbCacheConfig cc $ \dbCache -> - let combinedConfig = dbConfig <> cacheConfig dbCache - in do - hash_ <- sqitchEventChangeId - migratedConfig <- throwEither $ cacheAction (tmpdir <> "/" <> hash_) (deployDb port) combinedConfig - withConfig migratedConfig $ \db -> - bracket (acquire 1 (secondsToDiffTime 1) (secondsToDiffTime $ 60 * 30) $ toConnectionString db) release f - -runTmpDb :: Rel8DbT (DiscardLoggingT (WithSeverity ()) IO) () -> IO () -runTmpDb tests = - withDbSetup $ \pool -> discardLogging $ runRel8DbT tests pool - --- | Some tests need access to the pool -runTmpDbWithPool :: (Pool -> Rel8DbT (DiscardLoggingT (WithSeverity ()) IO) ()) -> IO () -runTmpDbWithPool tests = - withDbSetup $ \pool -> discardLogging $ runRel8DbT (tests pool) pool - --- | Like @MonadDb.insertSession@, but allows us to insert things --- directly into the database that otherwise might not be permitted by --- the type system. This is useful for testing purposes. -insertSessionRow :: Schema.SessionRow Expr -> Pool -> IO () -insertSessionRow row pool = - void $ - use pool $ - statement () $ - insert - Insert - { into = Schema.sessionRowSchema - , rows = - values - [ row - ] - , onConflict = Abort - , returning = NumberOfRowsAffected - } - --- | PostgreSQL's timestamp type has a precision of 1 microsecond, but --- 'getCurrentTime' has a precision of 1 picosecond. In order to --- compare times for our tests, we need to truncate the precision of --- the time returned by 'getCurrentTime'. --- --- Ref: --- https://www.postgresql.org/docs/13/datatype-datetime.html -lowPrecisionCurrentTime :: (MonadIO m) => m LastModified -lowPrecisionCurrentTime = do - LastModified (UTCTime day time) <- getCurrentTime - -- truncate to microseconds - let time' = picosecondsToDiffTime $ diffTimeToPicoseconds time `div` 1000000 * 1000000 - pure $ LastModified $ UTCTime day time' - --- | Return a 'SessionRow', which is useful for testing the database --- without needing to go through the Primer API. -mkSessionRow :: Int -> IO (SessionRow Result) -mkSessionRow n = do - u <- nextRandom - now <- lowPrecisionCurrentTime - pure $ - SessionRow - { uuid = u - , gitversion = "test-version" - , app = newApp - , name = "name-" <> show n - , lastmodified = utcTime now - } - --- | Like 'mkSessionRow', but with a callback to generate names. -mkSessionRow' :: (Int -> Text) -> Int -> IO (SessionRow Result) -mkSessionRow' mkName n = do - u <- nextRandom - now <- lowPrecisionCurrentTime - pure $ - SessionRow - { uuid = u - , gitversion = "test-version" - , app = newApp - , name = mkName n - , lastmodified = utcTime now - } diff --git a/primer-service/exe-server/Main.hs b/primer-service/exe-server/Main.hs index c3006e2e0..b2d2b3b74 100644 --- a/primer-service/exe-server/Main.hs +++ b/primer-service/exe-server/Main.hs @@ -11,7 +11,6 @@ import Control.Concurrent.Async ( import Control.Concurrent.STM ( newTBQueueIO, ) -import Control.Monad.Fail (fail) import Control.Monad.Log ( Handler, Severity (Informational), @@ -20,18 +19,7 @@ import Control.Monad.Log ( runLoggingT, withBatchedHandler, ) -import Data.ByteString as BS -import Data.ByteString.UTF8 (fromString) -import Data.String (String) import Data.Text qualified as Text -import Data.Time.Clock ( - secondsToDiffTime, - ) -import Hasql.Pool ( - Pool, - acquire, - release, - ) import Numeric.Natural (Natural) import Options.Applicative ( Parser, @@ -57,13 +45,6 @@ import Options.Applicative ( import Primer.API (APILog, PrimerErr (..)) import Primer.Database (Version) import Primer.Database qualified as Db -import Primer.Database.Rel8 ( - MonadRel8Db, - Rel8DbException, - Rel8DbLogMessage (..), - runRel8DbT, - ) -import Primer.Database.Rel8 qualified as Rel8Db import Primer.Database.Selda () import Primer.Database.Selda as SeldaDb import Primer.Database.Selda.SQLite ( @@ -91,7 +72,6 @@ import Prometheus qualified as P import Prometheus.Metric.GHC qualified as P import StmContainers.Map qualified as StmMap import System.Directory (canonicalizePath) -import System.Environment (lookupEnv) import System.IO ( BufferMode (LineBuffering), hSetBuffering, @@ -100,19 +80,10 @@ import System.IO ( {- HLINT ignore GlobalOptions "Use newtype instead of data" -} data GlobalOptions = GlobalOptions !Command -data Database - = SQLite FilePath - | PostgreSQL BS.ByteString - -parseDatabase :: Parser Database -parseDatabase = - (SQLite <$> option str (long "sqlite-db")) - <|> (PostgreSQL <$> option auto (long "pgsql-url")) - data Logger = Standard | Replay data Command - = Serve Version (Maybe Database) Int Natural Logger CorsAllowedOrigins + = Serve Version FilePath Int Natural Logger CorsAllowedOrigins parseOrigins :: Parser CorsAllowedOrigins parseOrigins = @@ -137,7 +108,7 @@ serveCmd :: Parser Command serveCmd = Serve <$> argument str (metavar "VERSION") - <*> optional parseDatabase + <*> argument str (metavar "DATABASE") <*> option auto (long "port" <> value 8081) <*> option auto (long "db-op-queue-size" <> value 128) <*> flag Standard Replay (long "record-replay" <> help "Change the log format to capture enough information so one can replay sessions") @@ -152,57 +123,6 @@ cmds = (info serveCmd (progDesc "Run the server")) ) -pgUrlEnvVar :: String -pgUrlEnvVar = "DATABASE_URL" - --- | When no database flag is provided on the command line, we try --- first to lookup and parse the magic @DATABASE_URL@ environment --- variable. If that's not present, we fail. -defaultDb :: IO Database -defaultDb = do - envVar <- lookupEnv pgUrlEnvVar - case envVar of - Nothing -> fail "No database argument was given, and the DATABASE_URL environment variable is not set. Exiting." - Just uri -> pure $ PostgreSQL $ fromString uri - -runRel8Db :: MonadRel8Db m l => Db.ServiceCfg -> Pool -> m Void -runRel8Db cfg = start - where - justRel8DbException :: Rel8DbException -> Maybe Rel8DbException - justRel8DbException = Just - - logDbException = logError . LogRel8DbException - - -- The database computation exception handler. - start pool = - catchJust - justRel8DbException - (flip runRel8DbT pool $ Db.serve cfg) - $ \e -> do - logDbException e - case e of - -- Retry the same operation until it succeeds. - -- Note: we need some backoff here. See: - -- - -- https://github.com/hackworthltd/primer/issues/678 - Rel8Db.ConnectionFailed _ -> start pool - -- Retry the same operation until it succeeds. - Rel8Db.TimeoutError -> start pool - -- The operation will probably fail if we try it again, - -- but other operations might be fine, so discard the - -- failed op from the queue and continue serving - -- subsequent ops. - -- - -- Note that we should be more selective than this: some - -- exceptions may indicate a serious problem with the - -- database, in which case we may not want to restart. - -- See: - -- - -- https://github.com/hackworthltd/primer/issues/381 - _ -> do - Db.discardOp (Db.opQueue cfg) - start pool - runSqliteDb :: MonadSeldaSQLiteDb m l => Db.ServiceCfg -> FilePath -> m Void runSqliteDb cfg = start where @@ -255,16 +175,14 @@ banner = ] serve :: - ( ConvertLogMessage Rel8DbLogMessage l - , ConvertLogMessage SeldaDbLogMessage l + ( ConvertLogMessage SeldaDbLogMessage l , ConvertLogMessage Text l - , ConvertLogMessage BS.ByteString l , ConvertLogMessage FilePath l , ConvertLogMessage PrimerErr l , ConvertServerLogs l , ConvertLogMessage ServantLog l ) => - Database -> + FilePath -> Version -> Int -> Natural -> @@ -276,32 +194,8 @@ serve :: -- @concurrently_ (putStrLn s1) (putStrLn s2)@ can.) Handler IO (WithSeverity l) -> IO () -serve (PostgreSQL uri) ver port qsz origins logger = - bracket (acquire poolSize timeout maxLifetime uri) release $ \pool -> do - dbOpQueue <- newTBQueueIO qsz - initialSessions <- StmMap.newIO - flip runLoggingT logger $ do - forM_ banner logInfo - logNotice $ "primer-server version " <> ver - logNotice ("Listening on port " <> show port :: Text) - logNotice $ "CORS allowed origins: " <> prettyPrintCorsAllowedOrigins origins - logNotice $ "PostgreSQL database: " <> uri - concurrently_ - (Server.serve initialSessions dbOpQueue ver port origins logger) - (flip runLoggingT logger $ runRel8Db (Db.ServiceCfg dbOpQueue ver) pool) - where - -- Note: pool size must be 1 in order to guarantee - -- read-after-write and write-after-write semantics for individual - -- sessions. See: - -- - -- https://github.com/hackworthltd/primer/issues/640#issuecomment-1217290598 - poolSize = 1 - -- 10 second connection timeout (arbitrary) - timeout = secondsToDiffTime 10 - -- 30 min max connection lifetime (arbitrary) - maxLifetime = secondsToDiffTime $ 60 * 30 -serve (SQLite path) ver port qsz origins logger = do - dbPath <- canonicalizePath path +serve db ver port qsz origins logger = do + dbPath <- canonicalizePath db dbOpQueue <- newTBQueueIO qsz initialSessions <- StmMap.newIO flip runLoggingT logger $ do @@ -328,8 +222,7 @@ main = do handleAll (bye (logToStdout . logMsgWithSeverity)) $ do args <- execParser opts case args of - GlobalOptions (Serve ver dbFlag port qsz logger origins) -> do - db <- maybe defaultDb pure dbFlag + GlobalOptions (Serve ver db port qsz logger origins) -> do case logger of Standard -> serve db ver port qsz origins (logToStdout . logMsgWithSeverity) Replay -> serve db ver port qsz origins (logToStdout . logReplay) @@ -358,15 +251,9 @@ logMsgWithSeverity (WithSeverity s m) = textWithSeverity $ WithSeverity s (unLog instance ConvertLogMessage Text LogMsg where convert = LogMsg -instance ConvertLogMessage BS.ByteString LogMsg where - convert = LogMsg . show - instance ConvertLogMessage FilePath LogMsg where convert = LogMsg . show -instance ConvertLogMessage Rel8DbLogMessage LogMsg where - convert = LogMsg . show - instance ConvertLogMessage SeldaDbLogMessage LogMsg where convert = LogMsg . show @@ -410,15 +297,9 @@ instance ConvertLogMessage LogReplay LogMsg where instance ConvertLogMessage Text LogReplay where convert = Other . LogMsg -instance ConvertLogMessage BS.ByteString LogReplay where - convert = Other . convert - instance ConvertLogMessage FilePath LogReplay where convert = Other . convert -instance ConvertLogMessage Rel8DbLogMessage LogReplay where - convert = Other . convert - instance ConvertLogMessage SeldaDbLogMessage LogReplay where convert = Other . convert diff --git a/primer-service/primer-service.cabal b/primer-service/primer-service.cabal index 4a160c4aa..7a3851df4 100644 --- a/primer-service/primer-service.cabal +++ b/primer-service/primer-service.cabal @@ -95,15 +95,12 @@ executable primer-service build-depends: , async ^>=2.2.4 , base - , bytestring >=0.10.8.2 && <0.12.0 , directory ^>=1.3 , exceptions - , hasql-pool ^>=0.9 , logging-effect ^>=1.4 , optparse-applicative ^>=0.17 , primer , primer-api - , primer-rel8 ^>=0.7.2 , primer-selda ^>=0.7.2 , primer-service , prometheus-client ^>=1.1.0 @@ -134,7 +131,7 @@ executable primer-client build-depends: , base - , bytestring + , bytestring >=0.10.8.2 && <0.12.0 , directory , exceptions , http-client-tls ^>=0.3.6.1 @@ -200,14 +197,11 @@ test-suite service-test , hedgehog-quickcheck ^>=0.1.1 , hspec ^>=2.10 , openapi3 - , postgres-options ^>=0.2 , pretty-simple ^>=4.1 , primer-api:{primer-api, primer-api-hedgehog} - , primer-rel8:{primer-rel8, primer-rel8-testlib} , primer-service , primer:{primer, primer-hedgehog, primer-testlib} , QuickCheck ^>=2.14.2 - , rel8 ^>=1.4 , servant-openapi3 , tasty ^>=1.4.1 , tasty-discover ^>=5.0 diff --git a/primer-service/test/Tests/Pagination.hs b/primer-service/test/Tests/Pagination.hs index c2d726b4c..eda43706c 100644 --- a/primer-service/test/Tests/Pagination.hs +++ b/primer-service/test/Tests/Pagination.hs @@ -13,11 +13,6 @@ import Primer.Database ( listSessions, safeMkSessionName, ) -import Primer.Database.Rel8 (SessionRow (..)) -import Primer.Database.Rel8.Test.Util ( - mkSessionRow, - runTmpDb, - ) import Primer.Finite (packFinite) import Primer.Pagination ( Pagination (Pagination, page, size), diff --git a/weeder.dhall b/weeder.dhall index f3c8295a5..9e410c75a 100644 --- a/weeder.dhall +++ b/weeder.dhall @@ -6,7 +6,6 @@ let -- these packages, but don't actually make use of ourselves. ignoreRoots = [ "^Foreword" - , "^Primer.Database.Rel8.Rel8Db.runRel8Db" , "^Primer.Pretty.prettyPrintExpr" , "^Primer.Pretty.prettyPrintType" , "^Primer.Client"