70 lines
2.7 KiB
Haskell
70 lines
2.7 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
|
|
|
|
module Handler.Admin.Ldap
|
|
( getAdminLdapR
|
|
, postAdminLdapR
|
|
) where
|
|
|
|
import Import
|
|
-- import qualified Control.Monad.State.Class as State
|
|
-- import Data.Aeson (encode)
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
-- import qualified Data.Set as Set
|
|
import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException())
|
|
import Handler.Utils
|
|
|
|
import qualified Ldap.Client as Ldap
|
|
import Auth.LDAP
|
|
|
|
|
|
getAdminLdapR, postAdminLdapR :: Handler Html
|
|
getAdminLdapR = postAdminLdapR
|
|
postAdminLdapR = do
|
|
((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html ->
|
|
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
|
|
|
|
let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList []))
|
|
procFormPerson lid = do
|
|
ldapPool' <- getsYesod $ view _appLdapPool
|
|
case ldapPool' of
|
|
Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
|
|
Just ldapPool -> do
|
|
addMessage Info $ text2Html "Input for LDAP test received."
|
|
ldapData <- campusUser'' ldapPool campusUserFailoverMode lid
|
|
decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
|
|
whenIsLeft decodedErr $ addMessageI Error
|
|
return ldapData
|
|
mbLdapData <- formResultMaybe presult procFormPerson
|
|
|
|
|
|
((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html ->
|
|
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
|
|
let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User)))
|
|
procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid)
|
|
mbLdapUpsert <- formResultMaybe uresult procFormUpsert
|
|
|
|
|
|
actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
|
|
siteLayoutMsg MsgMenuLdap $ do
|
|
setTitleI MsgMenuLdap
|
|
let personForm = wrapForm pwidget def
|
|
{ formAction = Just $ SomeRoute actionUrl
|
|
, formEncoding = penctype
|
|
}
|
|
upsertForm = wrapForm uwidget def
|
|
{ formAction = Just $ SomeRoute actionUrl
|
|
, formEncoding = uenctype
|
|
}
|
|
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
|
|
presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv)
|
|
|
|
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
|
$(widgetFile "ldap")
|
|
|