diff --git a/.envrc b/.envrc index 44610e5..a681efa 100644 --- a/.envrc +++ b/.envrc @@ -1 +1,2 @@ use flake; +watch_file flake.nix *.cabal *.lock; diff --git a/cabal.project b/cabal.project deleted file mode 100644 index 80a713b..0000000 --- a/cabal.project +++ /dev/null @@ -1,3 +0,0 @@ -packages: - ./ -allow-newer: servant, servant-server, *:servant-server, *:base, lucid-htmx:*, beam:* diff --git a/flake.lock b/flake.lock index f16c1d5..488bef7 100644 --- a/flake.lock +++ b/flake.lock @@ -1,42 +1,108 @@ { "nodes": { - "flake-utils": { + "flake-parts": { "inputs": { - "systems": "systems" + "nixpkgs-lib": "nixpkgs-lib" }, "locked": { - "lastModified": 1689068808, - "narHash": "sha256-6ixXo3wt24N/melDWjq70UuHQLxGV8jZvooRanIHXw0=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "919d646de7be200f3bf08cb76ae1f09402b6f9b4", + "lastModified": 1754487366, + "narHash": "sha256-pHYj8gUBapuUzKV/kN/tR3Zvqc7o6gdFB9XKXIp1SQ8=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "af66ad14b28a127c5c0f3bbb298218fc63528a18", "type": "github" }, "original": { - "owner": "numtide", - "repo": "flake-utils", + "owner": "hercules-ci", + "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, - "narHash": "sha256-wJ2OF51EYNbTGwuI3EmJWAJV9K5pNuP1aBpD9DXeNb4=", - "owner": "NixOS", + "lastModified": 1755615617, + "narHash": "sha256-HMwfAJBdrr8wXAkbGhtcby1zGFvs+StOp19xNsbqdOg=", + "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", - "nixpkgs": "nixpkgs" + "flake-parts": "flake-parts", + "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", diff --git a/flake.nix b/flake.nix index 398885b..7f8aa3b 100644 --- a/flake.nix +++ b/flake.nix @@ -1,43 +1,128 @@ -# SPDX-FileCopyrightText: 2021 Serokell -# -# 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"; - flake-utils.url = "github:numtide/flake-utils"; + nixpkgs.url = "github:nixos/nixpkgs/nixos-unstable"; + 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 }: - flake-utils.lib.eachDefaultSystem (system: - let - pkgs = nixpkgs.legacyPackages.${system}; + outputs = inputs: + inputs.flake-parts.lib.mkFlake { inherit inputs; } { + systems = import inputs.systems; + imports = [ + inputs.haskell-flake.flakeModule + inputs.treefmt-nix.flakeModule + inputs.flake-root.flakeModule + inputs.mission-control.flakeModule + ]; + 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; - haskellPackages = pkgs.haskellPackages; - - jailbreakUnbreak = pkg: - 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 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; }; - packages.default = self.packages.${system}.${packageName}; - defaultPackage = self.packages.${system}.default; + # Add your package overrides here + settings = { - 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}); + + # 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 }; - devShell = self.devShells.${system}.default; - }); + + # 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; [ + ]; + }; + }; + }; } diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..425b1d8 --- /dev/null +++ b/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 diff --git a/rcv-site.cabal b/rcv-site.cabal index 2572cda..3b5191e 100644 --- a/rcv-site.cabal +++ b/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 - -Wcompat - -fwarn-redundant-constraints - -fwarn-incomplete-uni-patterns - -fwarn-tabs - -fwarn-incomplete-record-updates - -fwarn-identities - -threaded + -- -Wall + -- -Wcompat + -- -fwarn-redundant-constraints + -- -fwarn-incomplete-uni-patterns + -- -fwarn-tabs + -- -fwarn-incomplete-record-updates + -- -fwarn-identities + -- -threaded "-with-rtsopts=-I0 -N" diff --git a/src/BeamDatabase.hs b/src/BeamDatabase.hs new file mode 100644 index 0000000..b6d1d2d --- /dev/null +++ b/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 diff --git a/src/Database.hs b/src/Database.hs index 6417893..9e7e96e 100644 --- a/src/Database.hs +++ b/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 diff --git a/src/InstantRunoff.hs b/src/InstantRunoff.hs index ec52245..3160e3a 100644 --- a/src/InstantRunoff.hs +++ b/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 diff --git a/src/LucidUtils.hs b/src/LucidUtils.hs index 5ec0db3..712e73f 100644 --- a/src/LucidUtils.hs +++ b/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"] diff --git a/src/Main.hs b/src/Main.hs index 7332279..7ce8d5d 100644 --- a/src/Main.hs +++ b/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" - maybe (pure ()) (h3_ . toHtml) . P.title . P.createInfo $ poll - h3_ . toHtml . P.question . P.createInfo $ poll + toHtml $ T.append (T.pack . show . length . (.votes) $ poll) " ballots submitted" + maybe (pure ()) (h3_ . toHtml) . (.title) . (.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 - gen <- Rd.asks gen + db <- Rd.asks (.db) + 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 - checkLength . P.question $ pollReq - maybe (pure ()) checkLength . P.title $ pollReq + M.mapM_ checkLength . LN.toList . (.options) $ pollReq + checkLength . (.question) $ 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 - db <- Rd.asks db + M.mapM_ checkLength . (.options) $ ballot + 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) - h3_ . toHtml . P.question $ createInfo + My.maybe (pure ()) (h3_ . toHtml) ((.title) 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