From c9eae072b9fade8db927d36065ac5ff8f398b267 Mon Sep 17 00:00:00 2001 From: Jack Wines Date: Fri, 26 May 2023 21:17:24 -0700 Subject: [PATCH] it works! --- client/src/Main.elm | 377 ++++++++++++++++++++++++------------ server/rcv-site.cabal | 2 +- server/src/API.hs | 4 +- server/src/Ballot.hs | 3 +- server/src/Database.hs | 9 +- server/src/InstantRunoff.hs | 4 +- server/src/Main.hs | 26 +-- server/src/Poll.hs | 14 +- 8 files changed, 287 insertions(+), 152 deletions(-) diff --git a/client/src/Main.elm b/client/src/Main.elm index 82ca427..f7dc1e8 100644 --- a/client/src/Main.elm +++ b/client/src/Main.elm @@ -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" @@ -135,8 +165,16 @@ parseUrl url = Just (VotingOnPoll pollId) -> ( Loading , Http.get - { url = S.concat ["/api/poll/", S.fromInt pollId ,"/vote"] - , expect = Http.expectJson toModel createPollInfoDecoder + { url = S.concat [ "/api/poll/", S.fromInt pollId, "/vote" ] + , 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 ) - (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) - (RecievedBallot createInfo, _) -> (Voting (Poll { - createInfo = createInfo, - votes = case createInfo of - (CreatePollInfo {options}) -> R.fromList <| A.toList <| options - }), Cmd.none) - (UrlChanged url, _) -> parseUrl url + case ( msg, model ) of + ( NewCreatePollInfo newCreateInfo, _ ) -> + ( Creating newCreateInfo, Cmd.none ) - (_, 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 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,56 +314,58 @@ remove n arr = -- set _ _ [] = Nothing -inputWithLabel name attributes = div [] - [ label [ HA.for name ] [ text name ] - , input (HA.name name :: attributes) [] - ] +inputWithLabel name attributes = + div [] + [ label [ HA.for name ] [ text name ] + , input (HA.name name :: attributes) [] + ] view model = let body = 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"] - [ input - [ HA.type_ "text" - , HA.value option - , HE.onInput (\new -> NewCreatePollInfo (CreatePollInfo { createInfo | options = A.set index new createInfo.options })) - ] - [] - , button - [ HE.onClick (NewCreatePollInfo (CreatePollInfo { createInfo | options = remove index createInfo.options })), HA.class "btn-warning-outline" ] - [ text "remove" ] - ] - in - div [ HA.style "display" "flex", HA.style "justify-content" "center" ] <| - 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 })) + 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" ] + [ input + [ HA.type_ "text" + , HA.value option + , HE.onInput (\new -> NewCreatePollInfo (CreatePollInfo { createInfo | options = A.set index new createInfo.options })) + ] + [] + , button + [ HE.onClick (NewCreatePollInfo (CreatePollInfo { createInfo | options = remove index createInfo.options })), HA.class "btn-warning-outline" ] + [ text "remove" ] ] - , 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" ] + in + div [ HA.style "display" "flex", HA.style "justify-content" "center" ] <| + 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" + [ 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" - , div [ HA.style "padding-left" "20px"] + , div [ HA.style "padding-left" "20px" ] [ 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.indexedMap toOption createInfo.options + A.indexedMap toOption createInfo.options , button [ HA.style "align-self" "start" , HA.style "margin-top" "10px" @@ -272,55 +375,83 @@ view model = [ text "add new option" ] ] ] - , - button + , button [ HA.style "align-self" "start" , HA.class "paper-btn btn-primary" , HE.onClick Submit ] [ text "submit" ] - ] + ] - SubmitResult id -> - let - pollLink = - "http://localhost:8080/vote/" ++ S.fromInt id - 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 ] ] + SubmitResult id -> + let + pollLink = + "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 <| 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"] - ] - Loading -> - text "loading..." + 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 - WrongUrl -> - text "wrong url..." + Just x -> + h3 [] [ text x ] :: rest + ) - _ -> - text "uhhh" + 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..." 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 - , 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" ] - ] - |> Tuple.pair key + +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" ] + ] + |> Tuple.pair key diff --git a/server/rcv-site.cabal b/server/rcv-site.cabal index 7fea8fb..387fb07 100644 --- a/server/rcv-site.cabal +++ b/server/rcv-site.cabal @@ -39,7 +39,7 @@ executable server aeson, uuid, base, - acid-state, + acid-state == 0.16.1.2, safecopy, random, splitmix, diff --git a/server/src/API.hs b/server/src/API.hs index 285cca1..0910c06 100644 --- a/server/src/API.hs +++ b/server/src/API.hs @@ -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 = diff --git a/server/src/Ballot.hs b/server/src/Ballot.hs index 211ffaf..f5f924d 100644 --- a/server/src/Ballot.hs +++ b/server/src/Ballot.hs @@ -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) diff --git a/server/src/Database.hs b/server/src/Database.hs index 4be90a7..980bbbd 100644 --- a/server/src/Database.hs +++ b/server/src/Database.hs @@ -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 diff --git a/server/src/InstantRunoff.hs b/server/src/InstantRunoff.hs index 72aa6ac..e366c50 100644 --- a/server/src/InstantRunoff.hs +++ b/server/src/InstantRunoff.hs @@ -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 diff --git a/server/src/Main.hs b/server/src/Main.hs index c6c9f33..58a85e3 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -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 diff --git a/server/src/Poll.hs b/server/src/Poll.hs index 2b18dc8..6d74fcc 100644 --- a/server/src/Poll.hs +++ b/server/src/Poll.hs @@ -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 {