added results screen

public/static/style.css

@@ -4,6 +4,35 @@ body {
     align-items: center;
 }
 
+.first-place {
+  background-color: #c4a500 !important;
+}
+
+.second-place {
+  background-color: #cecdcd !important;
+}
+
+.third-place {
+  background-color: #955822 !important;
+}
+
+#results {
+  display: grid;
+  grid-template-columns: auto 30%;
+  column-gap: 7px;
+  row-gap: 5px;
+}
+
+#results > div {
+  display: flex;
+  flex-direction:  row;
+  gap: 7px;
+}
+
+#results > div > div {
+  padding: 2px
+}
+
 #inputs, .options {
     display: flex;
     flex-direction: column;

src/API.hs

@@ -12,8 +12,8 @@ type RCVAPI =
   :<|> "create" :> "newInput" :> Get '[SL.HTML] (L.Html ())
   :<|> "create" :> "removeInput" :> Get '[SL.HTML] (L.Html ())
   :<|> "poll" :> Capture "pollId" P.PollId :> Get '[SL.HTML] (L.Html ())
-  -- :<|> "api" :> "poll" :> Capture "pollId" P.PollId :> "vote" :> ReqBody '[JSON] B.Ballot :> Post '[JSON] ()
-  -- :<|> "api" :> "poll" :> Capture "pollId" P.PollId :> "results" :> Get '[JSON] P.Result
+  :<|> "poll" :> Capture "pollId" P.PollId :> ReqBody '[JSON] B.Ballot :> Post '[SL.HTML] (L.Html ())
+  :<|> "poll" :> Capture "pollId" P.PollId :> "results" :> Get '[SL.HTML] (L.Html ())
   :<|> StaticAPI
 
 type StaticAPI =

src/Ballot.hs

@@ -11,5 +11,5 @@ type OptionHash = Int
 -- done as newtype because i'll inevitably add to this
 newtype Ballot = Ballot
   {
-    votes :: NE.NonEmpty T.Text
+    options :: NE.NonEmpty T.Text
   } deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)

src/Main.hs

@@ -26,6 +26,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
 
 
 throwOrLift :: AppM a -> Maybe a -> AppM a
@@ -37,43 +40,78 @@ getFromPollId pollId query = do
   pollResult <- query pollId
   throwOrLift (Er.noPollFound pollId) pollResult
 
-getResult :: P.PollId -> AppM P.Result
-getResult pollId = 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
+    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
-  pure $ P.Result . reverse . IR.solve . NE.map B.votes $ votesList
+  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
   where
+    noVotesOptions :: S.Set T.Text -> [S.Set T.Text]
+    noVotesOptions notVotedFor' = if S.null notVotedFor' then [] else [notVotedFor']
+
     -- discarding empty ballots
     maybeVotes :: P.Poll -> Maybe (LN.NonEmpty B.Ballot)
     maybeVotes = LN.nonEmpty . P.votes
 
+    nthPlaceFor :: S.Set T.Text -> L.Html () -> L.Html ()
+    nthPlaceFor options place = do
+      with div_ [classes_ ["child-borders"]] . mconcat . map (div_ . toHtml) . S.toList $ options
+      place
+
 mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text
 mapFromHash = M.fromList . map (\x -> (H.hash x, x))
 
+nthPlaces :: [L.Html ()]
+nthPlaces =
+  [with span_ [classes_ ["first-place", "badge"]] "1st",
+  with span_ [classes_ ["second-place", "badge"]] "2nd",
+  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
   gen <- Rd.asks gen
   pollId <- P.PollId <$> R.uniformWord64 gen
   liftIO $ Ac.update db (DB.CreatePoll pollReq pollId)
-  let fillOutLink = T.append "https://rankedchoice.net/poll/" (T.pack . show $ pollId)
-  pure $ do
+  let fillOutLink = toPollIdLink pollId
+  pure . div_ $ do
     "done! people can fill out your poll at "
     with a_ [href_ fillOutLink] (toHtml fillOutLink)
 
-vote :: P.PollId -> B.Ballot -> AppM ()
+
+toPollIdLink :: P.PollId -> T.Text
+toPollIdLink (P.PollId pollId) = T.append "//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)
-  pure ()
+  pure $ with div_ [id_ "resultLink"] $ do
+    "success! Here's the "
+    with a_ [href_ (toPollIdLink pollId `T.append` "/results")] "results"
 
 server :: ServerT A.RCVAPI AppM
 server = createPage
   :<|> makePoll
-  :<|> pure optionInput
+  :<|> pure optionWithRemoveButton
   :<|> (pure . pure $ ())
   :<|> getPollForBallot
+  :<|> vote
+  :<|> results
   :<|> serveDirectoryWith ((defaultWebAppSettings "public"))
 
 getPollForBallot :: P.PollId -> AppM (L.Html ())
@@ -87,7 +125,7 @@ getPollForBallot pollId = do
         div_ $ do
           "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 form_  [hxPost_ "", id_ "drag-into-vote"] $ 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"]] ""
@@ -118,9 +156,16 @@ pageBody :: L.Html () -> L.Html ()
 pageBody = with body_ [classes_ ["container", "container-sm", "paper"], hxExt_ "json-enc"]
 
 optionInput :: L.Html ()
-optionInput = div_ $
-  input_ [required_ "true", name_ "options", maxlength_ "100"] <>
-  with button_ [classes_ ["btn", "btn-warning-outline"], hxGet_ "create/removeInput", hxSwap_ "delete", hxTarget_ "closest .options > *"] "remove"
+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"
+
+optionWithRemoveButton :: L.Html ()
+optionWithRemoveButton = div_ (optionInput <> removeButton)
+
+optionWithoutRemoveButton :: L.Html ()
+optionWithoutRemoveButton = div_ optionInput
 
 createPage :: AppM (L.Html ())
 createPage = do
@@ -131,8 +176,8 @@ createPage = do
       with label_ [for_ "question"] "question" <> input_ [name_ "question", type_ "text", required_ "true", maxlength_ "100"]
       with fieldset_ [name_ "options", class_ "options"] $ do
         legend_ "options"
-        optionInput
-        optionInput
+        optionWithoutRemoveButton
+        optionWithoutRemoveButton
         with button_ [hxGet_ "create/newInput", hxTarget_ "this", hxSwap_ "beforebegin"] "add option"
       input_ [type_ "submit", classes_ ["paper-btn", "btn-primary"], value_ "submit"]
 
@@ -159,7 +204,7 @@ examplePoll :: P.CreatePollInfo
 examplePoll = P.CreatePollInfo {
   title = Nothing,
   question = "what's your favorite color?",
-  options = "red" LN.:| ["blue", "green", "yellow"]
+  options = "red" LN.:| ["blue", "green", "yellow", "orange", "pink", "purple", "grey", "black"]
                      }
 
 main :: IO ()
@@ -168,7 +213,9 @@ main = do
   opts <- S.getArgs
   -- let gen = R.globalStdGen
   -- pollId <- P.PollId <$> R.uniformWord64 gen
-  _ <- liftIO $ Ac.update (db env) (DB.CreatePoll examplePoll (P.PollId 7))
+  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
   let application = serve api . hoistServer api (runWithEnv env) $ server

src/Poll.hs

@@ -14,11 +14,6 @@ import qualified Data.Bifunctor as Bi
 maximumTextLength :: Int
 maximumTextLength = 280
 
-newtype Result = Result
-  {
-    winners :: [S.Set T.Text]
-  }
-  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
 
 newtype PollId = PollId Word64 deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)