fix: don't set user-last-authentication during ldap sync

src/Auth/Dummy.hs

@@ -1,5 +1,6 @@
 module Auth.Dummy
-  ( dummyLogin
+  ( apDummy
+  , dummyLogin
   , DummyMessage(..)
   ) where
 
@@ -32,6 +33,9 @@ dummyForm = do
     userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
     toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
 
+apDummy :: Text
+apDummy = "dummy"
+
 dummyLogin :: forall site.
               ( YesodAuth site
               , YesodPersist site
@@ -44,7 +48,7 @@ dummyLogin :: forall site.
 dummyLogin = AuthPlugin{..}
   where
     apName :: Text
-    apName = "dummy"
+    apName = apDummy
 
     apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
     apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do

src/Auth/PWHash.hs

@@ -1,5 +1,6 @@
 module Auth.PWHash
-  ( hashLogin
+  ( apHash
+  , hashLogin
   , PWHashMessage(..)
   ) where
 
@@ -39,6 +40,8 @@ hashForm = do
     <$> areq ciField (fslpI MsgPWHashIdent (mr MsgPWHashIdentPlaceholder)) Nothing
     <*> areq passwordField (fslpI MsgPWHashPassword (mr MsgPWHashPasswordPlaceholder)) Nothing
 
+apHash :: Text
+apHash = "PWHash"
 
 hashLogin :: forall site.
              ( YesodAuth site
@@ -53,7 +56,7 @@ hashLogin :: forall site.
 hashLogin pwHashAlgo = AuthPlugin{..}
   where
     apName :: Text
-    apName = "PWHash"
+    apName = apHash
 
     apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
     apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do

src/Foundation/Types.hs

@@ -1,6 +1,6 @@
 module Foundation.Types
   ( UpsertCampusUserMode(..)
-  , _UpsertCampusUser, _UpsertCampusUserDummy, _UpsertCampusUserOther
+  , _UpsertCampusUserLoginLdap, _UpsertCampusUserLoginDummy, _UpsertCampusUserLoginOther, _UpsertCampusUserLdapSync, _UpsertCampusUserGuessUser
   , _upsertCampusUserIdent
   ) where
 
@@ -8,9 +8,11 @@ import Import.NoFoundation
 
 
 data UpsertCampusUserMode
-  = UpsertCampusUser
+  = UpsertCampusUserLoginLdap
-  | UpsertCampusUserDummy { upsertCampusUserIdent :: UserIdent }
+  | UpsertCampusUserLoginDummy { upsertCampusUserIdent :: UserIdent }
-  | UpsertCampusUserOther { uspertCampusUserIdent :: UserIdent }
+  | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent }
+  | UpsertCampusUserLdapSync   { upsertCampusUserIdent :: UserIdent }
+  | UpsertCampusUserGuessUser
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 makeLenses_ ''UpsertCampusUserMode

src/Foundation/Yesod/Auth.hs

@@ -18,10 +18,11 @@ import Handler.Utils.LdapSystemFunctions
 
 import Yesod.Auth.Message
 import Auth.LDAP
+import Auth.PWHash (apHash)
+import Auth.Dummy (apDummy)
 
 import qualified Data.CaseInsensitive as CI
 import qualified Control.Monad.Catch as C (Handler(..))
-import qualified Data.List.NonEmpty as NonEmpty
 import qualified Ldap.Client as Ldap
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
@@ -55,8 +56,8 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
     uAuth = UniqueAuthentication $ CI.mk credsIdent
     upsertMode = creds ^? _upsertCampusUserMode
 
-    isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode
+    isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode
-    isOther = is (_Just . _UpsertCampusUserOther) upsertMode
+    isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode
 
     excRecovery res
       | isDummy || isOther
@@ -129,25 +130,30 @@ data CampusUserConversionException
 
 _upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
 _upsertCampusUserMode mMode cs@Creds{..}
-  | credsPlugin == "dummy"    = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent)
+  | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent)
-  | credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent)
+  | credsPlugin == apLdap  = setMode <$> mMode  UpsertCampusUserLoginLdap
-  | otherwise                 = setMode <$> mMode  UpsertCampusUser
+  | otherwise              = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent)
   where
-    setMode UpsertCampusUser
+    setMode UpsertCampusUserLoginLdap
-      = cs{ credsPlugin = "LDAP" }
+      = cs{ credsPlugin = apLdap }
-    setMode (UpsertCampusUserDummy ident)
+    setMode (UpsertCampusUserLoginDummy ident)
-      = cs{ credsPlugin = "dummy", credsIdent = CI.original ident }
+      = cs{ credsPlugin = apDummy
-    setMode (UpsertCampusUserOther ident)
+          , credsIdent  = CI.original ident
-      = cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident }
+          }
+    setMode (UpsertCampusUserLoginOther ident)
+      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
+          , credsIdent  = CI.original ident
+          }
+    setMode _ = cs
 
-    others = "PWHash" :| []
+    defaultOther = apHash
 
 upsertCampusUser :: forall m.
                     ( MonadHandler m, HandlerSite m ~ UniWorX
                     , MonadThrow m
                     )
                  => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
-upsertCampusUser plugin ldapData = do
+upsertCampusUser upsertMode ldapData = do
   now <- liftIO getCurrentTime
   UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
 
@@ -166,17 +172,18 @@ upsertCampusUser plugin ldapData = do
     userSex'            = fold [ v | (k, v) <- ldapData, k == ldapSex               ]
 
     userAuthentication
-      | is _UpsertCampusUserOther plugin
+      | is _UpsertCampusUserLoginOther upsertMode
-      = error "PWHash should only work for users that are already known"
+      = error "Non-LDAP logins should only work for users that are already known"
       | otherwise = AuthLDAP
-    userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin)
+    userLastAuthentication = guardOn isLogin now
+    isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
 
   userIdent <- if
     | [bs] <- userIdent''
     , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-    , hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin
+    , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
       -> return userIdent'
-    | Just userIdent' <- plugin ^? _upsertCampusUserIdent
+    | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
       -> return userIdent'
     | otherwise
       -> throwM CampusUserInvalidIdent
@@ -260,7 +267,7 @@ upsertCampusUser plugin ldapData = do
                   , UserSex                     =. userSex
                   , UserLastLdapSynchronisation =. Just now
                   ] ++
-                  [ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ]
+                  [ UserLastAuthentication =. Just now | isLogin ]
 
   user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate
   unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $

src/Handler/Users.hs

@@ -37,6 +37,8 @@ import qualified Data.Conduit.List as C
 
 import qualified Data.HashSet as HashSet
 
+import Auth.Dummy (apDummy)
+
 
 hijackUserForm :: Form ()
 hijackUserForm csrf = do
@@ -251,7 +253,7 @@ postUsersR = do
 hijackUser :: UserId -> Handler TypedContent
 hijackUser uid = do
   User{userIdent} <- runDB $ get404 uid
-  setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
+  setCredsRedirect $ Creds apDummy (CI.original userIdent) []
 
 postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
 postAdminHijackUserR cID = do

src/Handler/Utils/Users.hs

@@ -135,7 +135,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
             ldapPool' <- getsYesod $ view _appLdapPool
             fmap join . for ldapPool' $ \ldapPool -> do
               ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
-              for ldapData $ upsertCampusUser UpsertCampusUser
+              for ldapData $ upsertCampusUser UpsertCampusUserGuessUser
 
       let
         getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation

src/Jobs/Handler/SynchroniseLdap.hs

@@ -49,7 +49,7 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
 
         reTestAfter <- getsYesod $ view _appLdapReTestFailover
         ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user
-        void . lift $ upsertCampusUser UpsertCampusUser ldapAttrs
+        void . lift $ upsertCampusUser (UpsertCampusUserLdapSync userIdent) ldapAttrs
     Nothing ->
       throwM SynchroniseLdapNoLdap
   where

src/Jobs/HealthReport.hs

@@ -106,7 +106,7 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea
         Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) ->
           let hCampusExc :: CampusUserException -> Handler (Sum Integer)
               hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err)
-           in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
+           in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds apLdap adminIdent [])
         return $ numResolved % numAdmins
     _other -> return Nothing