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,32 +24,41 @@ main :: IO ()
 main = do
     CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
     runCLIM optionsDBUrl $ case optionsSubCommand of
-      AddUser {..} -> do
+      (AddUser addUserOpts) -> addUserMain addUserOpts
-          time <- currentTime
+      GCEmails -> gcEmailsMain
-          passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
+
-          userID <- addUser $ DBUser
+addUserMain :: AddUserOpts -> CLIM ()
-              { dBUserRegistered = time
+addUserMain AddUserOpts {..} = do
-              , dBUserToBeDeleted = Nothing
+    time <- currentTime
-              , dBUserPasswordCrypt = passwordHash
+    passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
-              , dBUserPermissions = show addUserPermissions
+    userID <- addUser $ DBUser
-              , dBUserAccepted = Just time
+        { dBUserRegistered = time
-              , dBUserSeceded = Nothing
+        , dBUserToBeDeleted = Nothing
-              , dBUserRejected = Nothing
+        , dBUserPasswordCrypt = passwordHash
-              , dBUserMemberData = toJSON $ MemberData
+        , dBUserPermissions = show addUserPermissions
-                  { nickname = addUserNickname
+        , dBUserAccepted = Just time
-                  , name = addUserName
+        , dBUserSeceded = Nothing
-                  , birthdate = addUserBirthdate
+        , dBUserRejected = Nothing
-                  , homeplace = addUserHomeplace
+        , dBUserMemberData = toJSON $ MemberData
-                  , application = addUserApplication
+            { nickname = addUserNickname
-                  , phoneNumber = addUserPhoneNumber
+            , name = addUserName
-                  }
+            , birthdate = addUserBirthdate
-              }
+            , homeplace = addUserHomeplace
-          _ <- addEmail $ DBEmail
+            , application = addUserApplication
-              { dBEmailUid = toDBKey userID
+            , phoneNumber = addUserPhoneNumber
-              , dBEmailEmail = addUserEmail
+            }
-              , dBEmailVerificationSecret = Nothing
+        }
-              }
+    _ <- addEmail $ DBEmail
-          pure ()
+        { dBEmailUid = toDBKey userID
+        , dBEmailEmail = addUserEmail
+        , dBEmailVid = Nothing
+        }
+    pure ()
+
+gcEmailsMain :: CLIM ()
+gcEmailsMain = do
+    time <- currentTime
+    deleteExpiredEmails time
 
 cliOptions :: Parser CLIOptions
 cliOptions = CLIOptions
@@ -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,16 +91,19 @@ data CLIOptions = CLIOptions
     , optionsSubCommand :: CLISubCommand
     }
 
-data CLISubCommand = AddUser
+data CLISubCommand = AddUser AddUserOpts
-    { addUserNickname :: Maybe Text
+                   | GCEmails
-    , addUserName :: Text
+
-    , addUserBirthdate :: Date
+data AddUserOpts = AddUserOpts
-    , addUserHomeplace :: Text
+        { addUserNickname :: Maybe Text
-    , addUserPhoneNumber :: PhoneNumber
+        , addUserName :: Text
-    , addUserEmail :: Email
+        , addUserBirthdate :: Date
-    , addUserPermissions :: Map Scope Permission
+        , addUserHomeplace :: Text
-    , addUserApplication :: Text
+        , addUserPhoneNumber :: PhoneNumber
-    }
+        , addUserEmail :: Email
+        , addUserPermissions :: Map Scope Permission
+        , addUserApplication :: Text
+        }
 
 newtype CLIM a = CLIM (ReaderT String IO a)
     deriving (Functor, Applicative, Monad, MonadIO, MonadReader String)