75 lines
3.8 KiB
Haskell
75 lines
3.8 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Admin.ExternalUser
|
|
( getAdminExternalUserR
|
|
, postAdminExternalUserR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Foundation.Yesod.Auth (userLookupAndUpsert) -- decodeUserTest
|
|
import Auth.OAuth2 (queryOAuth2User)
|
|
import Auth.LDAP
|
|
|
|
import Handler.Utils
|
|
|
|
import Data.Aeson.Encode.Pretty (encodePretty)
|
|
import qualified Data.Text.Lazy as Lazy
|
|
import qualified Data.Text.Lazy.Encoding as Lazy
|
|
|
|
|
|
getAdminExternalUserR, postAdminExternalUserR :: Handler Html
|
|
getAdminExternalUserR = postAdminExternalUserR
|
|
postAdminExternalUserR = do
|
|
((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminExternalUserLookup"::Text) $ \html ->
|
|
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
|
|
|
|
let
|
|
-- presentUtf8 v = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> v)
|
|
-- presentLatin1 v = Text.intercalate ", " ( Text.decodeLatin1 <$> v)
|
|
|
|
procFormPerson :: Text -> Handler (Maybe [(AuthSourceIdent,Lazy.Text)]) -- (Maybe [(AuthSourceIdent, [(Text,(Int,Text,Text))])])
|
|
procFormPerson needle = getsYesod (view _appUserAuthConf) >>= \case
|
|
UserAuthConfSingleSource{..} -> case userAuthConfSingleSource of
|
|
AuthSourceConfAzureAdV2 AzureConf{..} -> do
|
|
-- only singleton results supported right now, i.e. lookups by email, userPrincipalName (aka fraport ident), or id
|
|
queryOAuth2User @Value needle >>= \case
|
|
Left _ -> addMessage Error (text2Html "Encountered UserDataException while Azure user query!") >> return Nothing
|
|
Right azureResponse -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) . Lazy.decodeUtf8 $ encodePretty azureResponse
|
|
-- Right azureData -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) $ azureData <&> \(k,vs) -> (k, (length vs, presentUtf8 vs, presentLatin1 vs))
|
|
AuthSourceConfLdap LdapConf{..} -> do
|
|
getsYesod (view _appLdapPool) >>= \case
|
|
Nothing -> addMessage Error (text2Html "LDAP Pool configuration missing!") >> return Nothing
|
|
Just pool -> do
|
|
ldapData <- ldapSearch pool needle
|
|
-- decodedErr <- decodeUserTest $ NonEmpty.singleton UpsertUserDataLdap{ upsertUserLdapHost = ldapConfSourceId, upsertUserLdapData = concat ldapData }
|
|
-- whenIsLeft decodedErr $ addMessageI Error
|
|
return . Just . singleton . (AuthSourceIdLdap ldapConfSourceId,) . Lazy.decodeUtf8 $ encodePretty ldapData
|
|
-- return . Just $ ldapData <&> \(Ldap.SearchEntry _dn attrs) -> (AuthSourceIdLdap{..}, (\(k,v) -> (tshow k, (length v, presentUtf8 v, presentLatin1 v))) <$> attrs)
|
|
|
|
mbData <- formResultMaybe presult procFormPerson
|
|
|
|
|
|
((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminExternalUserUpsert"::Text) $ \html ->
|
|
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
|
|
let procFormUpsert :: Text -> Handler (Maybe (Entity User))
|
|
procFormUpsert lid = runDB (userLookupAndUpsert lid UpsertUserGuessUser)
|
|
|
|
mbUpsert <- formResultMaybe uresult procFormUpsert
|
|
|
|
|
|
actionUrl <- fromMaybe AdminExternalUserR <$> getCurrentRoute
|
|
siteLayoutMsg MsgMenuExternalUser $ do
|
|
setTitleI MsgMenuExternalUser
|
|
let personForm = wrapForm pwidget def
|
|
{ formAction = Just $ SomeRoute actionUrl
|
|
, formEncoding = penctype
|
|
}
|
|
upsertForm = wrapForm uwidget def
|
|
{ formAction = Just $ SomeRoute actionUrl
|
|
, formEncoding = uenctype
|
|
}
|
|
$(widgetFile "admin/external-user")
|