add Spam state

Makefile

@@ -8,7 +8,7 @@ build: build/zureg-lambda.zip
 
 # We need docker to build binaries that run on amazon's linux version, which is
 # why this command is a bit more complicated than just `stack install`.
-build/zureg-lambda/bootstrap: build/image.txt $(SOURCES)
+build/zureg-lambda/bootstrap: build/image.txt
 	mkdir -p build/zureg-lambda
 	docker run \
 		-m 4GB \
@@ -18,16 +18,14 @@ build/zureg-lambda/bootstrap: build/image.txt $(SOURCES)
 		$(shell cat build/image.txt) \
 		cp -r /zureg/bin/zureg-lambda /dist/bootstrap
 
-	touch $@
-
 # Put all code and dependencies in a zip file we can run on AWS Lambda.
 build/zureg-lambda.zip: build/zureg-lambda/bootstrap
 	zip $@ -j build/zureg-lambda/*
 	ls -lh $@
 
 # This is a text file with the name of the docker image.  We do things this way
 # to make the Makefile dependency tracking work.
-build/image.txt: Dockerfile
+build/image.txt: Dockerfile $(SOURCES)
 	mkdir -p build
 	docker build -m 4GB -t zureg .
 	echo "zureg" >$@

lib/Zureg/Database.hs

@@ -28,7 +28,7 @@ import           Control.Monad.Trans     (liftIO)
 import qualified Data.Aeson              as A
 import qualified Data.Aeson.TH.Extended  as A
 import qualified Data.HashMap.Strict     as HMS
-import           Data.Maybe              (listToMaybe)
+import           Data.Maybe              (fromMaybe, listToMaybe)
 import qualified Data.Text               as T
 import qualified Eventful                as E
 import qualified Eventful.Store.DynamoDB as E
@@ -168,6 +168,7 @@ data RegistrantsSummary = RegistrantsSummary
     , rsAttending :: Int
     , rsAvailable :: Int
     , rsScanned   :: Int
+    , rsSpam      :: Int
     } deriving (Show)
 
 $(A.deriveJSON A.options ''RegistrantsSummary)
@@ -182,13 +183,15 @@ registrantsSummaryToAttributeValue RegistrantsSummary {..} =
         , ("attending", avi rsAttending)
         , ("available", avi rsAvailable)
         , ("scanned", avi rsScanned)
+        , ("spam", avi rsSpam)
         ]
 
 registrantsSummaryFromAttributeValue
     :: DynamoDB.AttributeValue -> Maybe RegistrantsSummary
 registrantsSummaryFromAttributeValue av = RegistrantsSummary
     <$> getInt "total" <*> getInt "waiting" <*> getInt "confirmed"
     <*> getInt "attending" <*> getInt "available" <*> getInt "scanned"
+    <*> pure (fromMaybe 0 (getInt "spam"))
   where
     getInt :: T.Text -> Maybe Int
     getInt key = do

lib/Zureg/Main/Janitor.hs

@@ -51,6 +51,7 @@ app hackathon _event =
         registrantsToPop = take freeSpaces waitingRegistrants
         freeSpacesLeft = freeSpaces - length registrantsToPop
         scanned = length $ filter rScanned registrants
+        spam = countByState (== Spam) registrants
 
     popWaitinglistUUIDs hackathon registrantsToPop
 
@@ -61,6 +62,7 @@ app hackathon _event =
             , Database.rsAttending = attending
             , Database.rsAvailable = freeSpacesLeft
             , Database.rsScanned   = scanned
+            , Database.rsSpam      = spam
             }
 
     Database.putRegistrantsSummary db summary

lib/Zureg/Main/Web.hs

@@ -120,6 +120,12 @@ app hackathon =
               _               -> return ()
             respond . redirect $ "ticket?uuid=" <> E.uuidToText 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=" <> E.uuidToText uuid
+
         ["cancel"] -> do
             reqBody <- TL.decodeUtf8 <$> Wai.strictRequestBody req
             (view, mbCancel) <- runForm req reqBody "cancel" $

lib/Zureg/Model.hs

@@ -67,12 +67,13 @@ data Event a
     | Cancel
     | Uncancel UncancelInfo
     | JoinChat JoinChatInfo
+    | MarkSpam
     deriving (Eq, Show)
 
 --------------------------------------------------------------------------------
 -- State
 
-data RegisterState = Registered | Confirmed | Cancelled | Waitlisted
+data RegisterState = Registered | Confirmed | Cancelled | Waitlisted | Spam
     deriving (Bounded, Enum, Eq, Read, Show)
 
 data Registrant a = Registrant
@@ -87,17 +88,19 @@ registrantProjection :: E.UUID -> E.Projection (Registrant a) (Event a)
 registrantProjection uuid = E.Projection
     { E.projectionSeed         = Registrant uuid Nothing Nothing Nothing False
     , E.projectionEventHandler = \registrant event -> case event of
-        Cancel     -> registrant {rState = Just Cancelled}
-        Confirm    -> case rState registrant of
-                        Just Registered -> registrant {rState = Just Confirmed}
-                        _               -> registrant
+        Cancel | Just Spam /= rState registrant ->
+            registrant {rState = Just Cancelled}
+        Confirm -> case rState registrant of
+            Just Registered -> registrant {rState = Just Confirmed}
+            _               -> registrant
         Register i a -> registrant {rInfo = Just i, rAdditionalInfo = Just a, rState = Just Registered}
         Waitlist _ -> registrant {rState = Just Waitlisted}
         PopWaitlist _ | Just Waitlisted <- rState registrant ->
             registrant {rState = Just Registered}
         Scan _ -> registrant {rScanned = True}
         Uncancel _ | Just Cancelled <- rState registrant ->
             registrant {rState = Just Registered}
+        MarkSpam -> registrant {rState = Just Spam}
         _ -> registrant
     }
 
@@ -130,3 +133,4 @@ registrantCanJoinChat = \case
     Just Registered -> True
     Just Confirmed  -> True
     Just Waitlisted -> False
+    Just Spam       -> False

lib/Zureg/Model/Csv.hs

@@ -53,6 +53,7 @@ instance ToField RegisterState where
     toField Confirmed  = toField ("Confirmed" :: String)
     toField Cancelled  = toField ("Cancelled" :: String)
     toField Waitlisted = toField ("Waitlisted" :: String)
+    toField Spam       = toField ("Spam" :: String)
 
 instance ToField Bool where
     toField True  = toField ("true" :: String)

lib/Zureg/Views.hs

@@ -130,7 +130,7 @@ ticket hackathon Registrant {..} = template
             qrimg $ T.unpack $ E.uuidToText rUuid
 
         H.div $ do
-            H.h1 $ registerState rState
+            H.h1 $ fst $ registerState rState
             whenJust rInfo $ registrantInfo
             whenJust rAdditionalInfo $ Hackathon.ticketView hackathon
 
@@ -166,13 +166,14 @@ ticket hackathon Registrant {..} = template
                 H.input H.! A.type_ "submit"
                     H.! A.value "Cancel my registration")
 
-registerState :: Maybe RegisterState -> H.Html
+registerState :: Maybe RegisterState -> (H.Html, Bool)
 registerState rs = case rs of
-    Nothing         -> "❌ Not registered"
-    Just Cancelled  -> "❌ Cancelled"
-    Just Registered -> "✅ Registered"
-    Just Confirmed  -> "✅ Confirmed"
-    Just Waitlisted -> "⌛ on the waitlist"
+    Nothing         -> ("❌ Not registered", False)
+    Just Cancelled  -> ("❌ Cancelled", False)
+    Just Registered -> ("✅ Registered", True)
+    Just Confirmed  -> ("✅ Confirmed", True)
+    Just Waitlisted -> ("⌛ on the waitlist", False)
+    Just Spam       -> ("🥫 Spam", False)
 
 registrantInfo :: RegisterInfo -> H.Html
 registrantInfo RegisterInfo {..} = H.p $ do
@@ -230,12 +231,8 @@ fileScanner =
 
 scan :: Hackathon a -> Registrant a -> H.Html
 scan hackathon registrant@Registrant {..} = H.ul $ do
-    H.li $ H.strong $ case rState of
-        Nothing         -> red "❌ Not registered"
-        Just Cancelled  -> red "❌ Cancelled"
-        Just Registered -> "✅ Registered"
-        Just Confirmed  -> "✅ Confirmed"
-        Just Waitlisted -> red "⌛ on the waitlist"
+    H.li $ H.strong $
+        let (html, ok) = registerState rState in (if ok then id else red) html
 
     H.li $ case (registrantRegisteredAt registrant, registrantToBadge registrant) of
         (_, Nothing)                        -> red "No Badge"