-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Foundation.Yesod.Auth
  ( authenticate
  , ldapLookupAndUpsert
  , upsertCampusUser
  , decodeUserTest
  , CampusUserConversionException(..)
  , campusUserFailoverMode, 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.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.Conduit.Combinators as C

-- 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
                , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                , YesodAuth UniWorX, UserId ~ AuthId UniWorX
                )
             => Creds UniWorX -> m (AuthenticationResult UniWorX)
authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
  now <- liftIO getCurrentTime

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

    isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode
    isOther = is (_Just . _UpsertCampusUserLoginOther) 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 "LDAP" $ "User lookup failed after successful login for " <> credsIdent
            excRecovery . UserError $ IdentifierNotFound credsIdent
          CampusUserAmbiguous -> do
            $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
            excRecovery . UserError $ IdentifierNotFound credsIdent
          err -> do
            $logErrorS "LDAP" $ tshow err
            mr <- getMessageRender
            excRecovery . ServerError $ mr MsgInternalLdapError
      , C.Handler $ \(cExc :: CampusUserConversionException) -> do
          $logErrorS "LDAP" $ 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{..}  
  ldapPool' <- getsYesod $ view _appLdapPool

  flip catches excHandlers $ case ldapPool' of
    Just ldapPool
      | Just upsertMode' <- upsertMode -> do
          ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
          Authenticated . entityKey <$> upsertCampusUser 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)

_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
_upsertCampusUserMode mMode cs@Creds{..}
  | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent)
  | credsPlugin == apLdap  = setMode <$> mMode  UpsertCampusUserLoginLdap
  | otherwise              = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent)
  where
    setMode UpsertCampusUserLoginLdap
      = cs{ credsPlugin = apLdap }
    setMode (UpsertCampusUserLoginDummy ident)
      = cs{ credsPlugin = apDummy
          , credsIdent  = CI.original ident
          }
    setMode (UpsertCampusUserLoginOther 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 ->
      campusUser'' ldapPool campusUserFailoverMode ident >>= \case
        Nothing -> throwM CampusUserNoResult
        Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse

{- 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.
                    ( MonadHandler m, HandlerSite m ~ UniWorX
                    , MonadCatch m
                    )
                 => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
upsertCampusUser upsertMode ldapData = 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 <- 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

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
      | [bs] <- ldapMap !!! ldapUserPrincipalName
      , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
      , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
        -> return userIdent'
      | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
        -> 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
        , 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                    
        , 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)


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

campusUserFailoverMode :: FailoverMode
campusUserFailoverMode = FailoverUnlimited

embedRenderMessage ''UniWorX ''CampusUserConversionException id
