diff --git a/backend/src/Datarekisteri/Backend/DB/Queries.hs b/backend/src/Datarekisteri/Backend/DB/Queries.hs index 620e29e..79d08f7 100644 --- a/backend/src/Datarekisteri/Backend/DB/Queries.hs +++ b/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 diff --git a/backend/src/Datarekisteri/CLI.hs b/backend/src/Datarekisteri/CLI.hs index 3644d4d..7efad22 100644 --- a/backend/src/Datarekisteri/CLI.hs +++ b/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 - time <- currentTime - passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword - userID <- addUser $ DBUser - { dBUserRegistered = time - , dBUserToBeDeleted = Nothing - , dBUserPasswordCrypt = passwordHash - , dBUserPermissions = show addUserPermissions - , dBUserAccepted = Just time - , dBUserSeceded = Nothing - , dBUserRejected = Nothing - , dBUserMemberData = toJSON $ MemberData - { nickname = addUserNickname - , name = addUserName - , birthdate = addUserBirthdate - , homeplace = addUserHomeplace - , application = addUserApplication - , phoneNumber = addUserPhoneNumber - } - } - _ <- addEmail $ DBEmail - { dBEmailUid = toDBKey userID - , dBEmailEmail = addUserEmail - , dBEmailVerificationSecret = Nothing - } - pure () + (AddUser addUserOpts) -> addUserMain addUserOpts + GCEmails -> gcEmailsMain + +addUserMain :: AddUserOpts -> CLIM () +addUserMain AddUserOpts {..} = do + time <- currentTime + passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword + userID <- addUser $ DBUser + { dBUserRegistered = time + , dBUserToBeDeleted = Nothing + , dBUserPasswordCrypt = passwordHash + , dBUserPermissions = show addUserPermissions + , dBUserAccepted = Just time + , dBUserSeceded = Nothing + , dBUserRejected = Nothing + , dBUserMemberData = toJSON $ MemberData + { nickname = addUserNickname + , name = addUserName + , birthdate = addUserBirthdate + , homeplace = addUserHomeplace + , application = addUserApplication + , phoneNumber = addUserPhoneNumber + } + } + _ <- addEmail $ DBEmail + { 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 - { addUserNickname :: Maybe Text - , addUserName :: Text - , addUserBirthdate :: Date - , addUserHomeplace :: Text - , addUserPhoneNumber :: PhoneNumber - , addUserEmail :: Email - , addUserPermissions :: Map Scope Permission - , addUserApplication :: Text - } +data CLISubCommand = AddUser AddUserOpts + | GCEmails + +data AddUserOpts = AddUserOpts + { addUserNickname :: Maybe Text + , addUserName :: Text + , addUserBirthdate :: Date + , addUserHomeplace :: 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)