-- 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
  , LdapUserException(..)
  , ldapUser, ldapUser', ldapUser''
--, ldapUserReTest, ldapUserReTest'
  , ldapUserMatr, ldapUserMatr'
  , CampusMessage(..)
  , ldapPrimaryKey
  , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
  , ldapUserFirstName, ldapUserSurname
  , ldapAffiliation
  , ldapUserMobile, ldapUserTelephone
  , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
  , ldapUserTitle
  , ldapSearch
  ) 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"


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

-- TODO: rename
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 ldapConfBase $ 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 ldapConfBase $ userSearchSettings conf) retAttrs) userFilters
  where
    userFilters =
      [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
      ]

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

ldapSearch :: forall m.
              ( MonadUnliftIO m
              , MonadCatch m
              )
           => (LdapConf, LdapPool)
           -> Text -- ^ needle
           -> m [Ldap.SearchEntry]
ldapSearch (conf@LdapConf{..}, ldapPool) needle = either (throwM . LdapUserLdapError) return <=< withLdap ldapPool $ \ldap -> liftIO $ do
  Ldap.bind ldap ldapConfDn ldapConfPassword
  findUser conf ldap needle []

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: deprecate in favour of FetchUserDataException
data LdapUserException = LdapUserLdapError LdapPoolError
                       | LdapUserNoResult
                       | LdapUserAmbiguous
  deriving (Show, Eq, Generic)

instance Exception LdapUserException

makePrisms ''LdapUserException


ldapUserWith :: ( MonadUnliftIO m
                , MonadCatch m
              --, MonadLogger m
                )
                -- (    Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
                --     -> (LdapConf, LdapPool)
                --     -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
                --     -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
                -- )
             => (    LdapPool
                  -> (Ldap -> m (Either LdapUserException (Ldap.AttrList [])))
                  -> m (Either LdapPoolError (Either LdapUserException (Ldap.AttrList [])))
                )
             -> (LdapConf, LdapPool)
             -> Creds site
             -> m (Either LdapUserException (Ldap.AttrList []))
ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . LdapUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do
  lift $ Ldap.bind ldap ldapConfDn ldapConfPassword
  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 LdapUserNoResult
    [Ldap.SearchEntry _ attrs] -> return attrs
    _otherwise -> throwE LdapUserAmbiguous


-- TODO: reintroduce once failover has been reimplemented
-- 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 


-- TODO: deprecate in favour of fetchUserData
ldapUser :: ( MonadMask m
            , MonadUnliftIO m
          --, MonadLogger m
            )
         => (LdapConf, LdapPool)
         -> Creds site
         -> m (Ldap.AttrList [])
ldapUser pool creds = throwLeft =<< ldapUserWith withLdap pool creds

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

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


ldapUserMatr :: ( MonadUnliftIO m
                , MonadMask m
              --, MonadLogger m
                )
             => (LdapConf, LdapPool)
             -> UserMatriculation
             -> m (Ldap.AttrList [])
ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . LdapUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do
  Ldap.bind ldap ldapConfDn ldapConfPassword
  results <- findUserMatr conf ldap userMatr []
  case results of
    [] -> throwM LdapUserNoResult
    [Ldap.SearchEntry _ attrs] -> return attrs
    _otherwise -> throwM LdapUserAmbiguous

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


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


-- TODO: reintroduce Failover
ldapLogin :: forall site.
             ( YesodAuth site
             , RenderMessage site CampusMessage
             , RenderAFormSite site
             , RenderMessage site (ValueRequired site)
             , RenderMessage site ADInvalidCredentials
             , Button site ButtonSubmit
             )
          => LdapConf
          -> LdapPool
          -> AuthPlugin site
ldapLogin conf@LdapConf{..} pool = 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 pool $ \ldap -> liftIO $ do
          Ldap.bind ldap ldapConfDn ldapConfPassword
          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