Email tokens expire within 1 day

config/models

@@ -24,13 +24,15 @@ Sharer
     UniqueSharer ident
 
 Person
-    ident              SharerId
+    ident               SharerId
-    login              Text
+    login               Text
-    passphraseHash     ByteString
+    passphraseHash      ByteString
-    email              EmailAddress
+    email               EmailAddress
-    verified           Bool
+    verified            Bool
-    verifiedKey        Text
+    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,8 +496,10 @@ instance YesodAuthVerify App where
     verificationRoute _ = ResendVerifyEmailR
 
 instance YesodAuthAccount AccountPersistDB' App where
-    runAccountDB        = unAccountPersistDB'
+    emailVerifyKeyDuration _     = Just $ fromTimeUnit (1 :: Day)
-    unregisteredLogin u = do
+    passphraseResetKeyDuration _ = Just $ fromTimeUnit (1 :: Day)
+    runAccountDB                 = unAccountPersistDB'
+    unregisteredLogin u          = do
         lift $ setUnverifiedCreds True $ Creds "account" (username u) []
         return mempty
 

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

@@ -39,13 +39,15 @@ import Vervis.Model.Workflow
 makeEntities $(modelFile "config/models")
 
 instance PersistUserCredentials Person where
-    userUsernameF       = PersonLogin
+    userUsernameF              = PersonLogin
-    userPasswordHashF   = PersonPassphraseHash
+    userPasswordHashF          = PersonPassphraseHash
-    userEmailF          = PersonEmail
+    userEmailF                 = PersonEmail
-    userEmailVerifiedF  = PersonVerified
+    userEmailVerifiedF         = PersonVerified
-    userEmailVerifyKeyF = PersonVerifiedKey
+    userEmailVerifyKeyF        = PersonVerifiedKey
-    userResetPwdKeyF    = PersonResetPassphraseKey
+    userEmailVerifyKeyCreatedF = Just PersonVerifiedKeyCreated
-    uniqueUsername      = UniquePersonLogin
+    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
     -- implementation, where we can make sure to create a 'Sharer' and then a

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