-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@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

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Auth.LDAP
  ( apLdap
  , ADError(..), ADInvalidCredentials(..)
  , ldapLogin
  , CampusUserException(..)
  , ldapUser, ldapUser', ldapUser''
  , ldapUserReTest, ldapUserReTest'
  , ldapUserMatr, ldapUserMatr'
  , CampusMessage(..)
  , ldapPrimaryKey
  , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
  , ldapUserFirstName, ldapUserSurname
  , ldapAffiliation
  , ldapUserMobile, ldapUserTelephone
  , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
  , ldapUserTitle
  ) where

import Import.NoFoundation

import Auth.LDAP.AD

import qualified Ldap.Client as Ldap

import Utils.Form
import Utils.Metrics

import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as Text

import qualified Yesod.Auth.Message as Msg


-- | Plugin name of the LDAP yesod auth plugin
apLdap :: Text
apLdap = "LDAP"


-- | Allow Ldap.Attr usage as key for Data.Map
deriving newtype instance Ord Ldap.Attr


data CampusLogin = CampusLogin
  { campusIdent :: CI Text
  , campusPassword :: Text
  } deriving (Generic)

data CampusMessage = MsgCampusIdentPlaceholder
                   | MsgCampusIdent
                   | MsgCampusPassword
                   | MsgCampusPasswordPlaceholder
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)


findUser :: LdapConf 
         -> Ldap
         -> Text -- ^ needle
         -> [Ldap.Attr]
         -> IO [Ldap.SearchEntry]
findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
  where
    userFilters =
      [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
      , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@fraport.de|]
      ] ++
      [ ldapUserEmail'        Ldap.:= Text.encodeUtf8 ident'
      | ident' <- [ident, [st|#{ident}@fraport.de|]]
      , ldapUserEmail' <- toList ldapUserEmail
      -- ] ++
      -- [ ldapUserDisplayName   Ldap.:= Text.encodeUtf8 ident  -- for Fraport, userDisplayName has the pattern "Surname, Firstnames"
      ] ++
      [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident
      ]

findUserMatr :: LdapConf
             -> Ldap
             -> Text -- ^ matriculation needle
             -> [Ldap.Attr]
             -> IO [Ldap.SearchEntry]
findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
  where
    userFilters =
      [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
      ]

userSearchSettings :: LdapConf
                   -> Ldap.Mod Ldap.Search
userSearchSettings LdapConf{..} = mconcat
  [ Ldap.scope ldapScope
  , Ldap.size 2
  , Ldap.time ldapSearchTimeout
  , Ldap.derefAliases Ldap.DerefAlways
  ]

ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone,  ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung  :: Ldap.Attr
ldapPrimaryKey            = Ldap.Attr "cn" -- should always be identical to "sAMAccountName"
ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
ldapUserDisplayName       = Ldap.Attr "displayName"
ldapUserFirstName         = Ldap.Attr "givenName"
ldapUserSurname           = Ldap.Attr "sn"
ldapAffiliation           = Ldap.Attr "memberOf"   -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions
ldapUserTitle             = Ldap.Attr "title"      -- not used at Fraport
-- new
ldapUserTelephone             = Ldap.Attr "telephoneNumber"
ldapUserMobile                = Ldap.Attr "mobile"
ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName"
ldapUserFraportAbteilung      = Ldap.Attr "department"

ldapUserEmail :: NonEmpty Ldap.Attr
ldapUserEmail = Ldap.Attr "mail" :|
  [ Ldap.Attr "userPrincipalName"
  ]


-- TODO: rename
data CampusUserException = CampusUserLdapError LdapPoolError
                         | CampusUserNoResult
                         | CampusUserAmbiguous
  deriving (Show, Eq, Generic)

instance Exception CampusUserException

makePrisms ''CampusUserException


ldapUserWith :: ( MonadUnliftIO m
                , MonadCatch m
                )
             => (    Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
                    -> Failover (LdapConf, LdapPool)
                    -> FailoverMode
                    -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
                    -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
                )
             -> Failover (LdapConf, LdapPool)
             -> FailoverMode
             -> Creds site
             -> m (Either CampusUserException (Ldap.AttrList []))
ldapUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do
  lift $ Ldap.bind ldap ldapDn ldapPassword
  results <- case lookup "DN" credsExtra of
    Just userDN -> do
      let userFilter = Ldap.Present ldapUserPrincipalName
      lift $ Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter []
    Nothing -> do
      lift $ findUser conf ldap credsIdent []
  case results of
    [] -> throwE CampusUserNoResult
    [Ldap.SearchEntry _ attrs] -> return attrs
    _otherwise -> throwE CampusUserAmbiguous


ldapUserReTest  :: ( MonadUnliftIO m
                   , MonadMask m
                   , MonadLogger m
                   )
                => Failover (LdapConf, LdapPool)
                -> (Nano -> Bool)
                -> FailoverMode
                -> Creds site
                -> m (Ldap.AttrList [])
ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds

ldapUserReTest' :: ( MonadMask m
                   , MonadLogger m
                   , MonadUnliftIO m
                   )
                => Failover (LdapConf, LdapPool)
                -> (Nano -> Bool)
                -> FailoverMode
                -> User
                -> m (Maybe (Ldap.AttrList []))
ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey}
  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent [])
  where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey 


ldapUser :: ( MonadMask m
            , MonadUnliftIO m
            , MonadLogger m
            )
         => Failover (LdapConf, LdapPool)
         -> FailoverMode
         -> Creds site
         -> m (Ldap.AttrList [])
ldapUser pool mode creds = throwLeft =<< ldapUserWith withLdapFailover pool mode creds

ldapUser' :: ( MonadMask m
             , MonadUnliftIO m
             , MonadLogger m
             )
          => Failover (LdapConf, LdapPool)
          -> FailoverMode
          -> User
          -> m (Maybe (Ldap.AttrList []))
ldapUser' pool mode User{userIdent}
  = ldapUser'' pool mode $ CI.original userIdent

ldapUser'' :: ( MonadMask m
              , MonadUnliftIO m
              , MonadLogger m
              )
           => Failover (LdapConf, LdapPool)
           -> FailoverMode
           -> Text
           -> m (Maybe (Ldap.AttrList []))
ldapUser'' pool mode ident
  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool mode (Creds apLdap ident [])


ldapUserMatr :: ( MonadUnliftIO m
                , MonadMask m
                , MonadLogger m
                )
             => Failover (LdapConf, LdapPool)
             -> FailoverMode
             -> UserMatriculation
             -> m (Ldap.AttrList [])
ldapUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
  Ldap.bind ldap ldapDn ldapPassword
  results <- findUserMatr conf ldap userMatr []
  case results of
    [] -> throwM CampusUserNoResult
    [Ldap.SearchEntry _ attrs] -> return attrs
    _otherwise -> throwM CampusUserAmbiguous

ldapUserMatr' :: ( MonadMask m
                 , MonadUnliftIO m
                 , MonadLogger m
                 )
              => Failover (LdapConf, LdapPool)
              -> FailoverMode
              -> UserMatriculation
              -> m (Maybe (Ldap.AttrList []))
ldapUserMatr' pool mode
  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool mode


newtype ADInvalidCredentials = ADInvalidCredentials ADError
  deriving (Eq, Ord, Read, Show, Generic)
  deriving newtype (Universe, Finite, Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)

isUnusualADError :: ADError -> Bool
isUnusualADError = flip notElem [ADNoSuchObject, ADLogonFailure]


campusForm :: ( RenderMessage (HandlerSite m) FormMessage
              , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
              , RenderMessage (HandlerSite m) CampusMessage
              , MonadHandler m
              )
           => WForm m (FormResult CampusLogin)
campusForm = do
  MsgRenderer mr <- getMsgRenderer
  aFormToWForm $ CampusLogin
   <$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "" & addAttr "autocomplete" "username") Nothing
   <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing


ldapLogin :: forall site.
             ( YesodAuth site
             , RenderMessage site CampusMessage
             , RenderAFormSite site
             , RenderMessage site (ValueRequired site)
             , RenderMessage site ADInvalidCredentials
             , Button site ButtonSubmit
             )
          => (LdapConf, LdapPool) -- TODO: reintroduce Failover
          -> FailoverMode
          -> AuthPlugin site
ldapLogin pool mode = AuthPlugin{..}
  where
    apName :: Text
    apName = apLdap

    apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
    apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
      ((loginRes, _), _) <- runFormPost $ renderWForm FormLogin campusForm
      tp <- getRouteToParent

      resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> do
        ldapResult <- withLdap _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
          Ldap.bind ldap ldapDn ldapPassword
          searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
          case searchResults of
            [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
              | [principalName] <- nubOrd $ fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
              , Right credsIdent <- Text.decodeUtf8' principalName
              -> handleIf isInvalidCredentials (return . Left) $ do
                   Ldap.bind ldap (Ldap.Dn credsIdent) . Ldap.Password $ Text.encodeUtf8 campusPassword
                   return . Right $ Right (userDN, credsIdent)
            other -> return . Right $ Left other
        case ldapResult of
          Left err -> do
            $logErrorS apName $ "Error during login: " <> tshow err
            observeLoginOutcome apName LoginError
            loginErrorMessageI LoginR Msg.AuthError
          Right (Left (Ldap.ResponseErrorCode _ errCode _ errTxt))
            | Right adError <- parseADError errCode errTxt
            , isUnusualADError adError -> do
                $logInfoS apName [st|#{campusIdent}: #{toPathPiece adError}|]
                observeLoginOutcome apName LoginADInvalidCredentials
                MsgRenderer mr <- liftHandler getMsgRenderer
                setSessionJson SessionError . PermissionDenied . toPathPiece $ ADInvalidCredentials adError
                loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError
          Right (Left bindErr) -> do
            case bindErr of
              Ldap.ResponseErrorCode _ _ _ errTxt ->
                $logInfoS apName [st|#{campusIdent}: #{errTxt}|]
              _other -> return ()
            $logDebugS apName "Invalid credentials"
            observeLoginOutcome apName LoginInvalidCredentials
            loginErrorMessageI LoginR Msg.InvalidLogin
          Right (Right (Left searchResults))
            | null searchResults -> do
              $logDebugS apName "User not found"
              observeLoginOutcome apName LoginInvalidCredentials
              loginErrorMessageI LoginR Msg.InvalidLogin
            | otherwise -> do
                $logWarnS apName $ "Could not extract principal name: " <> tshow searchResults
                observeLoginOutcome apName LoginError
                loginErrorMessageI LoginR Msg.AuthError
          Right (Right (Right (userDN, credsIdent))) -> do
            observeLoginOutcome apName LoginSuccessful
            setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]

      maybe (redirect $ tp LoginR) return resp
    apDispatch _ [] = badMethod
    apDispatch _ _ = notFound

    apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
    apLogin toMaster = do
      (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormLogin campusForm
      let loginForm = wrapForm login FormSettings
            { formMethod = POST
            , formAction = Just . SomeRoute . toMaster $ PluginR apName []
            , formEncoding = loginEnctype
            , formAttrs = [("uw-no-navigate-away-prompt","")]
            , formSubmit = FormSubmit
            , formAnchor = Just "login--campus" :: Maybe Text
            }
      $(widgetFile "widgets/campus-login/campus-login-form")

    isInvalidCredentials = \case
      Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _ -> True
      _other -> False