make web compile against wai

zfoh · Dec 13, 2023 · 8136957 · 8136957
1 parent e6baa12
commit 8136957
Show file tree

Hide file tree

Showing 6 changed files with 134 additions and 114 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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