-- 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
  , userLookupAndUpsert
  , upsertUser, maybeUpsertUser
  , decodeUserTest
  , DecodeUserException(..)
  , updateUserLanguage
  ) where

import Import.NoFoundation hiding (authenticate)

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

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 Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken)

import qualified Control.Monad.Catch as C (Handler(..))

import qualified Data.ByteString as ByteString
import qualified Data.CaseInsensitive as CI
import qualified Data.Map as Map
import qualified Data.List.NonEmpty as NonEmpty (toList)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text

import qualified Ldap.Client as Ldap


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
  $logDebugS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m"
  setSessionJson SessionOAuth2Token (getAccessToken creds, getRefreshToken creds)

  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 $ \(fExc :: FetchUserDataException) -> case fExc of
          FetchUserDataNoResult -> do
            $logWarnS "FetchUserException" $ "User lookup failed after successful login for " <> credsIdent
            excRecovery . UserError $ IdentifierNotFound credsIdent
          FetchUserDataAmbiguous -> do
            $logWarnS "FetchUserException" $ "Multiple User results for " <> credsIdent
            excRecovery . UserError $ IdentifierNotFound credsIdent
          err -> do
            $logErrorS "FetchUserException" $ tshow err
            mr <- getMessageRender
            excRecovery . ServerError $ mr MsgInternalLoginError
      , C.Handler $ \(dExc :: DecodeUserException) -> do
          $logErrorS "Auth" $ tshow dExc
          mr <- getMessageRender
          excRecovery . ServerError $ mr dExc
      ]

    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{..}

  flip catches excHandlers $ if
    | not isDummy, not isOther
    , Just upsertMode' <- upsertMode -> fetchUserData Creds{..} >>= \case
      Just userData -> do
        $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData
        Authenticated . entityKey <$> upsertUser upsertMode' userData
      Nothing
        -> throwM FetchUserDataNoResult
    | otherwise
      -> acceptExisting


data DecodeUserException
  = DecodeUserInvalidIdent
  | DecodeUserInvalidEmail
  | DecodeUserInvalidDisplayName
  | DecodeUserInvalidGivenName
  | DecodeUserInvalidSurname
  | DecodeUserInvalidTitle
  | DecodeUserInvalidFeaturesOfStudy Text
  | DecodeUserInvalidAssociatedSchools 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 `elem` loginAPs
                           = setMode <$> mMode (UpsertUserLogin credsPlugin)
  | otherwise              = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
  where
    setMode UpsertUserLogin{..} | upsertUserSource `elem` loginAPs
      = cs { credsPlugin = upsertUserSource }
    setMode UpsertUserLoginDummy{..}
      = cs { credsPlugin = apDummy
           , credsIdent  = CI.original upsertUserIdent
           }
    setMode UpsertUserLoginOther{..}
      = cs { credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
           , credsIdent  = CI.original upsertUserIdent
           }
    setMode _ = cs

    loginAPs = [ apAzure, apLdap ]
    defaultOther = apHash


userLookupAndUpsert :: forall m.
                       ( MonadHandler m
                       , HandlerSite m ~ UniWorX
                       , MonadMask m
                       , MonadUnliftIO m
                       )
                    => Text
                    -> UpsertUserMode
                    -> SqlPersistT m (Maybe (Entity User))
userLookupAndUpsert credsIdent mode =
  fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= maybeUpsertUser mode


data FetchUserDataException
  = FetchUserDataNoResult
  | FetchUserDataAmbiguous
  | FetchUserDataException
  deriving (Eq, Ord, Read, Show, Generic)
  deriving anyclass (Exception)

-- | Fetch user data with given credentials from external source(s)
fetchUserData :: forall m site.
                 ( MonadHandler m
                 , HandlerSite m ~ UniWorX
                 , MonadCatch m
                 , MonadMask m
                 , MonadUnliftIO m
                 )
              => Creds site
              -> SqlPersistT m (Maybe (NonEmpty UpsertUserData))
fetchUserData Creds{..} = do
  userAuthConf <- getsYesod $ view _appUserAuthConf
  now <- liftIO getCurrentTime

  results :: Maybe (NonEmpty UpsertUserData) <- case userAuthConf of
    UserAuthConfSingleSource{..} -> fmap (:| []) <$> case userAuthConfSingleSource of
      AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do
        queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case
          Right upsertUserAzureData -> return $ Just UpsertUserDataAzure{..}
          Left _ -> return Nothing
      AuthSourceConfLdap LdapConf{..} -> getsYesod (view _appLdapPool) >>= \case
        Just ldapPool -> fmap (UpsertUserDataLdap ldapConfSourceId) <$> ldapUser'' ldapPool credsIdent
        Nothing -> throwM FetchUserDataException

  -- insert ExternalUser entries for each fetched dataset
  whenIsJust results $ \ress -> forM_ ress $ \res -> do
    let externalUserLastSync = now
        (externalUserData, externalUserSource) = case res of
          UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId)
          UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost)
    externalUserUser <- if
      | UpsertUserDataAzure{..} <- res
      , azureData <- Map.fromListWith (++) $ upsertUserAzureData <&> second (filter (not . ByteString.null))
      , [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName
        -> return $ CI.mk azureUserPrincipalName'
      | UpsertUserDataLdap{..} <- res
      , ldapData <- Map.fromListWith (++) $ upsertUserLdapData <&> second (filter (not . ByteString.null))
      , [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey
        -> return $ CI.mk ldapPrimaryKey'
      | otherwise
        -> throwM DecodeUserInvalidIdent
    void $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]

  return results


-- | Upsert User and related auth in DB according to given external source data (does not query source itself)
maybeUpsertUser :: forall m.
                   ( MonadHandler m
                   , HandlerSite m ~ UniWorX
                   , MonadCatch m
                   )
                => UpsertUserMode
                -> Maybe (NonEmpty UpsertUserData)
                -> SqlPersistT m (Maybe (Entity User))
maybeUpsertUser _upsertMode Nothing = return Nothing
maybeUpsertUser _upsertMode (Just upsertData) = do
  now <- liftIO getCurrentTime
  userDefaultConf <- getsYesod $ view _appUserDefaults

  (newUser,userUpdate) <- decodeUser 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 <- selectKeysList [ UserIdent ==. userIdent newUser ] []

  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' = concat $ upsertData <&> \case
      UpsertUserDataAzure{..} -> do
        (_k, v) <- upsertUserAzureData
        v' <- v
        Right str <- return $ Text.decodeUtf8' v'
        assertM' (not . Text.null) $ Text.strip str
      UpsertUserDataLdap{..} -> do
        (k, v) <- upsertUserLdapData
        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 $ Just user

decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
        => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
decodeUserTest mbIdent ldapData = do
    now <- liftIO getCurrentTime
    userDefaultConf <- getsYesod $ view _appUserDefaults
    let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
    try $ decodeUser now userDefaultConf mode ldapData


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

      userAuthentication
        | is _UpsertCampusUserLoginOther 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

      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
      | Just azureData <- mbAzureData
      , [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName
      , Just azureUserPrincipalName'' <- assertM' (not . Text.null) $ Text.strip azureUserPrincipalName'
        -> return $ CI.mk azureUserPrincipalName''
      | Just ldapData <- mbLdapData
      , [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey
      , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
        -> return $ CI.mk ldapPrimaryKey''
      | 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
        , userTitle                 =  Nothing
        , userExamOfficeGetSynced   =  userDefaultExamOfficeGetSynced
        , userExamOfficeGetLabels   =  userDefaultExamOfficeGetLabels
        , userNotificationSettings  =  def
        , userCsvOptions            =  def
        , userTokensIssuedAfter     =  Nothing
        , userDisplayEmail          =  userEmail
        , userMatrikelnummer        =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
        , userPostAddress           =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
        , userPostLastUpdate        =  Nothing
        , userPinPassword           =  Nothing -- must be derived via AVS
        , userPrefersPostal         =  userDefaultPrefersPostal
        , userPasswordHash          =  Nothing
        , userLastAuthentication    =  Nothing
        , userCreated               =  now
        , userLastSync              =  Just now
        , ..
        }
      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                    
        , UserLastLdapSynchronisation =. Just now
        , UserLdapPrimaryKey          =. userLdapPrimaryKey
        , UserMobile                  =. userMobile
        , UserTelephone               =. userTelephone
        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
        , UserCompanyDepartment       =. userCompanyDepartment
        ]
    return (newUser, userUpdate)

  where
    mbAzureData :: Maybe (Map Text [ByteString])
    mbAzureData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData
    mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString
    mbLdapData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData

    -- just returns Nothing on error, pure
    decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text
    decodeAzure azureData k = listToMaybe . rights $ Text.decodeUtf8' <$> azureData !!! k
    decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text
    decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr

    -- decodeAzure' :: Map Text [ByteString] -> Text -> Text
    -- decodeAzure' azureData = fromMaybe "" . decodeAzure azureData
    -- decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text
    -- decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData
    -- 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 ldapData attr err
    --     | (h:_) <- rights vs  = return h
    --     | otherwise           = throwM err
    --   where
    --     vs = Text.decodeUtf8' <$> (ldapData !!! 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)

decodeUserTest :: ( MonadHandler m
                  , HandlerSite m ~ UniWorX
                  , MonadCatch m
                  )
               => NonEmpty UpsertUserData
               -> m (Either DecodeUserException (User, [Update User]))
decodeUserTest decodeData = do
  now <- liftIO getCurrentTime
  userDefaultConf <- getsYesod $ view _appUserDefaults
  try $ decodeUser now userDefaultConf decodeData


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 ''DecodeUserException id
