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

reordering on the voting page works

Browse source
This commit is contained in:
Jack Wines 2023-05-09 00:48:36 -07:00
parent d1d01e8e3b
commit f27ad43635
15 changed files with 310 additions and 125 deletions
Download patch file Download diff file Expand all files Collapse all files

6
client/elm.json
View file

@ -10,13 +10,15 @@
"elm/core": "1.0.5",
"elm/html": "1.0.0",
"elm/http": "2.0.0",
"elm/json": "1.1.3"
"elm/json": "1.1.3",
"elm/parser": "1.1.0",
"elm/url": "1.0.0",
"zwilias/elm-reorderable": "1.3.0"
},
"indirect": {
"elm/bytes": "1.0.8",
"elm/file": "1.0.5",
"elm/time": "1.0.0",
"elm/url": "1.0.0",
"elm/virtual-dom": "1.0.3"
}
},

329
client/src/Main.elm
View file

@ -1,9 +1,8 @@
module Main exposing (..)
import Array as A
import String as S
import Maybe as M
import Browser
import Browser.Navigation
import Html exposing (..)
import Html.Attributes as HA
import Html.Events as HE
@ -11,34 +10,57 @@ import Http
import Json.Decode as D
import Json.Encode as E
import List as L
import Maybe as M
import Platform.Cmd as PC
import Result as R
import Html.Keyed as Keyed
import Reorderable as R
import String as S
import Url
import Url.Parser as P exposing ((</>))
main =
Browser.element
Browser.application
{ init = init
, update = update
, view = view
, subscriptions = subscriptions
, onUrlChange = UrlChanged
, onUrlRequest = LinkClicked
}
type Route
= Create
| VotingOnPoll Int
routeParser : P.Parser (Route -> a) a
routeParser =
P.oneOf
[ P.map VotingOnPoll (P.s "vote" </> P.int)
, P.map Create (P.s "create")
]
subscriptions : Model -> Sub Msg
subscriptions model =
Sub.none
init : () -> ( Model, Cmd Msg )
init _ =
( Creating (CreatePollInfo { title = Nothing, question = "favorite color?", options = A.fromList [ "blue", "green", "leaf" ] }), Cmd.none )
init : () -> Url.Url -> Browser.Navigation.Key -> ( Model, Cmd Msg )
init _ url _ = parseUrl url
-- testPoll = CreatePollInfo { title = , question = "what's your favorite color?", options = ["green", "blue", "red"] }
emptyCreatePollInfo =
CreatePollInfo { title = Nothing, question = "", options = A.empty }
type Model
= Loading
| Voting CreatePollInfo
| WrongUrl
| Error String
| Voting Poll
| ViewingResults Poll
| Creating CreatePollInfo
| SubmitResult Int
@ -51,8 +73,14 @@ type OptionHash
type Msg
= NewCreatePollInfo CreatePollInfo
| Submit
| Submitted (Result Http.Error Int)
| Submitted Int
| RecievedBallot CreatePollInfo
| LinkClicked Browser.UrlRequest
| UrlChanged Url.Url
| ThrowError String
| Remove Int
| MoveUp Int
| MoveDown Int
type CreatePollInfo
= CreatePollInfo
@ -61,51 +89,103 @@ type CreatePollInfo
, options : A.Array String
}
createPollInfoEncoder (CreatePollInfo createPollInfo) = E.object
[
("question", E.string createPollInfo.question),
("options", E.array E.string createPollInfo.options),
("title", M.withDefault E.null <| M.map E.string <| createPollInfo.title)
]
-- ("title", E.string createPollInfo.title)
createPollInfoNoRecord title question options =
CreatePollInfo { title = title, question = question, options = options }
createPollInfoDecoder : D.Decoder CreatePollInfo
createPollInfoDecoder =
D.map3 createPollInfoNoRecord
(D.field "title" (D.nullable D.string))
(D.field "question" D.string)
(D.field "options" (D.array D.string))
createPollInfoEncoder (CreatePollInfo createPollInfo) =
E.object
[ ( "question", E.string createPollInfo.question )
, ( "options", E.array E.string createPollInfo.options )
, ( "title", M.withDefault E.null <| M.map E.string <| createPollInfo.title )
]
-- ("title", E.string createPollInfo.title)
type Poll
= Poll
{ createInfo : CreatePollInfo
, votes : List Ballot
, votes : R.Reorderable String
}
type Ballot
= Ballot
{ votes : OptionHash
}
parseUrl url =
let
toModel response =
case response of
Ok createPollInfo ->
RecievedBallot createPollInfo
Err e ->
ThrowError "couldn't decode poll info"
in
case P.parse routeParser url of
Just (VotingOnPoll pollId) ->
( Loading
, Http.get
{ url = S.concat ["/api/poll/", S.fromInt pollId ,"/vote"]
, expect = Http.expectJson toModel createPollInfoDecoder
}
)
Just Create ->
( Creating emptyCreatePollInfo, Cmd.none )
Nothing ->
( WrongUrl, Cmd.none )
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
NewCreatePollInfo newCreateInfo ->
( Creating newCreateInfo, Cmd.none )
Submit ->
case model of
Creating createInfo ->
( Loading
, Http.post
{ url = "http://localhost:8080/api/poll/create"
, expect = (Http.expectJson Submitted D.int)
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
}
)
_ -> (model, Cmd.none)
)
(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
Submitted (Ok id) ->
(SubmitResult id, Cmd.none )
(_, Voting (Poll {createInfo, votes})) ->
let
changedVotes =
case msg of
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)
Submitted (Err err) ->
(Loading, Cmd.none )
(_, _) -> ( model, Cmd.none )
viewInput : String -> String -> String -> (String -> msg) -> Html msg
viewInput t p v toMsg =
@ -133,87 +213,114 @@ remove n arr =
-- set _ _ [] = Nothing
inputWithLabel name attributes =
inputWithLabel name attributes = div []
[ label [ HA.for name ] [ text name ]
, input (HA.name name :: attributes) []
]
view model =
case model of
Creating (CreatePollInfo createInfo) ->
let
toOption index option =
[ 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" ]
<|
L.concat <|
[ inputWithLabel "title"
[ HA.type_ "text"
, HA.value (Maybe.withDefault "" createInfo.title)
, HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | title = Just change }))
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" ]
]
, inputWithLabel "question"
[ HA.type_ "text"
, HA.value createInfo.question
, HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | question = change }))
]
, L.singleton <|
div [ HA.style "display" "flex", HA.style "flex-direction" "column" ]
[ text "options"
, div [ HA.style "padding-left" "10px" ]
[ div
[ HA.style "display" "grid", HA.style "grid-template-columns" "auto 80px" ]
<|
L.concat <|
A.toList <|
A.indexedMap toOption createInfo.options
, button
[ HA.style "align-self" "start"
, HA.class "paper-btn btn-primary-outline"
, HE.onClick (NewCreatePollInfo (CreatePollInfo { createInfo | options = A.push "" createInfo.options }))
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 }))
]
[ text "add new option" ]
, 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 "display" "flex", HA.style "flex-direction" "column", HA.style "gap" "5px"]
<|
A.toList <|
A.indexedMap toOption createInfo.options
, button
[ HA.style "align-self" "start"
, HA.style "margin-top" "10px"
, HA.class "paper-btn btn-primary-outline"
, HE.onClick (NewCreatePollInfo (CreatePollInfo { createInfo | options = A.push "" createInfo.options }))
]
[ text "add new option" ]
]
]
,
button
[ HA.style "align-self" "start"
, HA.class "paper-btn btn-primary"
, HE.onClick Submit
]
[ text "submit" ]
]
]
, L.singleton <|
button
[ HA.style "align-self" "start"
, HA.class "paper-btn btn-primary"
, HE.onClick Submit
]
[ text "submit" ]
]
SubmitResult id -> text ("done:" ++ S.fromInt id)
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 ] ]
Loading ->
text "loading..."
-- 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..."
_ ->
text "uhhh"
WrongUrl ->
text "wrong url..."
_ ->
text "uhhh"
in
{ title = "uhh, title"
, body = body
}
-- view (CreatePollInfo {options}) =
-- div [HA.style "display" "flex", HA.style "flex-direction" "column", HA.style "max-width" "300px"]
-- (L.map (button [] << L.singleton << text) options)
-- -- [ div [] [ text (text model.tile) ]
-- -- , div [] [ text (String.fromInt model) ]
-- -- , button [ onClick Increment ] [ text "+" ]
-- -- ]
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

45
client/static/fonts.css Normal file
View file

@ -0,0 +1,45 @@
/* cyrillic */
@font-face {
font-family: 'Neucha';
font-style: normal;
font-weight: 400;
font-display: swap;
src: url(/fonts/q5uGsou0JOdh94bfuQltOxU.woff2) format('woff2');
unicode-range: U+0301, U+0400-045F, U+0490-0491, U+04B0-04B1, U+2116;
}
/* latin */
@font-face {
font-family: 'Neucha';
font-style: normal;
font-weight: 400;
font-display: swap;
src: url(/fonts/q5uGsou0JOdh94bfvQlt.woff2) format('woff2');
unicode-range: U+0000-00FF, U+0131, U+0152-0153, U+02BB-02BC, U+02C6, U+02DA, U+02DC, U+2000-206F, U+2074, U+20AC, U+2122, U+2191, U+2193, U+2212, U+2215, U+FEFF, U+FFFD;
}
/* vietnamese */
@font-face {
font-family: 'Patrick Hand SC';
font-style: normal;
font-weight: 400;
font-display: swap;
src: url(/fonts/0nkwC9f7MfsBiWcLtY65AWDK873lgSK7FQc.woff2) format('woff2');
unicode-range: U+0102-0103, U+0110-0111, U+0128-0129, U+0168-0169, U+01A0-01A1, U+01AF-01B0, U+1EA0-1EF9, U+20AB;
}
/* latin-ext */
@font-face {
font-family: 'Patrick Hand SC';
font-style: normal;
font-weight: 400;
font-display: swap;
src: url(/fonts/0nkwC9f7MfsBiWcLtY65AWDK873lgCK7FQc.woff2) format('woff2');
unicode-range: U+0100-024F, U+0259, U+1E00-1EFF, U+2020, U+20A0-20AB, U+20AD-20CF, U+2113, U+2C60-2C7F, U+A720-A7FF;
}
/* latin */
@font-face {
font-family: 'Patrick Hand SC';
font-style: normal;
font-weight: 400;
font-display: swap;
src: url(/fonts/0nkwC9f7MfsBiWcLtY65AWDK873ljiK7.woff2) format('woff2');
unicode-range: U+0000-00FF, U+0131, U+0152-0153, U+02BB-02BC, U+02C6, U+02DA, U+02DC, U+2000-206F, U+2074, U+20AC, U+2122, U+2191, U+2193, U+2212, U+2215, U+FEFF, U+FFFD;
}

BIN
client/static/fonts/0nkwC9f7MfsBiWcLtY65AWDK873lgCK7FQc.woff2 Normal file
View file

Binary file not shown.

BIN
client/static/fonts/0nkwC9f7MfsBiWcLtY65AWDK873lgSK7FQc.woff2 Normal file
View file

Binary file not shown.

BIN
client/static/fonts/0nkwC9f7MfsBiWcLtY65AWDK873ljiK7.woff2 Normal file
View file

Binary file not shown.

BIN
client/static/fonts/q5uGsou0JOdh94bfuQltOxU.woff2 Normal file
View file

Binary file not shown.

BIN
client/static/fonts/q5uGsou0JOdh94bfvQlt.woff2 Normal file
View file

Binary file not shown.

5
client/static/index.html
View file

@ -3,8 +3,9 @@
<head>
<meta charset="UTF-8">
<title>Main</title>
<script src="main.js"></script>
<link href="paper.min.css" rel="stylesheet" />
<script src="/main.js"></script>
<link href="/paper.min.css" rel="stylesheet" />
<link href="/fonts.css" rel="stylesheet" />
</head>
<body>

4
client/static/paper.min.css vendored
View file

File diff suppressed because one or more lines are too long

14
server/src/API.hs
View file

@ -1,11 +1,9 @@
module API where
import Servant.API
import qualified Ballot as B
import qualified Data.Text as T
import qualified Poll as P
import qualified Ballot as B
import Servant.API
type PollResult = [T.Text]
@ -14,4 +12,10 @@ type RCVAPI =
:<|> "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
:<|> "static" :> Raw
:<|> StaticAPI
type StaticAPI =
-- "poll" :> "create" :> Get '[HTML] T.Tex
-- :<|> "poll" :> Raw
-- :<|>
Raw

2
server/src/Database.hs
View file

@ -25,7 +25,7 @@ createPoll createInfo = MS.state go
where
go DB {..} = (pollId, DB {polls = M.insert pollId insertedPoll polls, gen = gen'})
where
(pollId, gen') = R.genWord64 gen
(pollId, gen') = R.genWord32 gen
insertedPoll = P.Poll
{

12
server/src/Main.hs
View file

@ -24,9 +24,14 @@ import qualified InstantRunoff as IR
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)
staticFolderLoc = "../client/static"
getPollForBallot :: P.PollId -> AppM P.CreatePollInfo
getPollForBallot pollId = do
db <- Rd.asks db
@ -70,8 +75,13 @@ vote pollId ballot = do
liftIO $ Ac.update db (DB.PostBallot pollId ballot)
pure ()
server :: ServerT A.RCVAPI AppM
server = makePoll :<|> getPollForBallot :<|> vote :<|> getResult :<|> serveDirectoryWebApp staticFolderLoc
server = makePoll :<|> getPollForBallot :<|> vote :<|> getResult :<|> serveDirectoryWith ((defaultWebAppSettings "static") {ss404Handler = Just serveIndex})
serveIndex :: Application
serveIndex _ respond = respond $ W.responseFile status200 [(hContentType, "text/html")] ("static" <> "/index.html") Nothing
api :: Proxy A.RCVAPI
api = Proxy

2
server/src/Poll.hs
View file

@ -11,7 +11,7 @@ import Data.Word
maximumTextLength :: Int
maximumTextLength = 280
type PollId = Word64
type PollId = Word32
data Poll = Poll
{

16
server/src/Static.hs Normal file
View file

@ -0,0 +1,16 @@
module Static where
import Servant
path = "static"
api :: Proxy (MyApiType :<|> Raw)
api = Proxy
app :: Application
app = serve api (
handler
:<|> serveDirectoryWith ((defaultWebAppSettings path) {ss404Handler = Just serveIndex})
)
serveIndex :: Application
serveIndex _ respond = respond $ responseFile status200 [(hContentType, "text/html")] (path <> "/index.html") Nothing