238 lines
9.2 KiB
Haskell
238 lines
9.2 KiB
Haskell
module Main where
|
|
|
|
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.Wai.Application.Static (defaultWebAppSettings, StaticSettings (ss404Handler))
|
|
import Servant
|
|
import qualified Control.Concurrent.Async as A
|
|
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.Map.Strict as M
|
|
import qualified Data.Maybe as My
|
|
import qualified Commonmark as C
|
|
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.Handler.Warp as W
|
|
import qualified Network.Wai.Handler.WarpTLS as WTLS
|
|
import qualified Poll as P
|
|
import qualified System.Environment as S
|
|
import qualified Data.Text.IO as TIO
|
|
import qualified System.Random.Stateful as R
|
|
import qualified Network.Wai as NW
|
|
import qualified Data.Set as S
|
|
import qualified Control.Monad as M
|
|
import qualified Network.Wai.Middleware.ForceSSL as TLS
|
|
import qualified Network.HTTP.Types.Status as TS
|
|
import LucidUtils
|
|
import qualified Data.Text.Lazy as TL
|
|
|
|
throwOrLift :: AppM a -> Maybe a -> AppM a
|
|
throwOrLift err = My.maybe err pure
|
|
|
|
-- I didn't want to grab the whole poll (with votes) from the database so instead I pass a function.
|
|
getFromPollId :: P.PollId -> (P.PollId -> AppM (Maybe a)) -> AppM a
|
|
getFromPollId pollId query = do
|
|
pollResult <- query pollId
|
|
throwOrLift (Er.noPollFound pollId) pollResult
|
|
|
|
notVotedFor :: P.Poll -> S.Set T.Text
|
|
notVotedFor (P.Poll {..}) = S.difference allOptions votedFor
|
|
where
|
|
votedFor = S.unions $ map (S.fromList . B.options) votes
|
|
allOptions = S.fromList . LN.toList . P.options $ createInfo
|
|
|
|
results :: P.PollId -> AppM (L.Html ())
|
|
results pollId = do
|
|
db <- Rd.asks db
|
|
poll :: P.Poll <- getFromPollId pollId (liftIO . Ac.query db . DB.GetPoll)
|
|
case toNonEmptyList . P.votes $ poll of
|
|
Nothing -> fullPage "poll doesn't have any votes"
|
|
Just votesList -> do
|
|
let voteless = notVotedFor poll
|
|
let results' = (reverse . IR.solve $ votesList) ++ noVotesAsBallot voteless
|
|
fullPage $ do
|
|
h2_ "results"
|
|
toHtml $ T.append (T.pack . show . length . P.votes $ poll) " ballots submitted"
|
|
maybe "" (h3_ . toHtml) . P.title . P.createInfo $ poll
|
|
h3_ . toHtml . P.question . P.createInfo $ poll
|
|
with div_ [id_ "results"] . mconcat $ zipWith nthPlaceFor results' nthPlaces
|
|
where
|
|
noVotesAsBallot :: S.Set T.Text -> [S.Set T.Text]
|
|
noVotesAsBallot notVotedFor' = if S.null notVotedFor' then [] else [notVotedFor']
|
|
|
|
toNonEmptyList :: [B.Ballot] -> Maybe (LN.NonEmpty (LN.NonEmpty T.Text))
|
|
toNonEmptyList = LN.nonEmpty . My.mapMaybe (LN.nonEmpty . B.options)
|
|
|
|
nthPlaceFor :: S.Set T.Text -> L.Html () -> L.Html ()
|
|
nthPlaceFor options place = do
|
|
with div_ [classes_ ["child-borders"]] . mconcat . map (div_ . toHtml) . S.toList $ options
|
|
place
|
|
|
|
mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text
|
|
mapFromHash = M.fromList . map (\x -> (H.hash x, x))
|
|
|
|
nthPlaces :: [L.Html ()]
|
|
nthPlaces =
|
|
[with span_ [classes_ ["first-place", "badge"]] "1st",
|
|
with span_ [classes_ ["second-place", "badge"]] "2nd",
|
|
with span_ [classes_ ["third-place", "badge"]] "3rd"]
|
|
++ map (\n -> with span_ [class_ "badge"] . toHtml $ T.append (T.pack . show $ n) "th") [4 :: Int ..]
|
|
|
|
|
|
makePoll :: P.CreatePollInfo -> AppM (L.Html ())
|
|
makePoll pollReq = do
|
|
db <- Rd.asks db
|
|
gen <- Rd.asks gen
|
|
pollId <- P.PollId <$> R.uniformWord64 gen
|
|
liftIO $ Ac.update db (DB.CreatePoll pollReq pollId)
|
|
let fillOutLink = toPollIdLink pollId
|
|
pure . div_ $ do
|
|
"done! people can fill out your poll at "
|
|
with a_ [href_ fillOutLink] (toHtml fillOutLink)
|
|
|
|
|
|
toPollIdLink :: P.PollId -> T.Text
|
|
toPollIdLink (P.PollId pollId) = T.append "https://rankedchoice.net/poll/" (T.pack . show $ pollId)
|
|
|
|
vote :: P.PollId -> B.Ballot -> AppM (L.Html ())
|
|
vote pollId ballot = do
|
|
db <- Rd.asks db
|
|
liftIO $ Ac.update db (DB.PostBallot pollId ballot')
|
|
pure $ with div_ [id_ "resultLink"] $ do
|
|
"success! Here's the "
|
|
with a_ [href_ (toPollIdLink pollId `T.append` "/results")] "results"
|
|
where
|
|
ballot' = B.Ballot . filter (== "") . B.options $ ballot
|
|
|
|
server :: ServerT A.RCVAPI AppM
|
|
server = createPage
|
|
:<|> makePoll
|
|
:<|> pure optionWithRemoveButton
|
|
:<|> (pure . pure $ ())
|
|
:<|> getPollForBallot
|
|
:<|> vote
|
|
:<|> results
|
|
:<|> indexPage
|
|
:<|> serveDirectoryWith (defaultWebAppSettings "public")
|
|
|
|
emptyHiddenInput :: L.Html ()
|
|
emptyHiddenInput = input_ [hidden_ "", name_ "options", value_ ""]
|
|
|
|
getPollForBallot :: P.PollId -> AppM (L.Html ())
|
|
getPollForBallot pollId = do
|
|
db <- Rd.asks db
|
|
createInfo <- getFromPollId pollId (liftIO . Ac.query db . DB.GetPollForBallot)
|
|
fullPage $ do
|
|
My.maybe (pure ()) (h3_ . toHtml) (P.title createInfo)
|
|
h3_ . toHtml . P.question $ createInfo
|
|
with div_ [id_ "drag-boxes-container"] $ do
|
|
div_ $ do
|
|
"drag from here"
|
|
with div_ [classes_ ["draggable-options","sortable-from", "options", "child-borders", "border-primary", "background-primary"]] . mconcat . map toFormInput . LN.toList . P.options $ createInfo
|
|
with form_ [hxPost_ "", id_ "drag-into-vote", hxTarget_ "closest body"] $ do
|
|
div_$ do
|
|
"to here in order of preference"
|
|
with div_ [classes_ ["draggable-options", "sortable", "options", "child-borders", "border-primary", "background-primary"]]
|
|
(emptyHiddenInput <> emptyHiddenInput)
|
|
input_ [id_ "ballot-submit", type_ "submit", classes_ ["paper-btn", "btn-primary"], value_ "submit", form_ "drag-into-vote"]
|
|
a_ [href_ (T.concat [T.pack . show . P.asWord $ pollId, "/results"])] "skip voting and see results"
|
|
where
|
|
toFormInput :: T.Text -> L.Html ()
|
|
toFormInput option = with div_ [classes_ []] $ input_ [type_ "hidden", value_ option, name_ "options"] <> toHtml option
|
|
|
|
|
|
optionInput :: L.Html ()
|
|
optionInput = input_ [required_ "true", name_ "options", maxlength_ "100"]
|
|
|
|
removeButton :: L.Html ()
|
|
removeButton = with button_ [classes_ ["btn", "btn-warning-outline"], hxGet_ "create/removeInput", hxSwap_ "delete", hxTarget_ "closest .options > *"] "remove"
|
|
|
|
optionWithRemoveButton :: L.Html ()
|
|
optionWithRemoveButton = div_ (optionInput <> removeButton)
|
|
|
|
optionWithoutRemoveButton :: L.Html ()
|
|
optionWithoutRemoveButton = div_ optionInput
|
|
|
|
createPage :: AppM (L.Html ())
|
|
createPage = do
|
|
fullPage $ 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", maxlength_ "100"]
|
|
with label_ [for_ "question"] "question" <> input_ [name_ "question", type_ "text", required_ "true", maxlength_ "100"]
|
|
with fieldset_ [name_ "options", class_ "options"] $ do
|
|
legend_ "options"
|
|
optionWithoutRemoveButton
|
|
optionWithoutRemoveButton
|
|
with button_ [hxGet_ "create/newInput", hxTarget_ "this", hxSwap_ "beforebegin"] "add option"
|
|
input_ [type_ "submit", classes_ ["paper-btn", "btn-primary"], value_ "submit"]
|
|
|
|
indexPage :: AppM (L.Html ())
|
|
indexPage = fullPage . toHtmlRaw =<< Rd.asks index
|
|
|
|
api :: Proxy A.RCVAPI
|
|
api = Proxy
|
|
|
|
getEnv :: IO Env
|
|
getEnv = do
|
|
db <- DB.openLocalDB
|
|
script <- TIO.readFile "public/static/script.js"
|
|
let gen = R.globalStdGen
|
|
index <- convertMarkdown "public/static/index.md"
|
|
pure $ Env {..}
|
|
|
|
runWithEnv :: Env -> AppM a -> Handler a
|
|
runWithEnv = flip Rd.runReaderT
|
|
|
|
tlsSettings :: WTLS.TLSSettings
|
|
tlsSettings = WTLS.tlsSettingsChain
|
|
"/etc/letsencrypt/live/rankedchoice.net/cert.pem"
|
|
["/etc/letsencrypt/live/rankedchoice.net/fullchain.pem"]
|
|
"/etc/letsencrypt/live/rankedchoice.net/privkey.pem"
|
|
|
|
warpSettings :: W.Settings
|
|
warpSettings = W.setPort 443 W.defaultSettings
|
|
|
|
examplePoll :: P.CreatePollInfo
|
|
examplePoll = P.CreatePollInfo {
|
|
title = Nothing,
|
|
question = "what's your favorite color?",
|
|
options = "red" LN.:| ["blue", "green", "yellow", "orange", "pink", "purple", "grey", "black"]
|
|
}
|
|
|
|
convertMarkdown :: FilePath -> IO T.Text
|
|
convertMarkdown path = do
|
|
file <- TIO.readFile path
|
|
case C.commonmark path file of
|
|
Left err -> liftIO . fail . show $ err
|
|
Right (rst :: C.Html ()) -> pure . TL.toStrict . C.renderHtml $ rst
|
|
|
|
|
|
-- we need a WAI application for the redirect middleware to act on
|
|
emptyApp :: p -> (NW.Response -> b) -> b
|
|
emptyApp _ respondf = respondf $ NW.responseLBS TS.status200 [] "redirecting to https"
|
|
|
|
main :: IO ()
|
|
main = do
|
|
env <- getEnv
|
|
opts <- S.getArgs
|
|
M.void . liftIO $ Ac.update (db env) (DB.CreatePoll examplePoll (P.PollId 7))
|
|
M.void . liftIO $ Ac.update (db env) (DB.PostBallot (P.PollId 7) (B.Ballot ["blue", "green", "yellow", "orange", "pink"]))
|
|
M.void . liftIO $ Ac.update (db env) (DB.PostBallot (P.PollId 7) (B.Ballot ["blue", "red", "pink", "purple", "green"]))
|
|
pollids <- liftIO . Ac.query (db env) $ DB.GetPollIds
|
|
print pollids
|
|
let application = serve api . hoistServer api (runWithEnv env) $ server
|
|
case opts of
|
|
["--with-tls"] -> do
|
|
httpsSite <- A.async $ WTLS.runTLS tlsSettings warpSettings application
|
|
httpSite <- A.async $ W.run 80 $ TLS.forceSSL emptyApp
|
|
M.void $ A.waitAny [httpsSite, httpSite]
|
|
_ -> W.run 8080 application
|