swap to htmx
This commit is contained in:
parent
47989ab012
commit
b8b7d8a198
33 changed files with 155 additions and 544 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -6,3 +6,4 @@ server/db
|
||||||
/client/index.html
|
/client/index.html
|
||||||
/server/state/
|
/server/state/
|
||||||
client/static/main.js
|
client/static/main.js
|
||||||
|
/state/
|
||||||
|
|
|
||||||
2
cabal.project
Normal file
2
cabal.project
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
allow-newer: servant, servant-server, *:servant-server, *:base, servant-htmx:*, lucid-htmx:*
|
||||||
|
packages: rcv-site.cabal
|
||||||
|
|
@ -1,29 +0,0 @@
|
||||||
{
|
|
||||||
"type": "application",
|
|
||||||
"source-directories": [
|
|
||||||
"src"
|
|
||||||
],
|
|
||||||
"elm-version": "0.19.1",
|
|
||||||
"dependencies": {
|
|
||||||
"direct": {
|
|
||||||
"elm/browser": "1.0.2",
|
|
||||||
"elm/core": "1.0.5",
|
|
||||||
"elm/html": "1.0.0",
|
|
||||||
"elm/http": "2.0.0",
|
|
||||||
"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/virtual-dom": "1.0.3"
|
|
||||||
}
|
|
||||||
},
|
|
||||||
"test-dependencies": {
|
|
||||||
"direct": {},
|
|
||||||
"indirect": {}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
@ -1,457 +0,0 @@
|
||||||
module Main exposing (..)
|
|
||||||
|
|
||||||
import Array as A
|
|
||||||
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 exposing ((::))
|
|
||||||
import Maybe as M
|
|
||||||
import Platform.Cmd as PC
|
|
||||||
import Reorderable as R
|
|
||||||
import Result as R
|
|
||||||
import String as S
|
|
||||||
import Url
|
|
||||||
import Url.Parser as P exposing ((</>))
|
|
||||||
|
|
||||||
|
|
||||||
main =
|
|
||||||
B.application
|
|
||||||
{ init = init
|
|
||||||
, update = update
|
|
||||||
, view = view
|
|
||||||
, subscriptions = subscriptions
|
|
||||||
, onUrlChange = UrlChanged
|
|
||||||
, onUrlRequest = LinkClicked
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
type Route
|
|
||||||
= Create
|
|
||||||
| VotingOnPoll Int
|
|
||||||
| TryViewResults Int
|
|
||||||
|
|
||||||
|
|
||||||
routeParser : P.Parser (Route -> a) a
|
|
||||||
routeParser =
|
|
||||||
P.oneOf
|
|
||||||
[ 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")
|
|
||||||
]
|
|
||||||
|
|
||||||
|
|
||||||
subscriptions : Model -> Sub Msg
|
|
||||||
subscriptions model =
|
|
||||||
Sub.none
|
|
||||||
|
|
||||||
|
|
||||||
init : () -> Url.Url -> Browser.Navigation.Key -> ( Model, Cmd Msg )
|
|
||||||
init _ url _ =
|
|
||||||
parseUrl url
|
|
||||||
|
|
||||||
|
|
||||||
emptyCreatePollInfo =
|
|
||||||
CreatePollInfo { title = Nothing, question = "", options = A.empty }
|
|
||||||
|
|
||||||
|
|
||||||
type Model
|
|
||||||
= Loading
|
|
||||||
| WrongUrl
|
|
||||||
| Error String
|
|
||||||
| Voting Poll
|
|
||||||
| Voted Int
|
|
||||||
| ViewingResult Result
|
|
||||||
| Creating CreatePollInfo
|
|
||||||
| SubmitResult Int
|
|
||||||
|
|
||||||
|
|
||||||
type OptionHash
|
|
||||||
= Int
|
|
||||||
|
|
||||||
|
|
||||||
type Msg
|
|
||||||
= NewCreatePollInfo CreatePollInfo
|
|
||||||
| Submit
|
|
||||||
| Submitted Int
|
|
||||||
| 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
|
|
||||||
, question : String
|
|
||||||
, options : A.Array String
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
type Result
|
|
||||||
= Result
|
|
||||||
{ rounds : List (List String)
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
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 )
|
|
||||||
]
|
|
||||||
|
|
||||||
|
|
||||||
resultDecoder =
|
|
||||||
D.map (\x -> Result { rounds = x }) (D.field "winners" (D.list (D.list D.string)))
|
|
||||||
|
|
||||||
|
|
||||||
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 pollId response =
|
|
||||||
case response of
|
|
||||||
Ok 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"
|
|
||||||
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 pollId) createPollInfoDecoder
|
|
||||||
}
|
|
||||||
)
|
|
||||||
|
|
||||||
Just (TryViewResults pollId) ->
|
|
||||||
( Loading
|
|
||||||
, Http.get
|
|
||||||
{ url = S.concat [ "/api/poll/", S.fromInt pollId, "/results" ]
|
|
||||||
, expect = Http.expectJson (toResults pollId) resultDecoder
|
|
||||||
}
|
|
||||||
)
|
|
||||||
|
|
||||||
Just Create ->
|
|
||||||
( Creating emptyCreatePollInfo, Cmd.none )
|
|
||||||
|
|
||||||
Nothing ->
|
|
||||||
( 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 )
|
|
||||||
|
|
||||||
( 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
|
|
||||||
in
|
|
||||||
( Voting (Poll { createInfo = createInfo, votes = changedVotes, id = id }), Cmd.none )
|
|
||||||
|
|
||||||
( ThrowError e, _ ) ->
|
|
||||||
( Error "uhh", Cmd.none )
|
|
||||||
|
|
||||||
( _, _ ) ->
|
|
||||||
( model, Cmd.none )
|
|
||||||
|
|
||||||
|
|
||||||
viewInput : String -> String -> String -> (String -> msg) -> Html msg
|
|
||||||
viewInput t p v toMsg =
|
|
||||||
input
|
|
||||||
[ HA.type_ t
|
|
||||||
, HA.placeholder p
|
|
||||||
, HA.value v
|
|
||||||
]
|
|
||||||
[]
|
|
||||||
|
|
||||||
|
|
||||||
remove : Int -> A.Array a -> A.Array a
|
|
||||||
remove n arr =
|
|
||||||
A.append (A.slice 0 n arr) (A.slice (n + 1) (A.length arr) arr)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- remove : Int -> List a -> List a
|
|
||||||
-- remove 0 (_ :: xs) = xs
|
|
||||||
-- remove n (x :: xs) = x :: remove (n - 1) xs
|
|
||||||
-- remove _ [] = []
|
|
||||||
-- set : Int -> a -> List a -> (List a)
|
|
||||||
-- set 0 newElem (_ :: xs) = newElem :: xs
|
|
||||||
-- set n newElem (x :: xs) = x :: set (n - 1) newElem xs
|
|
||||||
-- set _ _ [] = Nothing
|
|
||||||
|
|
||||||
|
|
||||||
inputWithLabel name attributes =
|
|
||||||
div []
|
|
||||||
[ label [ HA.for name ] [ text name ]
|
|
||||||
, input (HA.name name :: attributes) []
|
|
||||||
]
|
|
||||||
|
|
||||||
|
|
||||||
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" ]
|
|
||||||
[ 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 }))
|
|
||||||
]
|
|
||||||
, 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" ]
|
|
||||||
]
|
|
||||||
|
|
||||||
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 } ->
|
|
||||||
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..."
|
|
||||||
in
|
|
||||||
{ title = "easy ranked choice voting"
|
|
||||||
, body = body
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1,19 +0,0 @@
|
||||||
<!DOCTYPE html>
|
|
||||||
<html>
|
|
||||||
<head>
|
|
||||||
<meta charset="UTF-8">
|
|
||||||
<title>Main</title>
|
|
||||||
<script src="/main.js"></script>
|
|
||||||
<link href="/paper.min.css" rel="stylesheet" />
|
|
||||||
<link href="/fonts.css" rel="stylesheet" />
|
|
||||||
</head>
|
|
||||||
|
|
||||||
<body>
|
|
||||||
<div id="myapp"></div>
|
|
||||||
<script>
|
|
||||||
var app = Elm.Main.init({
|
|
||||||
node: document.getElementById('myapp')
|
|
||||||
});
|
|
||||||
</script>
|
|
||||||
</body>
|
|
||||||
</html>
|
|
||||||
1
public/static/htmx.min.js
vendored
Normal file
1
public/static/htmx.min.js
vendored
Normal file
File diff suppressed because one or more lines are too long
12
public/static/json-enc.js
Normal file
12
public/static/json-enc.js
Normal file
|
|
@ -0,0 +1,12 @@
|
||||||
|
htmx.defineExtension('json-enc', {
|
||||||
|
onEvent: function (name, evt) {
|
||||||
|
if (name === "htmx:configRequest") {
|
||||||
|
evt.detail.headers['Content-Type'] = "application/json";
|
||||||
|
}
|
||||||
|
},
|
||||||
|
|
||||||
|
encodeParameters : function(xhr, parameters, elt) {
|
||||||
|
xhr.overrideMimeType('text/json');
|
||||||
|
return (JSON.stringify(parameters));
|
||||||
|
}
|
||||||
|
});
|
||||||
18
public/static/style.css
Normal file
18
public/static/style.css
Normal file
|
|
@ -0,0 +1,18 @@
|
||||||
|
#inputs, #options-create
|
||||||
|
{
|
||||||
|
display: flex;
|
||||||
|
flex-direction: column;
|
||||||
|
max-width: 400px;
|
||||||
|
gap: 10px;
|
||||||
|
}
|
||||||
|
|
||||||
|
#permenant-input
|
||||||
|
{
|
||||||
|
display: flex;
|
||||||
|
flex-direction: column;
|
||||||
|
}
|
||||||
|
|
||||||
|
#options-create > * {
|
||||||
|
flex-direction: row;
|
||||||
|
display: flex;
|
||||||
|
}
|
||||||
|
|
@ -15,6 +15,7 @@ executable server
|
||||||
FlexibleContexts,
|
FlexibleContexts,
|
||||||
FlexibleInstances,
|
FlexibleInstances,
|
||||||
ImpredicativeTypes,
|
ImpredicativeTypes,
|
||||||
|
ExtendedDefaultRules,
|
||||||
MultiParamTypeClasses,
|
MultiParamTypeClasses,
|
||||||
NamedFieldPuns,
|
NamedFieldPuns,
|
||||||
OverloadedLabels,
|
OverloadedLabels,
|
||||||
|
|
@ -36,24 +37,26 @@ executable server
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
src
|
||||||
build-depends:
|
build-depends:
|
||||||
aeson,
|
|
||||||
uuid,
|
|
||||||
base,
|
|
||||||
acid-state == 0.16.1.2,
|
acid-state == 0.16.1.2,
|
||||||
safecopy,
|
aeson,
|
||||||
random,
|
base,
|
||||||
splitmix,
|
|
||||||
containers,
|
|
||||||
blaze-html,
|
|
||||||
http-types,
|
|
||||||
bytestring,
|
bytestring,
|
||||||
|
containers,
|
||||||
|
deepseq,
|
||||||
hashable,
|
hashable,
|
||||||
|
http-types,
|
||||||
|
lucid,
|
||||||
|
lucid-htmx,
|
||||||
mtl,
|
mtl,
|
||||||
network-uri,
|
network-uri,
|
||||||
|
random,
|
||||||
|
safecopy,
|
||||||
servant,
|
servant,
|
||||||
deepseq,
|
servant-lucid,
|
||||||
servant-server,
|
servant-server,
|
||||||
|
splitmix,
|
||||||
text,
|
text,
|
||||||
|
uuid,
|
||||||
vector,
|
vector,
|
||||||
wai,
|
wai,
|
||||||
wai-app-static,
|
wai-app-static,
|
||||||
|
|
@ -1,19 +0,0 @@
|
||||||
module API where
|
|
||||||
|
|
||||||
import qualified Ballot as B
|
|
||||||
import qualified Poll as P
|
|
||||||
import Servant.API
|
|
||||||
|
|
||||||
|
|
||||||
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 :> "results" :> Get '[JSON] P.Result
|
|
||||||
:<|> StaticAPI
|
|
||||||
|
|
||||||
type StaticAPI =
|
|
||||||
-- "poll" :> "create" :> Get '[HTML] T.Tex
|
|
||||||
-- :<|> "poll" :> Raw
|
|
||||||
-- :<|>
|
|
||||||
Raw
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
../client/static
|
|
||||||
23
src/API.hs
Normal file
23
src/API.hs
Normal file
|
|
@ -0,0 +1,23 @@
|
||||||
|
module API where
|
||||||
|
|
||||||
|
import qualified Ballot as B
|
||||||
|
import qualified Poll as P
|
||||||
|
import Servant.API
|
||||||
|
import qualified Lucid as L
|
||||||
|
import qualified Servant.HTML.Lucid as SL
|
||||||
|
|
||||||
|
type RCVAPI =
|
||||||
|
"create" :> Get '[SL.HTML] (L.Html ())
|
||||||
|
:<|> "create" :> ReqBody '[JSON] P.CreatePollInfo :> Post '[SL.HTML] (L.Html ())
|
||||||
|
:<|> "create" :> "newInput" :> Get '[SL.HTML] (L.Html ())
|
||||||
|
:<|> "create" :> "removeInput" :> Get '[SL.HTML] (L.Html ())
|
||||||
|
-- :<|> "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 :> "results" :> Get '[JSON] P.Result
|
||||||
|
:<|> StaticAPI
|
||||||
|
|
||||||
|
type StaticAPI =
|
||||||
|
-- "poll" :> "create" :> Get '[HTML] T.Tex
|
||||||
|
-- :<|> "poll" :> Raw
|
||||||
|
-- :<|>
|
||||||
|
Raw
|
||||||
|
|
@ -4,26 +4,29 @@ import qualified API as A
|
||||||
import AppM
|
import AppM
|
||||||
import qualified Ballot as B
|
import qualified Ballot as B
|
||||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||||
|
import Lucid as L
|
||||||
|
import Lucid.Htmx
|
||||||
|
import Network.HTTP.Types (status200, hContentType)
|
||||||
|
import Network.Wai.Application.Static (defaultWebAppSettings, StaticSettings (ss404Handler))
|
||||||
|
import Servant
|
||||||
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 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.List.NonEmpty as NE
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import qualified Data.Maybe as My
|
import qualified Data.Maybe as My
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
|
import Lucid.Htmx as L
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Database as DB
|
import qualified Database as DB
|
||||||
import qualified Error as Er
|
import qualified Error as Er
|
||||||
import qualified InstantRunoff as IR
|
import qualified InstantRunoff as IR
|
||||||
|
import qualified Network.Wai as W
|
||||||
import qualified Network.Wai.Handler.Warp as W
|
import qualified Network.Wai.Handler.Warp as W
|
||||||
import qualified System.Environment as S
|
|
||||||
import qualified Network.Wai.Handler.WarpTLS as WTLS
|
import qualified Network.Wai.Handler.WarpTLS as WTLS
|
||||||
import qualified Poll as P
|
import qualified Poll as P
|
||||||
import Servant
|
import qualified System.Environment as S
|
||||||
import Network.Wai.Application.Static (defaultWebAppSettings, StaticSettings (ss404Handler))
|
|
||||||
import qualified Network.Wai as W
|
|
||||||
import Network.HTTP.Types (status200, hContentType)
|
|
||||||
import qualified Data.List.NonEmpty as NE
|
|
||||||
|
|
||||||
staticFolderLoc = "../client/static"
|
staticFolderLoc = "../client/static"
|
||||||
|
|
||||||
|
|
@ -56,10 +59,16 @@ getResult pollId = do
|
||||||
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))
|
||||||
|
|
||||||
makePoll :: P.CreatePollInfo -> AppM P.PollId
|
makePoll :: P.CreatePollInfo -> AppM (L.Html ())
|
||||||
makePoll pollReq = do
|
makePoll pollReq = do
|
||||||
db <- Rd.asks db
|
db <- Rd.asks db
|
||||||
liftIO $ Ac.update db (DB.CreatePoll pollReq)
|
(P.PollId pollId) <- liftIO $ Ac.update db (DB.CreatePoll pollReq)
|
||||||
|
let fillOutLink = T.append "https://rankedchoice.net/poll/" (T.pack . show $ pollId)
|
||||||
|
pure $ do
|
||||||
|
"done! people can fill out your poll at "
|
||||||
|
with a_ [href_ fillOutLink] (toHtml fillOutLink)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
vote :: P.PollId -> B.Ballot -> AppM ()
|
vote :: P.PollId -> B.Ballot -> AppM ()
|
||||||
vote pollId ballot = do
|
vote pollId ballot = do
|
||||||
|
|
@ -69,8 +78,39 @@ vote pollId ballot = do
|
||||||
|
|
||||||
|
|
||||||
server :: ServerT A.RCVAPI AppM
|
server :: ServerT A.RCVAPI AppM
|
||||||
server = makePoll :<|> getPollForBallot :<|> vote :<|> getResult :<|> serveDirectoryWith ((defaultWebAppSettings "static") {ss404Handler = Just serveIndex})
|
server = createPage :<|> makePoll :<|> pure optionInput :<|> (pure . pure $ ()) :<|> serveDirectoryWith ((defaultWebAppSettings "public"))
|
||||||
|
|
||||||
|
-- makePoll :<|> getPollForBallot :<|> vote :<|> getResult :<|> serveDirectoryWith ((defaultWebAppSettings "static") {ss404Handler = Just serveIndex})
|
||||||
|
|
||||||
|
pageHead :: L.Html ()
|
||||||
|
pageHead = head_ $ do
|
||||||
|
link_ [href_ "/static/style.css", rel_ "stylesheet"]
|
||||||
|
link_ [href_ "/static/paper.min.css", rel_ "stylesheet"]
|
||||||
|
link_ [href_ "/static/fonts.css", rel_ "stylesheet"]
|
||||||
|
with (script_ "") [src_ "/static/htmx.min.js"]
|
||||||
|
with (script_ "") [src_ "/static/json-enc.js"]
|
||||||
|
|
||||||
|
optionInput :: L.Html ()
|
||||||
|
optionInput = div_ $
|
||||||
|
input_ [required_ "true", name_ "options"] <>
|
||||||
|
with button_ [classes_ ["btn", "btn-warning-outline"], hxGet_ "create/removeInput", hxSwap_ "delete", hxTarget_ "closest #options-create > *"] "remove"
|
||||||
|
|
||||||
|
createPage :: AppM (L.Html ())
|
||||||
|
createPage = pure $ do
|
||||||
|
pageHead
|
||||||
|
with body_ [classes_ ["container", "container-sm", "paper"], hxExt_ "json-enc"] $ do
|
||||||
|
h2_ "create a poll"
|
||||||
|
with form_ [id_ "inputs", hxPost_ "/create", hxTarget_ "body"] $ do
|
||||||
|
with label_ [for_ "title"] "title (optional)" <> input_ [name_ "title", type_ "text"]
|
||||||
|
with label_ [for_ "question"] "question" <> input_ [name_ "question", type_ "text", required_ "true"]
|
||||||
|
with fieldset_ [name_ "options", id_ "options-create"] $ do
|
||||||
|
legend_ "options"
|
||||||
|
optionInput
|
||||||
|
optionInput
|
||||||
|
with button_ [hxGet_ "create/newInput", hxTarget_ "this", hxSwap_ "beforebegin"] "add option"
|
||||||
|
input_ [type_ "submit", classes_ ["btn-small", "paper-btn", "btn-primary"]]
|
||||||
|
|
||||||
|
-- notFoundPage = pure $ ("this is the 404 page")
|
||||||
|
|
||||||
serveIndex :: Application
|
serveIndex :: Application
|
||||||
serveIndex _ respond = respond $ W.responseFile status200 [(hContentType, "text/html")] ("static" <> "/index.html") Nothing
|
serveIndex _ respond = respond $ W.responseFile status200 [(hContentType, "text/html")] ("static" <> "/index.html") Nothing
|
||||||
34
src/schema.sql
Normal file
34
src/schema.sql
Normal file
|
|
@ -0,0 +1,34 @@
|
||||||
|
DROP TABLE polls;
|
||||||
|
DROP TABLE options;
|
||||||
|
DROP TABLE voters;
|
||||||
|
DROP TABLE votes;
|
||||||
|
|
||||||
|
CREATE TABLE 'polls'
|
||||||
|
(
|
||||||
|
'title' TEXT,
|
||||||
|
'question' TEXT NOT NULL,
|
||||||
|
'key' INTEGER PRIMARY KEY NOT NULL
|
||||||
|
) STRICT;
|
||||||
|
|
||||||
|
CREATE TABLE 'options'
|
||||||
|
(
|
||||||
|
'name' TEXT NOT NULL,
|
||||||
|
'poll' INTEGER NOT NULL,
|
||||||
|
'key' INTEGER PRIMARY KEY NOT NULL,
|
||||||
|
FOREIGN KEY(poll) REFERENCES polls
|
||||||
|
) STRICT;
|
||||||
|
|
||||||
|
CREATE TABLE 'voters'
|
||||||
|
(
|
||||||
|
'key' INTEGER PRIMARY KEY NOT NULL
|
||||||
|
) STRICT;
|
||||||
|
|
||||||
|
CREATE TABLE 'votes'
|
||||||
|
(
|
||||||
|
'key' INTEGER PRIMARY KEY NOT NULL,
|
||||||
|
'voter' INTEGER NOT NULL,
|
||||||
|
'option' INTEGER NOT NULL,
|
||||||
|
'rank' INTEGER NOT NULL,
|
||||||
|
FOREIGN KEY(voter) REFERENCES voters
|
||||||
|
FOREIGN KEY(option) REFERENCES voters
|
||||||
|
) STRICT;
|
||||||
0
src/state/checkpoints-0000000000.log
Normal file
0
src/state/checkpoints-0000000000.log
Normal file
1
src/state/checkpoints.version
Normal file
1
src/state/checkpoints.version
Normal file
|
|
@ -0,0 +1 @@
|
||||||
|
0.16.1.2
|
||||||
0
src/state/events-0000000000.log
Normal file
0
src/state/events-0000000000.log
Normal file
1
src/state/events.version
Normal file
1
src/state/events.version
Normal file
|
|
@ -0,0 +1 @@
|
||||||
|
0.16.1.2
|
||||||
0
src/state/open.lock
Normal file
0
src/state/open.lock
Normal file
Loading…
Add table
Add a link
Reference in a new issue