Email tokens expire within 1 day

config/models

@@ -30,7 +30,9 @@ Person
     email               EmailAddress
     verified            Bool
     verifiedKey         Text
-    resetPassphraseKey Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
 
     UniquePersonIdent ident
     UniquePersonLogin login

src/Vervis/Foundation.hs

@@ -19,6 +19,8 @@ import Prelude (init, last)
 
 import Control.Monad.Logger (logWarn)
 import Control.Monad.Trans.Maybe
+import Data.Time.Interval (fromTimeUnit)
+import Data.Time.Units (Day)
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Shakespeare.Text (textFile)
 import Text.Hamlet          (hamletFile)
@@ -41,7 +43,7 @@ import Data.Text as T (pack, intercalate, concat)
 --import qualified Data.Text.Encoding as TE
 
 import Text.Jasmine.Local (discardm)
-import Vervis.Import.NoFoundation hiding (last)
+import Vervis.Import.NoFoundation hiding (Day, last)
 import Vervis.Model.Group
 import Vervis.Model.Ident
 import Vervis.Model.Role
@@ -458,7 +460,8 @@ instance AccountDB AccountPersistDB' where
                 mr <- getMessageRender
                 return $ Left $ mr $ MsgUsernameExists name
             Right sid -> do
-                let person = Person sid name pwd email False key ""
+                let defTime = UTCTime (ModifiedJulianDay 0) 0
+                    person = Person sid name pwd email False key now "" defTime
                 pid <- insert person
                 return $ Right $ Entity pid person
 
@@ -493,6 +496,8 @@ instance YesodAuthVerify App where
     verificationRoute _ = ResendVerifyEmailR
 
 instance YesodAuthAccount AccountPersistDB' App where
+    emailVerifyKeyDuration _     = Just $ fromTimeUnit (1 :: Day)
+    passphraseResetKeyDuration _ = Just $ fromTimeUnit (1 :: Day)
     runAccountDB                 = unAccountPersistDB'
     unregisteredLogin u          = do
         lift $ setUnverifiedCreds True $ Creds "account" (username u) []

src/Vervis/Migration.hs

@@ -29,6 +29,7 @@ import Data.Foldable (traverse_, for_)
 import Data.Maybe (fromMaybe, listToMaybe)
 import Data.Proxy
 import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
 import Database.Persist
 import Database.Persist.BackendDataType (backendDataType)
 import Database.Persist.Migration
@@ -125,6 +126,18 @@ changes =
         }
       -- 17
     , renameField "Person" "hash" "passphraseHash"
+      -- 18
+    , renameField "Person" "resetPassphraseKey" "resetPassKey"
+      -- 19
+    , addField "Person" (Just "'1970-01-01 00:00:00'") $ Field
+        "verifiedKeyCreated"
+        (FTPrim $ backendDataType (Proxy :: Proxy UTCTime))
+        FieldRequired
+      -- 20
+    , addField "Person" (Just "'1970-01-01 00:00:00'") $ Field
+        "resetPassKeyCreated"
+        (FTPrim $ backendDataType (Proxy :: Proxy UTCTime))
+        FieldRequired
     ]
 
 migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

src/Vervis/Model.hs

@@ -44,7 +44,9 @@ instance PersistUserCredentials Person where
     userEmailF                 = PersonEmail
     userEmailVerifiedF         = PersonVerified
     userEmailVerifyKeyF        = PersonVerifiedKey
-    userResetPwdKeyF    = PersonResetPassphraseKey
+    userEmailVerifyKeyCreatedF = Just PersonVerifiedKeyCreated
+    userResetPwdKeyF           = PersonResetPassKey
+    userResetPwdKeyCreatedF    = Just PersonResetPassKeyCreated
     uniqueUsername             = UniquePersonLogin
     -- 'Person' contains a sharer ID, so we can't let yesod-auth-account use
     -- 'userCreate' to create a new user. Instead, override the default

vervis.cabal

@@ -298,6 +298,8 @@ library
                      , template-haskell
                      , text
                      , time
+                     , time-interval
+                     , time-units
                      , transformers
                        -- probably should be replaced with lenses once I learn
                      , tuple