chore(foundation): loosen tight ldap<>failover coupling, move campusUser to ldapUser

src/Foundation/Yesod/Auth.hs

@@ -1,13 +1,12 @@
--- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Foundation.Yesod.Auth
   ( authenticate
-  , oAuthenticate
+  -- , ldapLookupAndUpsert
-  , ldapLookupAndUpsert
+  , upsertLdapUser, upsertAzureUser
-  , upsertCampusUser
+  , decodeLdapUserTest, decodeAzureUserTest
-  , decodeUserTest
   , CampusUserConversionException(..)
   , campusUserFailoverMode, updateUserLanguage
   ) where
@@ -37,19 +36,8 @@ import qualified Data.Text.Encoding as Text
 import qualified Data.ByteString as ByteString
 import qualified Data.Set as Set
 import qualified Data.Map as Map
--- import qualified Data.Conduit.Combinators as C
+import qualified Data.List.PointedList as PointedList
-
+import qualified Data.UUID as UUID
--- import qualified Data.List as List ((\\))
-
--- import qualified Data.UUID as UUID
--- import Data.ByteArray (convert)
--- import Crypto.Hash (SHAKE128)
--- import qualified Data.Binary as Binary
-
--- import qualified Database.Esqueleto.Legacy as E
--- import qualified Database.Esqueleto.Utils as E
-
--- import Crypto.Hash.Conduit (sinkHash)
 
 
 authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
@@ -58,15 +46,16 @@ authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
                 )
              => Creds UniWorX -> m (AuthenticationResult UniWorX)
 authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
-  $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m"
+  $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
+
   now <- liftIO getCurrentTime
 
   let
     uAuth = UniqueAuthentication $ CI.mk credsIdent
-    upsertMode = creds ^? _upsertCampusUserMode
+    upsertMode = creds ^? _upsertUserMode
 
-    isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode
+    isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
-    isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode
+    isOther = is (_Just . _UpsertUserLoginOther) upsertMode
 
     excRecovery res
       | isDummy || isOther
@@ -82,17 +71,17 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
     excHandlers =
       [ C.Handler $ \case
           CampusUserNoResult -> do
-            $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
+            $logWarnS "Auth" $ "User lookup failed after successful login for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
           CampusUserAmbiguous -> do
-            $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
+            $logWarnS "Auth" $ "Multiple auth results for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
           err -> do
-            $logErrorS "LDAP" $ tshow err
+            $logErrorS "Auth" $ tshow err
             mr <- getMessageRender
             excRecovery . ServerError $ mr MsgInternalLdapError
       , C.Handler $ \(cExc :: CampusUserConversionException) -> do
-          $logErrorS "LDAP" $ tshow cExc
+          $logErrorS "Auth" $ tshow cExc
           mr <- getMessageRender
           excRecovery . ServerError $ mr cExc
       ]
@@ -111,91 +100,26 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
         _other -> return res
 
   $logDebugS "auth" $ tshow Creds{..}
-  ldapPool' <- getsYesod $ view _appLdapPool
 
-  flip catches excHandlers $ case ldapPool' of
+  userdbConf <- getsYesod $ view _appUserDbConf
-    Just ldapPool
+  flip catches excHandlers $ case userdbConf of
+    UserDbSingleSource (UserDbAzureAdV2 azureConf)
       | Just upsertMode' <- upsertMode -> do
-          ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
+          azureData <- oauth2User azureConf Creds{..}
-          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
+          $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData
-          Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
+          Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData
+    UserDbSingleSource (UserDbLdap _)
+      | Just upsertMode' <- upsertMode -> do
+          -- TODO WIP
+          ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
+          ldapConf <- mkFailover $ PointedList.singleton ldapPool
+          ldapData <- ldapUser ldapConf FailoverNone Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..}
+          $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow ldapData
+          Authenticated . entityKey <$> upsertLdapUser upsertMode' ldapData
     _other
       -> acceptExisting
 
 
--- | Authentication via AzureADv2 / OAuth 2
-oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
-                 , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
-                 , YesodAuth UniWorX, UserId ~ AuthId UniWorX
-                 )
-              => Creds UniWorX -> m (AuthenticationResult UniWorX)
-oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
-  $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m"
-  now <- liftIO getCurrentTime
-
-  let
-    uAuth = UniqueAuthentication $ CI.mk credsIdent
-    upsertMode = creds ^? _upsertAzureUserMode
-
-    isDummy = is (_Just . _UpsertAzureUserLoginDummy) upsertMode -- mock server 
-    isOther = is (_Just . _UpsertAzureUserLoginOther) upsertMode
-
-    excRecovery res
-      | isDummy || isOther
-      = do
-          case res of
-            UserError   err -> addMessageI Error   err
-            ServerError err -> addMessage  Error $ toHtml err
-            _other          -> return ()
-          acceptExisting
-      | otherwise
-      = return res
-
-    excHandlers =
-      [ C.Handler $ \case
-          AzureUserNoResult -> do
-            $logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent
-            excRecovery . UserError $ IdentifierNotFound credsIdent
-          AzureUserAmbiguous -> do
-            $logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent
-            excRecovery . UserError $ IdentifierNotFound credsIdent
-          err -> do
-            $logErrorS "OAuth" $ tshow err
-            mr <- getMessageRender
-            excRecovery . ServerError $ mr MsgInternalLdapError -- TODO where does this come from?
-      , C.Handler $ \(cExc :: CampusUserConversionException) -> do -- TODO new exception type or not?
-          $logErrorS "OAuth" $ tshow cExc
-          mr <- getMessageRender
-          excRecovery . ServerError $ mr cExc
-      ]
-
-    acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
-    acceptExisting = do
-      res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
-      case res of
-        Authenticated uid
-          -> associateUserSchoolsByTerms uid
-        _other
-          -> return ()
-      case res of
-        Authenticated uid
-          | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
-        _other -> return res
-
-  $logDebugS "oauth" $ tshow creds
-  -- TODO If user not in DB then put
-  pool <- getsYesod $ view _appLdapPool
-  flip catches excHandlers $ case pool of
-    Just ldapPool
-      | Just upsertMode' <- upsertMode -> do
-          ldapData <- campusUser ldapPool campusUserFailoverMode creds
-          $logDebugS "OAuth" $ "Successful LDAP lookup of Azure user: " <> tshow ldapData
-          Authenticated . entityKey <$> upsertAzureUser upsertMode' ldapData
-    _other
-      -> acceptExisting
-
-
-
 data CampusUserConversionException
   = CampusUserInvalidIdent
   | CampusUserInvalidEmail
@@ -209,19 +133,23 @@ data CampusUserConversionException
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (Exception)
 
-_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
+
-_upsertCampusUserMode mMode cs@Creds{..}
+_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode
-  | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent)
+_upsertUserMode mMode cs@Creds{..}
-  | credsPlugin == apLdap  = setMode <$> mMode  UpsertCampusUserLoginLdap
+  | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent)
-  | otherwise              = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent)
+  | credsPlugin == apAzure = setMode <$> mMode  UpsertUserLoginAzure
+  | credsPlugin == apLdap  = setMode <$> mMode  UpsertUserLoginLdap
+  | otherwise              = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
   where
-    setMode UpsertCampusUserLoginLdap
+    setMode UpsertUserLoginAzure
+      = cs{ credsPlugin = apAzure }
+    setMode UpsertUserLoginLdap
       = cs{ credsPlugin = apLdap }
-    setMode (UpsertCampusUserLoginDummy ident)
+    setMode (UpsertUserLoginDummy ident)
       = cs{ credsPlugin = apDummy
           , credsIdent  = CI.original ident
           }
-    setMode (UpsertCampusUserLoginOther ident)
+    setMode (UpsertUserLoginOther ident)
       = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
           , credsIdent  = CI.original ident
           }
@@ -230,73 +158,28 @@ _upsertCampusUserMode mMode cs@Creds{..}
     defaultOther = apHash
 
 
-_upsertAzureUserMode :: Traversal' (Creds UniWorX) UpsertAzureUserMode
+-- TODO: rewrite
-_upsertAzureUserMode mMode cs@Creds{..}
+-- ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)                    
-  | credsPlugin == mockPluginName = setMode <$> mMode (UpsertAzureUserLoginDummy $ CI.mk credsIdent)
+-- ldapLookupAndUpsert ident = 
-  | credsPlugin == "azureadv2"    = setMode <$> mMode  UpsertAzureUserLoginOAuth
+--   getsYesod (view _appLdapPool) >>= \case 
-  | otherwise                     = setMode <$> mMode (UpsertAzureUserLoginOther $ CI.mk credsIdent)
+--     Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
-  where
+--     Just ldapPool ->
-    setMode UpsertAzureUserLoginOAuth
+--       campusUser'' ldapPool campusUserFailoverMode ident >>= \case
-      = cs{ credsPlugin = "azureadv2" }
+--         Nothing -> throwM CampusUserNoResult
-    setMode (UpsertAzureUserLoginDummy ident)
+--         Just ldapResponse -> upsertLdapUser UpsertCampusUserGuessUser ldapResponse
-      = cs{ credsPlugin = mockPluginName
-          , credsIdent  = CI.original ident
-          }
-    setMode (UpsertAzureUserLoginOther ident)
-      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= mockPluginName && credsPlugin /= "azureadv2")
-          , credsIdent  = CI.original ident
-          }
-    setMode _ = cs
 
-    defaultOther = apHash
-
-
-
-ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)                    
-ldapLookupAndUpsert ident = 
-  getsYesod (view _appLdapPool) >>= \case 
-    Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
-    Just ldapPool ->
-      campusUser'' ldapPool campusUserFailoverMode ident >>= \case
-        Nothing -> throwM CampusUserNoResult
-        Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse
-
-
-upsertAzureUser :: forall m.
-                   ( MonadHandler m, HandlerSite m ~ UniWorX
-                   , MonadCatch m
-                   )
-                => UpsertAzureUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -- TODO UpsertAzureUserMode is probably redundant
-upsertAzureUser upsertMode = upsertCampusUser (toCampus upsertMode)
-  where
-    toCampus :: UpsertAzureUserMode -> UpsertCampusUserMode
-    toCampus  UpsertAzureUserLoginOAuth    = UpsertCampusUserLoginLdap
-    toCampus (UpsertAzureUserLoginDummy u) = UpsertCampusUserLoginDummy u
-    toCampus (UpsertAzureUserLoginOther u) = UpsertCampusUserLoginOther u
-    toCampus (UpsertAzureUserOAuthSync  u) = UpsertCampusUserLdapSync u
-    toCampus  UpsertAzureUserGuessUser     = UpsertCampusUserGuessUser
-
-
-{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP!
-upsertCampusUserByCn :: forall m.
-                        ( MonadHandler m, HandlerSite m ~ UniWorX
-                        , MonadThrow m
-                        )
-                      => Text -> SqlPersistT m (Entity User)
-upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])]
--}
 
 -- | Upsert User DB according to given LDAP data (does not query LDAP itself)
-upsertCampusUser :: forall m.
+upsertLdapUser :: forall m.
                     ( MonadHandler m, HandlerSite m ~ UniWorX
                     , MonadCatch m
                     )
-                 => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
+                 => UpsertUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
-upsertCampusUser upsertMode ldapData = do
+upsertLdapUser upsertMode ldapData = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
-  (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
+  (newUser,userUpdate) <- decodeLdapUser now userDefaultConf upsertMode ldapData
   --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
 
   oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
@@ -333,17 +216,72 @@ upsertCampusUser upsertMode ldapData = do
 
   return user
 
-decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
+-- | Upsert User DB according to given Azure data (does not query Azure itself)
+-- TODO: maybe merge with upsertLdapUser
+upsertAzureUser :: forall m.
+                    ( MonadHandler m, HandlerSite m ~ UniWorX
+                    , MonadCatch m
+                    )
+                 => UpsertUserMode -> [(Text, [ByteString])] -> SqlPersistT m (Entity User)
+upsertAzureUser upsertMode azureData = do
+  now <- liftIO getCurrentTime
+  userDefaultConf <- getsYesod $ view _appUserDefaults
+
+  (newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData
+  --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
+
+  oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] []
+
+  user@(Entity userId userRec) <- case oldUsers of
+    Just [oldUserId] -> updateGetEntity oldUserId userUpdate
+    _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
+  unless (validDisplayName (newUser ^. _userTitle)
+                           (newUser ^. _userFirstName)
+                           (newUser ^. _userSurname)
+                           (userRec ^. _userDisplayName)) $
+    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
+  when (validEmail' (userRec ^. _userEmail)) $ do
+    let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
+              ++ [ UserAuthentication =. AuthAzure                | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
+    unless (null emUps) $ update userId emUps
+    -- Attempt to update ident, too:
+    unless (validEmail' (userRec ^. _userIdent)) $
+      void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
+
+  let
+    userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
+    userSystemFunctions' = do
+      (_k, v) <- azureData
+      -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way?
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      assertM' (not . Text.null) $ Text.strip str
+
+  iforM_ userSystemFunctions $ \func preset -> do
+    memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
+    if | preset -> void $ upsert (UserSystemFunction userId func False False) []
+       | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
+
+  return user
+
+decodeLdapUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
         => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
-decodeUserTest mbIdent ldapData = do
+decodeLdapUserTest mbIdent ldapData = do
     now <- liftIO getCurrentTime
     userDefaultConf <- getsYesod $ view _appUserDefaults
-    let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
+    let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent
-    try $ decodeUser now userDefaultConf mode ldapData
+    try $ decodeLdapUser now userDefaultConf mode ldapData
 
+decodeAzureUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
+        => Maybe UserIdent -> [(Text, [ByteString])] -> m (Either CampusUserConversionException (User, [Update User]))
+decodeAzureUserTest mbIdent azureData = do
+    now <- liftIO getCurrentTime
+    userDefaultConf <- getsYesod $ view _appUserDefaults
+    let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent
+    try $ decodeAzureUser now userDefaultConf mode azureData
 
-decodeUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
+decodeLdapUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_)
-decodeUser now UserDefaultConf{..} upsertMode ldapData = do    
+decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
     let
       userTelephone             = decodeLdap ldapUserTelephone
       userMobile                = decodeLdap ldapUserMobile
@@ -351,11 +289,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
       userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
 
       userAuthentication
-        | is _UpsertCampusUserLoginOther upsertMode
+        | is _UpsertUserLoginOther upsertMode
                     = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
         | otherwise = AuthLDAP
       userLastAuthentication = guardOn isLogin now
-      isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
+      isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode
 
       userTitle       = decodeLdap  ldapUserTitle     -- CampusUserInvalidTitle
       userFirstName   = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
@@ -368,9 +306,9 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
     userIdent <- if
       | [bs] <- ldapMap !!! ldapUserPrincipalName
       , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-      , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
+      , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
         -> return userIdent'
-      | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
+      | Just userIdent' <- upsertMode ^? _upsertUserIdent
         -> return userIdent'
       | otherwise
         -> throwM CampusUserInvalidIdent
@@ -412,6 +350,8 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
         , userTokensIssuedAfter       = Nothing
         , userCreated                 = now
         , userLastLdapSynchronisation = Just now
+        , userAzurePrimaryKey         = Nothing
+        , userLastAzureSynchronisation = Nothing
         , userDisplayName             = userDisplayName
         , userDisplayEmail            = userEmail
         , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
@@ -425,7 +365,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
         [ UserLastAuthentication      =. Just now  | isLogin ] ++
         [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
         [
-        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName
           UserFirstName               =. userFirstName
         , UserSurname                 =. userSurname                    
         , UserLastLdapSynchronisation =. Just now
@@ -472,6 +412,123 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
     --   where
     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
+decodeAzureUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_)
+decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
+    let
+      userTelephone             = decodeAzure azureUserTelephone
+      userMobile                = decodeAzure azureUserMobile
+      userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer
+      userCompanyDepartment     = Nothing --TODO decodeAzure ldapUserFraportAbteilung
+
+      userAuthentication
+        | is _UpsertUserLoginOther upsertMode
+                    = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
+        | otherwise = AuthAzure
+      userLastAuthentication = guardOn isLogin now
+      isLogin = has (_UpsertUserLoginAzure <> _UpsertUserLoginOther . united) upsertMode
+
+      userTitle       = Nothing -- TODO decodeAzure  ldapUserTitle     -- CampusUserInvalidTitle
+      userFirstName   = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName
+      userSurname     = decodeAzure' azureUserSurname   -- CampusUserInvalidSurname
+    userDisplayName <- decodeAzure1  azureUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
+
+    --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
+    -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
+
+    userIdent <- if
+      | [bs] <- azureMap !!! azureUserPrincipalName
+      , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
+      , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
+        -> return userIdent'
+      | Just userIdent' <- upsertMode ^? _upsertUserIdent
+        -> return userIdent'
+      | otherwise
+        -> throwM CampusUserInvalidIdent
+
+    userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
+      | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome azureMap [azureUserMail])
+         -> return $ CI.mk userEmail
+      --      -> return $ CI.mk userEmail
+      | otherwise
+        -> throwM CampusUserInvalidEmail
+        
+    -- TODO: use fromASCIIBytes / fromByteString?
+    userAzurePrimaryKey <- if
+      | [bs] <- azureMap !!! azurePrimaryKey
+      , Right userAzurePrimaryKey'' <- Text.decodeUtf8' bs
+      , Just userAzurePrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userAzurePrimaryKey''
+      , Just userAzurePrimaryKey'''' <- UUID.fromText userAzurePrimaryKey'''
+        -> return $ Just userAzurePrimaryKey''''
+      | otherwise
+        -> return Nothing
+
+    let
+      newUser = User
+        { userMaxFavourites           = userDefaultMaxFavourites
+        , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
+        , userTheme                   = userDefaultTheme
+        , userDateTimeFormat          = userDefaultDateTimeFormat
+        , userDateFormat              = userDefaultDateFormat
+        , userTimeFormat              = userDefaultTimeFormat
+        , userDownloadFiles           = userDefaultDownloadFiles
+        , userWarningDays             = userDefaultWarningDays
+        , userShowSex                 = userDefaultShowSex
+        , userSex                     = Nothing
+        , userBirthday                = Nothing
+        , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
+        , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
+        , userNotificationSettings    = def
+        , userLanguages               = Nothing -- TODO: decode and parse preferredLanguages
+        , userCsvOptions              = def
+        , userTokensIssuedAfter       = Nothing
+        , userCreated                 = now
+        , userLastAzureSynchronisation = Just now
+        , userLdapPrimaryKey          = Nothing
+        , userLastLdapSynchronisation = Nothing
+        , userDisplayName             = userDisplayName
+        , userDisplayEmail            = userEmail
+        , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+        , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+        , userPostLastUpdate          = Nothing
+        , userPinPassword             = Nothing -- must be derived via AVS
+        , userPrefersPostal           = userDefaultPrefersPostal
+        , ..
+        }
+      userUpdate =  
+        [ UserLastAuthentication      =. Just now  | isLogin ] ++
+        [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
+        [
+        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+          UserFirstName               =. userFirstName
+        , UserSurname                 =. userSurname
+        , UserLastAzureSynchronisation =. Just now
+        , UserAzurePrimaryKey          =. userAzurePrimaryKey
+        , UserMobile                  =. userMobile
+        , UserTelephone               =. userTelephone
+        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
+        , UserCompanyDepartment       =. userCompanyDepartment
+        ]
+    return (newUser, userUpdate)
+
+  where
+    azureMap :: Map.Map Text [ByteString]
+    azureMap = Map.fromListWith (++) $ azureData <&> second (filter (not . ByteString.null))
+
+    -- just returns Nothing on error, pure
+    decodeAzure :: Text -> Maybe Text
+    decodeAzure attr = listToMaybe . rights $ Text.decodeUtf8' <$> azureMap !!! attr
+
+    decodeAzure' :: Text -> Text
+    decodeAzure' = fromMaybe "" . decodeAzure
+
+    -- only accepts the first successful decoding, ignoring all others, but failing if there is none
+    -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
+    decodeAzure1 attr err
+        | (h:_) <- rights vs  = return h
+        | otherwise           = throwM err
+      where
+        vs = Text.decodeUtf8' <$> (azureMap !!! attr)
+
 
 associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
 associateUserSchoolsByTerms uid = do
@@ -486,6 +543,7 @@ associateUserSchoolsByTerms uid = do
         , userSchoolIsOptOut = False
         }
 
+
 updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
                       , YesodAuth UniWorX
                       , UserId ~ AuthId UniWorX