swap to htmx

This commit is contained in:
Jack Wines 2023-06-10 20:26:26 -07:00
parent 47989ab012
commit b8b7d8a198
33 changed files with 155 additions and 544 deletions

1
.gitignore vendored
View file

@ -6,3 +6,4 @@ server/db
/client/index.html
/server/state/
client/static/main.js
/state/

2
cabal.project Normal file
View file

@ -0,0 +1,2 @@
allow-newer: servant, servant-server, *:servant-server, *:base, servant-htmx:*, lucid-htmx:*
packages: rcv-site.cabal

View file

@ -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": {}
}
}

View file

@ -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

View file

@ -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

File diff suppressed because one or more lines are too long

12
public/static/json-enc.js Normal file
View 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
View 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;
}

View file

@ -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,

View file

@ -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

View file

@ -1 +0,0 @@
../client/static

23
src/API.hs Normal file
View 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

View file

@ -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
View 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;

View file

View file

@ -0,0 +1 @@
0.16.1.2

View file

1
src/state/events.version Normal file
View file

@ -0,0 +1 @@
0.16.1.2

0
src/state/open.lock Normal file
View file