136 lines
4.9 KiB
Haskell
136 lines
4.9 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.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 Network.Wai.Handler.WarpTLS as WTLS
|
|
import qualified Poll as P
|
|
import qualified System.Environment as S
|
|
|
|
staticFolderLoc = "../client/static"
|
|
|
|
|
|
getPollForBallot :: P.PollId -> AppM P.CreatePollInfo
|
|
getPollForBallot pollId = do
|
|
db <- Rd.asks db
|
|
getFromPollId pollId (liftIO . Ac.query db . DB.GetPollForBallot)
|
|
|
|
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
|
|
|
|
getResult :: P.PollId -> AppM P.Result
|
|
getResult pollId = do
|
|
db <- Rd.asks db
|
|
poll :: (P.Poll) <- getFromPollId pollId (liftIO . Ac.query db . DB.GetPoll)
|
|
votesList <- throwOrLift Er.noVotes . maybeVotes $ poll
|
|
pure $ P.Result . reverse . IR.solve . NE.map B.votes $ votesList
|
|
where
|
|
-- discarding empty ballots
|
|
maybeVotes :: P.Poll -> Maybe (LN.NonEmpty (B.Ballot))
|
|
maybeVotes = LN.nonEmpty . P.votes
|
|
|
|
mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text
|
|
mapFromHash = M.fromList . map (\x -> (H.hash x, x))
|
|
|
|
makePoll :: P.CreatePollInfo -> AppM (L.Html ())
|
|
makePoll pollReq = do
|
|
db <- Rd.asks db
|
|
(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
|
|
db <- Rd.asks db
|
|
liftIO $ Ac.update db (DB.PostBallot pollId ballot)
|
|
pure ()
|
|
|
|
|
|
server :: ServerT A.RCVAPI AppM
|
|
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_ ["paper-btn", "btn-primary"], value_ "submit"]
|
|
|
|
-- notFoundPage = pure $ ("this is the 404 page")
|
|
|
|
serveIndex :: Application
|
|
serveIndex _ respond = respond $ W.responseFile status200 [(hContentType, "text/html")] ("static" <> "/index.html") Nothing
|
|
|
|
api :: Proxy A.RCVAPI
|
|
api = Proxy
|
|
|
|
getEnv = Env <$> DB.openLocalDB
|
|
|
|
runWithEnv :: Env -> AppM a -> Handler a
|
|
runWithEnv = flip Rd.runReaderT
|
|
|
|
tlsSettings = WTLS.tlsSettings "/etc/letsencrypt/live/rankedchoice.net/cert.pem" "/etc/letsencrypt/live/rankedchoice.net/privkey.pem"
|
|
warpSettings = W.setPort 443 W.defaultSettings
|
|
|
|
main :: IO ()
|
|
main = do
|
|
env <- getEnv
|
|
opts <- S.getArgs
|
|
let application = serve api . hoistServer api (runWithEnv env) $ server
|
|
case opts of
|
|
["--with-tls"] -> WTLS.runTLS tlsSettings warpSettings application
|
|
_ -> W.run 8080 application
|