From a91f9b41e8617ea82490c026ac2c6122b816559a Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <m@jaspervdj.be>
Date: Thu, 2 May 2024 15:51:31 +0200
Subject: [PATCH] add VIPs

---
 lib/Zureg/Hackathon/ZuriHac2024/Model.hs |  1 +
 lib/Zureg/Main/Web.hs                    |  7 +++++++
 lib/Zureg/Model.hs                       | 12 +++++++++++-
 lib/Zureg/Model/Csv.hs                   |  1 +
 lib/Zureg/Views.hs                       |  2 ++
 5 files changed, 22 insertions(+), 1 deletion(-)

diff --git a/lib/Zureg/Hackathon/ZuriHac2024/Model.hs b/lib/Zureg/Hackathon/ZuriHac2024/Model.hs
index 177512c..0b4cba2 100644
--- a/lib/Zureg/Hackathon/ZuriHac2024/Model.hs
+++ b/lib/Zureg/Hackathon/ZuriHac2024/Model.hs
@@ -107,6 +107,7 @@ csvHeader = Csv.header
     [ "UUID"
     , "State"
     , "Scanned"
+    , "VIP"
     , "Name"
     , "Email"
     , "Region"
diff --git a/lib/Zureg/Main/Web.hs b/lib/Zureg/Main/Web.hs
index 28e6581..6a5ffb2 100644
--- a/lib/Zureg/Main/Web.hs
+++ b/lib/Zureg/Main/Web.hs
@@ -126,6 +126,13 @@ app hackathon =
             Database.writeEvents db uuid [MarkSpam :: Event a]
             respond . redirect $ "ticket?uuid=" <> E.uuidToText 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=" <> E.uuidToText uuid
+
         ["cancel"] -> do
             reqBody <- TL.decodeUtf8 <$> Wai.strictRequestBody req
             (view, mbCancel) <- runForm req reqBody "cancel" $
diff --git a/lib/Zureg/Model.hs b/lib/Zureg/Model.hs
index 6eafa79..1b89f98 100644
--- a/lib/Zureg/Model.hs
+++ b/lib/Zureg/Model.hs
@@ -68,6 +68,7 @@ data Event a
     | Uncancel UncancelInfo
     | JoinChat JoinChatInfo
     | MarkSpam
+    | MarkVip
     deriving (Eq, Show)
 
 --------------------------------------------------------------------------------
@@ -82,11 +83,19 @@ data Registrant a = Registrant
     , rAdditionalInfo :: Maybe a
     , rState          :: Maybe RegisterState
     , rScanned        :: Bool
+    , rVip            :: Bool
     } deriving (Eq, Show)
 
 registrantProjection :: E.UUID -> E.Projection (Registrant a) (Event a)
 registrantProjection uuid = E.Projection
-    { E.projectionSeed         = Registrant uuid Nothing Nothing Nothing False
+    { E.projectionSeed         = Registrant
+        { rUuid           = uuid
+        , rInfo           = Nothing
+        , rAdditionalInfo = Nothing
+        , rState          = Nothing
+        , rScanned        = False
+        , rVip            = False
+        }
     , E.projectionEventHandler = \registrant event -> case event of
         Cancel | Just Spam /= rState registrant ->
             registrant {rState = Just Cancelled}
@@ -101,6 +110,7 @@ registrantProjection uuid = E.Projection
         Uncancel _ | Just Cancelled <- rState registrant ->
             registrant {rState = Just Registered}
         MarkSpam -> registrant {rState = Just Spam}
+        MarkVip -> registrant {rVip = True}
         _ -> registrant
     }
 
diff --git a/lib/Zureg/Model/Csv.hs b/lib/Zureg/Model/Csv.hs
index 2dce73e..e3ab11f 100644
--- a/lib/Zureg/Model/Csv.hs
+++ b/lib/Zureg/Model/Csv.hs
@@ -25,6 +25,7 @@ instance ToNamedRecord a => ToNamedRecord (Registrant a) where
                         Just ai -> toNamedRecord ai
                         Nothing -> HM.empty
                      , namedRecord [ "Scanned" .= rScanned ]
+                     , namedRecord [ "VIP" .= rVip ]
                      ]
 
 instance ToNamedRecord RegisterState where
diff --git a/lib/Zureg/Views.hs b/lib/Zureg/Views.hs
index ab8313c..20b12c1 100644
--- a/lib/Zureg/Views.hs
+++ b/lib/Zureg/Views.hs
@@ -234,6 +234,8 @@ scan hackathon registrant@Registrant {..} = H.ul $ do
     H.li $ H.strong $
         let (html, ok) = registerState rState in (if ok then id else red) html
 
+    when rVip $ H.li $ "⭐ " <> H.strong "VIP"
+
     H.li $ case (registrantRegisteredAt registrant, registrantToBadge registrant) of
         (_, Nothing)                        -> red "No Badge"
         (_, Just badge)                     ->