chore(auth): migrate password hash back to User model

models/auth.model

@@ -39,10 +39,3 @@ ExternalAuth
     lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source? -- TODO rethink
     UniqueExternalAuth user source        -- At most one entry of this user per source
     deriving Show Eq Ord Generic
-
--- | FraDrive-specific user authentication data, internal logins have precedence over external authentication
-InternalAuth
-    user      UserId
-    hash      Text                         -- Hashed password
-    UniqueInternalAuth user
-    deriving Show Eq Ord Generic

models/users.model

@@ -14,6 +14,8 @@
 
 User json    -- Each Uni2work user has a corresponding row in this table; created upon first login.
     ident          UserIdent                -- Case-insensitive user-identifier
+    passwordHash   Text Maybe        -- If specified, allows the user to login with credentials independently of external authentication
+    lastLogin      UTCTime Maybe     -- When did the user last authenticate?
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail
@@ -47,7 +49,6 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     prefersPostal         Bool default=false    -- user prefers letters by post instead of email
     examOfficeGetSynced   Bool default=true     -- whether synced status should be displayed for exam results by default
     examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
-    lastLogin             UTCTime Maybe         -- When did the user last authenticate?
     UniqueAuthentication  ident                 -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory

src/Auth/PWHash.hs

@@ -68,12 +68,13 @@ hashLogin pwHashAlgo = AuthPlugin{..}
       tp <- getRouteToParent
 
       resp <- formResultMaybe loginRes $ \HashLogin{..} -> Just <$> do
-        auth :: Maybe (Entity InternalAuth) <- liftHandler . runDB . getBy $ UniqueInternalAuth hashIdent
+        user :: Maybe (Entity User) <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
-        case auth of
+        case user of
-          Just (Entity _ InternalAuth{..})
+          Just (Entity _ User{userIdent,userPasswordHash})
-            | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 internalAuthHash) -> do -- (2^) is magic.
+            | Just pwHash <- userPasswordHash
+            , verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 pwHash) -> do -- (2^) is magic.
                 observeLoginOutcome apName LoginSuccessful
-                setCredsRedirect $ Creds apName (CI.original internalAuthUser) []
+                setCredsRedirect $ Creds apName (CI.original userIdent) []
           other -> do
             $logDebugS apName $ tshow other
             observeLoginOutcome apName LoginInvalidCredentials

src/Foundation/Authorization.hs

@@ -1531,11 +1531,10 @@ tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return retu
     CourseR _ _ _ (CUserR cID) -> return cID
     _other -> throwError =<< $unsupportedAuthPredicate AuthIsExternal route
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
+  let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents
   maybeTMExceptT (unauthorizedI MsgUnauthorizedExternal) $ do
-    User{..} <- MaybeT $ get referencedUser'
+    Entity uid _ <- MaybeT $ getEntity referencedUser'
-    let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents
+    guardM . lift $ exists [ ExternalAuthUser ==. uid, ExternalAuthSource <-. availableSources ]
-    guardM . lift $ exists [ ExternalAuthIdent ==. userIdent, ExternalAuthSource <-. availableSources ]
-    guardM . lift . fmap not . existsBy $ UniqueInternalAuth userIdent
   return Authorized
 tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
@@ -1549,7 +1548,7 @@ tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return retu
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
   maybeTMExceptT (unauthorizedI MsgUnauthorizedInternal) $ do
     User{..} <- MaybeT $ get referencedUser'
-    guardM . lift . existsBy $ UniqueInternalAuth userIdent
+    guard $ is _Just userPasswordHash
   return Authorized
 tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do

src/Foundation/Navigation.hs

@@ -1221,8 +1221,8 @@ pageActions (AdminUserR cID) = return
       , navRoute       = UserPasswordR cID
       , navAccess' = NavAccessDB $ do
           uid <- decrypt cID
-          User{userIdent} <- get404 uid
+          User{userPasswordHash} <- get404 uid
-          existsBy $ UniqueInternalAuth userIdent
+          return $ is _Just userPasswordHash
       , navType        = NavTypeLink { navModal = True }
       , navQuick'      = mempty
       , navForceActive = False

src/Foundation/Yesod/Auth.hs

@@ -183,7 +183,7 @@ ldapLookupAndUpsert :: forall m.
                        , MonadUnliftIO m
                        )
                     => Text
-                    -> SqlPersistT m (Entity UserAuth)
+                    -> SqlPersistT m (Entity User)
 ldapLookupAndUpsert ident = 
   getsYesod (view _appLdapPool) >>= \case 
     Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
@@ -201,8 +201,8 @@ upsertUser :: forall m.
                   )
                => UpsertUserMode
                -> UpsertUserData
-               -> SqlPersistT m (Entity UserAuth)
+               -> SqlPersistT m (Entity User)
-upsertUser upsertMode upsertData = do
+upsertUser _upsertMode upsertData = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
@@ -211,9 +211,9 @@ upsertUser upsertMode upsertData = do
 
   oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] []
 
-  _user@(Entity userId userRec) <- case oldUsers of
+  user@(Entity userId userRec) <- case oldUsers of
     [oldUserId] -> updateGetEntity oldUserId userUpdate
-    _other      -> upsertBy (UniqueUser (newUser ^. _userIdent)) newUser userUpdate
+    _other      -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
 
   -- sets display name
   -- TODO: use display name from external source, if possible
@@ -252,15 +252,7 @@ upsertUser upsertMode upsertData = do
     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
 
-  let (userAuthLastLogin, userAuthLastSync) = case upsertMode of
+  return user
-        UpsertUserSync{}      -> (Nothing , Just now)
-        UpsertUserGuessUser{} -> (Nothing , Nothing )
-        _other                -> (Just now, Nothing )
-  userAuth <- upsertBy (UniqueAuthentication $ newUser ^. _userIdent) UserAuth{ userAuthIdent = newUser ^. _userIdent, ..} $
-    [ UserAuthLastLogin =. Just lastLogin | lastLogin <- maybeToList userAuthLastLogin ] ++
-    [ UserAuthLastSync  =. Just lastSync  | lastSync  <- maybeToList userAuthLastSync  ]
-
-  return userAuth
 
 -- | Upsert User DB according to given Azure data (does not query Azure itself)
 -- upsertAzureUser :: forall m.
@@ -396,6 +388,8 @@ decodeUser now UserDefaultConf{..} upsertData = do
         , userPostLastUpdate        =  Nothing
         , userPinPassword           =  Nothing -- must be derived via AVS
         , userPrefersPostal         =  userDefaultPrefersPostal
+        , userPasswordHash          =  Nothing
+        , userLastLogin             =  Nothing
         , ..
         }
       userUpdate =