beam database (unfinished), overloadedRecordDot, fourmolu, relude
also one fix where the "skip voting and see results" link is broken.
This commit is contained in:
parent
123bbe79b5
commit
cee339a8ed
SSH key fingerprint:
SHA256:AaP2Hr/e3mEjeY+s9XJmQqAesqEms8ENRhwRkpO0WUk
11 changed files with 438 additions and 102 deletions
1
.envrc
1
.envrc
|
|
@ -1 +1,2 @@
|
|||
use flake;
|
||||
watch_file flake.nix *.cabal *.lock;
|
||||
|
|
|
|||
|
|
@ -1,3 +0,0 @@
|
|||
packages:
|
||||
./
|
||||
allow-newer: servant, servant-server, *:servant-server, *:base, lucid-htmx:*, beam:*
|
||||
118
flake.lock
generated
118
flake.lock
generated
|
|
@ -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",
|
||||
|
|
|
|||
151
flake.nix
151
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";
|
||||
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; [
|
||||
];
|
||||
};
|
||||
};
|
||||
};
|
||||
}
|
||||
|
|
|
|||
17
fourmolu.yaml
Normal file
17
fourmolu.yaml
Normal file
|
|
@ -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
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
134
src/BeamDatabase.hs
Normal file
134
src/BeamDatabase.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
|
|||
61
src/Main.hs
61
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 <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
|
||||
M.void . liftIO $ Ac.update (db env) (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 env) (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"]))
|
||||
mapM_ print =<< (liftIO . Ac.query (db env) $ DB.GetPollIds)
|
||||
let application = serve api . hoistServer api (runWithEnv env) $ server
|
||||
(Env {..}) <- getEnv
|
||||
M.void . liftIO $ Ac.update db (DB.CreatePoll examplePoll (P.PollId 7))
|
||||
M.void . liftIO $ Ac.update db (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", "red", "pink", "purple", "green"]))
|
||||
M.void . liftIO $ Ac.update db (DB.PostBallot (P.PollId 7) (B.Ballot ["purple", "black", "yellow", "orange", "blue"]))
|
||||
mapM_ print =<< (liftIO . Ac.query db $ DB.GetPollIds)
|
||||
let application = serve api . hoistServer api (runWithEnv (Env {..})) $ server
|
||||
W.run 8081 application
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue