index page & http redirect

public/static/index.md

@@ -0,0 +1,5 @@
+## simple ranked choice voting
+
+[create a poll](/create)
+
+[source code](https://gitlab.com/winesj/rcv-site)

public/static/style.css

@@ -75,4 +75,5 @@ body {
 
 #ballot-submit {
   margin-top: 10px;
+  margin-bottom: 10px;
 }

rcv-site.cabal

@@ -39,6 +39,7 @@ executable server
   build-depends:
     acid-state,
     aeson,
+    async,
     base,
     bytestring,
     containers,
@@ -49,6 +50,7 @@ executable server
     lucid-htmx,
     mtl,
     network-uri,
+    commonmark,
     random,
     safecopy,
     servant,
@@ -62,7 +64,7 @@ executable server
     wai-app-static,
     wai-extra,
     warp,
-    warp-tls
+    warp-tls == 3.4.0
   default-language:
     Haskell2010
   other-modules:

src/API.hs

@@ -14,6 +14,7 @@ type RCVAPI =
   :<|> "poll" :> Capture "pollId" P.PollId :> Get '[SL.HTML] (L.Html ())
   :<|> "poll" :> Capture "pollId" P.PollId :> ReqBody '[JSON] B.Ballot :> Post '[SL.HTML] (L.Html ())
   :<|> "poll" :> Capture "pollId" P.PollId :> "results" :> Get '[SL.HTML] (L.Html ())
+  :<|> Get '[SL.HTML] (L.Html ())
   :<|> StaticAPI
 
 type StaticAPI =

src/AppM.hs

@@ -11,6 +11,7 @@ data Env = Env
   {
     db :: Ac.AcidState DB.DB,
     script :: T.Text,
+    index :: T.Text,
     gen :: R.AtomicGenM R.StdGen
   }
 

src/Main.hs

@@ -8,12 +8,14 @@ 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
@@ -24,9 +26,13 @@ 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
@@ -54,6 +60,7 @@ results pollId = do
       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
@@ -105,7 +112,6 @@ vote pollId ballot = do
   where
     ballot' = B.Ballot . filter (== "") . B.options $ ballot
 
-
 server :: ServerT A.RCVAPI AppM
 server = createPage
   :<|> makePoll
@@ -114,12 +120,12 @@ server = createPage
   :<|> 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
@@ -137,6 +143,7 @@ getPollForBallot pollId = do
             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
@@ -168,6 +175,9 @@ createPage = do
         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
 
@@ -176,13 +186,17 @@ 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.tlsSettings "/etc/letsencrypt/live/rankedchoice.net/cert.pem" "/etc/letsencrypt/live/rankedchoice.net/privkey.pem"
+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
@@ -194,12 +208,19 @@ examplePoll = P.CreatePollInfo {
   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
+
+emptyApp _ respond = respond $ NW.responseLBS TS.status200 [] "redirecting to https"
+
 main :: IO ()
 main = do
   env <- getEnv
   opts <- S.getArgs
-  -- let gen = R.globalStdGen
-  -- pollId <- P.PollId <$> R.uniformWord64 gen
   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"]))
@@ -207,5 +228,8 @@ main = do
   print pollids
   let application = serve api . hoistServer api (runWithEnv env) $ server
   case opts of
-    ["--with-tls"] -> WTLS.runTLS tlsSettings warpSettings application
+    ["--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

src/Poll.hs

@@ -13,7 +13,10 @@ import qualified Data.Bifunctor as Bi
 maximumTextLength :: Int
 maximumTextLength = 280
 
-newtype PollId = PollId Word64 deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
+newtype PollId = PollId
+  {
+    asWord :: Word64
+  } deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
 
 instance FromHttpApiData PollId where
   parseUrlPiece = Bi.second PollId . parseUrlPiece