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

it works!

Browse source
This commit is contained in:
Jack Wines 2023-05-26 21:17:24 -07:00
parent f27ad43635
commit c9eae072b9
8 changed files with 287 additions and 152 deletions
Download patch file Download diff file Expand all files Collapse all files

259
client/src/Main.elm
View file

@ -1,27 +1,27 @@
module Main exposing (..)
import Array as A
import Browser
import Browser as B
import Browser.Navigation
import Html exposing (..)
import Html.Attributes as HA
import Html.Events as HE
import Html.Keyed as Keyed
import Http
import Json.Decode as D
import Json.Encode as E
import List as L
import List as L exposing ((::))
import Maybe as M
import Platform.Cmd as PC
import Result as R
import Html.Keyed as Keyed
import Reorderable as R
import Result as R
import String as S
import Url
import Url.Parser as P exposing ((</>))
main =
Browser.application
B.application
{ init = init
, update = update
, view = view
@ -34,12 +34,14 @@ main =
type Route
= Create
| VotingOnPoll Int
| TryViewResults Int
routeParser : P.Parser (Route -> a) a
routeParser =
P.oneOf
[ P.map VotingOnPoll (P.s "vote" </> P.int)
[ P.map VotingOnPoll (P.s "poll" </> P.int </> P.s "vote")
, P.map TryViewResults (P.s "poll" </> P.int </> P.s "results")
, P.map Create (P.s "create")
]
@ -50,7 +52,9 @@ subscriptions model =
init : () -> Url.Url -> Browser.Navigation.Key -> ( Model, Cmd Msg )
init _ url _ = parseUrl url
init _ url _ =
parseUrl url
emptyCreatePollInfo =
CreatePollInfo { title = Nothing, question = "", options = A.empty }
@ -61,7 +65,8 @@ type Model
| WrongUrl
| Error String
| Voting Poll
| ViewingResults Poll
| Voted Int
| ViewingResult Result
| Creating CreatePollInfo
| SubmitResult Int
@ -74,14 +79,18 @@ type Msg
= NewCreatePollInfo CreatePollInfo
| Submit
| Submitted Int
| RecievedBallot CreatePollInfo
| LinkClicked Browser.UrlRequest
| SubmitBallot
| SubmittedBallot
| RecievedBallot Int CreatePollInfo
| RecievedResult Result
| LinkClicked B.UrlRequest
| UrlChanged Url.Url
| ThrowError String
| Remove Int
| MoveUp Int
| MoveDown Int
type CreatePollInfo
= CreatePollInfo
{ title : Maybe String
@ -90,6 +99,12 @@ type CreatePollInfo
}
type Result
= Result
{ rounds : List (List String)
}
createPollInfoNoRecord title question options =
CreatePollInfo { title = title, question = question, options = options }
@ -110,23 +125,38 @@ createPollInfoEncoder (CreatePollInfo createPollInfo) =
]
resultDecoder =
D.map (\x -> Result { rounds = x }) (D.field "winners" (D.list (D.list D.string)))
-- ("title", E.string createPollInfo.title)
ballotEncoder x =
E.object
[ ( "votes", E.list E.string <| R.toList x )
]
type Poll
= Poll
{ createInfo : CreatePollInfo
, votes : R.Reorderable String
, id : Int
}
parseUrl url =
let
toModel response =
toModel pollId response =
case response of
Ok createPollInfo ->
RecievedBallot createPollInfo
RecievedBallot pollId createPollInfo
Err e ->
ThrowError "couldn't decode poll info"
toResults pollId response =
case response of
Ok results ->
RecievedResult results
Err e ->
ThrowError "couldn't decode poll info"
@ -136,7 +166,15 @@ parseUrl url =
( Loading
, Http.get
{ url = S.concat [ "/api/poll/", S.fromInt pollId, "/vote" ]
, expect = Http.expectJson toModel createPollInfoDecoder
, expect = Http.expectJson (toModel pollId) createPollInfoDecoder
}
)
Just (TryViewResults pollId) ->
( Loading
, Http.get
{ url = S.concat [ "/api/poll/", S.fromInt pollId, "/results" ]
, expect = Http.expectJson (toResults pollId) resultDecoder
}
)
@ -147,44 +185,107 @@ parseUrl url =
( WrongUrl, Cmd.none )
type Ballot
= Ballot
{ votes : List String
}
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case ( msg, model ) of
(NewCreatePollInfo newCreateInfo, _) -> ( Creating newCreateInfo, Cmd.none )
( NewCreatePollInfo newCreateInfo, _ ) ->
( Creating newCreateInfo, Cmd.none )
( Submit, Creating createInfo ) ->
let
toMsg response = case response of
Ok id -> Submitted id
Err err -> ThrowError "couldn't parse poll submit response"
toMsg response =
case response of
Ok id ->
Submitted id
Err err ->
ThrowError "couldn't parse poll submit response"
in
( model,
Http.post
( model
, Http.post
{ url = "/api/poll/create"
, expect = Http.expectJson (toMsg) D.int
, expect = Http.expectJson toMsg D.int
, body = Http.jsonBody <| createPollInfoEncoder createInfo
}
)
(Submitted id, _) -> (SubmitResult id, Cmd.none)
(RecievedBallot createInfo, _) -> (Voting (Poll {
createInfo = createInfo,
votes = case createInfo of
(CreatePollInfo {options}) -> R.fromList <| A.toList <| options
}), Cmd.none)
(UrlChanged url, _) -> parseUrl url
(_, Voting (Poll {createInfo, votes})) ->
( Submitted id, _ ) ->
( SubmitResult id, Cmd.none )
( SubmitBallot, Voting (Poll { createInfo, votes, id }) ) ->
let
toMsg response =
case response of
Ok () ->
SubmittedBallot
Err err ->
ThrowError "couldn't parse ballot submit response"
in
( model
, Http.post
{ url = S.concat [ "/api/poll/", S.fromInt id, "/vote" ]
, expect = Http.expectWhatever toMsg
, body = Http.jsonBody <| ballotEncoder votes
}
)
( SubmittedBallot, Voting (Poll { id }) ) ->
( Voted id, Cmd.none )
( RecievedBallot pollId createInfo, _ ) ->
( Voting
(Poll
{ id = pollId
, createInfo = createInfo
, votes =
case createInfo of
CreatePollInfo { options } ->
R.fromList <| A.toList <| options
}
)
, Cmd.none
)
( RecievedResult result, _ ) ->
( ViewingResult result-- (Result { rounds = [ [ "a", "g", "q" ], [ "gabababbaba" ], [ "goooeuooa", "more stuff" ], [ "lone thing" ] ] })
, Cmd.none )
( UrlChanged url, _ ) ->
parseUrl url
( LinkClicked (B.Internal url), _ ) ->
parseUrl url
( _, Voting (Poll { createInfo, votes, id }) ) ->
let
changedVotes =
case msg of
Remove idx -> R.drop idx votes
MoveUp idx -> R.moveUp idx votes
MoveDown idx -> R.moveDown idx votes
_ -> votes
Remove idx ->
R.drop idx votes
MoveUp idx ->
R.moveUp idx votes
MoveDown idx ->
R.moveDown idx votes
_ ->
votes
in
(Voting (Poll {createInfo = createInfo, votes = changedVotes}), Cmd.none)
( Voting (Poll { createInfo = createInfo, votes = changedVotes, id = id }), Cmd.none )
( ThrowError e, _ ) ->
( Error "uhh", Cmd.none )
(_, _) -> ( model, Cmd.none )
( _, _ ) ->
( model, Cmd.none )
viewInput : String -> String -> String -> (String -> msg) -> Html msg
@ -192,7 +293,7 @@ viewInput t p v toMsg =
input
[ HA.type_ t
, HA.placeholder p
, HA.value v -- , HE.onInput toMsg
, HA.value v
]
[]
@ -213,7 +314,8 @@ remove n arr =
-- set _ _ [] = Nothing
inputWithLabel name attributes = div []
inputWithLabel name attributes =
div []
[ label [ HA.for name ] [ text name ]
, input (HA.name name :: attributes) []
]
@ -222,11 +324,14 @@ inputWithLabel name attributes = div []
view model =
let
body =
L.singleton <|
div [ HA.class "paper container container-sm" ] <|
L.singleton <|
case model of
Creating (CreatePollInfo createInfo) ->
let
toOption index option = div [HA.style "display" "grid", HA.style "grid-template-columns" "auto 80px", HA.style "column-gap" "5px"]
toOption index option =
div [ HA.style "display" "grid", HA.style "grid-template-columns" "auto 80px", HA.style "column-gap" "5px" ]
[ input
[ HA.type_ "text"
, HA.value option
@ -242,9 +347,8 @@ view model =
L.singleton <|
div
[ HA.style "display" "flex", HA.style "flex-direction" "column", HA.style "max-width" "400px", HA.style "gap" "10px" ]
[ h3 [] [text "create a new poll"],
inputWithLabel "title (optional)"
[ h3 [] [ text "create a new poll" ]
, inputWithLabel "title (optional)"
[ HA.type_ "text"
, HA.value (Maybe.withDefault "" createInfo.title)
, HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | title = Just change }))
@ -254,8 +358,7 @@ view model =
, HA.value createInfo.question
, HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | question = change }))
]
,
div [ HA.style "display" "flex", HA.style "flex-direction" "column" ]
, div [ HA.style "display" "flex", HA.style "flex-direction" "column" ]
[ text "options"
, div [ HA.style "padding-left" "20px" ]
[ div
@ -272,8 +375,7 @@ view model =
[ text "add new option" ]
]
]
,
button
, button
[ HA.style "align-self" "start"
, HA.class "paper-btn btn-primary"
, HE.onClick Submit
@ -284,41 +386,70 @@ view model =
SubmitResult id ->
let
pollLink =
"http://localhost:8080/vote/" ++ S.fromInt id
"rankedchoice.net/poll/" ++ S.fromInt id ++ "/vote"
in
div
[ HA.style "display" "flex", HA.style "justify-content" "center", HA.style "align-items" "center", HA.style "height" "100vh" ]
<|
L.singleton <|
div [] [ text "people can fill out your poll at ", a [ HA.href pollLink ] [ text pollLink ] ]
div [] [ text "people can fill out your poll at ", a [ HA.href <| S.concat [ "/poll/", S.fromInt id, "/vote" ] ] [ text pollLink ] ]
-- Voting (Poll {createInfo , votes}) -> case createInfo of
-- CreatePollInfo {title, question, options} -> div [] <| A.toList <| A.map text options
Voting (Poll {createInfo , votes}) -> case createInfo of
CreatePollInfo {title, question, options} -> div
[ HA.style "display" "flex", HA.style "justify-content" "center", HA.style "align-items" "center"]
<| L.singleton <| div []
[
h3 [] [text question],
table [] <| L.singleton <| tbody [] <| L.map (\(_, x) -> x) <| L.indexedMap viewItem (R.toKeyedList votes),
button [HE.onClick Submit] [text "submit"]
Voting (Poll { createInfo, votes }) ->
case createInfo of
CreatePollInfo { title, question, options } ->
let
rest =
[ h3 [] [ text question ]
, table [ HA.style "width" "auto", HA.style "margin-bottom" "70px" ] <| L.singleton <| tbody [] <| L.map (\( _, x ) -> x) <| L.indexedMap viewItem (R.toKeyedList votes)
, button [ HE.onClick SubmitBallot ] [ text "submit" ]
]
in
div [ HA.style "display" "flex", HA.style "flex-direction" "column", HA.style "justify-content" "center", HA.style "align-items" "center", HA.style "width" "auto" ]
(case title of
Nothing ->
rest
Just x ->
h3 [] [ text x ] :: rest
)
Voted id ->
div
[ HA.style "display" "flex", HA.style "justify-content" "center", HA.style "align-items" "center", HA.style "flex-direction" "column", HA.style "width" "auto" ]
[ text "you're done!"
, a [ HA.href "./results" ] [ text "results" ]
]
ViewingResult (Result { rounds }) ->
div [ HA.style "display" "flex", HA.style "flex-direction" "column", HA.style "align-items" "center" ] <|
(h3 [] [text "results"]) :: L.map
(\place ->
case place of
[ x ] ->
div [] [ text x ]
rest ->
ul [ HA.class "inline", HA.style "padding-left" "0px" ] <| L.append (L.map (\x -> li [ HA.style "padding-right" "10px" ] [ text x ]) place) [ span [ HA.class "badge" ] [ text "tie" ] ]
)
rounds
Loading ->
text "loading..."
Error e ->
text e
WrongUrl ->
text "wrong url..."
_ ->
text "uhhh"
in
{ title = "uhh, title"
{ title = "easy ranked choice voting"
, body = body
}
viewItem idx ( key, value ) = tr [HA.style "display" "grid", HA.style "grid-template-columns" "70% 46.5px 46.5px 80px", HA.style "gap" "10px"]
[
td [] <| L.singleton <| text value
viewItem idx ( key, value ) =
tr [ HA.style "display" "grid", HA.style "grid-template-columns" "auto 46.5px 46.5px 80px", HA.style "gap" "10px" ]
[ td [ HA.style "margin-right" "75px" ] <| L.singleton <| text value
, td [ HE.onClick <| MoveUp idx ] [ button [ HA.class "btn-small" ] <| L.singleton <| text "↑" ]
, td [ HE.onClick <| MoveDown idx ] [ button [ HA.class "btn-small" ] <| L.singleton <| text "↓" ]
, td [ HE.onClick <| Remove idx ] [ button [ HA.class "btn", HA.class "btn-danger-outline", HA.class "btn-small" ] <| L.singleton <| text "remove" ]

2
server/rcv-site.cabal
View file

@ -39,7 +39,7 @@ executable server
aeson,
uuid,
base,
acid-state,
acid-state == 0.16.1.2,
safecopy,
random,
splitmix,

4
server/src/API.hs
View file

@ -1,17 +1,15 @@
module API where
import qualified Ballot as B
import qualified Data.Text as T
import qualified Poll as P
import Servant.API
type PollResult = [T.Text]
type RCVAPI =
"api" :> "poll" :> "create" :> ReqBody '[JSON] P.CreatePollInfo :> Post '[JSON] P.PollId
:<|> "api" :> "poll" :> Capture "pollId" P.PollId :> "vote" :> Get '[JSON] P.CreatePollInfo
:<|> "api" :> "poll" :> Capture "pollId" P.PollId :> "vote" :> ReqBody '[JSON] B.Ballot :> Post '[JSON] ()
:<|> "api" :> "poll" :> Capture "pollId" P.PollId :> "result" :> Get '[JSON] PollResult
:<|> "api" :> "poll" :> Capture "pollId" P.PollId :> "results" :> Get '[JSON] P.Result
:<|> StaticAPI
type StaticAPI =

3
server/src/Ballot.hs
View file

@ -4,11 +4,12 @@ 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
{
votes :: [OptionHash]
votes :: NE.NonEmpty T.Text
} deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)

9
server/src/Database.hs
View file

@ -11,6 +11,7 @@ import qualified Poll as P
import qualified Ballot as B
import qualified System.Random as R
import qualified System.Random.SplitMix as SM
import qualified Data.Bifunctor as Bi
data DB = DB {
gen :: R.StdGen,
@ -25,7 +26,7 @@ createPoll createInfo = MS.state go
where
go DB {..} = (pollId, DB {polls = M.insert pollId insertedPoll polls, gen = gen'})
where
(pollId, gen') = R.genWord32 gen
(pollId, gen') = Bi.first P.PollId . R.genWord32 $ gen
insertedPoll = P.Poll
{
@ -39,6 +40,9 @@ getPollForBallot pollId = MR.asks (fmap P.createInfo . M.lookup pollId . polls)
getPollIds :: Ac.Query DB [P.PollId]
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
@ -52,10 +56,11 @@ postBallot pollId ballot = MS.modify go
$(SC.deriveSafeCopy 0 'SC.base ''P.CreatePollInfo)
$(SC.deriveSafeCopy 0 'SC.base ''B.Ballot)
$(SC.deriveSafeCopy 0 'SC.base ''P.Poll)
$(SC.deriveSafeCopy 0 'SC.base ''P.PollId)
$(SC.deriveSafeCopy 0 'SC.base ''SM.SMGen)
$(SC.deriveSafeCopy 0 'SC.base ''R.StdGen)
$(SC.deriveSafeCopy 0 'SC.base ''DB)
Ac.makeAcidic ''DB['createPoll, 'getPollForBallot, 'getPoll, 'postBallot, 'getPollIds]
Ac.makeAcidic ''DB['createPoll, 'getPollForBallot, 'getPoll, 'postBallot, 'getPollIds, 'getDB]
openLocalDB :: IO (Ac.AcidState DB)
openLocalDB = do

4
server/src/InstantRunoff.hs
View file

@ -10,8 +10,8 @@ import Data.Maybe hiding (catMaybes)
import Data.Ratio
import qualified Data.Maybe as L
solve :: Ord a => Show a => LN.NonEmpty (LN.NonEmpty a) -> S.Set a
solve votes = maybe (M.keysSet voteCounts) solve . remove $ firstChoiceLosers
solve :: Ord a => Show a => LN.NonEmpty (LN.NonEmpty a) -> [S.Set a]
solve votes = maybe (L.singleton . M.keysSet $ voteCounts) ((firstChoiceLosers : ) . solve) . remove $ firstChoiceLosers
where
-- if Nothing, then all options in votes are valued equally

26
server/src/Main.hs
View file

@ -3,15 +3,9 @@ module Main where
import qualified API as A
import AppM
import qualified Ballot as B
import Control.Concurrent (takeMVar)
import qualified Control.Concurrent.MVar as MV
import qualified Control.Monad as CM
import qualified Control.Monad.Except as Ex
import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Control.Monad.Reader as Rd
import qualified Data.Acid as Ac
import Data.Aeson (ToJSON (toJSON), encode)
import qualified Data.ByteString.Lazy as BS
import qualified Data.Hashable as H
import qualified Data.List.NonEmpty as LN
import qualified Data.Map.Strict as M
@ -25,9 +19,9 @@ import qualified Network.Wai.Handler.Warp as W
import qualified Poll as P
import Servant
import Network.Wai.Application.Static (defaultWebAppSettings, StaticSettings (ss404Handler))
import Network.Wai (responseFile)
import qualified Network.Wai as W
import Network.HTTP.Types (status200, hContentType)
import qualified Data.List.NonEmpty as NE
staticFolderLoc = "../client/static"
@ -46,20 +40,16 @@ getFromPollId pollId query = do
pollResult <- query pollId
throwOrLift (Er.noPollFound pollId) pollResult
getResult :: P.PollId -> AppM A.PollResult
getResult :: P.PollId -> AppM P.Result
getResult pollId = do
db <- Rd.asks db
poll <- getFromPollId pollId $ liftIO . Ac.query db . DB.GetPoll
votesList <- throwOrLift Er.noVotes $ maybeVotes poll
pure $ solveAndUnHash poll votesList
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
where
-- discarding empty ballots
maybeVotes :: P.Poll -> Maybe (LN.NonEmpty (LN.NonEmpty B.OptionHash))
maybeVotes = LN.nonEmpty . My.mapMaybe (LN.nonEmpty . B.votes) . P.votes
unHashedMap = mapFromHash . LN.toList . P.options . P.createInfo
solveAndUnHash poll = My.mapMaybe (`M.lookup` unHashedMap poll) . S.toList . IR.solve
maybeVotes :: P.Poll -> Maybe (LN.NonEmpty (B.Ballot))
maybeVotes = LN.nonEmpty . P.votes
mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text
mapFromHash = M.fromList . map (\x -> (H.hash x, x))
@ -94,6 +84,4 @@ runWithEnv = flip Rd.runReaderT
main :: IO ()
main = do
env <- getEnv
everything <- liftIO $ Ac.query (db env) DB.GetPollIds
print everything
W.run 8080 . serve api . hoistServer api (runWithEnv env) $ server

14
server/src/Poll.hs
View file

@ -7,11 +7,23 @@ 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
type PollId = Word32
newtype Result = Result
{
winners :: [S.Set T.Text]
}
deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
newtype PollId = PollId Word32 deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
instance FromHttpApiData PollId where
parseUrlPiece = Bi.second PollId . parseUrlPiece
data Poll = Poll
{