69 lines
3.0 KiB
Haskell
69 lines
3.0 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Jobs.Handler.SynchroniseUserdb
|
|
( dispatchJobSynchroniseUserdb, dispatchJobSynchroniseUserdbUser
|
|
, SynchroniseUserdbException(..)
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import Auth.LDAP
|
|
import Foundation.Yesod.Auth (CampusUserConversionException, upsertLdapUser, upsertAzureUser)
|
|
|
|
import Jobs.Queue
|
|
|
|
|
|
data SynchroniseUserdbException
|
|
= SynchroniseUserdbNoUserdb
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
instance Exception SynchroniseUserdbException
|
|
|
|
dispatchJobSynchroniseUserdb :: Natural -> Natural -> Natural -> JobHandler UniWorX
|
|
dispatchJobSynchroniseUserdb numIterations epoch iteration
|
|
= JobHandlerAtomic . runConduit $
|
|
readUsers .| filterIteration .| sinkDBJobs
|
|
where
|
|
readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
|
|
readUsers = selectKeys [] []
|
|
|
|
filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
|
|
filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
|
|
let
|
|
userIteration, currentIteration :: Integer
|
|
userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
|
|
currentIteration = toInteger iteration `mod` toInteger numIterations
|
|
$logDebugS "SynchroniseUserdb" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
|
|
guard $ userIteration == currentIteration
|
|
|
|
return $ JobSynchroniseUserdbUser userId
|
|
|
|
dispatchJobSynchroniseUserdbUser :: UserId -> JobHandler UniWorX
|
|
dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do
|
|
UniWorX{..} <- getYesod
|
|
case appUserSourceConf of
|
|
UserSourceConfSingleSource (UserSourceLdap ldapConf) ->
|
|
runDB . void . runMaybeT . handleExc $ do
|
|
user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser
|
|
let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey
|
|
$logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with LDAP|]
|
|
-- reTestAfter <- getsYesod $ view _appUserdbRetestFailover
|
|
-- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user
|
|
ldapAttrs <- MaybeT $ ldapUser ldapConf user
|
|
void . lift $ upsertLdapUser (UpsertUserSync upsertIdent) ldapAttrs
|
|
UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf) ->
|
|
runDB . void . runMaybeT . handleExc $ do
|
|
user@User{userIdent,userAzurePrimaryKey} <- MaybeT $ get jUser
|
|
let upsertIdent = maybe userIdent CI.mk userAzurePrimaryKey
|
|
$logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with Azure|]
|
|
void . lift $ upsertAzureUser (UpsertUserSync upsertIdent) azureConf
|
|
where
|
|
handleExc :: MaybeT DB a -> MaybeT DB a
|
|
handleExc
|
|
= catchMPlus (Proxy @CampusUserException)
|
|
. catchMPlus (Proxy @CampusUserConversionException)
|