documentation

src/Error.hs

@@ -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

src/InstantRunoff.hs

@@ -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
+        ballotPreference :: [a] -> Maybe a
-        ballotFavors = L.find (`S.member` [x0, x1])
+        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 .

src/LucidUtils.hs

@@ -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

src/Main.hs

@@ -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 optionWithRemoveButton -- for that add option button on create page
-  :<|> (pure . pure $ ())
+  :<|> (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
+  M.void . liftIO $ Ac.update (db env) (DB.PostBallot (P.PollId 7) (B.Ballot ["purple", "black", "yellow", "orange", "blue"]))
-  print pollids
+  mapM_ print =<< (liftIO . Ac.query (db env) $ DB.GetPollIds)
-  print =<< (liftIO $ Ac.query (db env) (DB.GetPoll (P.PollId 4170187740530670890)))
   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