Jack/rcv-site
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

documentation

Browse source
This commit is contained in:
Jack Wines 2023-06-21 05:00:00 -07:00
parent 353f24315f
commit b4e4e0b3c0
4 changed files with 32 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/Error.hs
View file

@ -1,3 +1,5 @@
-- these errors have a big problem, they don't work with Lucid, it's raw Bytestring
-- so no page header .etc doesn't look good at all
module Error where
import qualified Data.Text as T
import Servant.Server.Internal.ServerError

11
src/InstantRunoff.hs
View file

@ -6,6 +6,8 @@ import qualified Data.Set as S
import qualified Data.Maybe as M
import qualified Data.Ord as O
-- find winner, remove winner from ballots, repeat for next place
solve :: forall a. Ord a => [a] -> LN.NonEmpty (LN.NonEmpty a) -> [S.Set a]
solve candidates votes' = if S.null notVotedForCandidates
then solved
@ -33,6 +35,8 @@ winner votes = maybe (M.keysSet $ voteCounts) winner . filterVotes (`S.notMember
firstChoiceLosers :: S.Set a
firstChoiceLosers = M.keysSet . M.filter ((==) . L.minimum . M.elems $ voteCounts) $ voteCounts
-- in the event of multiple first choice losers,
-- count how many ballots prefer one choice over another
losers :: S.Set a
losers = S.fromList . smallestSubset preferred . S.toList $ firstChoiceLosers
@ -42,14 +46,15 @@ winner votes = maybe (M.keysSet $ voteCounts) winner . filterVotes (`S.notMember
numMatch x = L.length . L.filter (== Just x) $ preferences
preferences :: [Maybe a]
preferences = map (ballotFavors . LN.toList) . LN.toList $ votes
preferences = map (ballotPreference . LN.toList) . LN.toList $ votes
ballotFavors :: [a] -> Maybe a
ballotFavors = L.find (`S.member` [x0, x1])
ballotPreference :: [a] -> Maybe a
ballotPreference = L.find (`S.member` [x0, x1])
voteCounts :: M.Map a Word
voteCounts =
M.unionsWith (+)
-- If there's a candidate with no first-place votes we need to include that
. (candidatesMinimumVoteCounts :)
. map (`M.singleton` 1)
. LN.toList .

1
src/LucidUtils.hs
View file

@ -19,6 +19,7 @@ pageHead = do
pageBody :: L.Html () -> L.Html ()
pageBody = with body_ [classes_ ["container", "container-sm", "paper"], hxExt_ "json-enc"]
-- TODO: add a footer here
fullPage :: L.Html () -> AppM (L.Html ())
fullPage rest = do
customHead <- pageHead

39
src/Main.hs
View file

@ -48,12 +48,6 @@ getFromPollId pollId query = do
pollResult <- query pollId
throwOrLift (Er.noPollFound pollId) pollResult
notVotedFor :: P.Poll -> S.Set T.Text
notVotedFor (P.Poll {..}) = S.difference allOptions votedFor
where
votedFor = S.unions $ map (S.fromList . B.options) votes
allOptions = S.fromList . LN.toList . P.options $ createInfo
results :: P.PollId -> AppM (L.Html ())
results pollId = do
db <- Rd.asks db
@ -61,11 +55,11 @@ results pollId = do
case toNonEmptyList . P.votes $ poll of
Nothing -> fullPage "poll doesn't have any votes"
Just votesList -> do
let results' = (IR.solve (LN.toList . P.options . P.createInfo $ poll) votesList)
let results' = IR.solve (LN.toList . P.options . P.createInfo $ poll) votesList
fullPage $ do
h2_ "results"
toHtml $ T.append (T.pack . show . length . P.votes $ poll) " ballots submitted"
maybe "" (h3_ . toHtml) . P.title . P.createInfo $ poll
maybe (pure ()) (h3_ . toHtml) . P.title . P.createInfo $ poll
h3_ . toHtml . P.question . P.createInfo $ poll
with div_ [id_ "results"] . mconcat $ zipWith nthPlaceFor results' nthPlaces
where
@ -92,6 +86,7 @@ makePoll pollReq = do
checkTextLengths
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)
let fillOutLink = toPollIdLink pollId
@ -104,6 +99,7 @@ makePoll pollReq = do
checkLength . P.question $ pollReq
maybe (pure ()) checkLength . P.title $ pollReq
-- TODO: lift current domain into ENV
toPollIdLink :: P.PollId -> T.Text
toPollIdLink (P.PollId pollId) = T.append "https://rankedchoice.net/poll/" (T.pack . show $ pollId)
@ -121,12 +117,13 @@ vote pollId ballot = do
server :: ServerT A.RCVAPI AppM
server = createPage
:<|> makePoll
:<|> pure optionWithRemoveButton
:<|> (pure . pure $ ())
:<|> pure optionWithRemoveButton -- for that add option button on create page
:<|> (pure . pure $ ()) -- for remove option button on create page
:<|> getPollForBallot
:<|> vote
:<|> results
:<|> indexPage
-- TODO: always reload static stuff in dev, never reload in prod
:<|> serveDirectoryWith (defaultWebAppSettings "public")
emptyHiddenInput :: L.Html ()
@ -140,9 +137,10 @@ getPollForBallot pollId = do
My.maybe (pure ()) (h3_ . toHtml) (P.title createInfo)
h3_ . toHtml . P.question $ createInfo
with div_ [id_ "drag-boxes-container"] $ do
div_ $ 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
with div_ [classes_ ["draggable-options","sortable-from", "options", "child-borders", "border-primary", "background-primary"]]
. mconcat . map toFormInput . LN.toList . P.options $ createInfo
with form_ [hxPost_ "", id_ "drag-into-vote", hxTarget_ "closest body"] $ do
div_$ do
"to here in order of preference"
@ -159,7 +157,9 @@ optionInput :: L.Html ()
optionInput = input_ [required_ "true", name_ "options", maxlength_ "100"]
removeButton :: L.Html ()
removeButton = with button_ [classes_ ["btn", "btn-warning-outline"], hxGet_ "create/removeInput", hxSwap_ "delete", hxTarget_ "closest .options > *"] "remove"
removeButton = with button_
[classes_ ["btn", "btn-warning-outline"], hxGet_ "create/removeInput", hxSwap_ "delete", hxTarget_ "closest .options > *"]
"remove"
optionWithRemoveButton :: L.Html ()
optionWithRemoveButton = div_ (optionInput <> removeButton)
@ -178,6 +178,9 @@ createPage = do
legend_ "options"
optionWithoutRemoveButton
optionWithoutRemoveButton
-- TODO:
-- when the user adds optionWithRemoveButton on the webpage, the buttons size causes stuff to move
-- ideally there's a visible but disabled button with like a tooltip
with button_ [hxGet_ "create/newInput", hxTarget_ "this", hxSwap_ "beforebegin"] "add option"
input_ [type_ "submit", classes_ ["paper-btn", "btn-primary"], value_ "submit"]
@ -190,6 +193,8 @@ api = Proxy
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
script <- TIO.readFile "public/static/script.js"
let gen = R.globalStdGen
index <- convertMarkdown "public/static/index.md"
@ -221,7 +226,6 @@ convertMarkdown path = do
Left err -> liftIO . fail . show $ err
Right (rst :: C.Html ()) -> pure . TL.toStrict . C.renderHtml $ rst
-- we need a WAI application for the redirect middleware to act on
emptyApp :: p -> (NW.Response -> b) -> b
emptyApp _ respondf = respondf $ NW.responseLBS TS.status200 [] "redirecting to https"
@ -233,11 +237,10 @@ main = do
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"]))
pollids <- liftIO . Ac.query (db env) $ DB.GetPollIds
print pollids
print =<< (liftIO $ Ac.query (db env) (DB.GetPoll (P.PollId 4170187740530670890)))
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
case opts of
case opts of -- TODO: allow more command-line options like tls & domain
["--with-tls"] -> do
httpsSite <- A.async $ WTLS.runTLS tlsSettings warpSettings application
httpSite <- A.async $ W.run 80 $ TLS.forceSSL emptyApp