fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(auth): implement fetchUserData, generalized version of azureUser and ldapUser

Browse Source
This commit is contained in:
Sarah Vaupel 2024-03-07 05:38:39 +01:00
parent 4feb05a02e
commit aca5a79de2
3 changed files with 182 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Auth/LDAP.hs
View File

@ -116,6 +116,7 @@ ldapUserEmail = Ldap.Attr "mail" :|
] ]
-- TODO: deprecate in favour of FetchUserDataException
data LdapUserException = LdapUserLdapError LdapPoolError data LdapUserException = LdapUserLdapError LdapPoolError
| LdapUserNoResult | LdapUserNoResult
| LdapUserAmbiguous | LdapUserAmbiguous
@ -182,6 +183,7 @@ ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . Ld
-- where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey -- where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey
-- TODO: deprecate in favour of fetchUserData
ldapUser :: ( MonadMask m ldapUser :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
--, MonadLogger m --, MonadLogger m

68
src/Auth/OAuth2.hs
View File

@ -7,7 +7,7 @@
module Auth.OAuth2 module Auth.OAuth2
( apAzure ( apAzure
, azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage
, azureUser, azureUser' -- , azureUser, azureUser'
, AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous
, apAzureMock , apAzureMock
, azureMockServer , azureMockServer
@ -15,7 +15,7 @@ module Auth.OAuth2
, refreshOAuth2Token , refreshOAuth2Token
) where ) where
import qualified Data.CaseInsensitive as CI -- import qualified Data.CaseInsensitive as CI
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Text import Data.Text
@ -33,6 +33,7 @@ apAzure :: Text
apAzure = "AzureADv2" apAzure = "AzureADv2"
-- TODO: deprecate in favour of FetchUserDataException
data AzureUserException = AzureUserError data AzureUserException = AzureUserError
| AzureUserNoResult | AzureUserNoResult
| AzureUserAmbiguous | AzureUserAmbiguous
@ -56,28 +57,49 @@ azureUserPreferredLanguage = "preferredLanguage"
-- | User lookup in Microsoft Graph with given credentials -- | User lookup in Microsoft Graph with given credentials
azureUser :: ( MonadMask m -- TODO: deprecate in favour of fetchUserData
, MonadHandler m -- azureUser :: ( MonadMask m
) -- , MonadHandler m
=> AzureConf -- -- , HandlerSite m ~ site
-> Creds site -- -- , BackendCompatible SqlBackend (YesodPersistBackend site)
-> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])]) -- -- , BaseBackend (YesodPersistBackend site) ~ SqlBackend
azureUser _conf Creds{..} = fmap throwLeft . runExceptT $ do -- -- , YesodPersist site
results <- queryOAuth2User @[(Text, [ByteString])] credsIdent -- -- , PersistUniqueWrite (YesodPersistBackend site)
case results of -- )
Left _ -> throwE AzureUserNoResult -- => AzureConf
Right [res] -> return res -- -> Creds site
Right _multiple -> throwE AzureUserAmbiguous -- -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])])
-- azureUser AzureConf{..} Creds{..} = fmap throwLeft . runExceptT $ do
-- now <- liftIO getCurrentTime
-- results <- queryOAuth2User @[(Text, [ByteString])] credsIdent
-- case results of
-- Right [res] -> do
-- -- void . liftHandler . runDB $ upsert ExternalUser
-- -- { externalUserUser = error "no userid" -- TODO: use azureUserPrimaryKey once UserIdent is referenced instead of UserId
-- -- , externalUserSource = AuthSourceIdAzure azureConfClientId
-- -- , externalUserData = toJSON res
-- -- , externalUserLastSync = now
-- -- }
-- -- [ ExternalUserData =. toJSON res
-- -- , ExternalUserLastSync =. now
-- -- ]
-- return res
-- Right _multiple -> throwE AzureUserAmbiguous
-- Left _ -> throwE AzureUserNoResult
-- | User lookup in Microsoft Graph with given user -- | User lookup in Microsoft Graph with given user
azureUser' :: ( MonadMask m -- azureUser' :: ( MonadMask m
, MonadHandler m -- , MonadHandler m
) -- , HandlerSite m ~ site
=> AzureConf -- , BaseBackend (YesodPersistBackend site) ~ SqlBackend
-> User -- , YesodPersist site
-> m (Maybe [(Text, [ByteString])]) -- (Either AzureUserException [(Text, [ByteString])]) -- , PersistUniqueWrite (YesodPersistBackend site)
azureUser' conf User{userIdent} -- )
= runMaybeT . catchIfMaybeT (is _AzureUserNoResult) $ azureUser conf (Creds apAzure (CI.original userIdent) []) -- => AzureConf
-- -> User
-- -> ReaderT (YesodPersistBackend site) m (Maybe [(Text, [ByteString])]) -- (Either AzureUserException [(Text, [ByteString])])
-- azureUser' conf User{userIdent}
-- = runMaybeT . catchIfMaybeT (is _AzureUserNoResult) $ azureUser conf (Creds apAzure (CI.original userIdent) [])
---------------------------------------- ----------------------------------------
@ -183,7 +205,7 @@ refreshOAuth2Token (_, rToken) url secure
clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID" clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID"
clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET" clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET"
return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")] return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")]
else return $ ("scope", "ID Profile") : body else return $ scopeParam " " ["ID","Profile"] : body
$logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure }) $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure })
eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure }) eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure })
case eResult of case eResult of

223
src/Foundation/Yesod/Auth.hs
View File

@ -4,7 +4,7 @@
module Foundation.Yesod.Auth module Foundation.Yesod.Auth
( authenticate ( authenticate
, ldapLookupAndUpsert -- TODO generalize -- , ldapLookupAndUpsert -- TODO: remove in favour of fetchUserData
, upsertUser , upsertUser
, decodeUserTest , decodeUserTest
, UserConversionException(..) , UserConversionException(..)
@ -35,6 +35,7 @@ import qualified Control.Monad.Catch as C (Handler(..))
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.List.NonEmpty as NonEmpty (toList)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
@ -55,7 +56,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
$logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only $logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
userAuthConf <- getsYesod $ view _appUserAuthConf userAuthConf <- getsYesod $ view _appUserAuthConf -- TODO: debug only
$logErrorS "authenticate AuthConf Debug" $ "\27[31m" <> tshow userAuthConf <> "\27[0m" -- TODO: debug only $logErrorS "authenticate AuthConf Debug" $ "\27[31m" <> tshow userAuthConf <> "\27[0m" -- TODO: debug only
let let
@ -77,27 +78,15 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
= return res = return res
excHandlers = excHandlers =
-- TODO: merge ldap and azure exception types [ C.Handler $ \(fExc :: FetchUserDataException) -> case fExc of
[ C.Handler $ \(ldapExc :: LdapUserException) -> case ldapExc of FetchUserDataNoResult -> do
LdapUserNoResult -> do $logWarnS "FetchUserException" $ "User lookup failed after successful login for " <> credsIdent
$logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent
excRecovery . UserError $ IdentifierNotFound credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent
LdapUserAmbiguous -> do FetchUserDataAmbiguous -> do
$logWarnS "Auth" $ "Multiple LDAP auth results for " <> credsIdent $logWarnS "FetchUserException" $ "Multiple User results for " <> credsIdent
excRecovery . UserError $ IdentifierNotFound credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent
err -> do err -> do
$logErrorS "Auth" $ tshow err $logErrorS "FetchUserException" $ tshow err
mr <- getMessageRender
excRecovery . ServerError $ mr MsgInternalLoginError
, C.Handler $ \case
AzureUserNoResult -> do
$logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent
excRecovery . UserError $ IdentifierNotFound credsIdent
AzureUserAmbiguous -> do
$logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent
excRecovery . UserError $ IdentifierNotFound credsIdent
err -> do
$logErrorS "OAuth" $ tshow err
mr <- getMessageRender mr <- getMessageRender
excRecovery . ServerError $ mr MsgInternalLoginError excRecovery . ServerError $ mr MsgInternalLoginError
, C.Handler $ \(cExc :: UserConversionException) -> do , C.Handler $ \(cExc :: UserConversionException) -> do
@ -123,22 +112,27 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
flip catches excHandlers $ if flip catches excHandlers $ if
| not isDummy, not isOther | not isDummy, not isOther
, UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf -- , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf
, Just upsertMode' <- upsertMode -> do , Just upsertMode' <- upsertMode -> do
upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..} userData <- fetchUserData upsertMode' Creds{..}
$logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData
Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..} Authenticated . entityKey <$> upsertUser upsertMode' userData
| not isDummy, not isOther -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
, UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf -- upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
, Just upsertMode' <- upsertMode -> do -- $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
upsertUserLdapData <- ldapUser ldapPool Creds{..} -- | not isDummy, not isOther
$logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData -- , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf
Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..} -- , Just upsertMode' <- upsertMode -> do
-- ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
-- upsertUserLdapData <- ldapUser ldapPool Creds{..}
-- $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
-- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
| otherwise | otherwise
-> acceptExisting -> acceptExisting
-- TODO: rename to DecodeUserException (associate with function!)
data UserConversionException data UserConversionException
= UserInvalidIdent = UserInvalidIdent
| UserInvalidEmail | UserInvalidEmail
@ -175,33 +169,75 @@ _upsertUserMode mMode cs@Creds{..}
defaultOther = apHash defaultOther = apHash
-- TODO: generalize data FetchUserDataException
ldapLookupAndUpsert :: forall m. = FetchUserDataNoResult
( MonadHandler m | FetchUserDataAmbiguous
, HandlerSite m ~ UniWorX | FetchUserDataException
, MonadMask m deriving (Eq, Ord, Read, Show, Generic)
, MonadUnliftIO m deriving anyclass (Exception)
)
=> Text -- TODO: deprecate in favour of fetchUserData
-> SqlPersistT m (Entity User) -- ldapLookupAndUpsert :: forall m.
ldapLookupAndUpsert ident = -- ( MonadHandler m
getsYesod (view _appLdapPool) >>= \case -- , HandlerSite m ~ UniWorX
Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." -- , MonadMask m
Just ldapPool@(upsertUserLdapConf, _) -> -- , MonadUnliftIO m
ldapUser'' ldapPool ident >>= \case -- )
Nothing -> throwM LdapUserNoResult -- => Text
Just upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..} -- -> SqlPersistT m (Entity User)
-- ldapLookupAndUpsert ident =
-- getsYesod (view _appLdapPool) >>= \case
-- Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
-- Just ldapPool ->
-- ldapUser'' ldapPool ident >>= \case
-- Nothing -> throwM LdapUserNoResult
-- Just ldapData -> upsertUser UpsertUserGuessUser ldapData
-- | Fetch user data with given credentials from external source(s)
fetchUserData :: forall m site.
( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
)
=> UpsertUserMode
-> Creds site
-> SqlPersistT m (NonEmpty UpsertUserData)
fetchUserData upsertMode creds@Creds{..} = do
userAuthConf <- getsYesod $ view _appUserAuthConf
now <- liftIO getCurrentTime
results :: NonEmpty UpsertUserData <- case userAuthConf of
UserAuthConfSingleSource{..} -> fmap throwLeft . runExceptT $ case userAuthConfSingleSource of
AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do
queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case
Right upsertUserAzureData -> return UpsertUserDataAzure{..}
Left _ -> throwE FetchUserDataNoResult
AuthSourceConfLdap LdapConf{..} -> do
ldapPool <- fmap (fromMaybe $ error "LDAP source configured, but no LDAP pool initialized") . getsYesod $ view _appLdapPool
UpsertUserDataLdap ldapConfSourceId <$> ldapUser ldapPool creds
-- insert ExternalUser entries for each fetched dataset
forM_ results $ \res ->
let externalUserUser = error "no userid" -- TODO: use azureUserPrimaryKey/ldapPrimaryKey once UserIdent is referenced instead of UserId
externalUserLastSync = now
(externalUserData, externalUserSource) = case res of
UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId)
UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost)
in void . liftHandler . runDB $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]
return results
-- | Upsert User and related auth in DB according to given external source data (does not query source itself) -- | Upsert User and related auth in DB according to given external source data (does not query source itself)
upsertUser :: forall m. upsertUser :: forall m.
( MonadHandler m ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadCatch m , MonadCatch m
) )
=> UpsertUserMode => UpsertUserMode
-> UpsertUserData -> NonEmpty UpsertUserData
-> SqlPersistT m (Entity User) -> SqlPersistT m (Entity User)
upsertUser _upsertMode upsertData = do upsertUser _upsertMode upsertData = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults userDefaultConf <- getsYesod $ view _appUserDefaults
@ -234,7 +270,7 @@ upsertUser _upsertMode upsertData = do
let let
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
userSystemFunctions' = case upsertData of userSystemFunctions' = concat $ upsertData <&> \case
UpsertUserDataAzure{..} -> do UpsertUserDataAzure{..} -> do
(_k, v) <- upsertUserAzureData (_k, v) <- upsertUserAzureData
v' <- v v' <- v
@ -259,7 +295,7 @@ decodeUser :: ( MonadThrow m
) )
=> UTCTime -- ^ Now => UTCTime -- ^ Now
-> UserDefaultConf -> UserDefaultConf
-> UpsertUserData -- ^ Raw source data -> NonEmpty UpsertUserData -- ^ Raw source data
-> m (User,_) -- ^ Data for new User entry and updating existing User entries -> m (User,_) -- ^ Data for new User entry and updating existing User entries
decodeUser now UserDefaultConf{..} upsertData = do decodeUser now UserDefaultConf{..} upsertData = do
userIdent <- if userIdent <- if
@ -275,35 +311,47 @@ decodeUser now UserDefaultConf{..} upsertData = do
-> throwM UserInvalidIdent -> throwM UserInvalidIdent
let let
(userSurname, userFirstName, userDisplayName, userEmail, userTelephone, userMobile, userCompanyPersonalNumber, userCompanyDepartment, userLanguages) (azureSurname, azureFirstName, azureDisplayName, azureEmail, azureTelephone, azureMobile, azureLanguages)
| Just azureData <- mbAzureData | Just azureData <- mbAzureData
= ( azureData `decodeAzure'` azureUserSurname = ( azureData `decodeAzure` azureUserSurname
, azureData `decodeAzure'` azureUserGivenName , azureData `decodeAzure` azureUserGivenName
, azureData `decodeAzure'` azureUserDisplayName , azureData `decodeAzure` azureUserDisplayName
, CI.mk $ , azureData `decodeAzure` azureUserMail
azureData `decodeAzure'` azureUserMail , azureData `decodeAzure` azureUserTelephone
, azureData `decodeAzure` azureUserTelephone , azureData `decodeAzure` azureUserMobile
, azureData `decodeAzure` azureUserMobile , Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
, Nothing -- userCompanyPersonalNumber not contained in Azure response
, Nothing -- userCompanyDepartment not contained in Azure response
, Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
)
| Just ldapData <- mbLdapData
= ( ldapData `decodeLdap'` ldapUserSurname
, ldapData `decodeLdap'` ldapUserFirstName
, ldapData `decodeLdap'` ldapUserDisplayName
, CI.mk $
ldapData `decodeLdap'` (Ldap.Attr "mail") -- TODO: use ldapUserEmail?
, ldapData `decodeLdap` ldapUserTelephone
, ldapData `decodeLdap` ldapUserMobile
, ldapData `decodeLdap` ldapUserFraportPersonalnummer
, ldapData `decodeLdap` ldapUserFraportAbteilung
, Nothing -- userLanguage not contained in LDAP response
) )
| otherwise | otherwise
= error "decodeUser: Both azureData and ldapData are empty, cannot decode basic fields from no data!" = ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
(ldapSurname, ldapFirstName, ldapDisplayName, ldapEmail, ldapTelephone, ldapMobile, ldapCompanyPersonalNumber, ldapCompanyDepartment)
| Just ldapData <- mbLdapData
= ( ldapData `decodeLdap` ldapUserSurname
, ldapData `decodeLdap` ldapUserFirstName
, ldapData `decodeLdap` ldapUserDisplayName
, ldapData `decodeLdap` (Ldap.Attr "mail") -- TODO: use ldapUserEmail?
, ldapData `decodeLdap` ldapUserTelephone
, ldapData `decodeLdap` ldapUserMobile
, ldapData `decodeLdap` ldapUserFraportPersonalnummer
, ldapData `decodeLdap` ldapUserFraportAbteilung
)
| otherwise
= ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
-- TODO: throw on collisions?
-- TODO: use user-auth precedence from app config when implementing multi-source support
let let
userSurname = fromMaybe mempty $ azureSurname <|> ldapSurname
userFirstName = fromMaybe mempty $ azureFirstName <|> ldapFirstName
userDisplayName = fromMaybe mempty $ azureDisplayName <|> ldapDisplayName
userEmail = maybe mempty CI.mk $ azureEmail <|> ldapEmail
userTelephone = azureTelephone <|> ldapTelephone
userMobile = azureMobile <|> ldapMobile
userLanguages = azureLanguages
userCompanyPersonalNumber = ldapCompanyPersonalNumber
userCompanyDepartment = ldapCompanyDepartment
newUser = User newUser = User
{ userMaxFavourites = userDefaultMaxFavourites { userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
@ -349,10 +397,9 @@ decodeUser now UserDefaultConf{..} upsertData = do
where where
mbAzureData :: Maybe (Map Text [ByteString]) mbAzureData :: Maybe (Map Text [ByteString])
mbAzureData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserAzureData upsertData mbAzureData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData
mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString
mbLdapData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserLdapData upsertData mbLdapData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData
-- ldapData = fmap (Map.fromListWith (++)) $ upsertData ^? _upsertUserLdapData . over _2 (filter $ not . ByteString.null)
-- just returns Nothing on error, pure -- just returns Nothing on error, pure
decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text
@ -360,10 +407,10 @@ decodeUser now UserDefaultConf{..} upsertData = do
decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text
decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr
decodeAzure' :: Map Text [ByteString] -> Text -> Text -- decodeAzure' :: Map Text [ByteString] -> Text -> Text
decodeAzure' azureData = fromMaybe "" . decodeAzure azureData -- decodeAzure' azureData = fromMaybe "" . decodeAzure azureData
decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text -- decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text
decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData -- decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData
-- accept the first successful decoding or empty; only throw an error if all decodings fail -- accept the first successful decoding or empty; only throw an error if all decodings fail
-- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text) -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
-- decodeLdap' attr err -- decodeLdap' attr err
@ -393,7 +440,7 @@ decodeUserTest :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadCatch m , MonadCatch m
) )
=> UpsertUserData => NonEmpty UpsertUserData
-> m (Either UserConversionException (User, [Update User])) -> m (Either UserConversionException (User, [Update User]))
decodeUserTest decodeData = do decodeUserTest decodeData = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime