From 319b8afd77cb882be90231f8a4fb698da26884c1 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Wed, 1 Jun 2022 16:05:19 +0100 Subject: [PATCH 01/24] Add missing quotes --- README.md | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index 2b852a5b..8f5e95cf 100644 --- a/README.md +++ b/README.md @@ -28,12 +28,12 @@ Rhyolite provides: { system ? builtins.currentSystem, obelisk ? import ./.obelisk/impl { inherit system; iosSdkVersion = "13.2"; - + # You must accept the Android Software Development Kit License Agreement at # https://developer.android.com/studio/terms in order to build Android apps. # Uncomment and set this to `true` to indicate your acceptance: # config.android_sdk.accept_license = false; - + # In order to use Let's Encrypt for HTTPS deployments you must accept # their terms of service at https://letsencrypt.org/repository/. # Uncomment and set this to `true` to indicate your acceptance: @@ -41,7 +41,7 @@ Rhyolite provides: } }: with obelisk; project ./. ({ pkgs, hackGet, ... }@args: { - + overrides = pkgs.lib.composeExtensions (pkgs.callPackage (hackGet ./dep/rhyolite) args).haskellOverrides (self: super: @@ -49,7 +49,7 @@ Rhyolite provides: { # Your custom overrides go here. }); - + android.applicationId = "systems.obsidian.obelisk.examples.minimal"; android.displayName = "Obelisk Minimal Example"; ios.bundleIdentifier = "systems.obsidian.obelisk.examples.minimal"; @@ -96,5 +96,5 @@ You can use `nix-shell -A proj.shells.ghc` to enter a shell from which you can b Because of the inter-related nature of these packages, `rhyolite-test-suite` tests that all of them can be built against one another. To test, run: ```bash -nix-shell -A proj.shells.ghc --run cabal build test +nix-shell -A proj.shells.ghc --run "cabal build test" ``` From df755778b6f9e4d74a87147bfb7b4b11ba42c8e1 Mon Sep 17 00:00:00 2001 From: Sean Chalmers Date: Thu, 26 Jan 2023 18:08:20 +0000 Subject: [PATCH 02/24] Update thunk github.json in README.md --- README.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 2b852a5b..53050a2c 100644 --- a/README.md +++ b/README.md @@ -74,8 +74,9 @@ with this Rhyolite thunk: "owner": "obsidiansystems", "repo": "rhyolite", "branch": "master", - "rev": "06b9851a101408a86a4ec0b7df5b2f71bc532ab0", - "sha256": "18adbc1nnj94qhggpcxmpd5i1rz0zx93cpphl09mw4c7s65rzah7" + "private": false, + "rev": "9f13d8d8a2233aae54e15c39acf68181893b859a", + "sha256": "1vhbw9bdqpfddavfjfdrq6kk5wwsd8hbgb8pnna9i2db3x3cmzvy" } ``` From 05f1c041c27e491a3d24e84f92b1f966db62328b Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 23 May 2023 16:09:27 -0400 Subject: [PATCH 03/24] Bump obelisk --- .obelisk/impl/github.json | 6 +++--- default.nix | 1 + dep/vessel/default.nix | 2 ++ dep/vessel/github.json | 8 ++++++++ dep/vessel/thunk.nix | 12 ++++++++++++ 5 files changed, 26 insertions(+), 3 deletions(-) create mode 100644 dep/vessel/default.nix create mode 100644 dep/vessel/github.json create mode 100644 dep/vessel/thunk.nix diff --git a/.obelisk/impl/github.json b/.obelisk/impl/github.json index 727afb1d..acc96ebb 100644 --- a/.obelisk/impl/github.json +++ b/.obelisk/impl/github.json @@ -1,8 +1,8 @@ { "owner": "obsidiansystems", "repo": "obelisk", - "branch": "aa/reflex-pkgs-dec22", + "branch": "release/1.1.0.0", "private": false, - "rev": "2d97ea0c1316b39fe084ff62bb5275a373e60851", - "sha256": "0rs3v2jgawwyqni2nwx2gij87lyl4bdq0ij3q1cq8fsx1991qj68" + "rev": "8e942c022ee08ed278bba8f13fdd3be76fc8d8a7", + "sha256": "07y1997mh9ycvdmfwm7l1fpscc238bnjyrqpf9jjka4d52aqkw6j" } diff --git a/default.nix b/default.nix index 29d054a2..72cade53 100644 --- a/default.nix +++ b/default.nix @@ -49,6 +49,7 @@ let gargoyle-postgresql-connect = repos.gargoyle + "/gargoyle-postgresql-connect"; gargoyle-postgresql-nix = repos.gargoyle + "/gargoyle-postgresql-nix"; push-notifications = repos.push-notifications; + vessel = repos.vessel; }; diff --git a/dep/vessel/default.nix b/dep/vessel/default.nix new file mode 100644 index 00000000..2b4d4ab1 --- /dev/null +++ b/dep/vessel/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/vessel/github.json b/dep/vessel/github.json new file mode 100644 index 00000000..95beaaf3 --- /dev/null +++ b/dep/vessel/github.json @@ -0,0 +1,8 @@ +{ + "owner": "obsidiansystems", + "repo": "vessel", + "branch": "release/0.3.0.0", + "private": false, + "rev": "c290833764f4054ee52047e3604c323493c1e5e8", + "sha256": "173sq64q3m41s3nlv601zzl171kq5kgd8sql45yrrnjw72rf1hjj" +} diff --git a/dep/vessel/thunk.nix b/dep/vessel/thunk.nix new file mode 100644 index 00000000..20f2d28c --- /dev/null +++ b/dep/vessel/thunk.nix @@ -0,0 +1,12 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file From 3ff0e9fc37406f58cef6ff5cf81c248ee12e0f82 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 25 May 2023 10:12:57 -0400 Subject: [PATCH 04/24] Update changelog --- ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ChangeLog.md b/ChangeLog.md index a7384f5c..3bb1a98b 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -10,6 +10,7 @@ This project's release branch is `master`. This log is written from the perspect * Update to vessel-0.3 * Support ghc-8.10 * Add Data.Vessel.Void +* Move .obelisk/impl to dep/obelisk ## 2023-01-26 * Breaking: Rhyolite.Frontend.Cookie now always Base64 encodes cookies From 29c5855cd36088452b1ce0f4f4ba95044ab05a1d Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 25 May 2023 10:59:08 -0400 Subject: [PATCH 05/24] dep: remove unnecessary overrides; bump others --- default.nix | 22 ++----------------- dep/bytestring-trie/default.nix | 7 ------ dep/bytestring-trie/github.json | 7 ------ dep/gargoyle/github.json | 4 ++-- dep/gargoyle/thunk.nix | 5 ++++- dep/postgresql-simple-interpolate/github.json | 6 ++--- dep/postgresql-simple-interpolate/thunk.nix | 5 ++++- 7 files changed, 15 insertions(+), 41 deletions(-) delete mode 100644 dep/bytestring-trie/default.nix delete mode 100644 dep/bytestring-trie/github.json diff --git a/default.nix b/default.nix index f02af8f2..673d5964 100644 --- a/default.nix +++ b/default.nix @@ -39,7 +39,6 @@ let # srcs used for overrides overrideSrcs = rhyolitePackages // { bytestring-aeson-orphans = repos.bytestring-aeson-orphans; - bytestring-trie = repos.bytestring-trie; monoid-map = repos.monoid-map; postgresql-simple-interpolate = repos.postgresql-simple-interpolate; @@ -61,30 +60,13 @@ let frontend = super.frontend.override { obelisk-executable-config-lookup = self.obelisk-executable-config-lookup; }; - beam-automigrate = haskellLib.doJailbreak super.beam-automigrate; - bytestring-trie = haskellLib.dontCheck super.bytestring-trie; + beam-automigrate = self.callHackage "beam-automigrate" "0.1.3.0" {}; gargoyle-postgresql-nix = haskellLib.overrideCabal super.gargoyle-postgresql-nix { librarySystemDepends = [ pkgs.postgresql ]; }; validation = haskellLib.dontCheck super.validation; - postgresql-lo-stream = haskellLib.doJailbreak (self.callHackageDirect { - pkg = "postgresql-lo-stream"; - ver = "0.1.1.1"; - sha256 = "0ifr6i6vygckj2nikv7k7yqia495gnn27pq6viasckmmh6zx6gwi"; - } {}); - - monad-logger-extras = self.callHackageDirect { - pkg = "monad-logger-extras"; - ver = "0.1.1.1"; - sha256 = "17dr2jwg1ig1gd4hw7160vf3l5jcx5p79b2lz7k17f6v4ygx3vbz"; - } {}; - monoid-subclasses = self.callHackageDirect { - pkg = "monoid-subclasses"; - ver = "1.1"; - sha256 = "02ggjcwjdjh6cmy7zaji5mcmnq140sp33cg9rvwjgply6hkddrvb"; - } {}; - HaskellNet = self.callHackage "HaskellNet" "0.6" {}; + monoid-subclasses = super.monoid-subclasses_1_1; HaskellNet-SSL = self.callHackage "HaskellNet-SSL" "0.3.4.4" {}; base-orphans = self.callHackageDirect { diff --git a/dep/bytestring-trie/default.nix b/dep/bytestring-trie/default.nix deleted file mode 100644 index 7a047786..00000000 --- a/dep/bytestring-trie/default.nix +++ /dev/null @@ -1,7 +0,0 @@ -# DO NOT HAND-EDIT THIS FILE -import ((import {}).fetchFromGitHub ( - let json = builtins.fromJSON (builtins.readFile ./github.json); - in { inherit (json) owner repo rev sha256; - private = json.private or false; - } -)) diff --git a/dep/bytestring-trie/github.json b/dep/bytestring-trie/github.json deleted file mode 100644 index 661b6d67..00000000 --- a/dep/bytestring-trie/github.json +++ /dev/null @@ -1,7 +0,0 @@ -{ - "owner": "obsidiansystems", - "repo": "bytestring-trie", - "branch": "ghc-8.4", - "rev": "27117ef4f9f01f70904f6e8007d33785c4fe300b", - "sha256": "103fqr710pddys3bqz4d17skgqmwiwrjksn2lbnc3w7s01kal98a" -} diff --git a/dep/gargoyle/github.json b/dep/gargoyle/github.json index 3683a9cc..c9a5e4c9 100644 --- a/dep/gargoyle/github.json +++ b/dep/gargoyle/github.json @@ -3,6 +3,6 @@ "repo": "gargoyle", "branch": "develop", "private": false, - "rev": "df0068f9572c1371bed7aa416af84d462c3574c0", - "sha256": "19amvx6r884ryvy9wq19x7a11fr56kwmw4h2nl8jx0ikzm0sdmfl" + "rev": "dfa94ae8366beca396015f320ad8937b376be36a", + "sha256": "0dk42ly6q92zc9qkq0fz9lvnprab5r76k8lrrm9y5jj3ig7zbsy8" } diff --git a/dep/gargoyle/thunk.nix b/dep/gargoyle/thunk.nix index bbf2dc18..20f2d28c 100644 --- a/dep/gargoyle/thunk.nix +++ b/dep/gargoyle/thunk.nix @@ -2,7 +2,10 @@ let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: if !fetchSubmodules && !private then builtins.fetchTarball { url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; - } else (import {}).fetchFromGitHub { + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { inherit owner repo rev sha256 fetchSubmodules private; }; json = builtins.fromJSON (builtins.readFile ./github.json); diff --git a/dep/postgresql-simple-interpolate/github.json b/dep/postgresql-simple-interpolate/github.json index 87379d48..08743be4 100644 --- a/dep/postgresql-simple-interpolate/github.json +++ b/dep/postgresql-simple-interpolate/github.json @@ -1,8 +1,8 @@ { "owner": "obsidiansystems", "repo": "postgresql-simple-interpolate", - "branch": "aa/iquery", + "branch": "master", "private": false, - "rev": "497583add970ee2d5da32b9620347de3eca6d42e", - "sha256": "09x1w8ffx5bq8llpvqiaxkm6psar8ir9aaskn3762qhy7rf5v0cq" + "rev": "fc34dd4d1e179b4dd8e2fa9419435d6f9bd29160", + "sha256": "0631fhycn8silm25rbajqc4fmhhh6n6kcnl6b0nddzx0bdmf1v0b" } diff --git a/dep/postgresql-simple-interpolate/thunk.nix b/dep/postgresql-simple-interpolate/thunk.nix index bbf2dc18..20f2d28c 100644 --- a/dep/postgresql-simple-interpolate/thunk.nix +++ b/dep/postgresql-simple-interpolate/thunk.nix @@ -2,7 +2,10 @@ let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: if !fetchSubmodules && !private then builtins.fetchTarball { url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; - } else (import {}).fetchFromGitHub { + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { inherit owner repo rev sha256 fetchSubmodules private; }; json = builtins.fromJSON (builtins.readFile ./github.json); From 9115c925764cca6bdc75293054fdc9343bca25c2 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 25 May 2023 11:20:53 -0400 Subject: [PATCH 06/24] deps: update deps * postgresql-lo-stream --- default.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/default.nix b/default.nix index 673d5964..6b1faf8a 100644 --- a/default.nix +++ b/default.nix @@ -65,6 +65,7 @@ let librarySystemDepends = [ pkgs.postgresql ]; }; validation = haskellLib.dontCheck super.validation; + postgresql-lo-stream = haskellLib.markUnbroken super.postgresql-lo-stream; monoid-subclasses = super.monoid-subclasses_1_1; HaskellNet-SSL = self.callHackage "HaskellNet-SSL" "0.3.4.4" {}; From 81976ba757e4b68cafa5031116c2737fd441e95f Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 25 May 2023 12:05:50 -0400 Subject: [PATCH 07/24] Cut rc-1.0; update changelog --- ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 4dfe7230..32ce71c0 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,7 +2,7 @@ This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released, and the date should reflect that release. -## Unreleased +## v1.0.0.0 2023-05-25 * Breaking: Drop groundhog support * Breaking: Use Commutative from commutative-semigroups instead of Additive from patch * Update to vessel-0.3 From 032e6d465001beebeac5259dc7c938448468c747 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 2 Aug 2023 12:31:39 -0400 Subject: [PATCH 08/24] deps: obelisk -> 1.1.1.0 --- dep/obelisk/github.json | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/dep/obelisk/github.json b/dep/obelisk/github.json index acc96ebb..ca7a270c 100644 --- a/dep/obelisk/github.json +++ b/dep/obelisk/github.json @@ -1,8 +1,8 @@ { "owner": "obsidiansystems", "repo": "obelisk", - "branch": "release/1.1.0.0", + "branch": "release/1.1.1.0", "private": false, - "rev": "8e942c022ee08ed278bba8f13fdd3be76fc8d8a7", - "sha256": "07y1997mh9ycvdmfwm7l1fpscc238bnjyrqpf9jjka4d52aqkw6j" + "rev": "d77d8e29bde6c1f336a38296dd47043abb2d789c", + "sha256": "1k34qhxkc6apzpz7lsdykd4r6j342zqis1m0m2x9377v875vrxvl" } From bcf0c1b6f9ba4beeadb6a941e98a7642e14db821 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 2 Aug 2023 14:57:13 -0400 Subject: [PATCH 09/24] deps: update bytestring-aeson-orphans and aeson-qq --- default.nix | 2 ++ dep/bytestring-aeson-orphans/github.json | 6 +++--- dep/bytestring-aeson-orphans/thunk.nix | 5 ++++- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/default.nix b/default.nix index 6b1faf8a..0975d20d 100644 --- a/default.nix +++ b/default.nix @@ -76,6 +76,8 @@ let sha256 = "sha256:17hplm1mgw65jbszg5z4vqk4i24ilxv8mbszr3s8lhpll5naik26"; } {}; + aeson-qq = self.callHackage "aeson-qq" "0.8.4" {}; + # 'locale' is broken on nix darwin which is required by postgres 'initdb' rhyolite-beam-task-worker-backend = if pkgs.stdenv.hostPlatform.isDarwin then diff --git a/dep/bytestring-aeson-orphans/github.json b/dep/bytestring-aeson-orphans/github.json index 9833606a..315a562f 100644 --- a/dep/bytestring-aeson-orphans/github.json +++ b/dep/bytestring-aeson-orphans/github.json @@ -1,8 +1,8 @@ { "owner": "obsidiansystems", "repo": "bytestring-aeson-orphans", - "branch": "release/0.1.0.0", + "branch": "release/0.1.0.1", "private": false, - "rev": "ca7818097360480b28745e56f7580ab0505a7c95", - "sha256": "1i4pdgv72x8idyq3limjvj25innw1pl4nd1m55ag29c5kcd9ap8q" + "rev": "4d3c8d2344af18a0e486b07d574e41ad7e24a10c", + "sha256": "17dhl97qsadn37pmvw5z9zjzwy750yis3wr88zqb1g4wfb95jv4h" } diff --git a/dep/bytestring-aeson-orphans/thunk.nix b/dep/bytestring-aeson-orphans/thunk.nix index bbf2dc18..20f2d28c 100644 --- a/dep/bytestring-aeson-orphans/thunk.nix +++ b/dep/bytestring-aeson-orphans/thunk.nix @@ -2,7 +2,10 @@ let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: if !fetchSubmodules && !private then builtins.fetchTarball { url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; - } else (import {}).fetchFromGitHub { + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { inherit owner repo rev sha256 fetchSubmodules private; }; json = builtins.fromJSON (builtins.readFile ./github.json); From a6a0d025c2c98f7f4ae1c94b1e4e9afbec7042dc Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 3 Aug 2023 10:37:48 -0400 Subject: [PATCH 10/24] deps: update beam-automigrate and postgresql-lo-stream --- default.nix | 8 +++++++- dep/beam-automigrate/default.nix | 2 ++ dep/beam-automigrate/github.json | 8 ++++++++ dep/beam-automigrate/thunk.nix | 12 ++++++++++++ dep/postgresql-lo-stream/default.nix | 2 ++ dep/postgresql-lo-stream/github.json | 8 ++++++++ dep/postgresql-lo-stream/thunk.nix | 12 ++++++++++++ 7 files changed, 51 insertions(+), 1 deletion(-) create mode 100644 dep/beam-automigrate/default.nix create mode 100644 dep/beam-automigrate/github.json create mode 100644 dep/beam-automigrate/thunk.nix create mode 100644 dep/postgresql-lo-stream/default.nix create mode 100644 dep/postgresql-lo-stream/github.json create mode 100644 dep/postgresql-lo-stream/thunk.nix diff --git a/default.nix b/default.nix index 0975d20d..7c08609f 100644 --- a/default.nix +++ b/default.nix @@ -49,6 +49,8 @@ let gargoyle-postgresql-nix = repos.gargoyle + "/gargoyle-postgresql-nix"; push-notifications = repos.push-notifications; vessel = repos.vessel; + postgresql-lo-stream = repos.postgresql-lo-stream; + beam-automigrate = repos.beam-automigrate; }; @@ -60,7 +62,6 @@ let frontend = super.frontend.override { obelisk-executable-config-lookup = self.obelisk-executable-config-lookup; }; - beam-automigrate = self.callHackage "beam-automigrate" "0.1.3.0" {}; gargoyle-postgresql-nix = haskellLib.overrideCabal super.gargoyle-postgresql-nix { librarySystemDepends = [ pkgs.postgresql ]; }; @@ -77,6 +78,11 @@ let } {}; aeson-qq = self.callHackage "aeson-qq" "0.8.4" {}; + postgresql-syntax = haskellLib.dontCheck super.postgresql-syntax; + vessel = haskellLib.doJailbreak super.vessel; + monoid-map = haskellLib.doJailbreak super.monoid-map; + + beam-migrate = self.callHackage "beam-migrate" "0.5.2.0" {}; # 'locale' is broken on nix darwin which is required by postgres 'initdb' rhyolite-beam-task-worker-backend = if pkgs.stdenv.hostPlatform.isDarwin diff --git a/dep/beam-automigrate/default.nix b/dep/beam-automigrate/default.nix new file mode 100644 index 00000000..2b4d4ab1 --- /dev/null +++ b/dep/beam-automigrate/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/beam-automigrate/github.json b/dep/beam-automigrate/github.json new file mode 100644 index 00000000..c6411f41 --- /dev/null +++ b/dep/beam-automigrate/github.json @@ -0,0 +1,8 @@ +{ + "owner": "obsidiansystems", + "repo": "beam-automigrate", + "branch": "release/0.1.4.0", + "private": false, + "rev": "a5d0090acd05a444a75dd3effecbba82ea195561", + "sha256": "03fdxwr14vjpif5c0vzqff5x21q98v5slqba1qg4ki092bwws6l6" +} diff --git a/dep/beam-automigrate/thunk.nix b/dep/beam-automigrate/thunk.nix new file mode 100644 index 00000000..20f2d28c --- /dev/null +++ b/dep/beam-automigrate/thunk.nix @@ -0,0 +1,12 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/postgresql-lo-stream/default.nix b/dep/postgresql-lo-stream/default.nix new file mode 100644 index 00000000..2b4d4ab1 --- /dev/null +++ b/dep/postgresql-lo-stream/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/postgresql-lo-stream/github.json b/dep/postgresql-lo-stream/github.json new file mode 100644 index 00000000..605ce837 --- /dev/null +++ b/dep/postgresql-lo-stream/github.json @@ -0,0 +1,8 @@ +{ + "owner": "obsidiansystems", + "repo": "postgresql-lo-stream", + "branch": "develop", + "private": false, + "rev": "ddf9778546ac90be5d74a8009d114c041f99cffb", + "sha256": "1hqrjmqmn45c7ghda7g2dqkndg7s2nsf0d9vpvhrmbim9aw9gvbr" +} diff --git a/dep/postgresql-lo-stream/thunk.nix b/dep/postgresql-lo-stream/thunk.nix new file mode 100644 index 00000000..20f2d28c --- /dev/null +++ b/dep/postgresql-lo-stream/thunk.nix @@ -0,0 +1,12 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file From ec1333cfba11f6f8c6dd3908780c6f2d01110c66 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 3 Aug 2023 13:12:48 -0400 Subject: [PATCH 11/24] v1 --- ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 32ce71c0..e6e921a2 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,7 +2,7 @@ This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released, and the date should reflect that release. -## v1.0.0.0 2023-05-25 +## v1.0.0.0 2023-08-03 * Breaking: Drop groundhog support * Breaking: Use Commutative from commutative-semigroups instead of Additive from patch * Update to vessel-0.3 From ad6488171c311e45dc67953a0aba3bcc31a27620 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 22 Aug 2023 22:40:52 -0400 Subject: [PATCH 12/24] widgets: remove Reflex.Dom.Modal.* --- ChangeLog.md | 4 + widgets/rhyolite-widgets.cabal | 2 - widgets/src/Reflex/Dom/Modal/Base.hs | 233 -------------------------- widgets/src/Reflex/Dom/Modal/Class.hs | 60 ------- 4 files changed, 4 insertions(+), 295 deletions(-) delete mode 100644 widgets/src/Reflex/Dom/Modal/Base.hs delete mode 100644 widgets/src/Reflex/Dom/Modal/Class.hs diff --git a/ChangeLog.md b/ChangeLog.md index e6e921a2..8539bdac 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,10 @@ This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released, and the date should reflect that release. +## Unreleased + +* Breaking: Remove Reflex.Dom.Modal.Base and Reflex.Dom.Modal.Class. The `` element is now broadly supported by browsers and provides a simpler solution to the problem of opening modals that is also more accessible. See the [documentation](https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dialog), and, in particular, this [example](https://developer.mozilla.org/en-US/docs/Web/API/HTMLDialogElement#opening_a_modal_dialog), which uses `showModal` and describes how to style the modal backdrop. + ## v1.0.0.0 2023-08-03 * Breaking: Drop groundhog support * Breaking: Use Commutative from commutative-semigroups instead of Additive from patch diff --git a/widgets/rhyolite-widgets.cabal b/widgets/rhyolite-widgets.cabal index 5c9105f7..2ede1a2b 100644 --- a/widgets/rhyolite-widgets.cabal +++ b/widgets/rhyolite-widgets.cabal @@ -16,8 +16,6 @@ category: UI library exposed-modules: - Reflex.Dom.Modal.Base - Reflex.Dom.Modal.Class Reflex.Dom.Widget.ExtensibleList Reflex.Dom.Widget.Form diff --git a/widgets/src/Reflex/Dom/Modal/Base.hs b/widgets/src/Reflex/Dom/Modal/Base.hs deleted file mode 100644 index 51dee149..00000000 --- a/widgets/src/Reflex/Dom/Modal/Base.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-| -Description: - Modal widgets - -The important definition here is 'ModalT', the related class is -in "Reflex.Dom.Modal.Class". --} - -{-# Language CPP #-} -{-# Language DataKinds #-} -{-# Language FlexibleContexts #-} -{-# Language FlexibleInstances #-} -{-# Language GeneralizedNewtypeDeriving #-} -{-# Language LambdaCase #-} -{-# Language MultiParamTypeClasses #-} -{-# Language OverloadedStrings #-} -{-# Language RankNTypes #-} -{-# Language RecursiveDo #-} -{-# Language ScopedTypeVariables #-} -{-# Language StandaloneDeriving #-} -{-# Language TypeFamilies #-} -{-# Language UndecidableInstances #-} - -module Reflex.Dom.Modal.Base where - -import Control.Applicative (liftA2) -import Control.Lens (Rewrapped, Wrapped (Unwrapped, _Wrapped'), iso) -import Control.Monad.Fix (MonadFix) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Primitive (PrimMonad (PrimState, primitive)) -import Control.Monad.Reader (MonadReader) -import Control.Monad.Ref (MonadAtomicRef, MonadRef) -import Control.Monad.Trans (MonadTrans (lift)) -import Data.Coerce (coerce) -import Data.Either.Combinators (rightToMaybe) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Semigroup (First(..)) -import Data.Text (Text) -import qualified GHCJS.DOM as DOM -import qualified GHCJS.DOM.EventM as EventM -import qualified GHCJS.DOM.GlobalEventHandlers as Events -import Language.Javascript.JSaddle (MonadJSM) -import Obelisk.Configs (HasConfigs) -import Obelisk.Route.Frontend -import Reflex.Dom.Core -import Reflex.Host.Class (MonadReflexCreateTrigger) - -import Reflex.Dom.Modal.Class (HasModal (ModalM, tellModal)) - -instance (Reflex t, Monad m) => HasModal t (ModalT t modalM m) where - type ModalM (ModalT t modalM m) = modalM - tellModal = ModalT . tellEvent . fmap First - --- | Modal monad transformer -newtype ModalT t modalM m a - = ModalT { unModalT :: EventWriterT t (First (Event t () -> modalM (Event t ()))) m a } - deriving - ( Functor, Applicative, Monad - , MonadFix, MonadIO, MonadRef, MonadAtomicRef, MonadReader r - , DomBuilder t, NotReady t, MonadHold t, MonadSample t - , PerformEvent t, TriggerEvent t, PostBuild t - , MonadReflexCreateTrigger t, MonadQuery t q, Requester t - ) - -instance PrimMonad m => PrimMonad (ModalT t modalM m) where - type PrimState (ModalT t modalM m) = PrimState m - primitive = lift . primitive - -instance Wrapped (ModalT t modalM m a) where - type Unwrapped (ModalT t modalM m a) = EventWriterT t (First (Event t () -> modalM (Event t ()))) m a - _Wrapped' = iso coerce coerce -instance ModalT t modalM m a ~ x => Rewrapped (ModalT t modalM m a) x - -instance HasDocument m => HasDocument (ModalT t modalM m) -#if !defined(ghcjs_HOST_OS) -instance MonadJSM m => MonadJSM (ModalT t modalM m) -#endif - -instance (Monad m, Routed t r m) => Routed t r (ModalT t modalM m) where - askRoute = lift askRoute - -instance (Monad m, RouteToUrl r m) => RouteToUrl r (ModalT t modalM m) where - askRouteToUrl = lift askRouteToUrl - -instance (Reflex t, Monad m, SetRoute t r m) => SetRoute t r (ModalT t modalM m) where - modifyRoute = lift . modifyRoute - -instance EventWriter t w m => EventWriter t w (ModalT t modalM m) where - tellEvent = lift . tellEvent - -instance MonadTrans (ModalT t modalM) where - lift = ModalT . lift - -instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (ModalT t modalM m) where - runWithReplace a0 a' = ModalT $ runWithReplace (unModalT a0) (fmapCheap unModalT a') - traverseDMapWithKeyWithAdjust f dm0 dm' = ModalT $ traverseDMapWithKeyWithAdjust (coerce f) dm0 dm' - traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = ModalT $ traverseDMapWithKeyWithAdjustWithMove (coerce f) dm0 dm' - traverseIntMapWithKeyWithAdjust f im0 im' = ModalT $ traverseIntMapWithKeyWithAdjust (coerce f) im0 im' - -deriving instance DomRenderHook t m => DomRenderHook t (ModalT t modalM m) - -instance (Prerender t m, Monad m, Reflex t) => Prerender t (ModalT t modalM m) where - type Client (ModalT t modalM m) = ModalT t modalM (Client m) - prerender back front = do - (a, ev) <- fmap splitDynPure $ lift $ prerender - (runEventWriterT $ unModalT back) - (runEventWriterT $ unModalT front) - ModalT $ tellEvent $ switchDyn ev - pure a - -instance HasConfigs m => HasConfigs (ModalT t modalM m) - --- | Like 'withModals' but with the full convenience of 'ModalT', allowing 'tellModal' to open a modal anywhere. --- --- NB: This must wrap all other DOM building. This is because DOM for the modal --- must occur *after* all other DOM in order for the modal to appear on top of it. -runModalT - :: forall m t a. - ( MonadFix m - , DomBuilder t m, MonadHold t m, PostBuild t m, Prerender t m - ) - => ModalBackdropConfig -> ModalT t m m a -> m a -runModalT backdropCfg f = do - rec - ((a, open), _) <- withModals backdropCfg (getFirst <$> open) $ runEventWriterT (unModalT f) - pure a - --- | Change the underlying monad of `ModalT` and the monad the modals will be run in. --- --- For cases where those two monads differ, checkout `mapModalT` and `mapModalM`. -mapModalTM :: (Reflex t, MonadHold t m) => (forall x. m x -> n x) -> ModalT t m m a -> ModalT t n n a -mapModalTM f = mapModalT f . mapModalM f - --- | Change the underlying monad of `ModalT`. -mapModalT :: (Reflex t, MonadHold t m) => (forall x. m x -> n x) -> ModalT t modalM m a -> ModalT t modalM n a -mapModalT f = ModalT . mapEventWriterT f . unModalT - --- | Change the monad the modals will be run in. -mapModalM :: (Reflex t, MonadHold t m) => (forall x. modalM x -> modalN x) -> ModalT t modalM m a -> ModalT t modalN m a -mapModalM f = ModalT . withEventWriterT ((fmap . fmap) f) . unModalT - --- | You can adjust the attributes passed to the backdrop with this config. --- --- You can adjust the background and the size, for example. You cannot change --- the CSS `display` property, as it is controlled by this library. Also note --- that the dialog is not a child widget of the backdrop, but rendered within --- a separate `untouchable` top level div. For positioning of your dialog, --- you should not rely on backdrop, nor on this hidden div, instead we --- recommend fixed positioning for the dialog, as described in `tellModal`. -newtype ModalBackdropConfig = ModalBackdropConfig - { _modalBackdropConfig_attrs :: Map Text Text - } deriving (Monoid, Semigroup) - --- | Set up DOM to support modals. --- --- NB: This must wrap all other DOM building. This is because DOM for the modal --- must occur *after* all other DOM in order for the modal to appear on top of it. -withModals - :: forall m a b t. - ( MonadFix m - , DomBuilder t m, MonadHold t m, PostBuild t m, Prerender t m - ) - => ModalBackdropConfig - -> Event t (Event t () -> m (Event t a)) - -- ^ Event to trigger a modal to open. - -- The event carries a function that takes close events and builds a modal window - -- which returns a close event. - -> m b -- ^ Page body - -> m (b, Event t a) -- ^ Result of page body and an event firing whenever a modal closes -withModals backdropCfg open body = liftA2 (,) body (modalDom backdropCfg open) - --- | Builds modal-related DOM. Avoid using this and use 'withModals' instead. --- --- NB: This must run after all other DOM building. This is because DOM for the modal --- must occur *after* all other DOM in order for the modal to appear on top of it. -modalDom - :: forall a m t. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m, Prerender t m) - => ModalBackdropConfig - -> Event t (Event t () -> m (Event t a)) - -- ^ Event to trigger a modal to open. - -- The event carries a function that takes close events and builds a modal window - -- which returns a close event. - -> m (Event t a) -- ^ An event firing whenever the modal closes -modalDom backdropCfg open = do - escPressed :: Event t () <- fmap switchDyn $ prerender (pure never) $ do - document <- DOM.currentDocumentUnchecked - wrapDomEventMaybe document (`EventM.on` Events.keyDown) $ do - key <- getKeyEvent - pure $ if keyCodeLookup (fromIntegral key) == Escape then Just () else Nothing - rec - isVisible <- holdDyn False $ leftmost [True <$ open, False <$ close] - (backdropEl, _) <- elDynAttr' "div" - (ffor isVisible $ \isVis -> - ("style" =: (isVisibleStyle isVis <> ";" <> existingBackdropStyle)) <> _modalBackdropConfig_attrs backdropCfg - ) - blank - close <- elDynAttr "div" (ffor isVisible $ \isVis -> "style" =: isVisibleStyle isVis) $ - fmap switchDyn $ widgetHold (pure never) $ leftmost - [ ($ leftmost [escPressed, domEvent Click backdropEl]) <$> open - , pure never <$ close - ] - pure close - where - existingBackdropStyle = fromMaybe "" $ Map.lookup "style" $ _modalBackdropConfig_attrs backdropCfg - isVisibleStyle isVis = "display:" <> (if isVis then "block" else "none") - --- | Widget used as a modal div for widgets that want to take some action when --- clicked anywhere but itself, such as dropdown widgets or the like. The --- first argument is a CSS class name, the suggested CSS class styling for use --- of this widget is as follows: --- --- > position: fixed; --- > top: 0; --- > bottom: 0; --- > right: 0; --- > left: 0; --- > z-index: 100; --- -{-# Deprecated withBackdrop "Use ModalT instead" #-} -withBackdrop :: forall m t a. (DomBuilder t m, MonadFix m, MonadHold t m) => Text -> Event t (m (Event t a)) -> m (Event t a) -withBackdrop cls openBackdropWithChild = mdo - sth <- widgetHold (return never) $ ffor (leftmost [close, open]) $ \case - Nothing -> return never - Just child -> do - (backgroundEl, _) <- elClass' "div" cls blank - childResult <- child - let backgroundEvent = domEvent Click backgroundEl - return $ leftmost [Left <$> backgroundEvent, Right <$> childResult] - let close :: Event t (Maybe (m (Event t a))) = Nothing <$ (switch . current $ sth) - open :: Event t (Maybe (m (Event t a))) = Just <$> openBackdropWithChild - return $ fmapMaybe rightToMaybe $ switch . current $ sth diff --git a/widgets/src/Reflex/Dom/Modal/Class.hs b/widgets/src/Reflex/Dom/Modal/Class.hs deleted file mode 100644 index 702ed07c..00000000 --- a/widgets/src/Reflex/Dom/Modal/Class.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-| Description: Class for modal creators -A class for widget that can have modals. A concrete implementation is in -"Reflex.Dom.Modal.Base". --} - -{-# Language DefaultSignatures #-} -{-# Language FlexibleInstances #-} -{-# Language MultiParamTypeClasses #-} -{-# Language TypeFamilies #-} - -module Reflex.Dom.Modal.Class where - -import Control.Monad.Reader (MonadReader (ask), ReaderT (..)) -import Control.Monad.Trans (MonadTrans (lift)) -import Obelisk.Route.Frontend (RoutedT, askRoute, runRoutedT) -import Reflex (Event, EventWriterT, Reflex) - --- | The class of monads supporting a 'tellModal' operation which will open a modal --- that stays on top of all other content. -class HasModal t m where - -- If 'm' is the monad that supports 'tellModal' then 'ModalM m' is the monad that the modal itself is in, - -- which, notably, probably doesn't support 'tellModal'. - type ModalM m :: * -> * - - -- | Opens a modal when the given event fires. The event carries a function which: - -- * takes a "close" event triggered when the user signifies that they want to close the modal, - -- * builds content in 'ModalM m', - -- * returns a "close" event which will be used to actually close the modal. - -- - -- For example, a modal may choose not to be closable by simply ignoring its input and returning 'never'. - -- - -- Note on positioning: We control the containing div of your dialog for - -- handling of the CSS display property. We recommend that you position - -- your dialog `fixed` with some Clay like the following: - -- - -- @ - -- position fixed - -- top (pct 50) - -- left (pct 50) - -- transform (translate (pct $ negate 50) (pct $ negate 50)) - -- @ - tellModal :: Event t (Event t () -> ModalM m (Event t ())) -> m () - - default tellModal :: (MonadTrans f, m ~ f m', HasModal t m', Monad m', ModalM (f m') ~ ModalM m') => Event t (Event t () -> ModalM m (Event t ())) -> m () - tellModal = lift . tellModal - -instance (Monad m, Reflex t, HasModal t m) => HasModal t (EventWriterT t w m) where - type ModalM (EventWriterT t w m) = ModalM m - -instance (Monad m, Reflex t, HasModal t m) => HasModal t (ReaderT r m) where - type ModalM (ReaderT r m) = ReaderT r (ModalM m) -- Transform the modal's monad - tellModal ev = do - r <- ask - lift $ tellModal $ (fmap . fmap) (`runReaderT` r) ev - -instance (Monad m, Reflex t, HasModal t m) => HasModal t (RoutedT t r m) where - type ModalM (RoutedT t r m) = RoutedT t r (ModalM m) -- Transform the modal's monad - tellModal ev = do - r <- askRoute - lift $ tellModal $ (fmap . fmap) (`runRoutedT` r) ev From 35cef32f7b59d906efc803bde2e98ef9b0f8120c Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 1 Sep 2023 10:34:54 -0400 Subject: [PATCH 13/24] account: make it possible to use accounts without notify --- ChangeLog.md | 4 + .../backend/rhyolite-account-backend.cabal | 2 + .../backend/src/Rhyolite/Backend/Account.hs | 174 +---------------- .../src/Rhyolite/Backend/Account/Db.hs | 184 ++++++++++++++++++ .../src/Rhyolite/Backend/Account/Notify.hs | 60 ++++++ 5 files changed, 252 insertions(+), 172 deletions(-) create mode 100644 account/backend/src/Rhyolite/Backend/Account/Db.hs create mode 100644 account/backend/src/Rhyolite/Backend/Account/Notify.hs diff --git a/ChangeLog.md b/ChangeLog.md index e6e921a2..65c3397e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,10 @@ This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released, and the date should reflect that release. +## Unreleased + +* Make it possible to use Rhyolite.Backend.Account without notifications. See Rhyolite.Backend.Account.Db for versions of createAccount and ensureAccountExists that don't send notifications. + ## v1.0.0.0 2023-08-03 * Breaking: Drop groundhog support * Breaking: Use Commutative from commutative-semigroups instead of Additive from patch diff --git a/account/backend/rhyolite-account-backend.cabal b/account/backend/rhyolite-account-backend.cabal index 71033d12..2449f253 100644 --- a/account/backend/rhyolite-account-backend.cabal +++ b/account/backend/rhyolite-account-backend.cabal @@ -13,6 +13,8 @@ category: Web library exposed-modules: Rhyolite.Backend.Account + Rhyolite.Backend.Account.Db + Rhyolite.Backend.Account.Notify build-depends: base , aeson , beam-core diff --git a/account/backend/src/Rhyolite/Backend/Account.hs b/account/backend/src/Rhyolite/Backend/Account.hs index e5b74879..acfabde0 100644 --- a/account/backend/src/Rhyolite/Backend/Account.hs +++ b/account/backend/src/Rhyolite/Backend/Account.hs @@ -8,7 +8,6 @@ Description: {-# Language OverloadedStrings #-} module Rhyolite.Backend.Account ( createAccount - , login , ensureAccountExists , setAccountPassword , setAccountPasswordHash @@ -19,174 +18,5 @@ module Rhyolite.Backend.Account , resetPasswordHash ) where -import Control.Monad (guard) -import Control.Monad.Trans.Maybe -import Crypto.PasswordStore -import Data.Aeson -import Data.ByteString -import Data.Constraint.Extras -import Data.Constraint.Forall -import Data.Functor.Identity -import Data.Maybe -import Data.Text -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Text.Encoding as T -import Data.Time -import Database.Beam -import Database.Beam.Backend.SQL.BeamExtensions -import Database.Beam.Postgres -import Data.Signed -import Data.Signed.ClientSession -import Database.Beam.Postgres.Full hiding (insert) -import Database.Beam.Postgres.Syntax -import Database.PostgreSQL.Simple.Beam () -import Rhyolite.Account -import Rhyolite.DB.Beam (current_timestamp_) -import Rhyolite.DB.NotifyListen -import Rhyolite.DB.NotifyListen.Beam -import Web.ClientSession as CS - --- | Creates a new account and emits a db notification about it -createAccount - :: (Has' ToJSON notice Identity, ForallF ToJSON notice) - => DatabaseEntity Postgres db (TableEntity Account) - -> notice (PrimaryKey Account Identity) - -> Text - -> Text - -> Pg (Either Text (PrimaryKey Account Identity)) -createAccount accountTable noticeWrapper email pass = do - hash <- makePasswordHash pass - accountIds <- runPgInsertReturningList $ flip returning _account_id $ insert accountTable $ insertExpressions - [ Account - { _account_id = default_ - , _account_email = lower_ (val_ email) - , _account_password = val_ (Just hash) - , _account_passwordResetNonce = just_ current_timestamp_ - } - ] - case accountIds of - [accountId] -> do - notify NotificationType_Insert noticeWrapper (AccountId accountId) - pure $ Right $ AccountId accountId - _ -> pure $ Left "Failed to create account" - --- | Attempts to login a user given some credentials. -login - :: Database Postgres db - => DatabaseEntity Postgres db (TableEntity Account) - -> Text - -> Text - -> Pg (Maybe (PrimaryKey Account Identity)) -login accountTable email pass = runMaybeT $ do - (aid, mPwHash) <- MaybeT $ fmap listToMaybe $ runSelectReturningList $ select $ do - acc <- all_ accountTable - guard_ $ lower_ (_account_email acc) ==. lower_ (val_ email) - pure (_account_id acc, _account_password acc) - pwHash <- MaybeT $ pure mPwHash - guard $ verifyPasswordWith pbkdf2 (2^) (T.encodeUtf8 pass) pwHash - pure (AccountId aid) - -ensureAccountExists - :: (Database Postgres db, HasNotification n Account, Has' ToJSON n Identity, ForallF ToJSON n) - => DatabaseEntity Postgres db (TableEntity Account) - -> Text - -> Pg (Bool, PrimaryKey Account Identity) -ensureAccountExists accountTable email = do - existingAccountId <- runSelectReturningOne $ select $ fmap primaryKey $ filter_ (\x -> - lower_ (_account_email x) ==. lower_ (val_ email)) $ all_ accountTable - case existingAccountId of - Just existing -> return (False, existing) - Nothing -> do - results <- runInsertReturningList $ insert accountTable $ insertExpressions - [ Account - { _account_id = default_ - , _account_email = lower_ (val_ email) - , _account_password = nothing_ - , _account_passwordResetNonce = nothing_ - } - ] - case results of - [acc] -> do - let aid = primaryKey acc - notify NotificationType_Insert (notification accountTable) aid - pure (True, aid) - _ -> error "ensureAccountExists: Creating account failed" - -setAccountPassword - :: DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> Text - -> Pg () -setAccountPassword tbl aid password = do - pw <- liftIO $ makePasswordHash password - setAccountPasswordHash tbl aid pw - -setAccountPasswordHash - :: DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> ByteString - -> Pg () -setAccountPasswordHash accountTable aid hash = runUpdate $ update accountTable - (\x -> mconcat - [ _account_password x <-. val_ (Just hash) - , _account_passwordResetNonce x <-. nothing_ - ] - ) - (\x -> primaryKey x ==. val_ aid) - -makePasswordHash - :: MonadIO m - => Text - -> m ByteString -makePasswordHash pw = do - salt <- liftIO genSaltIO - return $ makePasswordSaltWith pbkdf2 (2^) (encodeUtf8 pw) salt 14 - -resetPassword - :: (Database Postgres db) - => DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> UTCTime - -> Text - -> Pg (Maybe (PrimaryKey Account Identity)) -resetPassword tbl aid t pw = do - hash <- makePasswordHash pw - resetPasswordHash tbl aid t hash - -resetPasswordHash - :: (Database Postgres db) - => DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> UTCTime - -> ByteString - -> Pg (Maybe (PrimaryKey Account Identity)) -resetPasswordHash accountTable aid nonce pwhash = do - macc <- runSelectReturningOne $ lookup_ accountTable aid - case macc of - Nothing -> return Nothing - Just a -> if _account_passwordResetNonce a == Just nonce - then do - setAccountPasswordHash accountTable aid pwhash - return $ Just aid - else fail "nonce mismatch" - -passwordResetToken - :: MonadIO m - => CS.Key - -> PrimaryKey Account Identity - -> UTCTime - -> m (Signed PasswordResetToken) -passwordResetToken csk aid nonce = do - liftIO $ signWithKey csk $ PasswordResetToken (aid, nonce) - -newNonce - :: DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> Pg (Maybe UTCTime) -newNonce accountTable aid = do - a <- runUpdateReturningList $ update accountTable - (\x -> _account_passwordResetNonce x <-. just_ current_timestamp_) - (\x -> primaryKey x ==. val_ aid) - pure $ case a of - [acc] -> _account_passwordResetNonce acc - _ -> Nothing +import Rhyolite.Backend.Account.Db hiding (createAccount, ensureAccountExists) +import Rhyolite.Backend.Account.Notify (createAccount, ensureAccountExists) diff --git a/account/backend/src/Rhyolite/Backend/Account/Db.hs b/account/backend/src/Rhyolite/Backend/Account/Db.hs new file mode 100644 index 00000000..565ffd05 --- /dev/null +++ b/account/backend/src/Rhyolite/Backend/Account/Db.hs @@ -0,0 +1,184 @@ +{-| +Description: + Create or modify accounts in the database + + This module does not handle notifications. See + Rhyolite.Backend.Account.Notify for that +-} +{-# Language DeriveGeneric #-} +{-# Language FlexibleContexts #-} +{-# Language MonoLocalBinds #-} +{-# Language OverloadedStrings #-} +module Rhyolite.Backend.Account.Db + ( createAccount + , login + , ensureAccountExists + , setAccountPassword + , setAccountPasswordHash + , makePasswordHash + , passwordResetToken + , newNonce + , resetPassword + , resetPasswordHash + ) where + +import Control.Monad (guard) +import Control.Monad.Trans.Maybe +import Crypto.PasswordStore +import Data.ByteString +import Data.Functor.Identity +import Data.Maybe +import Data.Signed +import Data.Signed.ClientSession +import Data.Text +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Encoding as T +import Data.Time +import Database.Beam +import Database.Beam.Backend.SQL.BeamExtensions +import Database.Beam.Postgres +import Database.Beam.Postgres.Full hiding (insert) +import Database.PostgreSQL.Simple.Beam () +import Rhyolite.Account +import Rhyolite.DB.Beam (current_timestamp_) +import Web.ClientSession as CS + +-- | Creates a new account and emits a db notification about it +createAccount + :: DatabaseEntity Postgres db (TableEntity Account) + -> Text + -> Text + -> Pg (Either Text (PrimaryKey Account Identity)) +createAccount accountTable email pass = do + hash <- makePasswordHash pass + accountIds <- runPgInsertReturningList $ flip returning _account_id $ insert accountTable $ insertExpressions + [ Account + { _account_id = default_ + , _account_email = lower_ (val_ email) + , _account_password = val_ (Just hash) + , _account_passwordResetNonce = just_ current_timestamp_ + } + ] + case accountIds of + [accountId] -> pure $ Right $ AccountId accountId + _ -> pure $ Left "Failed to create account" + +-- | Attempts to login a user given some credentials. +login + :: Database Postgres db + => DatabaseEntity Postgres db (TableEntity Account) + -> Text + -> Text + -> Pg (Maybe (PrimaryKey Account Identity)) +login accountTable email pass = runMaybeT $ do + (aid, mPwHash) <- MaybeT $ fmap listToMaybe $ runSelectReturningList $ select $ do + acc <- all_ accountTable + guard_ $ lower_ (_account_email acc) ==. lower_ (val_ email) + pure (_account_id acc, _account_password acc) + pwHash <- MaybeT $ pure mPwHash + guard $ verifyPasswordWith pbkdf2 (2^) (T.encodeUtf8 pass) pwHash + pure (AccountId aid) + +ensureAccountExists + :: (Database Postgres db) + => DatabaseEntity Postgres db (TableEntity Account) + -> Text + -> Pg (Bool, PrimaryKey Account Identity) +ensureAccountExists accountTable email = do + existingAccountId <- runSelectReturningOne $ select $ fmap primaryKey $ filter_ (\x -> + lower_ (_account_email x) ==. lower_ (val_ email)) $ all_ accountTable + case existingAccountId of + Just existing -> return (False, existing) + Nothing -> do + results <- runInsertReturningList $ insert accountTable $ insertExpressions + [ Account + { _account_id = default_ + , _account_email = lower_ (val_ email) + , _account_password = nothing_ + , _account_passwordResetNonce = nothing_ + } + ] + case results of + [acc] -> do + let aid = primaryKey acc + pure (True, aid) + _ -> error "ensureAccountExists: Creating account failed" + +setAccountPassword + :: DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> Text + -> Pg () +setAccountPassword tbl aid password = do + pw <- liftIO $ makePasswordHash password + setAccountPasswordHash tbl aid pw + +setAccountPasswordHash + :: DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> ByteString + -> Pg () +setAccountPasswordHash accountTable aid hash = runUpdate $ update accountTable + (\x -> mconcat + [ _account_password x <-. val_ (Just hash) + , _account_passwordResetNonce x <-. nothing_ + ] + ) + (\x -> primaryKey x ==. val_ aid) + +makePasswordHash + :: MonadIO m + => Text + -> m ByteString +makePasswordHash pw = do + salt <- liftIO genSaltIO + return $ makePasswordSaltWith pbkdf2 (2^) (encodeUtf8 pw) salt 14 + +resetPassword + :: (Database Postgres db) + => DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> UTCTime + -> Text + -> Pg (Maybe (PrimaryKey Account Identity)) +resetPassword tbl aid t pw = do + hash <- makePasswordHash pw + resetPasswordHash tbl aid t hash + +resetPasswordHash + :: (Database Postgres db) + => DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> UTCTime + -> ByteString + -> Pg (Maybe (PrimaryKey Account Identity)) +resetPasswordHash accountTable aid nonce pwhash = do + macc <- runSelectReturningOne $ lookup_ accountTable aid + case macc of + Nothing -> return Nothing + Just a -> if _account_passwordResetNonce a == Just nonce + then do + setAccountPasswordHash accountTable aid pwhash + return $ Just aid + else fail "nonce mismatch" + +passwordResetToken + :: MonadIO m + => CS.Key + -> PrimaryKey Account Identity + -> UTCTime + -> m (Signed PasswordResetToken) +passwordResetToken csk aid nonce = do + liftIO $ signWithKey csk $ PasswordResetToken (aid, nonce) + +newNonce + :: DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> Pg (Maybe UTCTime) +newNonce accountTable aid = do + a <- runUpdateReturningList $ update accountTable + (\x -> _account_passwordResetNonce x <-. just_ current_timestamp_) + (\x -> primaryKey x ==. val_ aid) + pure $ case a of + [acc] -> _account_passwordResetNonce acc + _ -> Nothing diff --git a/account/backend/src/Rhyolite/Backend/Account/Notify.hs b/account/backend/src/Rhyolite/Backend/Account/Notify.hs new file mode 100644 index 00000000..13feca22 --- /dev/null +++ b/account/backend/src/Rhyolite/Backend/Account/Notify.hs @@ -0,0 +1,60 @@ +{-| +Description: + Create or modify accounts in the database, and send LISTEN notifications +-} +{-# Language DeriveGeneric #-} +{-# Language FlexibleContexts #-} +{-# Language MonoLocalBinds #-} +{-# Language OverloadedStrings #-} +module Rhyolite.Backend.Account.Notify + ( createAccount + , login + , ensureAccountExists + , setAccountPassword + , setAccountPasswordHash + , makePasswordHash + , passwordResetToken + , newNonce + , resetPassword + , resetPasswordHash + ) where + +import Data.Aeson +import Data.Constraint.Extras +import Data.Constraint.Forall +import Data.Functor.Identity +import Data.Text +import Database.Beam +import Database.Beam.Postgres +import Database.PostgreSQL.Simple.Beam () +import Rhyolite.Account +import Rhyolite.Backend.Account.Db hiding (createAccount, ensureAccountExists) +import qualified Rhyolite.Backend.Account.Db as Acc +import Rhyolite.DB.NotifyListen +import Rhyolite.DB.NotifyListen.Beam + +-- | Creates a new account and emits a db notification about it +createAccount + :: (Has' ToJSON notice Identity, ForallF ToJSON notice) + => DatabaseEntity Postgres db (TableEntity Account) + -> notice (PrimaryKey Account Identity) + -> Text + -> Text + -> Pg (Either Text (PrimaryKey Account Identity)) +createAccount accountTable noticeWrapper email pass = do + result <- Acc.createAccount accountTable email pass + case result of + Right accountId -> + notify NotificationType_Insert noticeWrapper accountId + _ -> pure () + pure result + +ensureAccountExists + :: (Database Postgres db, HasNotification n Account, Has' ToJSON n Identity, ForallF ToJSON n) + => DatabaseEntity Postgres db (TableEntity Account) + -> Text + -> Pg (Bool, PrimaryKey Account Identity) +ensureAccountExists accountTable email = do + aid <- Acc.ensureAccountExists accountTable email + notify NotificationType_Insert (notification accountTable) $ snd aid + pure aid From bd2155d1e7d7e7e3cd3b1a72ea45331f6f81a079 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 1 Sep 2023 10:34:54 -0400 Subject: [PATCH 14/24] account: make it possible to use accounts without notify --- ChangeLog.md | 4 + .../backend/rhyolite-account-backend.cabal | 2 + .../backend/src/Rhyolite/Backend/Account.hs | 173 +--------------- .../src/Rhyolite/Backend/Account/Db.hs | 184 ++++++++++++++++++ .../src/Rhyolite/Backend/Account/Notify.hs | 60 ++++++ 5 files changed, 252 insertions(+), 171 deletions(-) create mode 100644 account/backend/src/Rhyolite/Backend/Account/Db.hs create mode 100644 account/backend/src/Rhyolite/Backend/Account/Notify.hs diff --git a/ChangeLog.md b/ChangeLog.md index e6e921a2..65c3397e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,10 @@ This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released, and the date should reflect that release. +## Unreleased + +* Make it possible to use Rhyolite.Backend.Account without notifications. See Rhyolite.Backend.Account.Db for versions of createAccount and ensureAccountExists that don't send notifications. + ## v1.0.0.0 2023-08-03 * Breaking: Drop groundhog support * Breaking: Use Commutative from commutative-semigroups instead of Additive from patch diff --git a/account/backend/rhyolite-account-backend.cabal b/account/backend/rhyolite-account-backend.cabal index 71033d12..2449f253 100644 --- a/account/backend/rhyolite-account-backend.cabal +++ b/account/backend/rhyolite-account-backend.cabal @@ -13,6 +13,8 @@ category: Web library exposed-modules: Rhyolite.Backend.Account + Rhyolite.Backend.Account.Db + Rhyolite.Backend.Account.Notify build-depends: base , aeson , beam-core diff --git a/account/backend/src/Rhyolite/Backend/Account.hs b/account/backend/src/Rhyolite/Backend/Account.hs index e5b74879..8d18f272 100644 --- a/account/backend/src/Rhyolite/Backend/Account.hs +++ b/account/backend/src/Rhyolite/Backend/Account.hs @@ -19,174 +19,5 @@ module Rhyolite.Backend.Account , resetPasswordHash ) where -import Control.Monad (guard) -import Control.Monad.Trans.Maybe -import Crypto.PasswordStore -import Data.Aeson -import Data.ByteString -import Data.Constraint.Extras -import Data.Constraint.Forall -import Data.Functor.Identity -import Data.Maybe -import Data.Text -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Text.Encoding as T -import Data.Time -import Database.Beam -import Database.Beam.Backend.SQL.BeamExtensions -import Database.Beam.Postgres -import Data.Signed -import Data.Signed.ClientSession -import Database.Beam.Postgres.Full hiding (insert) -import Database.Beam.Postgres.Syntax -import Database.PostgreSQL.Simple.Beam () -import Rhyolite.Account -import Rhyolite.DB.Beam (current_timestamp_) -import Rhyolite.DB.NotifyListen -import Rhyolite.DB.NotifyListen.Beam -import Web.ClientSession as CS - --- | Creates a new account and emits a db notification about it -createAccount - :: (Has' ToJSON notice Identity, ForallF ToJSON notice) - => DatabaseEntity Postgres db (TableEntity Account) - -> notice (PrimaryKey Account Identity) - -> Text - -> Text - -> Pg (Either Text (PrimaryKey Account Identity)) -createAccount accountTable noticeWrapper email pass = do - hash <- makePasswordHash pass - accountIds <- runPgInsertReturningList $ flip returning _account_id $ insert accountTable $ insertExpressions - [ Account - { _account_id = default_ - , _account_email = lower_ (val_ email) - , _account_password = val_ (Just hash) - , _account_passwordResetNonce = just_ current_timestamp_ - } - ] - case accountIds of - [accountId] -> do - notify NotificationType_Insert noticeWrapper (AccountId accountId) - pure $ Right $ AccountId accountId - _ -> pure $ Left "Failed to create account" - --- | Attempts to login a user given some credentials. -login - :: Database Postgres db - => DatabaseEntity Postgres db (TableEntity Account) - -> Text - -> Text - -> Pg (Maybe (PrimaryKey Account Identity)) -login accountTable email pass = runMaybeT $ do - (aid, mPwHash) <- MaybeT $ fmap listToMaybe $ runSelectReturningList $ select $ do - acc <- all_ accountTable - guard_ $ lower_ (_account_email acc) ==. lower_ (val_ email) - pure (_account_id acc, _account_password acc) - pwHash <- MaybeT $ pure mPwHash - guard $ verifyPasswordWith pbkdf2 (2^) (T.encodeUtf8 pass) pwHash - pure (AccountId aid) - -ensureAccountExists - :: (Database Postgres db, HasNotification n Account, Has' ToJSON n Identity, ForallF ToJSON n) - => DatabaseEntity Postgres db (TableEntity Account) - -> Text - -> Pg (Bool, PrimaryKey Account Identity) -ensureAccountExists accountTable email = do - existingAccountId <- runSelectReturningOne $ select $ fmap primaryKey $ filter_ (\x -> - lower_ (_account_email x) ==. lower_ (val_ email)) $ all_ accountTable - case existingAccountId of - Just existing -> return (False, existing) - Nothing -> do - results <- runInsertReturningList $ insert accountTable $ insertExpressions - [ Account - { _account_id = default_ - , _account_email = lower_ (val_ email) - , _account_password = nothing_ - , _account_passwordResetNonce = nothing_ - } - ] - case results of - [acc] -> do - let aid = primaryKey acc - notify NotificationType_Insert (notification accountTable) aid - pure (True, aid) - _ -> error "ensureAccountExists: Creating account failed" - -setAccountPassword - :: DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> Text - -> Pg () -setAccountPassword tbl aid password = do - pw <- liftIO $ makePasswordHash password - setAccountPasswordHash tbl aid pw - -setAccountPasswordHash - :: DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> ByteString - -> Pg () -setAccountPasswordHash accountTable aid hash = runUpdate $ update accountTable - (\x -> mconcat - [ _account_password x <-. val_ (Just hash) - , _account_passwordResetNonce x <-. nothing_ - ] - ) - (\x -> primaryKey x ==. val_ aid) - -makePasswordHash - :: MonadIO m - => Text - -> m ByteString -makePasswordHash pw = do - salt <- liftIO genSaltIO - return $ makePasswordSaltWith pbkdf2 (2^) (encodeUtf8 pw) salt 14 - -resetPassword - :: (Database Postgres db) - => DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> UTCTime - -> Text - -> Pg (Maybe (PrimaryKey Account Identity)) -resetPassword tbl aid t pw = do - hash <- makePasswordHash pw - resetPasswordHash tbl aid t hash - -resetPasswordHash - :: (Database Postgres db) - => DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> UTCTime - -> ByteString - -> Pg (Maybe (PrimaryKey Account Identity)) -resetPasswordHash accountTable aid nonce pwhash = do - macc <- runSelectReturningOne $ lookup_ accountTable aid - case macc of - Nothing -> return Nothing - Just a -> if _account_passwordResetNonce a == Just nonce - then do - setAccountPasswordHash accountTable aid pwhash - return $ Just aid - else fail "nonce mismatch" - -passwordResetToken - :: MonadIO m - => CS.Key - -> PrimaryKey Account Identity - -> UTCTime - -> m (Signed PasswordResetToken) -passwordResetToken csk aid nonce = do - liftIO $ signWithKey csk $ PasswordResetToken (aid, nonce) - -newNonce - :: DatabaseEntity Postgres db (TableEntity Account) - -> PrimaryKey Account Identity - -> Pg (Maybe UTCTime) -newNonce accountTable aid = do - a <- runUpdateReturningList $ update accountTable - (\x -> _account_passwordResetNonce x <-. just_ current_timestamp_) - (\x -> primaryKey x ==. val_ aid) - pure $ case a of - [acc] -> _account_passwordResetNonce acc - _ -> Nothing +import Rhyolite.Backend.Account.Db hiding (createAccount, ensureAccountExists) +import Rhyolite.Backend.Account.Notify (createAccount, ensureAccountExists) diff --git a/account/backend/src/Rhyolite/Backend/Account/Db.hs b/account/backend/src/Rhyolite/Backend/Account/Db.hs new file mode 100644 index 00000000..565ffd05 --- /dev/null +++ b/account/backend/src/Rhyolite/Backend/Account/Db.hs @@ -0,0 +1,184 @@ +{-| +Description: + Create or modify accounts in the database + + This module does not handle notifications. See + Rhyolite.Backend.Account.Notify for that +-} +{-# Language DeriveGeneric #-} +{-# Language FlexibleContexts #-} +{-# Language MonoLocalBinds #-} +{-# Language OverloadedStrings #-} +module Rhyolite.Backend.Account.Db + ( createAccount + , login + , ensureAccountExists + , setAccountPassword + , setAccountPasswordHash + , makePasswordHash + , passwordResetToken + , newNonce + , resetPassword + , resetPasswordHash + ) where + +import Control.Monad (guard) +import Control.Monad.Trans.Maybe +import Crypto.PasswordStore +import Data.ByteString +import Data.Functor.Identity +import Data.Maybe +import Data.Signed +import Data.Signed.ClientSession +import Data.Text +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Encoding as T +import Data.Time +import Database.Beam +import Database.Beam.Backend.SQL.BeamExtensions +import Database.Beam.Postgres +import Database.Beam.Postgres.Full hiding (insert) +import Database.PostgreSQL.Simple.Beam () +import Rhyolite.Account +import Rhyolite.DB.Beam (current_timestamp_) +import Web.ClientSession as CS + +-- | Creates a new account and emits a db notification about it +createAccount + :: DatabaseEntity Postgres db (TableEntity Account) + -> Text + -> Text + -> Pg (Either Text (PrimaryKey Account Identity)) +createAccount accountTable email pass = do + hash <- makePasswordHash pass + accountIds <- runPgInsertReturningList $ flip returning _account_id $ insert accountTable $ insertExpressions + [ Account + { _account_id = default_ + , _account_email = lower_ (val_ email) + , _account_password = val_ (Just hash) + , _account_passwordResetNonce = just_ current_timestamp_ + } + ] + case accountIds of + [accountId] -> pure $ Right $ AccountId accountId + _ -> pure $ Left "Failed to create account" + +-- | Attempts to login a user given some credentials. +login + :: Database Postgres db + => DatabaseEntity Postgres db (TableEntity Account) + -> Text + -> Text + -> Pg (Maybe (PrimaryKey Account Identity)) +login accountTable email pass = runMaybeT $ do + (aid, mPwHash) <- MaybeT $ fmap listToMaybe $ runSelectReturningList $ select $ do + acc <- all_ accountTable + guard_ $ lower_ (_account_email acc) ==. lower_ (val_ email) + pure (_account_id acc, _account_password acc) + pwHash <- MaybeT $ pure mPwHash + guard $ verifyPasswordWith pbkdf2 (2^) (T.encodeUtf8 pass) pwHash + pure (AccountId aid) + +ensureAccountExists + :: (Database Postgres db) + => DatabaseEntity Postgres db (TableEntity Account) + -> Text + -> Pg (Bool, PrimaryKey Account Identity) +ensureAccountExists accountTable email = do + existingAccountId <- runSelectReturningOne $ select $ fmap primaryKey $ filter_ (\x -> + lower_ (_account_email x) ==. lower_ (val_ email)) $ all_ accountTable + case existingAccountId of + Just existing -> return (False, existing) + Nothing -> do + results <- runInsertReturningList $ insert accountTable $ insertExpressions + [ Account + { _account_id = default_ + , _account_email = lower_ (val_ email) + , _account_password = nothing_ + , _account_passwordResetNonce = nothing_ + } + ] + case results of + [acc] -> do + let aid = primaryKey acc + pure (True, aid) + _ -> error "ensureAccountExists: Creating account failed" + +setAccountPassword + :: DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> Text + -> Pg () +setAccountPassword tbl aid password = do + pw <- liftIO $ makePasswordHash password + setAccountPasswordHash tbl aid pw + +setAccountPasswordHash + :: DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> ByteString + -> Pg () +setAccountPasswordHash accountTable aid hash = runUpdate $ update accountTable + (\x -> mconcat + [ _account_password x <-. val_ (Just hash) + , _account_passwordResetNonce x <-. nothing_ + ] + ) + (\x -> primaryKey x ==. val_ aid) + +makePasswordHash + :: MonadIO m + => Text + -> m ByteString +makePasswordHash pw = do + salt <- liftIO genSaltIO + return $ makePasswordSaltWith pbkdf2 (2^) (encodeUtf8 pw) salt 14 + +resetPassword + :: (Database Postgres db) + => DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> UTCTime + -> Text + -> Pg (Maybe (PrimaryKey Account Identity)) +resetPassword tbl aid t pw = do + hash <- makePasswordHash pw + resetPasswordHash tbl aid t hash + +resetPasswordHash + :: (Database Postgres db) + => DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> UTCTime + -> ByteString + -> Pg (Maybe (PrimaryKey Account Identity)) +resetPasswordHash accountTable aid nonce pwhash = do + macc <- runSelectReturningOne $ lookup_ accountTable aid + case macc of + Nothing -> return Nothing + Just a -> if _account_passwordResetNonce a == Just nonce + then do + setAccountPasswordHash accountTable aid pwhash + return $ Just aid + else fail "nonce mismatch" + +passwordResetToken + :: MonadIO m + => CS.Key + -> PrimaryKey Account Identity + -> UTCTime + -> m (Signed PasswordResetToken) +passwordResetToken csk aid nonce = do + liftIO $ signWithKey csk $ PasswordResetToken (aid, nonce) + +newNonce + :: DatabaseEntity Postgres db (TableEntity Account) + -> PrimaryKey Account Identity + -> Pg (Maybe UTCTime) +newNonce accountTable aid = do + a <- runUpdateReturningList $ update accountTable + (\x -> _account_passwordResetNonce x <-. just_ current_timestamp_) + (\x -> primaryKey x ==. val_ aid) + pure $ case a of + [acc] -> _account_passwordResetNonce acc + _ -> Nothing diff --git a/account/backend/src/Rhyolite/Backend/Account/Notify.hs b/account/backend/src/Rhyolite/Backend/Account/Notify.hs new file mode 100644 index 00000000..13feca22 --- /dev/null +++ b/account/backend/src/Rhyolite/Backend/Account/Notify.hs @@ -0,0 +1,60 @@ +{-| +Description: + Create or modify accounts in the database, and send LISTEN notifications +-} +{-# Language DeriveGeneric #-} +{-# Language FlexibleContexts #-} +{-# Language MonoLocalBinds #-} +{-# Language OverloadedStrings #-} +module Rhyolite.Backend.Account.Notify + ( createAccount + , login + , ensureAccountExists + , setAccountPassword + , setAccountPasswordHash + , makePasswordHash + , passwordResetToken + , newNonce + , resetPassword + , resetPasswordHash + ) where + +import Data.Aeson +import Data.Constraint.Extras +import Data.Constraint.Forall +import Data.Functor.Identity +import Data.Text +import Database.Beam +import Database.Beam.Postgres +import Database.PostgreSQL.Simple.Beam () +import Rhyolite.Account +import Rhyolite.Backend.Account.Db hiding (createAccount, ensureAccountExists) +import qualified Rhyolite.Backend.Account.Db as Acc +import Rhyolite.DB.NotifyListen +import Rhyolite.DB.NotifyListen.Beam + +-- | Creates a new account and emits a db notification about it +createAccount + :: (Has' ToJSON notice Identity, ForallF ToJSON notice) + => DatabaseEntity Postgres db (TableEntity Account) + -> notice (PrimaryKey Account Identity) + -> Text + -> Text + -> Pg (Either Text (PrimaryKey Account Identity)) +createAccount accountTable noticeWrapper email pass = do + result <- Acc.createAccount accountTable email pass + case result of + Right accountId -> + notify NotificationType_Insert noticeWrapper accountId + _ -> pure () + pure result + +ensureAccountExists + :: (Database Postgres db, HasNotification n Account, Has' ToJSON n Identity, ForallF ToJSON n) + => DatabaseEntity Postgres db (TableEntity Account) + -> Text + -> Pg (Bool, PrimaryKey Account Identity) +ensureAccountExists accountTable email = do + aid <- Acc.ensureAccountExists accountTable email + notify NotificationType_Insert (notification accountTable) $ snd aid + pure aid From 35c1063200ad5155d42baf14da48dfb622628e1b Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 3 Sep 2023 21:16:45 -0400 Subject: [PATCH 15/24] account: Re-add login to export list --- account/backend/src/Rhyolite/Backend/Account.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/account/backend/src/Rhyolite/Backend/Account.hs b/account/backend/src/Rhyolite/Backend/Account.hs index acfabde0..5d7ceda9 100644 --- a/account/backend/src/Rhyolite/Backend/Account.hs +++ b/account/backend/src/Rhyolite/Backend/Account.hs @@ -9,6 +9,7 @@ Description: module Rhyolite.Backend.Account ( createAccount , ensureAccountExists + , login , setAccountPassword , setAccountPasswordHash , makePasswordHash From 7589b06da525303584d6b8b5d7999df9b674f773 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 5 Sep 2023 10:07:24 -0400 Subject: [PATCH 16/24] account: Add AccountId type synonym --- account/types/src/Rhyolite/Account.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/account/types/src/Rhyolite/Account.hs b/account/types/src/Rhyolite/Account.hs index 19ba1cdb..0e633a2c 100644 --- a/account/types/src/Rhyolite/Account.hs +++ b/account/types/src/Rhyolite/Account.hs @@ -37,6 +37,8 @@ instance Table Account where instance Beamable (PrimaryKey Account) +type AccountId = PrimaryKey Account Identity + deriving instance Eq (PrimaryKey Account Identity) deriving instance Ord (PrimaryKey Account Identity) deriving instance Show (PrimaryKey Account Identity) From ab7e62ed76f8c921c31d65a59f35b4bfd9d200c5 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 29 Dec 2023 07:37:18 -0500 Subject: [PATCH 17/24] obelisk 1.1 -> 1.3 --- ChangeLog.md | 1 + default.nix | 1 - dep/beam-automigrate/github.json | 6 +++--- dep/gargoyle/github.json | 4 ++-- dep/obelisk/github.json | 6 +++--- dep/vessel/github.json | 6 +++--- 6 files changed, 12 insertions(+), 12 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 65c3397e..d2faa51f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,6 +5,7 @@ This project's release branch is `master`. This log is written from the perspect ## Unreleased * Make it possible to use Rhyolite.Backend.Account without notifications. See Rhyolite.Backend.Account.Db for versions of createAccount and ensureAccountExists that don't send notifications. +* Update to obelisk v1.3.0.0 ## v1.0.0.0 2023-08-03 * Breaking: Drop groundhog support diff --git a/default.nix b/default.nix index 7c08609f..fe531ef6 100644 --- a/default.nix +++ b/default.nix @@ -68,7 +68,6 @@ let validation = haskellLib.dontCheck super.validation; postgresql-lo-stream = haskellLib.markUnbroken super.postgresql-lo-stream; - monoid-subclasses = super.monoid-subclasses_1_1; HaskellNet-SSL = self.callHackage "HaskellNet-SSL" "0.3.4.4" {}; base-orphans = self.callHackageDirect { diff --git a/dep/beam-automigrate/github.json b/dep/beam-automigrate/github.json index c6411f41..a9656852 100644 --- a/dep/beam-automigrate/github.json +++ b/dep/beam-automigrate/github.json @@ -1,8 +1,8 @@ { "owner": "obsidiansystems", "repo": "beam-automigrate", - "branch": "release/0.1.4.0", + "branch": "develop", "private": false, - "rev": "a5d0090acd05a444a75dd3effecbba82ea195561", - "sha256": "03fdxwr14vjpif5c0vzqff5x21q98v5slqba1qg4ki092bwws6l6" + "rev": "5bd03ad708583d7edcd5a796e7d6306bdd3919a8", + "sha256": "1cl7z1srig1h7wzai583ggi4alc8ln39yrspvsagp9d94xrwads3" } diff --git a/dep/gargoyle/github.json b/dep/gargoyle/github.json index c9a5e4c9..bc040df0 100644 --- a/dep/gargoyle/github.json +++ b/dep/gargoyle/github.json @@ -3,6 +3,6 @@ "repo": "gargoyle", "branch": "develop", "private": false, - "rev": "dfa94ae8366beca396015f320ad8937b376be36a", - "sha256": "0dk42ly6q92zc9qkq0fz9lvnprab5r76k8lrrm9y5jj3ig7zbsy8" + "rev": "d9a2b0ab4297d883caef784c7c11891611a6d4b0", + "sha256": "1rxqvy10bgzd3bldrv223m71j3nll297llcpaiz32nyzjdw2rwik" } diff --git a/dep/obelisk/github.json b/dep/obelisk/github.json index ca7a270c..4b45bef3 100644 --- a/dep/obelisk/github.json +++ b/dep/obelisk/github.json @@ -1,8 +1,8 @@ { "owner": "obsidiansystems", "repo": "obelisk", - "branch": "release/1.1.1.0", + "branch": "release/1.3.0.0", "private": false, - "rev": "d77d8e29bde6c1f336a38296dd47043abb2d789c", - "sha256": "1k34qhxkc6apzpz7lsdykd4r6j342zqis1m0m2x9377v875vrxvl" + "rev": "58c04270d606c061e7ffd2f16345e0f451eba600", + "sha256": "167h4qkkc7rvhwlfbv3fdj3gd8jn5svdawh2vzpi04j9xlsw3jlf" } diff --git a/dep/vessel/github.json b/dep/vessel/github.json index 95beaaf3..a1430326 100644 --- a/dep/vessel/github.json +++ b/dep/vessel/github.json @@ -1,8 +1,8 @@ { "owner": "obsidiansystems", "repo": "vessel", - "branch": "release/0.3.0.0", + "branch": "release/0.3.0.0-r1", "private": false, - "rev": "c290833764f4054ee52047e3604c323493c1e5e8", - "sha256": "173sq64q3m41s3nlv601zzl171kq5kgd8sql45yrrnjw72rf1hjj" + "rev": "a0eafdd20b3844dd23e3b0ac537049c60b9049b0", + "sha256": "19nn25sdr4hxvd9i81aqvx2hm7c6dg9zzb244rl21jp689nnkxqk" } From 79f21b0e03a363e2c04ad4353baca58f6849f73e Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Wed, 8 May 2024 12:24:07 -0400 Subject: [PATCH 18/24] Make authentication easier to use and fix some things about ErrorV The forced polymorphism in handlePersonalAuthMapQuery was preventing use of ErrorV for handling authorization failures (because its operations are intentionally monomorphic). liftErrorV was not a good primitive to make queries, it would have been fine for reporting success, but did not explicitly register interest in the error part. Because of that, cropV would have quietly deleted the errors from the view. I'd be surprised if anything using this managed to avoid this pitfall. As such, liftErrorV has been replaced by two new primitives: queryErrorV for registering interest in a view wrapped in ErrorV, and successErrorV for constructing a successful Identity view. I also removed unsafeProjectE / unsafeProjectV from ErrorV rather than reworking them because the things they did were not entirely sensible to begin with: * unsafeProjectE was requesting only errors from the backend, but then discarding those errors from the corresponding view on the way back. If you want that, you ought to avoid registering interest in the ErrorV in the first place, rather than making the backend work to discover that there's an error you're going to ignore. * unsafeProjectV was treating failures the same way as lag (which is maybe on a rare occasion something you'd want, but let's not encourage it). --- common/Rhyolite/Vessel/AuthMapV.hs | 45 +++++++++++++++-------- common/Rhyolite/Vessel/AuthenticatedV.hs | 18 ++++----- common/Rhyolite/Vessel/ErrorV/Internal.hs | 41 ++++++--------------- 3 files changed, 48 insertions(+), 56 deletions(-) diff --git a/common/Rhyolite/Vessel/AuthMapV.hs b/common/Rhyolite/Vessel/AuthMapV.hs index 114a2f3c..23e0fcda 100644 --- a/common/Rhyolite/Vessel/AuthMapV.hs +++ b/common/Rhyolite/Vessel/AuthMapV.hs @@ -24,6 +24,7 @@ import Data.Aeson import Data.Constraint.Extras import Data.Maybe import qualified Data.Map.Monoidal as MMap +import Data.Map.Monoidal (MonoidalMap) import qualified Data.Map as DataMap import qualified Data.Map.Strict as Map import Data.Patch @@ -55,9 +56,9 @@ getAuthMapV (AuthMapV v) = mkSubVessel $ MMap.mapMaybeWithKey (\_ -> snd . unsaf -- | Construct an authorised 'AuthMapV' makeAuthMapV :: (Ord auth, View v) - => SubVessel auth v g - -> AuthMapV auth v g -makeAuthMapV = AuthMapV . mkSubVessel . MMap.mapMaybeWithKey (\_ -> Just . liftErrorV) . getSubVessel + => SubVessel auth v Identity + -> AuthMapV auth v Identity +makeAuthMapV = AuthMapV . mkSubVessel . MMap.mapMaybeWithKey (\_ -> Just . successErrorV) . getSubVessel deriving instance (Ord auth, Eq (view g), Eq (g (First (Maybe ())))) => Eq (AuthMapV auth view g) @@ -193,11 +194,8 @@ handlePersonalAuthMapQuery => (token -> Maybe user) -- ^ How to figure out the identity corresponding to a token. Note: this is pure because it absolutely must be cheap. See the corresponding comment on -- 'handleAuthMapQuery'. - -> (forall f g. - ViewQueryResult f ~ g - => (forall x. x -> f x -> g x) - -> v (Compose (MMap.MonoidalMap user) f) - -> m (v (Compose (MMap.MonoidalMap user) g)) + -> (v (Compose (MMap.MonoidalMap user) Proxy) + -> m (v (Compose (MMap.MonoidalMap user) Identity)) ) -- ^ Handle the query for each individual identity -> AuthMapV token v Proxy @@ -221,9 +219,6 @@ handlePersonalAuthMapQuery readToken handler vt = do . (MMap.foldMapWithKey $ \t (Compose u) -> TaggedQuery (Set.singleton t) <$ u) . getCompose - injectResult :: forall x. x -> TaggedQuery (Set token) x -> ((Set token), x) - injectResult x (TaggedQuery xs) = (xs, x) - disperseTokens :: MMap.MonoidalMap user (Set token, a) -> Compose (MMap.MonoidalMap token) Identity a @@ -237,11 +232,29 @@ handlePersonalAuthMapQuery readToken handler vt = do $ getSubVessel $ getAuthMapV vt - vt' <- handler injectResult $ mapV condenseTokens $ condenseV $ getSubVessel vtReadToken - - -- TODO: warn about collisions in alignWithV - pure $ alignWithV (these id id const) (AuthMapV $ mkSubVessel $ MMap.MonoidalMap invalidTokens) - (makeAuthMapV (mkSubVessel $ disperseV $ mapV (disperseTokens . getCompose) vt')) + let condensedV = condenseV $ getSubVessel vtReadToken + condensedTokensV :: v (Compose (MonoidalMap user) (TaggedQuery (Set token))) + condensedTokensV = mapV condenseTokens condensedV + queryByUserV :: v (Compose (MonoidalMap user) Proxy) + queryByUserV = mapV (\(Compose m) -> Compose (fmap (const Proxy) m)) condensedTokensV + + views <- handler queryByUserV + + let reattachToken :: TaggedQuery (Set token) a -> Identity a -> (Set token, a) + reattachToken (TaggedQuery s) (Identity x) = (s,x) + + reattachTokenMap :: Compose (MonoidalMap user) (TaggedQuery (Set token)) a + -> Compose (MonoidalMap user) Identity a + -> Compose (MonoidalMap user) ((,) (Set token)) a + reattachTokenMap (Compose mtokens) (Compose mviews) = Compose (MMap.intersectionWith reattachToken mtokens mviews) + tokenedViewsM :: Maybe (v (Compose (MonoidalMap user) ((,) (Set token)))) + tokenedViewsM = cropV reattachTokenMap condensedTokensV views + case tokenedViewsM of + Nothing -> return emptyV + Just tokenedViews -> + -- TODO: warn about collisions in alignWithV + pure $ alignWithV (these id id const) (AuthMapV $ mkSubVessel $ MMap.MonoidalMap invalidTokens) + (makeAuthMapV (mkSubVessel $ disperseV $ mapV (disperseTokens . getCompose) tokenedViews)) -- | A query morphism that takes a view for a single identity and lifts it to -- a map of identities to views. diff --git a/common/Rhyolite/Vessel/AuthenticatedV.hs b/common/Rhyolite/Vessel/AuthenticatedV.hs index 19a4daf7..cd07c724 100644 --- a/common/Rhyolite/Vessel/AuthenticatedV.hs +++ b/common/Rhyolite/Vessel/AuthenticatedV.hs @@ -18,7 +18,6 @@ {-# LANGUAGE RankNTypes #-} module Rhyolite.Vessel.AuthenticatedV where -import Control.Applicative import Control.Monad import Data.Aeson import Data.Aeson.GADT.TH @@ -33,7 +32,6 @@ import Data.Vessel import Data.Vessel.Vessel import Data.Semigroup import Data.Semigroup.Commutative -import Data.Vessel.Path (Keyed(..)) import GHC.Generics import Reflex.Query.Class import Data.Map.Monoidal (MonoidalMap) @@ -54,7 +52,6 @@ import Control.Applicative (Alternative) import Prelude hiding ((.), id) import Control.Category import Data.Vessel.ViewMorphism (ViewQueryResult, ViewMorphism(..), ViewHalfMorphism(..)) -import Data.Vessel.Vessel (vessel) import Data.Bifoldable -- TODO upstream this instance @@ -173,11 +170,8 @@ handleAuthenticatedQuery -> (private Proxy -> m (private Identity)) -- ^ The result of private queries is only available to authenticated identities -- but the result is the same for all of them. - -> ( forall f g. - ViewQueryResult f ~ g - => (forall x. x -> f x -> g x) - -> personal (Compose (MonoidalMap user) f) - -> m (personal (Compose (MonoidalMap user) g))) + -> ( personal (Compose (MonoidalMap user) Proxy) + -> m (personal (Compose (MonoidalMap user) Identity))) -- ^ The result of personal queries depends on the identity making the query -> AuthenticatedV public (AuthMapV token private) (AuthMapV token personal) Proxy -> m (AuthenticatedV public (AuthMapV token private) (AuthMapV token personal) Identity) @@ -383,6 +377,8 @@ disperseAuthenticatedErrorV :: ( View publicV , Semigroup (publicV Identity) , EmptyView privateV , Semigroup (privateV Identity) , EmptyView personalV , Semigroup (personalV Identity) + , Num x, Semigroup x, Semigroup (privateV (Const x)) + , Semigroup (personalV (Const x)) ) => QueryMorphism (ErrorV () (AuthenticatedV publicV privateV personalV) (Const x)) @@ -390,10 +386,10 @@ disperseAuthenticatedErrorV :: disperseAuthenticatedErrorV = QueryMorphism (maybe emptyV (runIdentity . traverseAuthenticatedV pure - (pure . liftErrorV) - (pure . liftErrorV)) + (pure . queryErrorVConst) + (pure . queryErrorVConst)) . snd . unsafeObserveErrorV) - (bifoldMap @(,) (maybe emptyV failureErrorV . (=<<) (getFirst . runIdentity)) liftErrorV + (bifoldMap @(,) (maybe emptyV failureErrorV . (=<<) (getFirst . runIdentity)) successErrorV . traverseAuthenticatedV ((,) Nothing) (fmap (maybe emptyV id) . unsafeObserveErrorV) diff --git a/common/Rhyolite/Vessel/ErrorV/Internal.hs b/common/Rhyolite/Vessel/ErrorV/Internal.hs index ddcb17c8..d79cb91c 100644 --- a/common/Rhyolite/Vessel/ErrorV/Internal.hs +++ b/common/Rhyolite/Vessel/ErrorV/Internal.hs @@ -8,6 +8,7 @@ {-# Language LambdaCase #-} {-# Language MultiParamTypeClasses #-} {-# Language PolyKinds #-} +{-# Language RankNTypes #-} {-# Language StandaloneDeriving #-} {-# Language TemplateHaskell #-} {-# Language TypeFamilies #-} @@ -122,9 +123,17 @@ instance type QueryResult (ErrorV err v (Compose c g)) = ErrorV err v (Compose c (VesselLeafWrapper (QueryResult (Vessel (ErrorVK err v) g)))) crop (ErrorV s) (ErrorV r) = ErrorV $ crop s r +-- | Construct a query that registers interest in both the success and error parts of an ErrorV. +queryErrorV :: (View v, Semigroup (v Proxy)) => v Proxy -> ErrorV e v Proxy +queryErrorV v = ErrorV (singletonV ErrorVK_View v <> singletonV ErrorVK_Error (SingleV Proxy)) + +-- | Construct a query that registers interest in both the success and error parts of an ErrorV. +queryErrorVConst :: (View v, Num x, Semigroup x, Semigroup (v (Const x))) => v (Const x) -> ErrorV e v (Const x) +queryErrorVConst v = ErrorV (singletonV ErrorVK_View v <> singletonV ErrorVK_Error (SingleV (Const 1))) + -- | The error part of the view will never be present -liftErrorV :: View v => v g -> ErrorV e v g -liftErrorV = ErrorV . singletonV ErrorVK_View +successErrorV :: View v => v Identity -> ErrorV e v Identity +successErrorV = ErrorV . singletonV ErrorVK_View -- | The successful part of the view will never be present failureErrorV :: e -> ErrorV e v Identity @@ -141,7 +150,7 @@ buildErrorV f (ErrorV v) = case lookupV ErrorVK_View v of Nothing -> pure (ErrorV emptyV) Just v' -> f v' >>= \case Left err -> pure $ failureErrorV err - Right val -> pure $ liftErrorV val + Right val -> pure $ successErrorV val -- | Given an 'ErrorV' result, observe whether it is an error result -- or a result of the underlying view type. @@ -166,29 +175,3 @@ unsafeObserveErrorV (ErrorV v) = let err = fmap unSingleV $ lookupV ErrorVK_Error v in (err, lookupV ErrorVK_View v) - - --- | A morphism that only cares about error results. -unsafeProjectE - :: ( EmptyView v - ) - => QueryMorphism - () - (ErrorV () v (Const SelectedCount)) -unsafeProjectE = QueryMorphism - { _queryMorphism_mapQuery = const (liftErrorV emptyV) - , _queryMorphism_mapQueryResult = const () - } - --- | A morphism that only cares about successful results. -unsafeProjectV - :: (EmptyView v, QueryResult (v (Const SelectedCount)) ~ v Identity) - => QueryMorphism - (v (Const SelectedCount)) - (ErrorV () v (Const SelectedCount)) -unsafeProjectV = QueryMorphism - { _queryMorphism_mapQuery = liftErrorV - , _queryMorphism_mapQueryResult = \r -> case observeErrorV r of - Left _ -> emptyV - Right r' -> r' - } From 81752cc08a62a16e6306b470c765661b54ce0dfc Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Wed, 8 May 2024 17:57:51 -0400 Subject: [PATCH 19/24] Add a Path to ErrorV to make it easier to use on the frontend. --- common/Rhyolite/Vessel/ErrorV/Internal.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/common/Rhyolite/Vessel/ErrorV/Internal.hs b/common/Rhyolite/Vessel/ErrorV/Internal.hs index d79cb91c..2530b2fe 100644 --- a/common/Rhyolite/Vessel/ErrorV/Internal.hs +++ b/common/Rhyolite/Vessel/ErrorV/Internal.hs @@ -166,6 +166,11 @@ observeErrorV (ErrorV v) = case lookupV ErrorVK_Error v of Nothing -> Right emptyV Just e -> Left e +-- | A 'Path' which abstracts over constructing the query and observing the result. +errorV :: (Semigroup (v Proxy), EmptyView v) + => Path (v Proxy) (ErrorV e v Proxy) (ErrorV e v Identity) (Either e (v Identity)) +errorV = Path { _path_to = queryErrorV, _path_from = Just . observeErrorV } + -- | Given an 'ErrorV' result, observe both error and result -- of the underlying view type. unsafeObserveErrorV From f0223095938678e6ae674e71bd12e383d5ed73f5 Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Thu, 9 May 2024 00:44:12 -0400 Subject: [PATCH 20/24] Const SelectedCount is more convenient on the frontend than Proxy for the Path --- common/Rhyolite/Vessel/ErrorV/Internal.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/common/Rhyolite/Vessel/ErrorV/Internal.hs b/common/Rhyolite/Vessel/ErrorV/Internal.hs index 2530b2fe..e5851029 100644 --- a/common/Rhyolite/Vessel/ErrorV/Internal.hs +++ b/common/Rhyolite/Vessel/ErrorV/Internal.hs @@ -167,9 +167,9 @@ observeErrorV (ErrorV v) = case lookupV ErrorVK_Error v of Just e -> Left e -- | A 'Path' which abstracts over constructing the query and observing the result. -errorV :: (Semigroup (v Proxy), EmptyView v) - => Path (v Proxy) (ErrorV e v Proxy) (ErrorV e v Identity) (Either e (v Identity)) -errorV = Path { _path_to = queryErrorV, _path_from = Just . observeErrorV } +errorV :: (Semigroup (v (Const x)), EmptyView v, Num x, Semigroup x) + => Path (v (Const x)) (ErrorV e v (Const x)) (ErrorV e v Identity) (Either e (v Identity)) +errorV = Path { _path_to = queryErrorVConst, _path_from = Just . observeErrorV } -- | Given an 'ErrorV' result, observe both error and result -- of the underlying view type. From de67d6ece8841462b6953a1ceef04fff219d7a72 Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Thu, 9 May 2024 01:48:32 -0400 Subject: [PATCH 21/24] Make observeErrorV more general and correct. --- common/Rhyolite/Vessel/ErrorV/Internal.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/common/Rhyolite/Vessel/ErrorV/Internal.hs b/common/Rhyolite/Vessel/ErrorV/Internal.hs index e5851029..8ac29e34 100644 --- a/common/Rhyolite/Vessel/ErrorV/Internal.hs +++ b/common/Rhyolite/Vessel/ErrorV/Internal.hs @@ -155,21 +155,18 @@ buildErrorV f (ErrorV v) = case lookupV ErrorVK_View v of -- | Given an 'ErrorV' result, observe whether it is an error result -- or a result of the underlying view type. observeErrorV - :: EmptyView v - => ErrorV e v Identity - -> Either e (v Identity) + :: ErrorV e v Identity + -> Maybe (Either e (v Identity)) observeErrorV (ErrorV v) = case lookupV ErrorVK_Error v of - Nothing -> Right $ case lookupV ErrorVK_View v of - Nothing -> emptyV - Just v' -> v' + Nothing -> Right <$> lookupV ErrorVK_View v Just err -> case lookupSingleV err of - Nothing -> Right emptyV - Just e -> Left e + Nothing -> Right <$> lookupV ErrorVK_View v + Just e -> Just (Left e) -- | A 'Path' which abstracts over constructing the query and observing the result. errorV :: (Semigroup (v (Const x)), EmptyView v, Num x, Semigroup x) => Path (v (Const x)) (ErrorV e v (Const x)) (ErrorV e v Identity) (Either e (v Identity)) -errorV = Path { _path_to = queryErrorVConst, _path_from = Just . observeErrorV } +errorV = Path { _path_to = queryErrorVConst, _path_from = observeErrorV } -- | Given an 'ErrorV' result, observe both error and result -- of the underlying view type. From 7c80f95240b2728ecb08adbebde1aecc5c90805a Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Thu, 9 May 2024 15:48:29 -0400 Subject: [PATCH 22/24] Fix the type of errorV Path. --- common/Rhyolite/Vessel/ErrorV/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/common/Rhyolite/Vessel/ErrorV/Internal.hs b/common/Rhyolite/Vessel/ErrorV/Internal.hs index 8ac29e34..bf85b6c0 100644 --- a/common/Rhyolite/Vessel/ErrorV/Internal.hs +++ b/common/Rhyolite/Vessel/ErrorV/Internal.hs @@ -164,7 +164,7 @@ observeErrorV (ErrorV v) = case lookupV ErrorVK_Error v of Just e -> Just (Left e) -- | A 'Path' which abstracts over constructing the query and observing the result. -errorV :: (Semigroup (v (Const x)), EmptyView v, Num x, Semigroup x) +errorV :: (Semigroup (v (Const x)), View v, Num x, Semigroup x) => Path (v (Const x)) (ErrorV e v (Const x)) (ErrorV e v Identity) (Either e (v Identity)) errorV = Path { _path_to = queryErrorVConst, _path_from = observeErrorV } From 4adb328fa62c95d5ad5b91a0f3eb68c849451189 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 24 May 2024 21:27:24 -0400 Subject: [PATCH 23/24] Update ChangeLog.md --- ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ChangeLog.md b/ChangeLog.md index 501231ce..207ab7a6 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,6 +5,7 @@ This project's release branch is `master`. This log is written from the perspect ## Unreleased * Breaking: Remove Reflex.Dom.Modal.Base and Reflex.Dom.Modal.Class. The `` element is now broadly supported by browsers and provides a simpler solution to the problem of opening modals that is also more accessible. See the [documentation](https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dialog), and, in particular, this [example](https://developer.mozilla.org/en-US/docs/Web/API/HTMLDialogElement#opening_a_modal_dialog), which uses `showModal` and describes how to style the modal backdrop. +* Breaking: [Make authentication easier to use and fix some things about ErrorV #213](https://github.com/obsidiansystems/rhyolite/pull/213) * Make it possible to use Rhyolite.Backend.Account without notifications. See Rhyolite.Backend.Account.Db for versions of createAccount and ensureAccountExists that don't send notifications. * Update to obelisk v1.3.0.0 From 8a952fb898a3dc29d2a130006ed5e700a76c5b1e Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 24 May 2024 21:29:04 -0400 Subject: [PATCH 24/24] Bump version --- ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 207ab7a6..96241ca8 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,7 +2,7 @@ This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released, and the date should reflect that release. -## Unreleased +## v1.1.0.0 2024-05-24 * Breaking: Remove Reflex.Dom.Modal.Base and Reflex.Dom.Modal.Class. The `` element is now broadly supported by browsers and provides a simpler solution to the problem of opening modals that is also more accessible. See the [documentation](https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dialog), and, in particular, this [example](https://developer.mozilla.org/en-US/docs/Web/API/HTMLDialogElement#opening_a_modal_dialog), which uses `showModal` and describes how to style the modal backdrop. * Breaking: [Make authentication easier to use and fix some things about ErrorV #213](https://github.com/obsidiansystems/rhyolite/pull/213)