beam database (unfinished), overloadedRecordDot, fourmolu, relude

also one fix where the "skip voting and see results" link is broken.

.envrc

@@ -1 +1,2 @@
 use flake;
+watch_file flake.nix *.cabal *.lock;

cabal.project

@@ -1,3 +0,0 @@
-packages:
-         ./
-allow-newer: servant, servant-server, *:servant-server, *:base, lucid-htmx:*, beam:*

flake.lock

@@ -1,42 +1,108 @@
 {
   "nodes": {
-    "flake-utils": {
+    "flake-parts": {
       "inputs": {
-        "systems": "systems"
+        "nixpkgs-lib": "nixpkgs-lib"
       },
       "locked": {
-        "lastModified": 1689068808,
+        "lastModified": 1754487366,
-        "narHash": "sha256-6ixXo3wt24N/melDWjq70UuHQLxGV8jZvooRanIHXw0=",
+        "narHash": "sha256-pHYj8gUBapuUzKV/kN/tR3Zvqc7o6gdFB9XKXIp1SQ8=",
-        "owner": "numtide",
+        "owner": "hercules-ci",
-        "repo": "flake-utils",
+        "repo": "flake-parts",
-        "rev": "919d646de7be200f3bf08cb76ae1f09402b6f9b4",
+        "rev": "af66ad14b28a127c5c0f3bbb298218fc63528a18",
         "type": "github"
       },
       "original": {
-        "owner": "numtide",
+        "owner": "hercules-ci",
-        "repo": "flake-utils",
+        "repo": "flake-parts",
+        "type": "github"
+      }
+    },
+    "flake-root": {
+      "locked": {
+        "lastModified": 1723604017,
+        "narHash": "sha256-rBtQ8gg+Dn4Sx/s+pvjdq3CB2wQNzx9XGFq/JVGCB6k=",
+        "owner": "srid",
+        "repo": "flake-root",
+        "rev": "b759a56851e10cb13f6b8e5698af7b59c44be26e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "srid",
+        "repo": "flake-root",
+        "type": "github"
+      }
+    },
+    "haskell-flake": {
+      "locked": {
+        "lastModified": 1756071733,
+        "narHash": "sha256-hRlG8+m5oOBb6/a8DQAzrt0ApLYkbNfActj7b3OzeLk=",
+        "owner": "srid",
+        "repo": "haskell-flake",
+        "rev": "99200161a88c1cb83bb114ab237e66d3fe327692",
+        "type": "github"
+      },
+      "original": {
+        "owner": "srid",
+        "repo": "haskell-flake",
+        "type": "github"
+      }
+    },
+    "mission-control": {
+      "locked": {
+        "lastModified": 1733438716,
+        "narHash": "sha256-1tt43rwHk0N5fwEhbpsHWO4nBVFCQN0w1KM427DNycM=",
+        "owner": "Platonic-Systems",
+        "repo": "mission-control",
+        "rev": "65d04c4ab9db076eff09824d2936a5c215c21f36",
+        "type": "github"
+      },
+      "original": {
+        "owner": "Platonic-Systems",
+        "repo": "mission-control",
         "type": "github"
       }
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1692665005,
+        "lastModified": 1755615617,
-        "narHash": "sha256-wJ2OF51EYNbTGwuI3EmJWAJV9K5pNuP1aBpD9DXeNb4=",
+        "narHash": "sha256-HMwfAJBdrr8wXAkbGhtcby1zGFvs+StOp19xNsbqdOg=",
-        "owner": "NixOS",
+        "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "50097d75fa0dcc6be7271bc390e612fa0363a38d",
+        "rev": "20075955deac2583bb12f07151c2df830ef346b4",
         "type": "github"
       },
       "original": {
-        "owner": "NixOS",
+        "owner": "nixos",
+        "ref": "nixos-unstable",
         "repo": "nixpkgs",
         "type": "github"
       }
     },
+    "nixpkgs-lib": {
+      "locked": {
+        "lastModified": 1753579242,
+        "narHash": "sha256-zvaMGVn14/Zz8hnp4VWT9xVnhc8vuL3TStRqwk22biA=",
+        "owner": "nix-community",
+        "repo": "nixpkgs.lib",
+        "rev": "0f36c44e01a6129be94e3ade315a5883f0228a6e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-community",
+        "repo": "nixpkgs.lib",
+        "type": "github"
+      }
+    },
     "root": {
       "inputs": {
-        "flake-utils": "flake-utils",
+        "flake-parts": "flake-parts",
-        "nixpkgs": "nixpkgs"
+        "flake-root": "flake-root",
+        "haskell-flake": "haskell-flake",
+        "mission-control": "mission-control",
+        "nixpkgs": "nixpkgs",
+        "systems": "systems",
+        "treefmt-nix": "treefmt-nix"
       }
     },
     "systems": {
@@ -53,6 +119,26 @@
         "repo": "default",
         "type": "github"
       }
+    },
+    "treefmt-nix": {
+      "inputs": {
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1755934250,
+        "narHash": "sha256-CsDojnMgYsfshQw3t4zjRUkmMmUdZGthl16bXVWgRYU=",
+        "owner": "numtide",
+        "repo": "treefmt-nix",
+        "rev": "74e1a52d5bd9430312f8d1b8b0354c92c17453e5",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "treefmt-nix",
+        "type": "github"
+      }
     }
   },
   "root": "root",

flake.nix

@@ -1,43 +1,128 @@
-# SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io/>
-#
-# SPDX-License-Identifier: CC0-1.0
-
 {
-  description = "My haskell application";
+  description = "srid/haskell-template: Nix template for Haskell projects";
-
   inputs = {
-    nixpkgs.url = "github:NixOS/nixpkgs";
+    nixpkgs.url = "github:nixos/nixpkgs/nixos-unstable";
-    flake-utils.url = "github:numtide/flake-utils";
+    systems.url = "github:nix-systems/default";
+    flake-parts.url = "github:hercules-ci/flake-parts";
+    haskell-flake.url = "github:srid/haskell-flake";
+    treefmt-nix.url = "github:numtide/treefmt-nix";
+    treefmt-nix.inputs.nixpkgs.follows = "nixpkgs";
+    # tmp-postgres.url = "github:jfischoff/tmp-postgres";
+    # tmp-postgres.flake = false;
+    mission-control.url = "github:Platonic-Systems/mission-control";
+    flake-root.url = "github:srid/flake-root";
   };
 
-  outputs = { self, nixpkgs, flake-utils }:
+  outputs = inputs:
-    flake-utils.lib.eachDefaultSystem (system:
+    inputs.flake-parts.lib.mkFlake { inherit inputs; } {
-      let
+      systems = import inputs.systems;
-        pkgs = nixpkgs.legacyPackages.${system};
+      imports = [
-
+        inputs.haskell-flake.flakeModule
-        haskellPackages = pkgs.haskellPackages;
+        inputs.treefmt-nix.flakeModule
-
+        inputs.flake-root.flakeModule
-        jailbreakUnbreak = pkg:
+        inputs.mission-control.flakeModule
-          pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
-
-        # DON'T FORGET TO PUT YOUR PACKAGE NAME HERE, REMOVING `throw`
-        packageName = "rcv-site";
-      in {
-        packages.${packageName} =
-          haskellPackages.callCabal2nix packageName self rec {
-            # Dependency overrides go here
-          };
-
-        packages.default = self.packages.${system}.${packageName};
-        defaultPackage = self.packages.${system}.default;
-
-        devShells.default = pkgs.mkShell {
-          buildInputs = with pkgs; [
-            haskellPackages.haskell-language-server # you must build it with your ghc to work
-            cabal-install
       ];
-          inputsFrom = map (__getAttr "env") (__attrValues self.packages.${system});
+      perSystem = { self', system, lib, config, pkgs, ... }: {
+        # Our only Haskell project. You can have multiple projects, but this template
+        # has only one.
+        # See https://github.com/srid/haskell-flake/blob/master/example/flake.nix
+        haskellProjects.default = {
+          # The base package set (this value is the default)
+          # basePackages = pkgs.haskellPackages.ghc_9_12_1;
+
+          # Packages to add on top of `basePackages`
+          packages = {
+            # Add source or Hackage overrides here
+            # (Local packages are added automatically)
+            # https://github.com/lehins/hip.git
+            # hip.source = inputs.hip + "/hip";
+            # tmp-postgres.source = inputs.tmp-postgres;
+          };
+
+          # Add your package overrides here
+          settings = {
+
+
+            # tmp-postgres.check = false;
+
+            # beam-migrate = {
+            #   broken = false;
+            #   jailbreak = true;
+            # };
+
+            # beam-postgres = {
+            #   broken = false;
+            #   jailbreak = true;
+            # };
+            # barbies-th = {
+            #   broken = false;
+            #   jailbreak = true;
+            # };
+          };
+
+          # Development shell configuration
+          devShell = {
+            # hlsCheck.enable = false;
+          };
+
+          # What should haskell-flake add to flake outputs?
+          autoWire = [ "packages" "apps" "checks" ]; # Wire all but the devShell
+        };
+
+        # Auto formatters. This also adds a flake check to ensure that the
+        # source tree was auto formatted.
+        treefmt.config = {
+          projectRootFile = "flake.nix";
+
+          programs.ormolu.enable = true;
+          programs.nixpkgs-fmt.enable = true;
+          programs.cabal-fmt.enable = true;
+          programs.hlint.enable = true;
+
+          # We use fourmolu
+          programs.ormolu.package = pkgs.haskellPackages.fourmolu;
+        };
+
+        mission-control.scripts = {
+          hoogle = {
+            description = "Start Hoogle server for project dependencies";
+            exec = ''
+              hoogle serve -p 8888 --local;
+            '';
+            category = "Dev Tools";
+          };
+
+          haddocks = {
+            description = "make docs & serve them";
+            exec = ''
+              echo http://127.0.0.1:8887;
+              cabal haddock-project --executables --internal --hoogle || true;
+              python3 -m http.server -d haddocks 8887;
+            '';
+            category = "Dev Tools";
+          };
+
+        };
+
+
+
+        # Default package & app.
+        packages.default = self'.packages.rcv-site;
+        apps.default = self'.apps.rcv-site;
+
+        # Default shell.
+        devShells.default = pkgs.mkShell {
+          name = "haskell-template";
+          meta.description = "Haskell development environment";
+          # See https://zero-to-flakes.com/haskell-flake/devshell#composing-devshells
+          inputsFrom = [
+            config.haskellProjects.default.outputs.devShell
+            config.treefmt.build.devShell
+            config.mission-control.devShell
+          ];
+          nativeBuildInputs = with pkgs; [
+          ];
+        };
+      };
     };
-        devShell = self.devShells.${system}.default;
-      });
 }

fourmolu.yaml

@@ -0,0 +1,17 @@
+# Generated from web app, for more information, see: https://fourmolu.github.io/config/
+indentation: 4
+column-limit: none
+function-arrows: trailing
+comma-style: leading
+import-export-style: diff-friendly
+indent-wheres: false
+record-brace-space: false
+newlines-between-decls: 1
+haddock-style: multi-line
+haddock-style-module: null
+let-style: auto
+in-style: right-align
+single-constraint-parens: always
+unicode: never
+respectful: true
+single-deriving-parens: always

rcv-site.cabal

@@ -12,13 +12,18 @@ executable rcv-site
     DeriveAnyClass,
     DeriveGeneric,
     DuplicateRecordFields,
+    ExtendedDefaultRules,
     FlexibleContexts,
     FlexibleInstances,
     ImpredicativeTypes,
-    ExtendedDefaultRules,
+    InstanceSigs,
     MultiParamTypeClasses,
+    NoFieldSelectors,
+    DerivingStrategies,
+    DerivingVia,
     NamedFieldPuns,
     OverloadedLabels,
+    OverloadedRecordDot,
     OverloadedLists,
     OverloadedStrings,
     PartialTypeSignatures,
@@ -27,6 +32,7 @@ executable rcv-site
     RecursiveDo,
     ScopedTypeVariables,
     StandaloneDeriving,
+    StrictData,
     TemplateHaskell,
     TupleSections,
     TypeApplications,
@@ -36,15 +42,25 @@ executable rcv-site
     UndecidableInstances,
   hs-source-dirs:
     src
+
+
+  mixins:
+    base hiding (Prelude),
+    relude (Relude as Prelude),
+    relude
+
   build-depends:
     acid-state,
     aeson,
-    -- beam-sqlite,
-    -- beam-core,
-    -- sqlite-simple,
     async,
+    relude,
     base,
+    beam-core,
+    beam-migrate,
+    beam-postgres,
     bytestring,
+    cereal,
+    commonmark,
     containers,
     deepseq,
     hashable,
@@ -53,7 +69,6 @@ executable rcv-site
     lucid-htmx,
     mtl,
     network-uri,
-    commonmark,
     random,
     safecopy,
     servant,
@@ -69,11 +84,11 @@ executable rcv-site
     warp
     -- warp-tls
   default-language:
-    Haskell2010
+    GHC2021
   other-modules:
     API
     Database
-    -- BeamDatabase
+    BeamDatabase
     InstantRunoff
     Error
     Poll
@@ -81,12 +96,12 @@ executable rcv-site
     Ballot
     AppM
   ghc-options:
-    -Wall
+    -- -Wall
-    -Wcompat
+    -- -Wcompat
-    -fwarn-redundant-constraints
+    -- -fwarn-redundant-constraints
-    -fwarn-incomplete-uni-patterns
+    -- -fwarn-incomplete-uni-patterns
-    -fwarn-tabs
+    -- -fwarn-tabs
-    -fwarn-incomplete-record-updates
+    -- -fwarn-incomplete-record-updates
-    -fwarn-identities
+    -- -fwarn-identities
-    -threaded
+    -- -threaded
     "-with-rtsopts=-I0 -N"

src/BeamDatabase.hs

@@ -0,0 +1,134 @@
+module BeamDatabase where
+
+import Data.Word
+import Data.Int
+import GHC.Generics (Generic)
+import qualified Data.List as L
+import qualified Data.Vector as V
+import qualified Data.List.NonEmpty as LN
+import qualified Data.Text as T
+import qualified Database.Beam as B
+import qualified Database.Beam.Migrate as BM
+import qualified Database.Beam.Migrate.Simple as BMS
+import qualified API as A
+import qualified Database.Beam.Postgres as BP
+import qualified Database.Beam.Postgres.Migrate as BPM
+import qualified Data.ByteString as By
+-- import qualified Database.Sqlite.Simple as PS
+import qualified Data.String as S
+import Database.Beam.Backend.SQL (SqlSerial, IsSql92DataTypeSyntax (domainType))
+-- import Database.Beam.Sqlite as B ( connect )
+import qualified Database.Beam as BM
+import qualified Database.Beam.Backend.SQL.BeamExtensions as BSQLE
+import qualified Database.Beam.Backend.SQL.BeamExtensions as B
+
+
+
+
+-- deriving instance Show Poll
+-- deriving instance Eq Poll
+-- deriving instance Ord Poll
+
+
+type SerialInt = SqlSerial Int32
+
+
+data OptionT f = OptionT {
+  identity:: B.C f SerialInt,
+  forPoll :: B.PrimaryKey PollT f,
+  name :: B.C f T.Text
+} deriving (Generic, B.Beamable)
+
+type Option = OptionT B.Identity
+
+data BallotT f = BallotT {
+  identity :: B.C f SerialInt,
+  forPoll :: B.PrimaryKey PollT f,
+  votes :: B.C f By.ByteString-- [Int32]
+} deriving (Generic, B.Beamable)
+
+type Ballot = BallotT B.Identity
+
+type Poll = PollT B.Identity
+
+data PollT f = PollT {
+  identity :: B.C f SerialInt,
+  title :: B.C f (Maybe T.Text),
+  question :: B.C f T.Text
+} deriving (Generic, B.Beamable)
+
+
+-- deriving instance Show Ballot
+-- deriving instance Eq Ballot
+-- deriving instance Ord Ballot
+
+instance B.Table PollT where
+
+  data PrimaryKey PollT f = PollId (B.C f SerialInt) deriving (Generic, B.Beamable)
+
+  primaryKey :: PollT f -> BM.PrimaryKey PollT f
+  primaryKey = PollId . (.identity)
+
+instance B.Table OptionT where
+
+  data PrimaryKey OptionT f = OptionId (B.Columnar f SerialInt) deriving (Generic, B.Beamable)
+
+  primaryKey :: OptionT f -> BM.PrimaryKey OptionT f
+  primaryKey (OptionT {..})= OptionId identity
+
+instance B.Table BallotT where
+
+  data PrimaryKey BallotT f = BallotId (B.Columnar f SerialInt) deriving (Generic, B.Beamable)
+
+  primaryKey :: BallotT f -> BM.PrimaryKey BallotT f
+  primaryKey (BallotT {..}) = BallotId identity
+
+type PollId = B.PrimaryKey PollT B.Identity
+
+-- the actual database
+data PollDatabase f = PollDatabase {
+  polls :: f (B.TableEntity PollT),
+  options :: f (B.TableEntity OptionT),
+  ballots :: f (B.TableEntity BallotT)
+} deriving (Generic, B.Database be)
+
+-- forPollOptions :: OptionT f -> PollT f
+forPollOptions (OptionT {..})= forPoll
+
+getPoll :: Int32 -> BM.Q BP.Postgres PollDatabase s (PollT (BM.QExpr BP.Postgres s))
+getPoll id = do
+  poll' <- B.all_ $ (.polls) pollDb
+  B.guard_ (B.primaryKey poll' B.==. (PollId . fromIntegral $ id))
+  pure poll'
+
+getOptionsForPoll :: BM.MonadBeam BP.Postgres m => Int32 -> m [Option]
+getOptionsForPoll = B.runSelectReturningList . B.select . getOptionsForPoll'
+
+getOptionsForPoll' :: Int32 -> BM.Q BP.Postgres PollDatabase s (OptionT (BM.QExpr BP.Postgres s))
+getOptionsForPoll' id = do
+  (options' :: OptionT f) <- B.all_ $ (.options) pollDb
+  B.guard_ ((forPollOptions options') B.==. (PollId . fromIntegral $ id))
+  pure options'
+
+-- insertPoll :: MonadBeamInsertReturning BP.Postgres m => A.CreatePollReq -> m (PollT BM.Identity, [OptionT BM.Identity])
+-- insertPoll :: MonadBeamInsertReturning BP.Postgres m => A.CreatePollReq -> m [PollT BM.Identity]
+-- insertPoll A.CreatePollReq{..} = BSQLE.runInsertReturningList . B.insert (polls pollDb) $ B.insertExpressions [PollT B.default_ (B.val_ question)]
+-- -- insertOptions :: MonadBeamInsertReturning BP.Postgres m => m [OptionT BM.Identity]
+-- insertOptions pollId' optionNames = BSQLE.runInsertReturningList . B.insert (options pollDb) $ B.insertExpressions $ map toOption optionNames
+--   where
+--     toOption optionName = OptionT B.default_ (B.val_ $ B.SqlSerial $ pollId') (B.val_ optionName)
+
+
+-- postBallot :: MonadBeamInsertReturning BP.Postgres m => Int32 -> [Int32] -> m ()
+postBallot pollKey optionKeys = BSQLE.runInsertReturningList . B.insert ((.ballots) pollDb) $ B.insertExpressions [BallotT B.default_ (B.val_ pollKey) (B.val_ optionKeys)]
+
+pollDb :: B.DatabaseSettings BP.Postgres PollDatabase
+pollDb = BM.unCheckDatabase checkedSettings
+
+checkedSettings :: BM.CheckedDatabaseSettings BP.Postgres PollDatabase
+checkedSettings = BM.defaultMigratableDbSettings
+
+connection :: IO BP.Connection
+connection = BP.connect $ BP.defaultConnectInfo {BP.connectUser = "jackoe", BP.connectDatabase = "postgres"}
+
+makeDB = BMS.createSchema BPM.migrationBackend checkedSettings

src/Database.hs

@@ -28,16 +28,16 @@ createPoll createInfo pollId = MS.modify go
       }
 
 getPollForBallot :: P.PollId -> Ac.Query DB (Maybe P.CreatePollInfo)
-getPollForBallot pollId = MR.asks (fmap P.createInfo . M.lookup pollId . polls)
+getPollForBallot pollId = MR.asks (fmap (.createInfo) . M.lookup pollId . (.polls))
 
 getPollIds :: Ac.Query DB [P.PollId]
-getPollIds = MR.asks (M.keys . polls)
+getPollIds = MR.asks (M.keys . (.polls))
 
 getDB :: Ac.Query DB DB
 getDB = MR.ask
 
 getPoll :: P.PollId -> Ac.Query DB (Maybe P.Poll)
-getPoll pollId = MR.asks $ M.lookup pollId . polls
+getPoll pollId = MR.asks $ M.lookup pollId . (.polls)
 
 postBallot :: P.PollId -> B.Ballot -> Ac.Update DB ()
 postBallot pollId ballot = MS.modify go

src/InstantRunoff.hs

@@ -62,7 +62,7 @@ rank votes =
     candidates = S.unions . LN.map (S.fromList . LN.toList) $ votes
 
 filterVotes :: (a -> Bool) -> LN.NonEmpty (LN.NonEmpty a) -> Maybe (LN.NonEmpty (LN.NonEmpty a))
-filterVotes f = catMaybes . LN.map (LN.nonEmpty . LN.filter f)
+filterVotes f = InstantRunoff.catMaybes . LN.map (LN.nonEmpty . LN.filter f)
 
 catMaybes :: LN.NonEmpty (Maybe a) -> Maybe (LN.NonEmpty a)
 catMaybes = LN.nonEmpty . M.catMaybes . LN.toList

src/LucidUtils.hs

@@ -6,7 +6,7 @@ import qualified Control.Monad.Reader as Rd
 
 pageHead :: AppM (L.Html ())
 pageHead = do
-  script <- Rd.asks script
+  script <- Rd.asks (.script)
   pure . head_ $ do
     link_ [href_ "/static/style.css", rel_ "stylesheet"]
     link_ [href_ "/static/paper.min.css", rel_ "stylesheet"]

src/Main.hs

@@ -32,10 +32,11 @@ import qualified Network.Wai.Middleware.ForceSSL as TLS
 import qualified Network.HTTP.Types.Status as TS
 import LucidUtils
 import qualified Data.Text.Lazy as TL
+import Prelude hiding (for_)
 
 checkLength :: T.Text -> AppM ()
 checkLength txt
-  | (T.length txt) <= 100 = pure ()
+  | T.length txt <= 100 = pure ()
   | otherwise = Er.nameTooLong
 
 throwOrLift :: AppM a -> Maybe a -> AppM a
@@ -49,21 +50,21 @@ getFromPollId pollId query = do
 
 results :: P.PollId -> AppM (L.Html ())
 results pollId = do
-  db <- Rd.asks db
+  db <- Rd.asks (.db)
   poll :: P.Poll <- getFromPollId pollId (liftIO . Ac.query db . DB.GetPoll)
-  case toNonEmptyList . P.votes $ poll of
+  case toNonEmptyList . (.votes) $ poll of
     Nothing -> fullPage "poll doesn't have any votes"
     Just votesList -> do
-      let results' = IR.solve (LN.filter (not . T.null) . P.options . P.createInfo $ poll) (votesList)
+      let results' = IR.solve (LN.filter (not . T.null) . (.options) . (.createInfo) $ poll) votesList
       fullPage $ do
         h2_ "results"
-        toHtml $ T.append (T.pack . show . length . P.votes $ poll) " ballots submitted"
+        toHtml $ T.append (T.pack . show . length . (.votes) $ poll) " ballots submitted"
-        maybe (pure ()) (h3_ . toHtml) . P.title . P.createInfo $ poll
+        maybe (pure ()) (h3_ . toHtml) . (.title) . (.createInfo) $ poll
-        h3_ . toHtml . P.question . P.createInfo $ poll
+        h3_ . toHtml . (.question) . (.createInfo) $ poll
         with div_ [id_ "results"] . mconcat $ zipWith nthPlaceFor results' nthPlaces
   where
     toNonEmptyList :: [B.Ballot] -> Maybe (LN.NonEmpty (LN.NonEmpty T.Text))
-    toNonEmptyList = LN.nonEmpty . My.mapMaybe (LN.nonEmpty . filter (not . T.null) . B.options)
+    toNonEmptyList = LN.nonEmpty . My.mapMaybe (LN.nonEmpty . filter (not . T.null) . (.options))
 
     nthPlaceFor :: S.Set T.Text -> L.Html () -> L.Html ()
     nthPlaceFor options place = do
@@ -83,8 +84,8 @@ nthPlaces =
 makePoll :: P.CreatePollInfo -> AppM (L.Html ())
 makePoll pollReq = do
   checkTextLengths
-  db <- Rd.asks db
+  db <- Rd.asks (.db)
-  gen <- Rd.asks gen
+  gen <- Rd.asks (.gen)
   -- TODO: handle rare case of poll id collision
   pollId <- P.PollId <$> R.uniformWord64 gen
   liftIO $ Ac.update db (DB.CreatePoll pollReq pollId)
@@ -94,9 +95,9 @@ makePoll pollReq = do
     with a_ [href_ fillOutLink] (toHtml fillOutLink)
   where
     checkTextLengths = do
-      M.mapM_ checkLength . LN.toList . P.options $ pollReq
+      M.mapM_ checkLength . LN.toList . (.options) $ pollReq
-      checkLength . P.question $ pollReq
+      checkLength . (.question) $ pollReq
-      maybe (pure ()) checkLength . P.title $ pollReq
+      maybe (pure ()) checkLength . (.title) $ pollReq
 
 -- TODO: lift current domain into ENV
 toPollIdLink :: P.PollId -> T.Text
@@ -104,14 +105,14 @@ toPollIdLink (P.PollId pollId) = T.append "https://rankedchoice.net/poll/" (T.pa
 
 vote :: P.PollId -> B.Ballot -> AppM (L.Html ())
 vote pollId ballot = do
-  M.mapM_ checkLength . B.options $ ballot
+  M.mapM_ checkLength . (.options) $ ballot
-  db <- Rd.asks db
+  db <- Rd.asks (.db)
   liftIO $ Ac.update db (DB.PostBallot pollId ballot')
   pure $ with div_ [id_ "resultLink"] $ do
     "success! Here are the "
     with a_ [href_ (toPollIdLink pollId `T.append` "/results")] "results"
   where
-    ballot' = B.Ballot . filter (not . T.null) . B.options $ ballot
+    ballot' = B.Ballot . filter (not . T.null) . (.options) $ ballot
 
 server :: ServerT A.RCVAPI AppM
 server = createPage
@@ -130,23 +131,23 @@ emptyHiddenInput = input_ [hidden_ "", name_ "options", value_ ""]
 
 getPollForBallot :: P.PollId -> AppM (L.Html ())
 getPollForBallot pollId = do
-  db <- Rd.asks db
+  db <- Rd.asks (.db)
   createInfo <- getFromPollId pollId (liftIO . Ac.query db . DB.GetPollForBallot)
   fullPage $ do
-      My.maybe (pure ()) (h3_ . toHtml) (P.title createInfo)
+      My.maybe (pure ()) (h3_ . toHtml) ((.title) createInfo)
-      h3_ . toHtml . P.question $ createInfo
+      h3_ . toHtml . (.question) $ createInfo
       with div_ [id_ "drag-boxes-container"] $ do
         div_ $ do -- TODO: check accessibility on this
           "drag from here"
           with div_ [classes_ ["draggable-options","sortable-from", "options", "child-borders", "border-primary", "background-primary"]]
-            . mconcat . map toFormInput . LN.toList . P.options $ createInfo
+            . mconcat . map toFormInput . LN.toList . (.options) $ createInfo
         with form_  [hxPost_ "", id_ "drag-into-vote", hxTarget_ "closest body"] $ do
           div_$ do
             "to here in order of preference"
             with div_ [classes_ ["draggable-options", "sortable", "options", "child-borders", "border-primary", "background-primary"]]
               (emptyHiddenInput <> emptyHiddenInput)
       input_ [id_ "ballot-submit", type_ "submit", classes_ ["paper-btn", "btn-primary"], value_ "submit", form_ "drag-into-vote"]
-      a_ [href_ (T.concat [T.pack . show . P.asWord $ pollId, "/results"])] "skip voting and see results"
+      a_ [href_ "results"] "skip voting and see results"
   where
     toFormInput :: T.Text -> L.Html ()
     toFormInput option = with div_ [classes_ []] $ input_ [type_ "hidden", value_ option, name_ "options"] <> toHtml option
@@ -184,7 +185,7 @@ createPage = do
       input_ [type_ "submit", classes_ ["paper-btn", "btn-primary"], value_ "submit"]
 
 indexPage :: AppM (L.Html ())
-indexPage = fullPage . toHtmlRaw =<< Rd.asks index
+indexPage = fullPage . toHtmlRaw =<< Rd.asks (.index)
 
 api :: Proxy A.RCVAPI
 api = Proxy
@@ -193,7 +194,7 @@ getEnv :: IO Env
 getEnv = do
  db <- DB.openLocalDB
  -- this needs to be in a <script> tag in the header,
- -- so we need it in the ENv
+ -- so we need it in the Env
  script <- TIO.readFile "public/static/script.js"
  let gen = R.globalStdGen
  index <- convertMarkdown "public/static/index.md"
@@ -225,11 +226,11 @@ emptyApp _ respondf = respondf $ NW.responseLBS TS.status200 [] "redirecting to
 
 main :: IO ()
 main = do
-  env <- getEnv
+  (Env {..}) <- getEnv
-  M.void . liftIO $ Ac.update (db env) (DB.CreatePoll examplePoll (P.PollId 7))
+  M.void . liftIO $ Ac.update db (DB.CreatePoll examplePoll (P.PollId 7))
-  M.void . liftIO $ Ac.update (db env) (DB.PostBallot (P.PollId 7) (B.Ballot ["blue", "green", "yellow", "orange", "pink"]))
+  M.void . liftIO $ Ac.update db (DB.PostBallot (P.PollId 7) (B.Ballot ["blue", "green", "yellow", "orange", "pink"]))
-  M.void . liftIO $ Ac.update (db env) (DB.PostBallot (P.PollId 7) (B.Ballot ["blue", "red", "pink", "purple", "green"]))
+  M.void . liftIO $ Ac.update db (DB.PostBallot (P.PollId 7) (B.Ballot ["blue", "red", "pink", "purple", "green"]))
-  M.void . liftIO $ Ac.update (db env) (DB.PostBallot (P.PollId 7) (B.Ballot ["purple", "black", "yellow", "orange", "blue"]))
+  M.void . liftIO $ Ac.update db (DB.PostBallot (P.PollId 7) (B.Ballot ["purple", "black", "yellow", "orange", "blue"]))
-  mapM_ print =<< (liftIO . Ac.query (db env) $ DB.GetPollIds)
+  mapM_ print =<< (liftIO . Ac.query db $ DB.GetPollIds)
-  let application = serve api . hoistServer api (runWithEnv env) $ server
+  let application = serve api . hoistServer api (runWithEnv (Env {..})) $ server
   W.run 8081 application