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

377
client/src/Main.elm
View file

@ -1,27 +1,27 @@
module Main exposing (..) module Main exposing (..)
import Array as A import Array as A
import Browser import Browser as B
import Browser.Navigation import Browser.Navigation
import Html exposing (..) import Html exposing (..)
import Html.Attributes as HA import Html.Attributes as HA
import Html.Events as HE import Html.Events as HE
import Html.Keyed as Keyed
import Http import Http
import Json.Decode as D import Json.Decode as D
import Json.Encode as E import Json.Encode as E
import List as L import List as L exposing ((::))
import Maybe as M import Maybe as M
import Platform.Cmd as PC import Platform.Cmd as PC
import Result as R
import Html.Keyed as Keyed
import Reorderable as R import Reorderable as R
import Result as R
import String as S import String as S
import Url import Url
import Url.Parser as P exposing ((</>)) import Url.Parser as P exposing ((</>))
main = main =
Browser.application B.application
{ init = init { init = init
, update = update , update = update
, view = view , view = view
@ -34,12 +34,14 @@ main =
type Route type Route
= Create = Create
| VotingOnPoll Int | VotingOnPoll Int
| TryViewResults Int
routeParser : P.Parser (Route -> a) a routeParser : P.Parser (Route -> a) a
routeParser = routeParser =
P.oneOf 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") , P.map Create (P.s "create")
] ]
@ -50,7 +52,9 @@ subscriptions model =
init : () -> Url.Url -> Browser.Navigation.Key -> ( Model, Cmd Msg ) init : () -> Url.Url -> Browser.Navigation.Key -> ( Model, Cmd Msg )
init _ url _ = parseUrl url init _ url _ =
parseUrl url
emptyCreatePollInfo = emptyCreatePollInfo =
CreatePollInfo { title = Nothing, question = "", options = A.empty } CreatePollInfo { title = Nothing, question = "", options = A.empty }
@ -61,7 +65,8 @@ type Model
| WrongUrl | WrongUrl
| Error String | Error String
| Voting Poll | Voting Poll
| ViewingResults Poll | Voted Int
| ViewingResult Result
| Creating CreatePollInfo | Creating CreatePollInfo
| SubmitResult Int | SubmitResult Int
@ -74,14 +79,18 @@ type Msg
= NewCreatePollInfo CreatePollInfo = NewCreatePollInfo CreatePollInfo
| Submit | Submit
| Submitted Int | Submitted Int
| RecievedBallot CreatePollInfo | SubmitBallot
| LinkClicked Browser.UrlRequest | SubmittedBallot
| RecievedBallot Int CreatePollInfo
| RecievedResult Result
| LinkClicked B.UrlRequest
| UrlChanged Url.Url | UrlChanged Url.Url
| ThrowError String | ThrowError String
| Remove Int | Remove Int
| MoveUp Int | MoveUp Int
| MoveDown Int | MoveDown Int
type CreatePollInfo type CreatePollInfo
= CreatePollInfo = CreatePollInfo
{ title : Maybe String { title : Maybe String
@ -90,6 +99,12 @@ type CreatePollInfo
} }
type Result
= Result
{ rounds : List (List String)
}
createPollInfoNoRecord title question options = createPollInfoNoRecord title question options =
CreatePollInfo { title = title, question = question, options = 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 type Poll
= Poll = Poll
{ createInfo : CreatePollInfo { createInfo : CreatePollInfo
, votes : R.Reorderable String , votes : R.Reorderable String
, id : Int
} }
parseUrl url = parseUrl url =
let let
toModel response = toModel pollId response =
case response of case response of
Ok createPollInfo -> 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 -> Err e ->
ThrowError "couldn't decode poll info" ThrowError "couldn't decode poll info"
@ -135,8 +165,16 @@ parseUrl url =
Just (VotingOnPoll pollId) -> Just (VotingOnPoll pollId) ->
( Loading ( Loading
, Http.get , Http.get
{ url = S.concat ["/api/poll/", S.fromInt pollId ,"/vote"] { 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 ) ( WrongUrl, Cmd.none )
type Ballot
= Ballot
{ votes : List String
}
update : Msg -> Model -> ( Model, Cmd Msg ) update : Msg -> Model -> ( Model, Cmd Msg )
update msg model = update msg model =
case (msg, model) of case ( msg, model ) of
(NewCreatePollInfo newCreateInfo, _) -> ( Creating newCreateInfo, Cmd.none ) ( NewCreatePollInfo newCreateInfo, _ ) ->
(Submit, Creating createInfo) -> ( Creating newCreateInfo, Cmd.none )
let
toMsg response = case response of
Ok id -> Submitted id
Err err -> ThrowError "couldn't parse poll submit response"
in
( model,
Http.post
{ url = "/api/poll/create"
, 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})) -> ( Submit, Creating createInfo ) ->
let
toMsg response =
case response of
Ok id ->
Submitted id
Err err ->
ThrowError "couldn't parse poll submit response"
in
( model
, Http.post
{ url = "/api/poll/create"
, expect = Http.expectJson toMsg D.int
, body = Http.jsonBody <| createPollInfoEncoder createInfo
}
)
( 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 let
changedVotes = changedVotes =
case msg of case msg of
Remove idx -> R.drop idx votes Remove idx ->
MoveUp idx -> R.moveUp idx votes R.drop idx votes
MoveDown idx -> R.moveDown idx votes
_ -> votes MoveUp idx ->
R.moveUp idx votes
MoveDown idx ->
R.moveDown idx votes
_ ->
votes
in 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 viewInput : String -> String -> String -> (String -> msg) -> Html msg
@ -192,7 +293,7 @@ viewInput t p v toMsg =
input input
[ HA.type_ t [ HA.type_ t
, HA.placeholder p , HA.placeholder p
, HA.value v -- , HE.onInput toMsg , HA.value v
] ]
[] []
@ -213,56 +314,58 @@ remove n arr =
-- set _ _ [] = Nothing -- set _ _ [] = Nothing
inputWithLabel name attributes = div [] inputWithLabel name attributes =
[ label [ HA.for name ] [ text name ] div []
, input (HA.name name :: attributes) [] [ label [ HA.for name ] [ text name ]
] , input (HA.name name :: attributes) []
]
view model = view model =
let let
body = body =
L.singleton <| L.singleton <|
case model of div [ HA.class "paper container container-sm" ] <|
Creating (CreatePollInfo createInfo) -> L.singleton <|
let case model of
toOption index option = div [HA.style "display" "grid", HA.style "grid-template-columns" "auto 80px", HA.style "column-gap" "5px"] Creating (CreatePollInfo createInfo) ->
[ input let
[ HA.type_ "text" toOption index option =
, HA.value option div [ HA.style "display" "grid", HA.style "grid-template-columns" "auto 80px", HA.style "column-gap" "5px" ]
, HE.onInput (\new -> NewCreatePollInfo (CreatePollInfo { createInfo | options = A.set index new createInfo.options })) [ input
] [ HA.type_ "text"
[] , HA.value option
, button , HE.onInput (\new -> NewCreatePollInfo (CreatePollInfo { createInfo | options = A.set index new createInfo.options }))
[ HE.onClick (NewCreatePollInfo (CreatePollInfo { createInfo | options = remove index createInfo.options })), HA.class "btn-warning-outline" ] ]
[ text "remove" ] []
] , button
in [ HE.onClick (NewCreatePollInfo (CreatePollInfo { createInfo | options = remove index createInfo.options })), HA.class "btn-warning-outline" ]
div [ HA.style "display" "flex", HA.style "justify-content" "center" ] <| [ text "remove" ]
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)"
[ HA.type_ "text"
, HA.value (Maybe.withDefault "" createInfo.title)
, HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | title = Just change }))
] ]
, inputWithLabel "question" in
[ HA.type_ "text" div [ HA.style "display" "flex", HA.style "justify-content" "center" ] <|
, HA.value createInfo.question L.singleton <|
, HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | question = change })) 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" ]
div [ HA.style "display" "flex", HA.style "flex-direction" "column" ] , inputWithLabel "title (optional)"
[ HA.type_ "text"
, HA.value (Maybe.withDefault "" createInfo.title)
, HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | title = Just change }))
]
, inputWithLabel "question"
[ HA.type_ "text"
, HA.value createInfo.question
, HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | question = change }))
]
, div [ HA.style "display" "flex", HA.style "flex-direction" "column" ]
[ text "options" [ text "options"
, div [ HA.style "padding-left" "20px"] , div [ HA.style "padding-left" "20px" ]
[ div [ div
[HA.style "display" "flex", HA.style "flex-direction" "column", HA.style "gap" "5px"] [ HA.style "display" "flex", HA.style "flex-direction" "column", HA.style "gap" "5px" ]
<| <|
A.toList <| A.toList <|
A.indexedMap toOption createInfo.options A.indexedMap toOption createInfo.options
, button , button
[ HA.style "align-self" "start" [ HA.style "align-self" "start"
, HA.style "margin-top" "10px" , HA.style "margin-top" "10px"
@ -272,55 +375,83 @@ view model =
[ text "add new option" ] [ text "add new option" ]
] ]
] ]
, , button
button
[ HA.style "align-self" "start" [ HA.style "align-self" "start"
, HA.class "paper-btn btn-primary" , HA.class "paper-btn btn-primary"
, HE.onClick Submit , HE.onClick Submit
] ]
[ text "submit" ] [ text "submit" ]
] ]
SubmitResult id -> SubmitResult id ->
let let
pollLink = pollLink =
"http://localhost:8080/vote/" ++ S.fromInt id "rankedchoice.net/poll/" ++ S.fromInt id ++ "/vote"
in in
div div
[ HA.style "display" "flex", HA.style "justify-content" "center", HA.style "align-items" "center", HA.style "height" "100vh" ] [ HA.style "display" "flex", HA.style "justify-content" "center", HA.style "align-items" "center", HA.style "height" "100vh" ]
<| <|
L.singleton <| 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 Voting (Poll { createInfo, votes }) ->
-- CreatePollInfo {title, question, options} -> div [] <| A.toList <| A.map text options case createInfo of
Voting (Poll {createInfo , votes}) -> case createInfo of CreatePollInfo { title, question, options } ->
CreatePollInfo {title, question, options} -> div let
[ HA.style "display" "flex", HA.style "justify-content" "center", HA.style "align-items" "center"] rest =
<| L.singleton <| div [] [ 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)
h3 [] [text question], , button [ HE.onClick SubmitBallot ] [ text "submit" ]
table [] <| L.singleton <| tbody [] <| L.map (\(_, x) -> x) <| L.indexedMap viewItem (R.toKeyedList votes), ]
button [HE.onClick Submit] [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" ]
Loading -> (case title of
text "loading..." Nothing ->
rest
WrongUrl -> Just x ->
text "wrong url..." h3 [] [ text x ] :: rest
)
_ -> Voted id ->
text "uhhh" 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..."
in in
{ title = "uhh, title" { title = "easy ranked choice voting"
, body = body , 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"]
[ viewItem idx ( key, value ) =
td [] <| L.singleton <| text value tr [ HA.style "display" "grid", HA.style "grid-template-columns" "auto 46.5px 46.5px 80px", HA.style "gap" "10px" ]
, td [HE.onClick <| MoveUp idx] [button [HA.class "btn-small"] <| L.singleton <| text "↑" ] [ td [ HA.style "margin-right" "75px" ] <| L.singleton <| text value
, td [HE.onClick <| MoveDown idx] [button [HA.class "btn-small"] <| L.singleton <| text "↓" ] , td [ HE.onClick <| MoveUp 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" ] , 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" ]
|> Tuple.pair key ]
|> Tuple.pair key

2
server/rcv-site.cabal
View file

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

4
server/src/API.hs
View file

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

3
server/src/Ballot.hs
View file

@ -4,11 +4,12 @@ import GHC.Generics
import Data.Aeson import Data.Aeson
import qualified Control.DeepSeq as DS import qualified Control.DeepSeq as DS
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.List.NonEmpty as NE
type OptionHash = Int type OptionHash = Int
-- done as newtype because i'll inevitably add to this -- done as newtype because i'll inevitably add to this
newtype Ballot = Ballot newtype Ballot = Ballot
{ {
votes :: [OptionHash] votes :: NE.NonEmpty T.Text
} deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData) } 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 Ballot as B
import qualified System.Random as R import qualified System.Random as R
import qualified System.Random.SplitMix as SM import qualified System.Random.SplitMix as SM
import qualified Data.Bifunctor as Bi
data DB = DB { data DB = DB {
gen :: R.StdGen, gen :: R.StdGen,
@ -25,7 +26,7 @@ createPoll createInfo = MS.state go
where where
go DB {..} = (pollId, DB {polls = M.insert pollId insertedPoll polls, gen = gen'}) go DB {..} = (pollId, DB {polls = M.insert pollId insertedPoll polls, gen = gen'})
where where
(pollId, gen') = R.genWord32 gen (pollId, gen') = Bi.first P.PollId . R.genWord32 $ gen
insertedPoll = P.Poll 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 :: Ac.Query DB [P.PollId]
getPollIds = MR.asks (M.keys . polls) getPollIds = MR.asks (M.keys . polls)
getDB :: Ac.Query DB DB
getDB = MR.ask
getPoll :: P.PollId -> Ac.Query DB (Maybe P.Poll) getPoll :: P.PollId -> Ac.Query DB (Maybe P.Poll)
getPoll pollId = MR.asks $ M.lookup pollId . polls 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 ''P.CreatePollInfo)
$(SC.deriveSafeCopy 0 'SC.base ''B.Ballot) $(SC.deriveSafeCopy 0 'SC.base ''B.Ballot)
$(SC.deriveSafeCopy 0 'SC.base ''P.Poll) $(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 ''SM.SMGen)
$(SC.deriveSafeCopy 0 'SC.base ''R.StdGen) $(SC.deriveSafeCopy 0 'SC.base ''R.StdGen)
$(SC.deriveSafeCopy 0 'SC.base ''DB) $(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 :: IO (Ac.AcidState DB)
openLocalDB = do openLocalDB = do

4
server/src/InstantRunoff.hs
View file

@ -10,8 +10,8 @@ import Data.Maybe hiding (catMaybes)
import Data.Ratio import Data.Ratio
import qualified Data.Maybe as L import qualified Data.Maybe as L
solve :: Ord a => Show a => LN.NonEmpty (LN.NonEmpty a) -> S.Set a solve :: Ord a => Show a => LN.NonEmpty (LN.NonEmpty a) -> [S.Set a]
solve votes = maybe (M.keysSet voteCounts) solve . remove $ firstChoiceLosers solve votes = maybe (L.singleton . M.keysSet $ voteCounts) ((firstChoiceLosers : ) . solve) . remove $ firstChoiceLosers
where where
-- if Nothing, then all options in votes are valued equally -- 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 qualified API as A
import AppM import AppM
import qualified Ballot as B 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 Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Control.Monad.Reader as Rd import qualified Control.Monad.Reader as Rd
import qualified Data.Acid as Ac 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.Hashable as H
import qualified Data.List.NonEmpty as LN import qualified Data.List.NonEmpty as LN
import qualified Data.Map.Strict as M 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 qualified Poll as P
import Servant import Servant
import Network.Wai.Application.Static (defaultWebAppSettings, StaticSettings (ss404Handler)) import Network.Wai.Application.Static (defaultWebAppSettings, StaticSettings (ss404Handler))
import Network.Wai (responseFile)
import qualified Network.Wai as W import qualified Network.Wai as W
import Network.HTTP.Types (status200, hContentType) import Network.HTTP.Types (status200, hContentType)
import qualified Data.List.NonEmpty as NE
staticFolderLoc = "../client/static" staticFolderLoc = "../client/static"
@ -46,20 +40,16 @@ getFromPollId pollId query = do
pollResult <- query pollId pollResult <- query pollId
throwOrLift (Er.noPollFound pollId) pollResult throwOrLift (Er.noPollFound pollId) pollResult
getResult :: P.PollId -> AppM A.PollResult getResult :: P.PollId -> AppM P.Result
getResult pollId = do getResult pollId = do
db <- Rd.asks db db <- Rd.asks db
poll <- getFromPollId pollId $ liftIO . Ac.query db . DB.GetPoll poll :: (P.Poll) <- getFromPollId pollId (liftIO . Ac.query db . DB.GetPoll)
votesList <- throwOrLift Er.noVotes $ maybeVotes poll votesList <- throwOrLift Er.noVotes . maybeVotes $ poll
pure $ solveAndUnHash poll votesList pure $ P.Result . reverse . IR.solve . NE.map B.votes $ votesList
where where
-- discarding empty ballots -- discarding empty ballots
maybeVotes :: P.Poll -> Maybe (LN.NonEmpty (LN.NonEmpty B.OptionHash)) maybeVotes :: P.Poll -> Maybe (LN.NonEmpty (B.Ballot))
maybeVotes = LN.nonEmpty . My.mapMaybe (LN.nonEmpty . B.votes) . P.votes maybeVotes = LN.nonEmpty . P.votes
unHashedMap = mapFromHash . LN.toList . P.options . P.createInfo
solveAndUnHash poll = My.mapMaybe (`M.lookup` unHashedMap poll) . S.toList . IR.solve
mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text
mapFromHash = M.fromList . map (\x -> (H.hash x, x)) mapFromHash = M.fromList . map (\x -> (H.hash x, x))
@ -94,6 +84,4 @@ runWithEnv = flip Rd.runReaderT
main :: IO () main :: IO ()
main = do main = do
env <- getEnv env <- getEnv
everything <- liftIO $ Ac.query (db env) DB.GetPollIds
print everything
W.run 8080 . serve api . hoistServer api (runWithEnv env) $ server 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 Control.DeepSeq as DS
import qualified Data.List.NonEmpty as LN import qualified Data.List.NonEmpty as LN
import Data.Word import Data.Word
import qualified Data.Set as S
import Servant.API
import qualified Data.Bifunctor as Bi
maximumTextLength :: Int maximumTextLength :: Int
maximumTextLength = 280 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 data Poll = Poll
{ {