59 lines
2.1 KiB
Haskell
59 lines
2.1 KiB
Haskell
module Jobs.Handler.SynchroniseLdap
|
|
( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser
|
|
, SynchroniseLdapException(..)
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import Auth.LDAP
|
|
|
|
import Jobs.Queue
|
|
|
|
|
|
data SynchroniseLdapException
|
|
= SynchroniseLdapNoLdap
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
instance Exception SynchroniseLdapException
|
|
|
|
dispatchJobSynchroniseLdap :: Natural -> Natural -> Natural -> JobHandler UniWorX
|
|
dispatchJobSynchroniseLdap 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 "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
|
|
guard $ userIteration == currentIteration
|
|
|
|
return $ JobSynchroniseLdapUser userId
|
|
|
|
dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX
|
|
dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
|
|
UniWorX{..} <- getYesod
|
|
case appLdapPool of
|
|
Just ldapPool ->
|
|
runDB . void . runMaybeT . handleExc $ do
|
|
user@User{userIdent} <- MaybeT $ get jUser
|
|
|
|
$logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent}|]
|
|
|
|
reTestAfter <- getsYesod $ view _appLdapReTestFailover
|
|
ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user
|
|
void . lift $ upsertCampusUser UpsertCampusUser ldapAttrs
|
|
Nothing ->
|
|
throwM SynchroniseLdapNoLdap
|
|
where
|
|
handleExc :: MaybeT DB a -> MaybeT DB a
|
|
handleExc
|
|
= catchMPlus (Proxy @CampusUserException)
|
|
. catchMPlus (Proxy @CampusUserConversionException)
|