module Auth.LDAP
  ( apLdap
  , ADError(..), ADInvalidCredentials(..)
  , campusLogin
  , CampusUserException(..)
  , campusUser, campusUser'
  , campusUserReTest, campusUserReTest'
  , campusUserMatr, campusUserMatr'
  , CampusMessage(..)
  , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
  , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
  , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
  , ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
  , ldapAffiliation, ldapPrimaryKey
  ) 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


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

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


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}@campus.lmu.de|]
      ] ++
      [ ldapUserEmail'        Ldap.:= Text.encodeUtf8 ident'
      | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@campus.lmu.de|]]
      , ldapUserEmail' <- toList ldapUserEmail
      ] ++
      [ ldapUserDisplayName   Ldap.:= Text.encodeUtf8 ident
      , ldapUserMatriculation 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 =
      [ ldapUserMatriculation 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
  ]

ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester, ldapAffiliation, ldapPrimaryKey :: Ldap.Attr
ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
ldapUserDisplayName       = Ldap.Attr "displayName"
ldapUserMatriculation     = Ldap.Attr "LMU-Stud-Matrikelnummer"
ldapUserFirstName         = Ldap.Attr "givenName"
ldapUserSurname           = Ldap.Attr "sn"
ldapUserTitle             = Ldap.Attr "title"
ldapUserStudyFeatures     = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
ldapUserFieldName         = Ldap.Attr "LMU-Stg-Fach"
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
ldapSex                   = Ldap.Attr "schacGender"
ldapUserSubTermsSemester  = Ldap.Attr "LMU-Stg-FachundFS"
ldapAffiliation           = Ldap.Attr "eduPersonAffiliation"
ldapPrimaryKey            = Ldap.Attr "eduPersonPrincipalName"

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


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

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}
  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) [])

campusUser :: (MonadUnliftIO m, MonadMask 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}
  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) [])


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, Typeable)
  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" "") Nothing
   <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder)) Nothing

apLdap :: Text
apLdap = "LDAP"

campusLogin :: forall site.
               ( YesodAuth site
               , RenderMessage site CampusMessage
               , RenderMessage site AFormMessage
               , 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 FormStandard 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 FormStandard 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
