organization & better results handling

rcv-site.cabal

@@ -71,6 +71,7 @@ executable server
     InstantRunoff
     Error
     Poll
+    LucidUtils
     Ballot
     AppM
   ghc-options:

src/API.hs

@@ -17,7 +17,4 @@ type RCVAPI =
   :<|> StaticAPI
 
 type StaticAPI =
-  -- "poll" :> "create" :> Get '[HTML] T.Tex
-  -- :<|> "poll" :> Raw
-  -- :<|>
   Raw

src/Ballot.hs

@@ -4,12 +4,11 @@ import GHC.Generics
 import Data.Aeson
 import qualified Control.DeepSeq as DS
 import qualified Data.Text as T
-import qualified Data.List.NonEmpty as NE
 
 type OptionHash = Int
 
 -- done as newtype because i'll inevitably add to this
 newtype Ballot = Ballot
   {
-    options :: NE.NonEmpty T.Text
+    options :: [T.Text]
   } deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)

src/Error.hs

@@ -13,6 +13,3 @@ badPollId = throwError . withReason err400 . T.append "not a valid id: " . T.pac
 
 noPollFound :: P.PollId -> AppM a
 noPollFound = throwError . withReason err404 . T.append "invalid id, no poll with id: " . T.pack . show
-
-noVotes :: AppM a
-noVotes = throwError . withReason err400 $ "poll has no votes, or only empty ballots"

src/LucidUtils.hs

@@ -0,0 +1,27 @@
+module LucidUtils where
+import AppM
+import Lucid as L
+import Lucid.Htmx
+import qualified Control.Monad.Reader as Rd
+
+pageHead :: AppM (L.Html ())
+pageHead = do
+  script <- Rd.asks script
+  pure . head_ $ do
+    link_ [href_ "/static/style.css", rel_ "stylesheet"]
+    link_ [href_ "/static/paper.min.css", rel_ "stylesheet"]
+    link_ [href_ "/static/fonts.css", rel_ "stylesheet"]
+    with (script_ "") [src_ "/static/Sortable.min.js"]
+    with (script_ "") [src_ "/static/htmx.min.js"]
+    with (script_ "") [src_ "/static/json-enc.js"]
+    script_ script
+
+pageBody :: L.Html () -> L.Html ()
+pageBody = with body_ [classes_ ["container", "container-sm", "paper"], hxExt_ "json-enc"]
+
+fullPage :: L.Html () -> AppM (L.Html ())
+fullPage rest = do
+  customHead <- pageHead
+  pure $ doctypehtml_ $ do
+    customHead
+    pageBody rest

src/Main.hs

@@ -6,14 +6,12 @@ import qualified Ballot as B
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Lucid as L
 import Lucid.Htmx
-import Network.HTTP.Types (status200, hContentType)
 import Network.Wai.Application.Static (defaultWebAppSettings, StaticSettings (ss404Handler))
 import Servant
 import qualified Control.Monad.Reader as Rd
 import qualified Data.Acid as Ac
 import qualified Data.Hashable as H
 import qualified Data.List.NonEmpty as LN
-import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as M
 import qualified Data.Maybe as My
 import qualified Data.Text as T
@@ -26,10 +24,9 @@ import qualified Poll as P
 import qualified System.Environment as S
 import qualified Data.Text.IO as TIO
 import qualified System.Random.Stateful as R
-import qualified Text.Show as T
 import qualified Data.Set as S
 import qualified Control.Monad as M
-
+import LucidUtils
 
 throwOrLift :: AppM a -> Maybe a -> AppM a
 throwOrLift err = My.maybe err pure
@@ -43,28 +40,29 @@ getFromPollId pollId query = do
 notVotedFor :: P.Poll -> S.Set T.Text
 notVotedFor (P.Poll {..}) = S.difference allOptions votedFor
   where
-    votedFor = S.unions $ map (S.fromList . LN.toList . B.options) votes
+    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
   poll :: P.Poll <- getFromPollId pollId (liftIO . Ac.query db . DB.GetPoll)
-  votesList <- throwOrLift Er.noVotes . maybeVotes $ poll
-  let voteless = notVotedFor poll
-  let results' = (reverse . IR.solve . NE.map B.options $ votesList) ++ (noVotesOptions voteless)
-  fullPage $ do
-    h2_ "results"
-    maybe "" (h3_ . toHtml) . P.title . P.createInfo $ poll
-    h3_ . toHtml . P.question . P.createInfo $ poll
-    with div_ [id_ "results"] . mconcat $ zipWith nthPlaceFor results' nthPlaces
+  case toNonEmptyList . P.votes $ poll of
+    Nothing -> fullPage "poll doesn't have any votes"
+    Just votesList -> do
+      let voteless = notVotedFor poll
+      let results' = (reverse . IR.solve $ votesList) ++ noVotesAsBallot voteless
+      fullPage $ do
+        h2_ "results"
+        maybe "" (h3_ . toHtml) . P.title . P.createInfo $ poll
+        h3_ . toHtml . P.question . P.createInfo $ poll
+        with div_ [id_ "results"] . mconcat $ zipWith nthPlaceFor results' nthPlaces
   where
-    noVotesOptions :: S.Set T.Text -> [S.Set T.Text]
-    noVotesOptions notVotedFor' = if S.null notVotedFor' then [] else [notVotedFor']
+    noVotesAsBallot :: S.Set T.Text -> [S.Set T.Text]
+    noVotesAsBallot notVotedFor' = if S.null notVotedFor' then [] else [notVotedFor']
 
-    -- discarding empty ballots
-    maybeVotes :: P.Poll -> Maybe (LN.NonEmpty B.Ballot)
-    maybeVotes = LN.nonEmpty . P.votes
+    toNonEmptyList :: [B.Ballot] -> Maybe (LN.NonEmpty (LN.NonEmpty T.Text))
+    toNonEmptyList = LN.nonEmpty . My.mapMaybe (LN.nonEmpty . B.options)
 
     nthPlaceFor :: S.Set T.Text -> L.Html () -> L.Html ()
     nthPlaceFor options place = do
@@ -81,6 +79,7 @@ nthPlaces =
   with span_ [classes_ ["third-place",  "badge"]] "3rd"]
     ++ map (\n -> with span_ [class_ "badge"] . toHtml $ T.append (T.pack . show $ n) "th") [4 :: Int ..]
 
+
 makePoll :: P.CreatePollInfo -> AppM (L.Html ())
 makePoll pollReq = do
   db <- Rd.asks db
@@ -94,15 +93,18 @@ makePoll pollReq = do
 
 
 toPollIdLink :: P.PollId -> T.Text
-toPollIdLink (P.PollId pollId) = T.append "//rankedchoice.net/poll/" (T.pack . show $ pollId)
+toPollIdLink (P.PollId pollId) = T.append "https://rankedchoice.net/poll/" (T.pack . show $ pollId)
 
 vote :: P.PollId -> B.Ballot -> AppM (L.Html ())
 vote pollId ballot = do
   db <- Rd.asks db
-  liftIO $ Ac.update db (DB.PostBallot pollId ballot)
+  liftIO $ Ac.update db (DB.PostBallot pollId ballot')
   pure $ with div_ [id_ "resultLink"] $ do
     "success! Here's the "
     with a_ [href_ (toPollIdLink pollId `T.append` "/results")] "results"
+  where
+    ballot' = B.Ballot . filter (== "") . B.options $ ballot
+
 
 server :: ServerT A.RCVAPI AppM
 server = createPage
@@ -114,6 +116,10 @@ server = createPage
   :<|> results
   :<|> serveDirectoryWith (defaultWebAppSettings "public")
 
+emptyHiddenInput :: L.Html ()
+emptyHiddenInput = input_ [hidden_ "", name_ "options", value_ ""]
+
+
 getPollForBallot :: P.PollId -> AppM (L.Html ())
 getPollForBallot pollId = do
   db <- Rd.asks db
@@ -128,35 +134,14 @@ getPollForBallot pollId = do
         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"]] ""
+            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"]
   where
     toFormInput :: T.Text -> L.Html ()
     toFormInput option = with div_ [classes_ []] $ input_ [type_ "hidden", value_ option, name_ "options"] <> toHtml option
 
 
-fullPage :: L.Html () -> AppM (L.Html ())
-fullPage rest = do
-  customHead <- pageHead
-  pure $ doctypehtml_ $ do
-    customHead
-    pageBody rest
-
-pageHead :: AppM (L.Html ())
-pageHead = do
-  script <- Rd.asks script
-  pure . head_ $ do
-    link_ [href_ "/static/style.css", rel_ "stylesheet"]
-    link_ [href_ "/static/paper.min.css", rel_ "stylesheet"]
-    link_ [href_ "/static/fonts.css", rel_ "stylesheet"]
-    with (script_ "") [src_ "/static/Sortable.min.js"]
-    with (script_ "") [src_ "/static/htmx.min.js"]
-    with (script_ "") [src_ "/static/json-enc.js"]
-    script_ script
-
-pageBody :: L.Html () -> L.Html ()
-pageBody = with body_ [classes_ ["container", "container-sm", "paper"], hxExt_ "json-enc"]
-
 optionInput :: L.Html ()
 optionInput = input_ [required_ "true", name_ "options", maxlength_ "100"]
 

src/Poll.hs

@@ -7,14 +7,12 @@ import GHC.Generics
 import qualified Control.DeepSeq as DS
 import qualified Data.List.NonEmpty as LN
 import Data.Word
-import qualified Data.Set as S
 import Servant.API
 import qualified Data.Bifunctor as Bi
 
 maximumTextLength :: Int
 maximumTextLength = 280
 
-
 newtype PollId = PollId Word64 deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
 
 instance FromHttpApiData PollId where