module Auth.LDAP
  ( apLdap
  , campusLogin
  , CampusUserException(..)
  , campusUser, campusUser'
  , campusUserMatr, campusUserMatr'
  , CampusMessage(..)
  , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
  , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
  , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
  , ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
  ) where

import Import.NoFoundation
import Network.Connection

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import qualified Control.Monad.Catch as Exc

import Utils.Form

import Ldap.Client (Ldap)
import qualified Ldap.Client as Ldap

import qualified Data.Text.Encoding as Text

import qualified Yesod.Auth.Message as Msg


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

data CampusMessage = MsgCampusIdentPlaceholder
                   | MsgCampusIdent
                   | MsgCampusPassword
                   | MsgCampusPasswordPlaceholder
                   | MsgCampusSubmit
                   | MsgCampusInvalidCredentials
  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 :: 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"

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


data CampusUserException = CampusUserLdapError LdapPoolError
                         | CampusUserHostNotResolved String
                         | CampusUserLineTooLong
                         | CampusUserHostCannotConnect String [IOException]
                         | CampusUserNoResult
                         | CampusUserAmbiguous
  deriving (Show, Eq, Generic, Typeable)

instance Exception CampusUserException

makePrisms ''CampusUserException

campusUser :: MonadUnliftIO m => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
  Ldap.bind ldap ldapDn ldapPassword
  results <- case lookup "DN" credsExtra of
    Just userDN -> do
      let userFilter = Ldap.Present ldapUserPrincipalName
      Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter []
    Nothing -> do
      findUser conf ldap credsIdent []
  case results of
    [] -> throwM CampusUserNoResult
    [Ldap.SearchEntry _ attrs] -> return attrs
    _otherwise -> throwM CampusUserAmbiguous
  where
    errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
                  , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
                  , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
                  ]

campusUser' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
campusUser' conf pool User{userIdent}
  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])


campusUserMatr :: MonadUnliftIO m => LdapConf -> LdapPool -> UserMatriculation -> m (Ldap.AttrList [])
campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
  Ldap.bind ldap ldapDn ldapPassword
  results <- findUserMatr conf ldap userMatr []
  case results of
    [] -> throwM CampusUserNoResult
    [Ldap.SearchEntry _ attrs] -> return attrs
    _otherwise -> throwM CampusUserAmbiguous
  where
    errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
                  , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
                  , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
                  ]
  
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
campusUserMatr' conf pool
  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr conf pool



campusForm :: ( RenderMessage (HandlerSite m) FormMessage
              , RenderMessage (HandlerSite m) CampusMessage
              , MonadHandler m
              ) => WForm m (FormResult CampusLogin)
campusForm = do
  MsgRenderer mr <- getMsgRenderer
  
  ident <- wreq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "") Nothing
  password <- wreq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder)) Nothing

  return $ CampusLogin
    <$> ident
    <*> password

apLdap :: Text
apLdap = "LDAP"

campusLogin :: forall site.
               ( YesodAuth site
               , RenderMessage site CampusMessage
               , RenderMessage site AFormMessage
               , Button site ButtonSubmit
               ) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
  where
    apName :: Text
    apName = apLdap
  
    apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
    apDispatch "POST" [] = liftSubHandler $ do
      ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
      tp <- getRouteToParent
      case loginRes of
        FormFailure errs -> do
          forM_ errs $ addMessage Error . toHtml
          redirect $ tp LoginR
        FormMissing -> redirect $ tp LoginR
        FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
          ldapResult <- withLdap pool $ \ldap -> liftIO $ do
            Ldap.bind ldap ldapDn ldapPassword
            searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
            case searchResults of
              [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
                | [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
                , Right credsIdent <- Text.decodeUtf8' principalName
                -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
              other -> return $ Left other
          case ldapResult of
            Left err
              | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
                -> do
                  $logDebugS "LDAP" "Invalid credentials"
                  loginErrorMessageI LoginR Msg.InvalidLogin
              | otherwise -> do
                  $logErrorS "LDAP" $ "Error during login: " <> tshow err
                  loginErrorMessageI LoginR Msg.AuthError
            Right (Right (userDN, credsIdent)) ->
              setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
            Right (Left searchResults) -> do
              $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
              loginErrorMessageI LoginR Msg.AuthError
    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 "LDAP" []
            , formEncoding = loginEnctype
            , formAttrs = [("uw-no-navigate-away-prompt","")]
            , formSubmit = FormSubmit
            , formAnchor = Just "login--campus" :: Maybe Text
            }
      $(widgetFile "widgets/campus-login/campus-login-form")
