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
|
||||
/server/state/
|
||||
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,
|
||||
FlexibleInstances,
|
||||
ImpredicativeTypes,
|
||||
ExtendedDefaultRules,
|
||||
MultiParamTypeClasses,
|
||||
NamedFieldPuns,
|
||||
OverloadedLabels,
|
||||
|
|
@ -36,24 +37,26 @@ executable server
|
|||
hs-source-dirs:
|
||||
src
|
||||
build-depends:
|
||||
aeson,
|
||||
uuid,
|
||||
base,
|
||||
acid-state == 0.16.1.2,
|
||||
safecopy,
|
||||
random,
|
||||
splitmix,
|
||||
containers,
|
||||
blaze-html,
|
||||
http-types,
|
||||
aeson,
|
||||
base,
|
||||
bytestring,
|
||||
containers,
|
||||
deepseq,
|
||||
hashable,
|
||||
http-types,
|
||||
lucid,
|
||||
lucid-htmx,
|
||||
mtl,
|
||||
network-uri,
|
||||
random,
|
||||
safecopy,
|
||||
servant,
|
||||
deepseq,
|
||||
servant-lucid,
|
||||
servant-server,
|
||||
splitmix,
|
||||
text,
|
||||
uuid,
|
||||
vector,
|
||||
wai,
|
||||
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 qualified Ballot as B
|
||||
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 Data.Acid as Ac
|
||||
import qualified Data.Hashable as H
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Maybe as My
|
||||
import qualified Data.Set as S
|
||||
import Lucid.Htmx as L
|
||||
import qualified Data.Text as T
|
||||
import qualified Database as DB
|
||||
import qualified Error as Er
|
||||
import qualified InstantRunoff as IR
|
||||
import qualified Network.Wai 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 Poll as P
|
||||
import Servant
|
||||
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
|
||||
import qualified System.Environment as S
|
||||
|
||||
staticFolderLoc = "../client/static"
|
||||
|
||||
|
|
@ -56,10 +59,16 @@ getResult pollId = do
|
|||
mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text
|
||||
mapFromHash = M.fromList . map (\x -> (H.hash x, x))
|
||||
|
||||
makePoll :: P.CreatePollInfo -> AppM P.PollId
|
||||
makePoll :: P.CreatePollInfo -> AppM (L.Html ())
|
||||
makePoll pollReq = do
|
||||
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 pollId ballot = do
|
||||
|
|
@ -69,8 +78,39 @@ vote pollId ballot = do
|
|||
|
||||
|
||||
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 _ 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