Keep track of userLastAuthentication

messages/uniworx/de.msg

@@ -253,8 +253,10 @@ Theme: Oberflächen Design
 Favoriten: Anzahl gespeicherter Favoriten
 Plugin: Plugin
 Ident: Identifikation
+LastLogin: Letzter Login
 Settings: Individuelle Benutzereinstellungen
 SettingsUpdate: Einstellungen wurden gespeichert.
+Never: Nie
 
 MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
 

models/users

@@ -1,6 +1,7 @@
 User json
     ident          (CI Text)
     authentication AuthenticationMode
+    lastAuthentication UTCTime Maybe
     matrikelnummer Text Maybe
     email          (CI Text)
     displayName    Text

src/Foundation.hs

@@ -80,8 +80,6 @@ import Data.Bits (Bits(zeroBits))
 
 import Network.Wai.Parse (lbsBackEnd)
 
-import qualified Data.UUID.V4 as UUID
-
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
@@ -1916,6 +1914,8 @@ instance YesodAuth UniWorX where
         $(widgetFile "login")
 
     authenticate Creds{..} = runDB $ do
+      now <- liftIO getCurrentTime
+
       let
         userIdent = CI.mk credsIdent
         uAuth = UniqueAuthentication userIdent
@@ -1943,7 +1943,12 @@ instance YesodAuth UniWorX where
                   return $ ServerError "LDAP lookup failed"
             ]
 
-        acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
+        acceptExisting = do
+          res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
+          case res of
+            Authenticated uid
+              | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
+            _other -> return res
 
       $logDebugS "auth" $ tshow Creds{..}
       UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
@@ -1962,6 +1967,7 @@ instance YesodAuth UniWorX where
             userAuthentication
               | isPWHash  = error "PWHash should only work for users that are already known"
               | otherwise = AuthLDAP
+            userLastAuthentication = now <$ guard (not isDummy)
 
           userEmail <- if
             | Just [bs] <- userEmail'
@@ -2002,15 +2008,15 @@ instance YesodAuth UniWorX where
               , userMailLanguages        = def
               , ..
               }
-            userUpdate =  [ UserMatrikelnummer =. userMatrikelnummer
-                          , UserDisplayName    =. userDisplayName
-                          , UserSurname        =. userSurname
-                          , UserEmail          =. userEmail
-                          ]
+            userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
+                          , UserDisplayName        =. userDisplayName
+                          , UserSurname            =. userSurname
+                          , UserEmail              =. userEmail
+                          ] ++
+                          [ UserLastAuthentication =. Just now | not isDummy ]
 
           userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
-          studyTermCandidateIncidence <- liftIO UUID.nextRandom
-          now <- liftIO getCurrentTime
+          studyTermCandidateIncidence <- liftIO getRandom
 
           let
             userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now

src/Handler/Course.hs

@@ -302,8 +302,8 @@ registerForm registered msecret extra = do
   (msecretRes', msecretView) <- case msecret of
     (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
     _ -> return (Nothing,Nothing)
-  (sfRes' , sfView) <- if not registered then return (Nothing,Nothing) else
-                       mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing
+  (_msfRes, msfView) <- if not registered then return (Nothing, Nothing) else
+                        bimap Just Just <$> mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing
   (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
 
   let widget = $(widgetFile "widgets/register-form/register-form")

src/Handler/Profile.hs

@@ -248,6 +248,8 @@ getProfileDataR = do
   let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
   let tutorialTable    = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
 
+  lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication
+
   -- Delete Button
   (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
   defaultLayout $ do

src/Import/NoFoundation.hs

@@ -61,6 +61,9 @@ import Database.Esqueleto.Instances as Import ()
 import Database.Persist.Sql.Instances as Import ()
 import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
 
+import System.Random as Import (Random)
+import Control.Monad.Random.Class as Import (MonadRandom(..))
+
 
 import Control.Monad.Trans.RWS (RWST)
 

templates/profileData.hamlet

@@ -10,6 +10,12 @@
       <dd .deflist__dd> #{display userEmail}
       <dt .deflist__dt> _{MsgIdent}
       <dd .deflist__dd> #{display userIdent}
+      <dt .deflist__dt> _{MsgLastLogin}
+      <dd .deflist__dd>
+        $maybe llogin <- lastLogin 
+          #{llogin}
+        $nothing
+          _{MsgNever}
     $if not $ null admin_rights
       <dt .deflist__dt> Administrator
       <dd .deflist__dd>

templates/widgets/register-form/register-form.hamlet

@@ -4,5 +4,7 @@ $# Maybe display textField for passcode
 $maybe secretView <- msecretView
   ^{fvInput secretView}
 $# Ask for associated primary field uf study, unless registered
+$maybe sfView <- msfView
+  ^{fvInput sfView}
 $# Always display register/deregister button
 ^{fvInput btnView}