-- 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
  , ldapLookupAndUpsert
  , upsertLdapUser, upsertAzureUser
  , decodeLdapUserTest, decodeAzureUserTest
  , CampusUserConversionException(..)
  , updateUserLanguage
  ) where

import Import.NoFoundation hiding (authenticate)

import Foundation.Type
import Foundation.Types
import Foundation.I18n

import Handler.Utils.Profile
import Handler.Utils.LdapSystemFunctions
import Handler.Utils.Memcached
import Foundation.Authorization (AuthorizationCacheKey(..))

import Yesod.Auth.Message
import Auth.LDAP
import Auth.OAuth2
import Auth.PWHash (apHash)
import Auth.Dummy (apDummy)

import qualified Data.CaseInsensitive as CI
import qualified Control.Monad.Catch as C (Handler(..))
import qualified Ldap.Client as Ldap
import qualified Data.Text as Text
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.UUID as UUID


authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
                , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                , YesodAuth UniWorX, UserId ~ AuthId UniWorX
                )
             => Creds UniWorX -> m (AuthenticationResult UniWorX)
authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
  $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only

  now <- liftIO getCurrentTime

  let
    uAuth = UniqueAuthentication $ CI.mk credsIdent
    upsertMode = creds ^? _upsertUserMode

    isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
    isOther = is (_Just . _UpsertUserLoginOther) 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
          CampusUserNoResult -> do
            $logWarnS "Auth" $ "User lookup failed after successful login for " <> credsIdent
            excRecovery . UserError $ IdentifierNotFound credsIdent
          CampusUserAmbiguous -> do
            $logWarnS "Auth" $ "Multiple auth results for " <> credsIdent
            excRecovery . UserError $ IdentifierNotFound credsIdent
          err -> do
            $logErrorS "Auth" $ tshow err
            mr <- getMessageRender
            excRecovery . ServerError $ mr MsgInternalLdapError
      , C.Handler $ \(cExc :: CampusUserConversionException) -> do
          $logErrorS "Auth" $ 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 "auth" $ tshow Creds{..}

  userSourceConf <- getsYesod $ view _appUserSourceConf
  flip catches excHandlers $ case userSourceConf of
    UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf)
      | Just upsertMode' <- upsertMode -> do
          azureData <- azureUser azureConf Creds{..}
          $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData
          Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData
    UserSourceConfSingleSource (UserSourceLdap _)
      | Just upsertMode' <- upsertMode -> do
          ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
          ldapData <- ldapUser ldapPool Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..}
          $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow ldapData
          Authenticated . entityKey <$> upsertLdapUser upsertMode' ldapData
    _other
      -> acceptExisting


data CampusUserConversionException
  = CampusUserInvalidIdent
  | CampusUserInvalidEmail
  | CampusUserInvalidDisplayName
  | CampusUserInvalidGivenName
  | CampusUserInvalidSurname
  | CampusUserInvalidTitle
  -- | CampusUserInvalidMatriculation
  | CampusUserInvalidFeaturesOfStudy Text
  | CampusUserInvalidAssociatedSchools Text
  deriving (Eq, Ord, Read, Show, Generic)
  deriving anyclass (Exception)


_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode
_upsertUserMode mMode cs@Creds{..}
  | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent)
  | credsPlugin == apAzure = setMode <$> mMode  UpsertUserLoginAzure
  | credsPlugin == apLdap  = setMode <$> mMode  UpsertUserLoginLdap
  | otherwise              = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
  where
    setMode UpsertUserLoginAzure
      = cs{ credsPlugin = apAzure }
    setMode UpsertUserLoginLdap
      = cs{ credsPlugin = apLdap }
    setMode (UpsertUserLoginDummy ident)
      = cs{ credsPlugin = apDummy
          , credsIdent  = CI.original ident
          }
    setMode (UpsertUserLoginOther ident)
      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
          , 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 ->
      ldapUser'' ldapPool ident >>= \case
        Nothing -> throwM CampusUserNoResult
        Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse


-- | Upsert User DB according to given LDAP data (does not query LDAP itself)
upsertLdapUser :: forall m.
                    ( MonadHandler m, HandlerSite m ~ UniWorX
                    , MonadCatch m
                    )
                 => UpsertUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
upsertLdapUser upsertMode ldapData = do
  now <- liftIO getCurrentTime
  userDefaultConf <- getsYesod $ view _appUserDefaults

  (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 ] []

  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 =. AuthLDAP                 | 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) <- ldapData
      guard $ k == ldapAffiliation
      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

-- | 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]))
decodeLdapUserTest mbIdent ldapData = do
    now <- liftIO getCurrentTime
    userDefaultConf <- getsYesod $ view _appUserDefaults
    let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent
    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

decodeLdapUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_)
decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
    let
      userTelephone             = decodeLdap ldapUserTelephone
      userMobile                = decodeLdap ldapUserMobile
      userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
      userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung

      userAuthentication
        | 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 (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode

      userTitle       = decodeLdap  ldapUserTitle     -- CampusUserInvalidTitle
      userFirstName   = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
      userSurname     = decodeLdap' ldapUserSurname   -- CampusUserInvalidSurname
    userDisplayName <- decodeLdap1  ldapUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName

    --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
    -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)

    userIdent <- if
      | [bs] <- ldapMap !!! ldapUserPrincipalName
      , 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 ldapMap $ toList ldapUserEmail)
         -> return $ CI.mk userEmail
      --   | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
      --      -> return $ CI.mk userEmail
      | otherwise
        -> throwM CampusUserInvalidEmail
        
    userLdapPrimaryKey <- if
      | [bs] <- ldapMap !!! ldapPrimaryKey
      , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
      , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
        -> return $ Just userLdapPrimaryKey'''
      | 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
        , userCsvOptions              = def
        , 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
        , 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
          UserFirstName               =. userFirstName
        , UserSurname                 =. userSurname                    
        , UserLastLdapSynchronisation =. Just now
        , UserLdapPrimaryKey          =. userLdapPrimaryKey
        , UserMobile                  =. userMobile
        , UserTelephone               =. userTelephone
        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
        , UserCompanyDepartment       =. userCompanyDepartment
        ]
    return (newUser, userUpdate)

  where
    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))

    -- just returns Nothing on error, pure
    decodeLdap :: Ldap.Attr -> Maybe Text
    decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr

    decodeLdap' :: Ldap.Attr -> Text
    decodeLdap' = fromMaybe "" . decodeLdap
    -- accept the first successful decoding or empty; only throw an error if all decodings fail
    -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
    -- decodeLdap' attr err
    --     | []    <-        vs = return   Nothing
    --     | (h:_) <- rights vs = return $ Just h
    --     | otherwise          = throwM err
    --   where
    --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)

    -- 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
    decodeLdap1 attr err
        | (h:_) <- rights vs  = return h
        | otherwise           = throwM err
      where
        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)

    -- accept and merge one or more successful decodings, ignoring all others
    -- decodeLdapN attr err
    --     | t@(_:_) <- rights vs
    --       = return $ Text.unwords t
    --     | otherwise = throwM err
    --   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
  sfs <- selectList [StudyFeaturesUser ==. uid] []

  forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
    schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
    forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
      void $ insertUnique UserSchool
        { userSchoolUser     = uid
        , userSchoolSchool   = schoolTermsSchool
        , userSchoolIsOptOut = False
        }


updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
                      , YesodAuth UniWorX
                      , UserId ~ AuthId UniWorX
                      )
                   => Maybe Lang -> SqlPersistT m (Maybe Lang)
updateUserLanguage (Just lang) = do
  unless (lang `elem` appLanguages) $
    invalidArgs ["Unsupported language"]

  muid <- maybeAuthId
  for_ muid $ \uid -> do
    langs <- languages
    update uid [ UserLanguages =. Just (Languages $ lang : nubOrd (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
  setRegisteredCookie CookieLang lang
  return $ Just lang
updateUserLanguage Nothing = runMaybeT $ do
  uid <- MaybeT maybeAuthId
  User{..} <- MaybeT $ get uid
  setLangs <- toList . selectLanguages appLanguages <$> languages
  highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
  let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
  lang <- case (userLanguages', setLangs, highPrioSetLangs) of
    (_, _, hpl : _)
      -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
    (Just (l : _), _, _)
      -> return l
    (Nothing, l : _, _)
      -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
    (Just [], l : _, _)
      -> return l
    (_, [], _)
      -> mzero
  setRegisteredCookie CookieLang lang
  return lang

embedRenderMessage ''UniWorX ''CampusUserConversionException id
