-- SPDX-FileCopyrightText: 2022 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(..)
  , campusLogin
  , CampusUserException(..)
  , campusUser, campusUser', campusUser''
  , campusUserReTest, campusUserReTest'
  , campusUserMatr, campusUserMatr'
  , CampusMessage(..)
  , ldapPrimaryKey
  , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
  , ldapUserFirstName, ldapUserSurname
  , ldapAffiliation
  , ldapUserMobile, ldapUserTelephone
  , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
  , ldapUserTitle
  ) where

import Import.NoFoundation

import qualified Data.CaseInsensitive as CI

import Utils.Metrics
import Utils.Form

import qualified Ldap.Client as Ldap

import qualified Data.Text.Encoding as Text

import qualified Yesod.Auth.Message as Msg

import Auth.LDAP.AD

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


data CampusUserException = CampusUserLdapError LdapPoolError
                         | CampusUserNoResult
                         | CampusUserAmbiguous
  deriving (Show, Eq, Generic)

instance Exception CampusUserException

makePrisms ''CampusUserException

campusUserWith :: ( 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 []))
campusUserWith 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

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

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


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

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

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

campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
campusUserMatr 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

campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
campusUserMatr' pool mode
  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr 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

apLdap :: Text
apLdap = "LDAP"

campusLogin :: forall site.
               ( YesodAuth site
               , RenderMessage site CampusMessage
               , RenderAFormSite site
               , RenderMessage site (ValueRequired site)
               , RenderMessage site ADInvalidCredentials
               , Button site ButtonSubmit
               ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
campusLogin 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 <- withLdapFailover _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
