From 8136957306675257b3831bc29b03fbab9c47695f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 13 Dec 2023 11:08:53 +0100 Subject: [PATCH] make web compile against wai --- lib/Zureg/Captcha.hs | 3 +- lib/Zureg/Captcha/HCaptcha.hs | 3 +- lib/Zureg/Captcha/ReCaptcha.hs | 3 +- lib/Zureg/Main/Web.hs | 220 +++++++++++++++++---------------- lib/Zureg/Serverless.hs | 14 ++- zureg.cabal | 5 +- 6 files changed, 134 insertions(+), 114 deletions(-) diff --git a/lib/Zureg/Captcha.hs b/lib/Zureg/Captcha.hs index 6d707bd..582b7d0 100644 --- a/lib/Zureg/Captcha.hs +++ b/lib/Zureg/Captcha.hs @@ -7,6 +7,7 @@ module Zureg.Captcha import Control.Exception (Exception) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Network.HTTP.Client as Http import qualified Text.Blaze.Html5 as H @@ -28,5 +29,5 @@ data ClientHtml = ClientHtml data Handle = Handle { clientHtml :: ClientHtml - , verify :: Http.Manager -> Maybe T.Text -> IO () + , verify :: Http.Manager -> Maybe TL.Text -> IO () } diff --git a/lib/Zureg/Captcha/HCaptcha.hs b/lib/Zureg/Captcha/HCaptcha.hs index 99bb183..309fca5 100644 --- a/lib/Zureg/Captcha/HCaptcha.hs +++ b/lib/Zureg/Captcha/HCaptcha.hs @@ -14,6 +14,7 @@ import qualified Data.Aeson as A import qualified Data.Aeson.TH.Extended as A import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL import qualified Data.URLEncoded as UrlEncoded import qualified Network.HTTP.Client as Http import System.Environment (getEnv) @@ -42,7 +43,7 @@ new Config {..} = pure Handle , verify = \httpManager mbRequestBody -> do requestBody <- maybe bail return mbRequestBody - params <- UrlEncoded.importString (T.unpack requestBody) + params <- UrlEncoded.importString (TL.unpack requestBody) param <- maybe bail return (UrlEncoded.lookup paramName params) request0 <- Http.parseRequest "https://hcaptcha.com/siteverify" diff --git a/lib/Zureg/Captcha/ReCaptcha.hs b/lib/Zureg/Captcha/ReCaptcha.hs index 962f817..4e8cdc3 100644 --- a/lib/Zureg/Captcha/ReCaptcha.hs +++ b/lib/Zureg/Captcha/ReCaptcha.hs @@ -13,6 +13,7 @@ import qualified Data.Aeson as A import qualified Data.Aeson.TH.Extended as A import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL import qualified Data.URLEncoded as UrlEncoded import qualified Network.HTTP.Client as Http import qualified Text.Blaze.Html5 as H @@ -33,7 +34,7 @@ new Config {..} = pure Handle , verify = \httpManager mbRequestBody -> do requestBody <- maybe bail return mbRequestBody - params <- UrlEncoded.importString (T.unpack requestBody) + params <- UrlEncoded.importString (TL.unpack requestBody) param <- maybe bail return (UrlEncoded.lookup paramName params) request0 <- Http.parseRequest "https://www.google.com/recaptcha/api/siteverify" diff --git a/lib/Zureg/Main/Web.hs b/lib/Zureg/Main/Web.hs index 6b59f6d..7db604e 100644 --- a/lib/Zureg/Main/Web.hs +++ b/lib/Zureg/Main/Web.hs @@ -8,147 +8,159 @@ module Zureg.Main.Web import Control.Applicative (liftA2) import Control.Exception (throwIO) -import Control.Monad (unless, when) +import Control.Monad (join, unless, when) import qualified Data.Aeson as A import Data.Maybe (isNothing) import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Time as Time import qualified Eventful as E import qualified Network.HTTP.Client as Http import qualified Network.HTTP.Client.TLS as Http +import qualified Network.HTTP.Types as Http +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp import qualified System.IO as IO -import qualified Text.Blaze.Html.Renderer.Text as RenderHtml +import qualified Text.Blaze.Html.Renderer.Utf8 as RenderHtml import qualified Text.Blaze.Html5 as H import qualified Text.Digestive as D import qualified Zureg.Captcha as Captcha import qualified Zureg.Database as Database import Zureg.Form -import Zureg.Hackathon (Hackathon) import qualified Zureg.Hackathon as Hackathon +import Zureg.Hackathon (Hackathon) import Zureg.Model import qualified Zureg.SendEmail as SendEmail import Zureg.SendEmail.Hardcoded import qualified Zureg.Serverless as Serverless import qualified Zureg.Views as Views -html :: H.Html -> IO Serverless.Response -html = return . Serverless.responseHtml . - Serverless.response200 . RenderHtml.renderHtml +html :: H.Html -> Wai.Response +html = Wai.responseBuilder Http.status200 headers . RenderHtml.renderHtmlBuilder + where + headers = [("Content-Type", "text/html; charset=utf-8")] + +redirect :: T.Text -> Wai.Response +redirect l = Wai.responseLBS Http.status302 [("Location", T.encodeUtf8 l)] "" main :: forall a. (A.FromJSON a, A.ToJSON a) => Hackathon a -> IO () -main hackathon = +main hackathon = app hackathon >>= Warp.run 8000 + +app :: forall a. (A.FromJSON a, A.ToJSON a) => Hackathon a -> IO Wai.Application +app hackathon = Http.newManager Http.tlsManagerSettings >>= \httpManager -> Database.withHandle (Hackathon.databaseConfig hackathon) $ \db -> SendEmail.withHandle (Hackathon.sendEmailConfig hackathon) $ \sendEmail -> - Serverless.main IO.stdin IO.stdout $ \req@Serverless.Request {..} -> - case Serverless.requestPath req of - ["register"] -> do - when (reqHttpMethod == "POST") $ Captcha.verify - (Hackathon.captcha hackathon) - httpManager - (Serverless.reqBody req) - (view, mbReg) <- Serverless.runForm req "register" $ D.checkM - "Email address already registered" - (fmap isNothing . Database.lookupEmail db . riEmail . fst) - (liftA2 (,) - (registerForm hackathon) - (Hackathon.registerForm hackathon)) - registrantsSummary <- Database.lookupRegistrantsSummary db - let atCapacity = Database.rsAvailable registrantsSummary <= 0 - case mbReg of - Nothing -> html $ Views.register - hackathon - (Captcha.clientHtml $ Hackathon.captcha hackathon) - view - - Just (info, additionalInfo) | atCapacity -> do - -- You're on the waitlist - uuid <- E.uuidNextRandom - time <- Time.getCurrentTime - let wlinfo = WaitlistInfo time - Database.writeEvents db uuid - [Register info additionalInfo, Waitlist wlinfo] - Database.putEmail db (riEmail info) uuid - sendWaitlistEmail sendEmail hackathon info uuid - html $ Views.registerWaitlist uuid info - Just (info, additionalInfo) -> do - -- Success registration - uuid <- E.uuidNextRandom - Database.writeEvents db uuid [Register info additionalInfo] - Database.putEmail db (riEmail info) uuid - sendRegisterSuccessEmail sendEmail hackathon info uuid - html $ Views.registerSuccess uuid info - - ["ticket"] | reqHttpMethod == "GET" -> do - uuid <- getUuidParam req - registrant <- Database.getRegistrant db uuid :: IO (Registrant a) - html $ Views.ticket hackathon registrant + pure $ \req respond -> case Wai.pathInfo req of + ["register"] -> do + reqBody <- TL.decodeUtf8 <$> Wai.strictRequestBody req + when (Wai.requestMethod req == Http.methodPost) $ Captcha.verify + (Hackathon.captcha hackathon) + httpManager + (Just reqBody) + (view, mbReg) <- Serverless.runForm req reqBody "register" $ D.checkM + "Email address already registered" + (fmap isNothing . Database.lookupEmail db . riEmail . fst) + (liftA2 (,) + (registerForm hackathon) + (Hackathon.registerForm hackathon)) + registrantsSummary <- Database.lookupRegistrantsSummary db + let atCapacity = Database.rsAvailable registrantsSummary <= 0 + case mbReg of + Nothing -> respond . html $ Views.register + hackathon + (Captcha.clientHtml $ Hackathon.captcha hackathon) + view - ["scanner"] | reqHttpMethod == "GET" -> - scannerAuthorized req $ - html $ Views.scanner - - ["scan"] | reqHttpMethod == "GET" -> - scannerAuthorized req $ do + Just (info, additionalInfo) | atCapacity -> do + -- You're on the waitlist + uuid <- E.uuidNextRandom time <- Time.getCurrentTime - uuid <- getUuidParam req - registrant <- Database.getRegistrant db uuid :: IO (Registrant a) - Database.writeEvents db uuid [Scan $ ScanInfo time :: Event a] - html $ Views.scan hackathon registrant + let wlinfo = WaitlistInfo time + Database.writeEvents db uuid + [Register info additionalInfo, Waitlist wlinfo] + Database.putEmail db (riEmail info) uuid + sendWaitlistEmail sendEmail hackathon info uuid + respond . html $ Views.registerWaitlist uuid info + Just (info, additionalInfo) -> do + -- Success registration + uuid <- E.uuidNextRandom + Database.writeEvents db uuid [Register info additionalInfo] + Database.putEmail db (riEmail info) uuid + sendRegisterSuccessEmail sendEmail hackathon info uuid + respond . html $ Views.registerSuccess uuid info - ["chat"] -> do + ["ticket"] | Wai.requestMethod req == Http.methodGet -> do + uuid <- getUuidParam req + registrant <- Database.getRegistrant db uuid :: IO (Registrant a) + respond . html $ Views.ticket hackathon registrant + + ["scanner"] | Wai.requestMethod req == Http.methodGet -> + scannerAuthorized req $ + respond . html $ Views.scanner + + ["scan"] | Wai.requestMethod req == Http.methodGet -> + scannerAuthorized req $ do time <- Time.getCurrentTime uuid <- getUuidParam req registrant <- Database.getRegistrant db uuid :: IO (Registrant a) - unless (registrantCanJoinChat $ rState registrant) $ throwIO $ - Serverless.ServerlessException 400 - "Invalid registrant state" + Database.writeEvents db uuid [Scan $ ScanInfo time :: Event a] + respond . html $ Views.scan hackathon registrant - url <- Hackathon.chatUrl hackathon - Database.writeEvents db uuid - [JoinChat $ JoinChatInfo time :: Event a] - return $ Serverless.response302 url + ["chat"] -> do + time <- Time.getCurrentTime + uuid <- getUuidParam req + registrant <- Database.getRegistrant db uuid :: IO (Registrant a) + unless (registrantCanJoinChat $ rState registrant) $ throwIO $ + Serverless.ServerlessException 400 + "Invalid registrant state" - ["confirm"] | Hackathon.confirmation hackathon -> do - uuid <- getUuidParam req - registrant <- Database.getRegistrant db uuid :: IO (Registrant a) - case rState registrant of - Just Registered -> Database.writeEvents db uuid [Confirm :: Event a] - _ -> return () - return $ Serverless.response302 $ "ticket?uuid=" <> E.uuidToText uuid - - ["cancel"] -> do - (view, mbCancel) <- Serverless.runForm req "cancel" $ - cancelForm (lookupUuidParam req) - case mbCancel of - Just (uuid, True) -> do - registrant <- Database.getRegistrant db uuid :: IO (Registrant a) - -- TODO: Check that not yet cancelled? - Database.writeEvents db uuid [Cancel :: Event a] - case rInfo registrant of - Nothing -> return () - Just info -> Database.deleteEmail db $ riEmail info - html Views.cancelSuccess - _ -> html $ - Views.cancel (lookupUuidParam req) view - - _ -> throwIO $ Serverless.ServerlessException 404 $ - T.unpack reqPath ++ " not found" + url <- Hackathon.chatUrl hackathon + Database.writeEvents db uuid + [JoinChat $ JoinChatInfo time :: Event a] + respond $ redirect url + + ["confirm"] | Hackathon.confirmation hackathon -> do + uuid <- getUuidParam req + registrant <- Database.getRegistrant db uuid :: IO (Registrant a) + case rState registrant of + Just Registered -> Database.writeEvents db uuid [Confirm :: Event a] + _ -> return () + respond . redirect $ "ticket?uuid=" <> E.uuidToText uuid + + ["cancel"] -> do + reqBody <- TL.decodeUtf8 <$> Wai.strictRequestBody req + (view, mbCancel) <- Serverless.runForm req reqBody "cancel" $ + cancelForm (lookupUuidParam req) + case mbCancel of + Just (uuid, True) -> do + registrant <- Database.getRegistrant db uuid :: IO (Registrant a) + -- TODO: Check that not yet cancelled? + Database.writeEvents db uuid [Cancel :: Event a] + case rInfo registrant of + Nothing -> return () + Just info -> Database.deleteEmail db $ riEmail info + respond . html $ Views.cancelSuccess + _ -> respond . html $ + Views.cancel (lookupUuidParam req) view + + pathInfo -> throwIO $ Serverless.ServerlessException 404 $ + T.unpack (T.intercalate "/" pathInfo) ++ " not found" where - lookupUuidParam :: Serverless.Request -> Maybe E.UUID - lookupUuidParam = - (>>= E.uuidFromText) . - Serverless.requestLookupQueryStringParameter "uuid" + textParam k req = fmap T.decodeUtf8 . join . lookup k $ Wai.queryString req + + lookupUuidParam :: Wai.Request -> Maybe E.UUID + lookupUuidParam = (>>= E.uuidFromText) . textParam "uuid" - getUuidParam :: Serverless.Request -> IO E.UUID + getUuidParam :: Wai.Request -> IO E.UUID getUuidParam req = maybe (throwIO $ Serverless.ServerlessException 400 "Missing uuid") return (lookupUuidParam req) - scannerAuthorized request m = - case Serverless.requestLookupQueryStringParameter "secret" request of - Just s | s == Hackathon.scannerSecret hackathon -> m - _ -> throwIO $ - Serverless.ServerlessException 403 - "Wrong or missing secret for scanner access" + scannerAuthorized request m = case textParam "secret" request of + Just s | s == Hackathon.scannerSecret hackathon -> m + _ -> throwIO $ + Serverless.ServerlessException 403 + "Wrong or missing secret for scanner access" diff --git a/lib/Zureg/Serverless.hs b/lib/Zureg/Serverless.hs index f621e7d..51c167b 100644 --- a/lib/Zureg/Serverless.hs +++ b/lib/Zureg/Serverless.hs @@ -28,6 +28,8 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.URLEncoded as UrlEncoded import qualified Data.Vector as V +import qualified Network.HTTP.Types as Http +import qualified Network.Wai as Wai import qualified System.IO as IO import qualified Text.Digestive as D import qualified Zureg.Lambda as Lambda @@ -100,15 +102,15 @@ main ih oh f = | otherwise = responseHtml $ response 500 (TL.pack (show exception)) runForm - :: Request -> T.Text -> D.Form v IO a -> IO (D.View v, Maybe a) -runForm Request {..} name form - | reqHttpMethod == "GET" = do + :: Wai.Request -> TL.Text -> T.Text -> D.Form v IO a + -> IO (D.View v, Maybe a) +runForm req reqBody name form + | Wai.requestMethod req == Http.methodGet = do view <- D.getForm name form return (view, Nothing) - | reqHttpMethod == "POST" = do - body <- maybe (fail "missing post body") return reqBody - encoded <- UrlEncoded.importString $ T.unpack body + | Wai.requestMethod req == Http.methodPost = do + encoded <- UrlEncoded.importString $ TL.unpack reqBody let env :: D.Env IO env = \path -> return $ diff --git a/zureg.cabal b/zureg.cabal index cf59a52..100c458 100644 --- a/zureg.cabal +++ b/zureg.cabal @@ -97,6 +97,7 @@ Library hal >= 1.0 && < 1.1, http-client >= 0.5 && < 0.7, http-client-tls >= 0.3 && < 0.4, + http-types >= 0.12 && < 0.13, lens >= 4.16 && < 4.20, mtl >= 2.2 && < 2.3, mustache >= 2.3 && < 2.4, @@ -108,7 +109,9 @@ Library unordered-containers >= 0.2 && < 0.3, urlencoded >= 0.4 && < 0.6, uuid >= 1.3 && < 1.4, - vector >= 0.12 && < 1.13 + vector >= 0.12 && < 1.13, + wai >= 3.2 && < 3.3, + warp >= 3.3 && < 3.4 Autogen-modules: Paths_zureg