Add CLI command to GC expired emails

backend/src/Datarekisteri/Backend/DB/Queries.hs

@@ -132,6 +132,12 @@ addEmailVerification secret = do
         , dBEmailVerificationExpires = expires
         }
 
+deleteExpiredEmails :: MonadDB m => Time -> m ()
+deleteExpiredEmails time = runQuery $ delete $ do
+    verification <- from $ table @DBEmailVerification
+    where_ $ verification ^. DBEmailVerificationExpires <=. val time
+
+
 updateEmail :: (MonadDB m, MonadTime m) => UserID -> Email -> Text -> m (Key DBEmail)
 updateEmail user email secret = getExpireTime >>= \expires -> runQuery $ do
     delete $ do

backend/src/Datarekisteri/CLI.hs

@@ -24,7 +24,11 @@ main :: IO ()
 main = do
     CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
     runCLIM optionsDBUrl $ case optionsSubCommand of
-      AddUser {..} -> do
+      (AddUser addUserOpts) -> addUserMain addUserOpts
+      GCEmails -> gcEmailsMain
+
+addUserMain :: AddUserOpts -> CLIM ()
+addUserMain AddUserOpts {..} = do
     time <- currentTime
     passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
     userID <- addUser $ DBUser
@@ -47,10 +51,15 @@ main = do
     _ <- addEmail $ DBEmail
         { dBEmailUid = toDBKey userID
         , dBEmailEmail = addUserEmail
-              , dBEmailVerificationSecret = Nothing
+        , dBEmailVid = Nothing
         }
     pure ()
 
+gcEmailsMain :: CLIM ()
+gcEmailsMain = do
+    time <- currentTime
+    deleteExpiredEmails time
+
 cliOptions :: Parser CLIOptions
 cliOptions = CLIOptions
     <$> strOption (short 'u' <> long "db-url" <> metavar "URL" <> value "postgres:///datarekisteri-backend")
@@ -59,9 +68,10 @@ cliOptions = CLIOptions
 cliCommandParser :: Parser CLISubCommand
 cliCommandParser = hsubparser
     $ command "add-user" (info addUserCommand (progDesc "Add a user to datarekisteri"))
+    <> command "gc-expired-emails" (info (pure GCEmails) (progDesc "Delete emails that have not been verified in time."))
 
 addUserCommand :: Parser CLISubCommand
-addUserCommand = AddUser
+addUserCommand = fmap AddUser $ AddUserOpts
     <$> optional (strOption (long "nickname" <> metavar "NAME"))
     <*> strOption (long "name" <> metavar "NAME")
     <*> option (maybeReader $ toDate . toText) (long "birthdate" <> metavar "DATE" <> help "The user's birthdate, YYYY-MM-DD")
@@ -81,7 +91,10 @@ data CLIOptions = CLIOptions
     , optionsSubCommand :: CLISubCommand
     }
 
-data CLISubCommand = AddUser
+data CLISubCommand = AddUser AddUserOpts
+                   | GCEmails
+
+data AddUserOpts = AddUserOpts
         { addUserNickname :: Maybe Text
         , addUserName :: Text
         , addUserBirthdate :: Date