From 7c2faa7faaca26b38d3fde7261d1f2b96eef482d Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sun, 1 Apr 2018 03:02:35 +0000
Subject: [PATCH] Email tokens expire within 1 day

---
 config/models            | 16 +++++++++-------
 src/Vervis/Foundation.hs | 13 +++++++++----
 src/Vervis/Migration.hs  | 13 +++++++++++++
 src/Vervis/Model.hs      | 16 +++++++++-------
 vervis.cabal             |  2 ++
 5 files changed, 42 insertions(+), 18 deletions(-)

diff --git a/config/models b/config/models
index a87fdfd..883722e 100644
--- a/config/models
+++ b/config/models
@@ -24,13 +24,15 @@ Sharer
     UniqueSharer ident
 
 Person
-    ident              SharerId
-    login              Text
-    passphraseHash     ByteString
-    email              EmailAddress
-    verified           Bool
-    verifiedKey        Text
-    resetPassphraseKey Text
+    ident               SharerId
+    login               Text
+    passphraseHash      ByteString
+    email               EmailAddress
+    verified            Bool
+    verifiedKey         Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
 
     UniquePersonIdent ident
     UniquePersonLogin login
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index be70e82..4d7a31d 100644
--- a/src/Vervis/Foundation.hs
+++ b/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'
-    unregisteredLogin u = do
+    emailVerifyKeyDuration _     = Just $ fromTimeUnit (1 :: Day)
+    passphraseResetKeyDuration _ = Just $ fromTimeUnit (1 :: Day)
+    runAccountDB                 = unAccountPersistDB'
+    unregisteredLogin u          = do
         lift $ setUnverifiedCreds True $ Creds "account" (username u) []
         return mempty
 
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index b62ac30..e8dbca8 100644
--- a/src/Vervis/Migration.hs
+++ b/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))
diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs
index 913ce50..70996e3 100644
--- a/src/Vervis/Model.hs
+++ b/src/Vervis/Model.hs
@@ -39,13 +39,15 @@ import Vervis.Model.Workflow
 makeEntities $(modelFile "config/models")
 
 instance PersistUserCredentials Person where
-    userUsernameF       = PersonLogin
-    userPasswordHashF   = PersonPassphraseHash
-    userEmailF          = PersonEmail
-    userEmailVerifiedF  = PersonVerified
-    userEmailVerifyKeyF = PersonVerifiedKey
-    userResetPwdKeyF    = PersonResetPassphraseKey
-    uniqueUsername      = UniquePersonLogin
+    userUsernameF              = PersonLogin
+    userPasswordHashF          = PersonPassphraseHash
+    userEmailF                 = PersonEmail
+    userEmailVerifiedF         = PersonVerified
+    userEmailVerifyKeyF        = PersonVerifiedKey
+    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
     -- implementation, where we can make sure to create a 'Sharer' and then a
diff --git a/vervis.cabal b/vervis.cabal
index 8977225..8f40681 100644
--- a/vervis.cabal
+++ b/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