diff --git a/lib/Zureg/Database.hs b/lib/Zureg/Database.hs index 9d345be..e243bc6 100644 --- a/lib/Zureg/Database.hs +++ b/lib/Zureg/Database.hs @@ -22,7 +22,9 @@ module Zureg.Database , putRegistrantsSummary -- New stuff + , insertRegistration , setRegistrationState + , setRegistrationScanned ) where import Control.Exception (Exception) @@ -90,5 +92,11 @@ putRegistrantsSummary _ _ = pure () lookupRegistrantsSummary :: Handle -> IO RegistrantsSummary lookupRegistrantsSummary _ = undefined +insertRegistration :: Handle -> UUID -> InsertRegistration -> IO Registration +insertRegistration _ _ _ = undefined + setRegistrationState :: Handle -> UUID -> RegistrationState -> IO Registration setRegistrationState _ _ _ = undefined + +setRegistrationScanned :: Handle -> UUID -> IO Registration +setRegistrationScanned _ _ = undefined diff --git a/lib/Zureg/Database/Migrations/01-init.sql b/lib/Zureg/Database/Migrations/01-init.sql index 2ce954f..07ac730 100644 --- a/lib/Zureg/Database/Migrations/01-init.sql +++ b/lib/Zureg/Database/Migrations/01-init.sql @@ -32,7 +32,7 @@ INSERT INTO occupations (occupation) VALUES ('Tech'); INSERT INTO occupations (occupation) VALUES ('Academia'); INSERT INTO occupations (occupation) VALUES ('Other'); -CREATE TABLE registrants ( +CREATE TABLE registrations ( id UUID NOT NULL PRIMARY KEY DEFAULT GEN_RANDOM_UUID(), email TEXT NOT NULL, name TEXT NOT NULL, @@ -45,12 +45,17 @@ CREATE TABLE registrants ( region TEXT, CONSTRAINT region_fk FOREIGN KEY (region) REFERENCES regions (region), occupation TEXT, - CONSTRAINT registrants_occupation_fk FOREIGN KEY (occupation) + CONSTRAINT registrations_occupation_fk FOREIGN KEY (occupation) REFERENCES occupations (occupation), - beginner_track_interest BOOLEAN NOT NULL + beginner_track_interest BOOLEAN NOT NULL, + state TEXT NOT NULL, + CONSTRAINT state_fk FOREIGN KEY (state) + REFERENCES registration_states (state), + scanned_at TIMESTAMPTZ, + vip BOOLEAN NOT NULL DEFAULT false ); -CREATE UNIQUE INDEX registrants_email_idx ON registrants (email); +CREATE UNIQUE INDEX registrations_email_idx ON registrations (email); CREATE TABLE projects ( id UUID NOT NULL PRIMARY KEY DEFAULT GEN_RANDOM_UUID(), @@ -62,5 +67,5 @@ CREATE TABLE projects ( contributor_level_advanced BOOLEAN NOT NULL, registrant_id UUID NOT NULL, CONSTRAINT registrant_id_fk FOREIGN KEY (registrant_id) - REFERENCES registrants (id) + REFERENCES registrations (id) ); diff --git a/lib/Zureg/Hackathon/Interface.hs b/lib/Zureg/Hackathon/Interface.hs index 69fccbe..c48ccf1 100644 --- a/lib/Zureg/Hackathon/Interface.hs +++ b/lib/Zureg/Hackathon/Interface.hs @@ -23,6 +23,8 @@ data Hackathon = Hackathon , emailFrom :: T.Text -- | When T-shirt order is sent. , tShirtDeadline :: Maybe Time.UTCTime + -- | Secret for accessing the scanner page. + , scannerSecret :: T.Text } hackathonFromEnv :: IO Hackathon diff --git a/lib/Zureg/Main/Web.hs b/lib/Zureg/Main/Web.hs index ae15e4d..c27322f 100644 --- a/lib/Zureg/Main/Web.hs +++ b/lib/Zureg/Main/Web.hs @@ -29,6 +29,7 @@ import qualified Zureg.Captcha as Captcha import qualified Zureg.Database as Database import Zureg.Database.Models import Zureg.Form +import qualified Zureg.Hackathon.ZuriHac2020.Discord as Discord import qualified Zureg.Hackathon as Hackathon import Zureg.Hackathon (Hackathon) import Zureg.Http @@ -39,10 +40,15 @@ import qualified Zureg.Views as Views main :: forall a. (A.FromJSON a, A.ToJSON a) => Hackathon a -> IO () main hackathon = do dbConfig <- Database.configFromEnv + discord <- Discord.configFromEnv app dbConfig hackathon >>= Warp.run 8000 -app :: forall a. (A.FromJSON a, A.ToJSON a) => Database.Config -> Hackathon a -> IO Wai.Application -app dbConfig hackathon = +app + :: Database.Config + -> Discord.Config + -> Hackathon + -> IO Wai.Application +app dbConfig discord hackathon = fmap httpExceptionMiddleware $ Http.newManager Http.tlsManagerSettings >>= \httpManager -> Database.withHandle dbConfig $ \db -> @@ -88,7 +94,7 @@ app dbConfig hackathon = ["ticket"] | Wai.requestMethod req == Http.methodGet -> do uuid <- getUuidParam req - registrant <- Database.getRegistrant db uuid :: IO (Registrant a) + registrant <- Database.getRegistrant db uuid respond . html $ Views.ticket hackathon registrant ["scanner"] | Wai.requestMethod req == Http.methodGet -> @@ -99,56 +105,38 @@ app dbConfig hackathon = scannerAuthorized req $ do time <- Time.getCurrentTime uuid <- getUuidParam req - registrant <- Database.getRegistrant db uuid :: IO (Registrant a) - Database.writeEvents db uuid [Scan $ ScanInfo time :: Event a] + Database.setRegistrationScanned db uuid + registrant <- Database.getRegistrant db uuid respond . html $ Views.scan hackathon registrant ["chat"] -> do time <- Time.getCurrentTime uuid <- getUuidParam req - registrant <- Database.getRegistrant db uuid :: IO (Registrant a) + registrant <- Database.getRegistrant db uuid unless (registrantCanJoinChat $ rState registrant) $ throwIO $ HttpException 400 "Invalid registrant state" - url <- Hackathon.chatUrl hackathon - Database.writeEvents db uuid - [JoinChat $ JoinChatInfo time :: Event a] + welcomeChannel <- Discord.getWelcomeChannelId discord + url <- Discord.generateTempInviteUrl discord welcomeChannel respond $ redirect url ["confirm"] | Hackathon.confirmation hackathon -> do uuid <- getUuidParam req - registrant <- Database.getRegistrant db uuid :: IO (Registrant a) + registrant <- Database.getRegistrant db uuid case rState registrant of - Just Registered -> Database.writeEvents db uuid [Confirm :: Event a] + Just Registered -> Database.setRegistrationState db uuid Confirmed _ -> return () respond . redirect $ "ticket?uuid=" <> UUID.toText uuid - ["spam"] | Wai.requestMethod req == Http.methodPost -> do - uuid <- getUuidParam req - _ <- Database.getRegistrant db uuid :: IO (Registrant a) - Database.writeEvents db uuid [MarkSpam :: Event a] - respond . redirect $ "ticket?uuid=" <> UUID.toText uuid - - ["vip"] | Wai.requestMethod req == Http.methodPost -> - scannerAuthorized req $ do - uuid <- getUuidParam req - _ <- Database.getRegistrant db uuid :: IO (Registrant a) - Database.writeEvents db uuid [MarkVip :: Event a] - respond . redirect $ "ticket?uuid=" <> UUID.toText uuid - ["cancel"] -> do reqBody <- TL.decodeUtf8 <$> Wai.strictRequestBody req (view, mbCancel) <- 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 + registrant <- Database.setRegistrationState db uuid Cancelled respond . html $ Views.cancelSuccess _ -> respond . html $ Views.cancel (lookupUuidParam req) view