Make it compile

zfoh · Jan 14, 2025 · 1fd6662 · 1fd6662
1 parent 192b695
commit 1fd6662
Show file tree

Hide file tree

Showing 8 changed files with 81 additions and 92 deletions.
diff --git a/lib/Zureg/Captcha/HCaptcha.hs b/lib/Zureg/Captcha/HCaptcha.hs
@@ -6,7 +6,7 @@ module Zureg.Captcha.HCaptcha
     ( module Zureg.Captcha
     , Config (..)
     , configFromEnv
-    , new
+    , withHandle
     ) where
 
 import           Control.Exception           (throwIO)
@@ -64,6 +64,9 @@ new Config {..} = pure Handle
     bail      = throwIO $ VerificationFailed []
     paramName = "h-captcha-response" :: String
 
+withHandle :: Config -> (Handle -> IO a) -> IO a
+withHandle cfg f = new cfg >>= f
+
 data ApiResponse = ApiResponse
     { arSuccess    :: !Bool
     , _arHostname  :: !T.Text

diff --git a/lib/Zureg/Database.hs b/lib/Zureg/Database.hs
@@ -92,8 +92,8 @@ putRegistrantsSummary _ _ = pure ()
 lookupRegistrantsSummary :: Handle -> IO RegistrantsSummary
 lookupRegistrantsSummary _ = undefined
 
-insertRegistration :: Handle -> UUID -> InsertRegistration -> IO Registration
-insertRegistration _ _ _ = undefined
+insertRegistration :: Handle -> InsertRegistration -> IO Registration
+insertRegistration _ _ = undefined
 
 setRegistrationState :: Handle -> UUID -> RegistrationState -> IO Registration
 setRegistrationState _ _ _ = undefined

diff --git a/lib/Zureg/Main/PopWaitlist.hs b/lib/Zureg/Main/PopWaitlist.hs
@@ -30,7 +30,7 @@ popWaitinglistUUIDs dbConfig hackathon uuids =
         registrant <- Database.setRegistrationState db uuid Registered
         IO.hPutStrLn IO.stderr $
             "Mailing " ++ T.unpack (rEmail registrant) ++ "..."
-        sendPopWaitlistEmail mailer hackathon registrant uuid
+        sendPopWaitlistEmail mailer hackathon registrant
         IO.hPutStrLn IO.stderr "OK"
 
 main :: Hackathon -> IO ()

diff --git a/lib/Zureg/Main/Web.hs b/lib/Zureg/Main/Web.hs
@@ -7,90 +7,100 @@ module Zureg.Main.Web
     , app
     ) where
 
-import           Control.Applicative       (liftA2)
-import           Control.Exception         (throwIO)
-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           Data.UUID                 (UUID)
-import qualified Data.UUID                 as UUID
-import qualified Data.UUID.V4              as UUID
-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 Text.Digestive            as D
-import qualified Zureg.Captcha             as Captcha
-import qualified Zureg.Database            as Database
+import           Control.Applicative                 (liftA2)
+import           Control.Exception                   (throwIO)
+import           Control.Monad                       (join, unless, void, 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           Data.UUID                           (UUID)
+import qualified Data.UUID                           as UUID
+import qualified Data.UUID.V4                        as UUID
+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 Text.Digestive                      as D
+import qualified Zureg.Captcha                       as Captcha
+import qualified Zureg.Captcha.HCaptcha              as HCaptcha
+import qualified Zureg.Database                      as Database
 import           Zureg.Database.Models
 import           Zureg.Form
+import qualified Zureg.Hackathon                     as Hackathon
+import           Zureg.Hackathon                     (Hackathon)
 import qualified Zureg.Hackathon.ZuriHac2020.Discord as Discord
-import qualified Zureg.Hackathon           as Hackathon
-import           Zureg.Hackathon           (Hackathon)
 import           Zureg.Http
-import qualified Zureg.SendEmail           as SendEmail
+import qualified Zureg.SendEmail                     as SendEmail
 import           Zureg.SendEmail.Hardcoded
-import qualified Zureg.Views               as Views
+import qualified Zureg.Views                         as Views
 
-main :: forall a. (A.FromJSON a, A.ToJSON a) => Hackathon a -> IO ()
+main :: Hackathon -> IO ()
 main hackathon = do
-    dbConfig <- Database.configFromEnv
+    db <- Database.configFromEnv
     discord <- Discord.configFromEnv
-    app dbConfig hackathon >>= Warp.run 8000
+    hcaptcha <- HCaptcha.configFromEnv
+    app db discord hcaptcha hackathon >>= Warp.run 8000
 
 app
     :: Database.Config
     -> Discord.Config
+    -> HCaptcha.Config  -- ^ TODO: generic captcha config?
     -> Hackathon
     -> IO Wai.Application
-app dbConfig discord hackathon =
+app dbConfig discord hcaptchaConfig hackathon =
     fmap httpExceptionMiddleware $
     Http.newManager Http.tlsManagerSettings >>= \httpManager ->
     Database.withHandle dbConfig $ \db ->
-    SendEmail.withHandle (Hackathon.sendEmailConfig hackathon) $ \sendEmail ->
+    SendEmail.withHandle $ \sendEmail ->
+    HCaptcha.withHandle hcaptchaConfig $ \captcha ->
     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)
+                captcha
                 httpManager
                 (Just reqBody)
             (view, mbReg) <- runForm req reqBody "register" $ D.checkM
                 "Email address already registered"
-                (fmap isNothing . Database.lookupEmail db . riEmail . fst)
-                (liftA2 (,)
-                    (registerForm hackathon)
-                    (Hackathon.registerForm hackathon))
+                (fmap isNothing . Database.lookupEmail db . irEmail)
+                registerForm
             case mbReg of
                 Nothing -> respond . html $ Views.register
                     hackathon
-                    (Captcha.clientHtml $ Hackathon.captcha hackathon)
+                    (Captcha.clientHtml captcha)
                     view
-                Just (info, additionalInfo) -> do
+                Just insert -> do
+                    -- TODO: transaction this
                     registrantsSummary <- Database.lookupRegistrantsSummary db
                     let atCapacity = Database.rsAvailable registrantsSummary <= 0
                     if atCapacity then do
                         -- You're on the waitlist
                         uuid <- UUID.nextRandom
+                        {-
                         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
-                        respond . html $ Views.registerWaitlist uuid info
+                        -}
+                        registrant <- Database.insertRegistration db insert
+                        let uuid = rUuid registrant
+                        registrant' <- Database.setRegistrationState db uuid
+                            Waitlisted
+                        sendWaitlistEmail sendEmail hackathon registrant'
+                        respond . html $ Views.registerWaitlist registrant'
                     else do
                         -- Success registration
-                        uuid <- UUID.nextRandom
-                        Database.writeEvents db uuid [Register info additionalInfo]
-                        Database.putEmail db (riEmail info) uuid
-                        sendRegisterSuccessEmail sendEmail hackathon info uuid
-                        respond . html $ Views.registerSuccess uuid info
+                        registrant <- Database.insertRegistration db insert
+                        let uuid = rUuid registrant
+                        registrant' <- Database.setRegistrationState db uuid
+                            Registered
+                        sendRegisterSuccessEmail sendEmail hackathon registrant'
+                        respond . html $ Views.registerSuccess registrant'
 
         ["ticket"] | Wai.requestMethod req == Http.methodGet -> do
             uuid <- getUuidParam req
@@ -125,8 +135,9 @@ app dbConfig discord hackathon =
             uuid <- getUuidParam req
             registrant <- Database.getRegistrant db uuid
             case rState registrant of
-              Just Registered -> Database.setRegistrationState db uuid Confirmed
-              _               -> return ()
+                Registered -> void $
+                  Database.setRegistrationState db uuid Confirmed
+                _ -> pure ()
             respond . redirect $ "ticket?uuid=" <> UUID.toText uuid
 
         ["cancel"] -> do

diff --git a/lib/Zureg/SendEmail/Hardcoded.hs b/lib/Zureg/SendEmail/Hardcoded.hs
@@ -8,15 +8,14 @@ module Zureg.SendEmail.Hardcoded
     ) where
 
 import qualified Data.Text             as T
-import           Data.UUID             (UUID)
 import qualified Data.UUID             as UUID
 import           Zureg.Database.Models
 import           Zureg.Hackathon
 import qualified Zureg.SendEmail       as SendEmail
 
 sendRegisterSuccessEmail
-    :: SendEmail.Handle -> Hackathon -> Registration -> UUID -> IO ()
-sendRegisterSuccessEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
+    :: SendEmail.Handle -> Hackathon -> Registration -> IO ()
+sendRegisterSuccessEmail sendEmail Hackathon {..} info = SendEmail.sendEmail
     sendEmail
     emailFrom
     (rEmail info)
@@ -29,7 +28,7 @@ sendRegisterSuccessEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmai
     , ""
     , "You can view your registration and join our chat here:"
     , ""
-    , "    " <> baseUrl <> "/ticket?uuid=" <> UUID.toText uuid
+    , "    " <> baseUrl <> "/ticket?uuid=" <> UUID.toText (rUuid info)
     , ""
     , "If you have any concerns, you can find our contact info here:"
     , ""
@@ -41,8 +40,8 @@ sendRegisterSuccessEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmai
     ]
 
 sendWaitlistEmail
-    :: SendEmail.Handle -> Hackathon -> Registration -> UUID -> IO ()
-sendWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
+    :: SendEmail.Handle -> Hackathon -> Registration -> IO ()
+sendWaitlistEmail sendEmail Hackathon {..} info = SendEmail.sendEmail
     sendEmail
     emailFrom
     (rEmail info)
@@ -55,7 +54,7 @@ sendWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
     , ""
     , "You can view your status here:"
     , ""
-    , "    " <> baseUrl <> "/ticket?uuid=" <> UUID.toText uuid
+    , "    " <> baseUrl <> "/ticket?uuid=" <> UUID.toText (rUuid info)
     , ""
     , "If you have any concerns, you can find our contact info here:"
     , ""
@@ -66,8 +65,8 @@ sendWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
     ]
 
 sendPopWaitlistEmail
-    :: SendEmail.Handle -> Hackathon -> Registration -> UUID -> IO ()
-sendPopWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
+    :: SendEmail.Handle -> Hackathon -> Registration -> IO ()
+sendPopWaitlistEmail sendEmail Hackathon {..} info = SendEmail.sendEmail
     sendEmail
     emailFrom
     (rEmail info)
@@ -80,7 +79,7 @@ sendPopWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
     , ""
     , "You can view your registration and join our chat here:"
     , ""
-    , "    " <> baseUrl <> "/ticket?uuid=" <> UUID.toText uuid
+    , "    " <> baseUrl <> "/ticket?uuid=" <> UUID.toText (rUuid info)
     , ""
     , "If you have any concerns, you can find our contact info here:"
     , ""

diff --git a/lib/Zureg/Views.hs b/lib/Zureg/Views.hs
@@ -98,18 +98,18 @@ register hackathon captchaHtml view =
     template (Captcha.chScript captchaHtml) $
     Form.registerView hackathon captchaHtml view
 
-registerSuccess :: UUID -> InsertRegistration -> H.Html
-registerSuccess _uuid InsertRegistration {..} = template mempty $ do
+registerSuccess :: Registration -> H.Html
+registerSuccess Registration {..} = template mempty $ do
     H.h1 "Registration successful"
-    H.p $ H.toHtml irName <> ", your registration was successful."
-    H.p $ "You will receive a confirmation mail at " <> H.toHtml irEmail <>
+    H.p $ H.toHtml rName <> ", your registration was successful."
+    H.p $ "You will receive a confirmation mail at " <> H.toHtml rEmail <>
         " soon."
 
-registerWaitlist :: UUID -> InsertRegistration -> H.Html
-registerWaitlist _uuid InsertRegistration {..} = template mempty $ do
+registerWaitlist :: Registration -> H.Html
+registerWaitlist Registration {..} = template mempty $ do
     H.h1 "You are now on the waitlist"
-    H.p $ H.toHtml irName <> ", your have been added to the waitlist."
-    H.p $ "You will receive an email at " <> H.toHtml irEmail <> " soon."
+    H.p $ H.toHtml rName <> ", your have been added to the waitlist."
+    H.p $ "You will receive an email at " <> H.toHtml rEmail <> " soon."
 
 ticket :: Hackathon -> Registration -> H.Html
 ticket hackathon registration@Registration {..} = template

diff --git a/src/Lambda.hs b/src/Lambda.hs
diff --git a/zureg.cabal b/zureg.cabal
@@ -72,7 +72,7 @@ Library
     digestive-functors-blaze >= 0.6  && < 0.7,
     directory                >= 1.3  && < 1.4,
     file-embed               >= 0.0  && < 0.1,
-    filepath                 >= 1.4  && < 1.5,
+    filepath                 >= 1.4  && < 1.6,
     http-client              >= 0.5  && < 0.8,
     http-client-tls          >= 0.3  && < 0.4,
     http-types               >= 0.12 && < 0.13,
@@ -128,10 +128,3 @@ Executable zureg-badges
 Executable zureg-janitor
   Import:  exe
   Main-is: Janitor.hs
-
-Executable zureg-lambda
-  Import:        exe
-  Main-is:       Lambda.hs
-  Build-depends:
-    hal             >= 1.0 && < 1.1,
-    wai-handler-hal >= 0.3 && < 0.5