diff --git a/config/settings.yml b/config/settings.yml index ca2520708..05984ad70 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -41,6 +41,9 @@ health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true" health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)? health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5" +synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:604800" +synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600" + log-settings: detailed: "_env:DETAILED_LOGGING:false" all: "_env:LOG_ALL:false" diff --git a/models/users b/models/users index 0b23d02a2..223cd2b8a 100644 --- a/models/users +++ b/models/users @@ -14,6 +14,8 @@ User json -- Each Uni2work user has a corresponding row in this table; create ident (CI Text) -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date + created UTCTime default=now() + lastLdapSynchronisation UTCTime Maybe tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) firstName Text -- For export in tables, pre-split firstName from displayName diff --git a/src/Foundation.hs b/src/Foundation.hs index 1c54c1093..a40a88b4e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -3110,12 +3110,15 @@ upsertCampusUser ldapData Creds{..} = do , userNotificationSettings = def , userMailLanguages = def , userTokensIssuedAfter = Nothing + , userCreated = now + , userLastLdapSynchronisation = Just now , .. } - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName - , UserSurname =. userSurname - , UserEmail =. userEmail + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + , UserDisplayName =. userDisplayName + , UserSurname =. userSurname + , UserEmail =. userEmail + , UserLastLdapSynchronisation =. Just now ] ++ [ UserLastAuthentication =. Just now | not isDummy ] diff --git a/src/Jobs.hs b/src/Jobs.hs index ba9296216..9c9e67c72 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -66,6 +66,7 @@ import Jobs.Handler.SendCourseCommunication import Jobs.Handler.Invitation import Jobs.Handler.SendPasswordReset import Jobs.Handler.TransactionLog +import Jobs.Handler.SynchroniseLdap import Jobs.HealthReport @@ -428,11 +429,19 @@ jLocked jId act = do pruneLastExecs :: Crontab JobCtl -> DB () pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab where - ensureCrontab (Entity leId CronLastExec{..}) - | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob - , HashMap.member (JobCtlQueue job) crontab - = return () - | otherwise = delete leId + ensureCrontab (Entity leId CronLastExec{..}) = void . runMaybeT $ do + now <- liftIO getCurrentTime + flushInterval <- MaybeT . getsYesod . view $ appSettings . _appJobFlushInterval + + + if + | abs (now `diffUTCTime` cronLastExecTime) > flushInterval * 2 + -> return () + | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob + , HashMap.member (JobCtlQueue job) crontab + -> return () + | otherwise + -> lift $ delete leId determineCrontab' :: DB (Crontab JobCtl) determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 8d07f908e..36045f697 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -11,6 +11,7 @@ import qualified Data.Map as Map import Data.Semigroup (Max(..)) import Data.Time.Zones +import Data.Time.Clock.POSIX import Control.Monad.Trans.Writer (WriterT, execWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -23,7 +24,7 @@ import qualified Database.Esqueleto as E determineCrontab :: DB (Crontab JobCtl) -- ^ Extract all future jobs from the database (sheet deadlines, ...) determineCrontab = execWriterT $ do - AppSettings{..} <- getsYesod appSettings' + UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod case appJobFlushInterval of Just interval -> tell $ HashMap.singleton @@ -84,6 +85,48 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } + + if + | is _Just appLdapConf + , is _Just appLdapConf + , Just syncWithin <- appSynchroniseLdapUsersWithin + -> do + now <- liftIO getPOSIXTime + let + interval = appSynchroniseLdapUsersInterval + + (ldapEpoch, epochNow) = now `divMod'` syncWithin + ldapInterval = epochNow `div'` interval + numIntervals = floor $ syncWithin / interval + + nextIntervals = do + let + n = ceiling $ 4 * appJobCronInterval / appSynchroniseLdapUsersInterval + i <- [negate (ceiling $ n % 2) .. ceiling $ n % 2] + let + ((+ ldapEpoch) -> nextEpoch, nextInterval) = (ldapInterval + i) `divMod` numIntervals + nextIntervalTime + = posixSecondsToUTCTime $ fromInteger nextEpoch * syncWithin + fromInteger nextInterval * interval + return (nextEpoch, nextInterval, nextIntervalTime) + + forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime) -> do + $logDebugS "SynchroniseLdap" [st|currentTime: #{tshow ldapEpoch}.#{tshow epochNow}; upcomingSync: #{tshow nextEpoch}.#{tshow (fromInteger nextInterval * interval)}; upcomingData: #{tshow (numIntervals, nextEpoch, nextInterval)}|] + tell $ HashMap.singleton + (JobCtlQueue JobSynchroniseLdap + { jEpoch = fromInteger nextEpoch + , jNumIterations = fromInteger numIntervals + , jIteration = fromInteger nextInterval + }) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime + , cronRepeat = CronRepeatNever + , cronRateLimit = appSynchroniseLdapUsersInterval + , cronNotAfter = Left syncWithin + } + | otherwise + -> return () + + let sheetJobs (Entity nSheet Sheet{..}) = do tell $ HashMap.singleton diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs new file mode 100644 index 000000000..b7d695614 --- /dev/null +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -0,0 +1,55 @@ +module Jobs.Handler.SynchroniseLdap + ( dispatchJobSynchroniseLdap + , SynchroniseLdapException(..) + ) where + +import Import + +import qualified Data.Conduit.List as C +import qualified Data.CaseInsensitive as CI + +import Auth.LDAP + +data SynchroniseLdapException + = SynchroniseLdapNoLdap + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +instance Exception SynchroniseLdapException + +dispatchJobSynchroniseLdap :: Natural -> Natural -> Natural -> Handler () +dispatchJobSynchroniseLdap numIterations epoch iteration = do + UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod + case (,) <$> appLdapConf <*> appLdapPool of + Just (ldapConf, ldapPool) -> + runDB . runConduit $ + readUsers .| filterIteration .| synchroniseUser ldapConf ldapPool + Nothing -> + throwM SynchroniseLdapNoLdap + where + readUsers :: Source (YesodDB UniWorX) UserId + readUsers = selectKeys [] [] + + filterIteration :: Conduit UserId (YesodDB UniWorX) User + 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 + + MaybeT $ get userId + + synchroniseUser :: LdapConf -> LdapPool -> Sink User (YesodDB UniWorX) () + synchroniseUser conf pool = C.mapM_ $ \user -> void . runMaybeT . handleExc $ do + $logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent user}|] + + ldapAttrs <- MaybeT $ campusUser' conf pool user + void . lift $ upsertCampusUser ldapAttrs Creds + { credsIdent = CI.original $ userIdent user + , credsPlugin = "dummy" + , credsExtra = [] + } + where + handleExc + = catchMPlus (Proxy @CampusUserException) + . catchMPlus (Proxy @CampusUserConversionException) diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index 656305634..7463dea78 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -80,6 +80,7 @@ writeJobCtlBlock = writeJobCtlBlock' writeJobCtl queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX QueuedJobId queueJobUnsafe queuedJobWriteLastExec job = do + $logInfoS "queueJob" $ tshow job queuedJobCreationTime <- liftIO getCurrentTime queuedJobCreationInstance <- getsYesod appInstanceID insert QueuedJob diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 8e85020c6..bafb1db20 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -50,6 +50,10 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica } | JobTruncateTransactionLog | JobDeleteTransactionLogIPs + | JobSynchroniseLdap { jNumIterations + , jEpoch + , jIteration :: Natural + } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index 4c1d6fdfa..246c84800 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -103,7 +103,7 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim setup <- liftIO newEmptyTMVarIO ldapAsync <- allocateAsync . flip runLoggingT logFunc $ do - $logInfoS "LdapExecutor" "Starting" + $logDebugS "LdapExecutor" "Starting" res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup) case res of Left exc -> do diff --git a/src/Settings.hs b/src/Settings.hs index 7e99cae3a..5c9d0ba61 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -118,6 +118,9 @@ data AppSettings = AppSettings , appHealthCheckHTTP :: Bool , appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime + , appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime + , appSynchroniseLdapUsersInterval :: NominalDiffTime + , appInitialLogSettings :: LogSettings , appTransactionLogIPRetentionTime :: NominalDiffTime @@ -396,6 +399,9 @@ instance FromJSON AppSettings where appSessionTimeout <- o .: "session-timeout" + appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within" + appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval" + appMaximumContentLength <- o .: "maximum-content-length" appReloadTemplates <- o .:? "reload-templates" .!= defaultDev diff --git a/src/Utils.hs b/src/Utils.hs index b2913b2e1..f60c469ba 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -51,7 +51,7 @@ import Control.Arrow as Utils ((>>>)) import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) import Control.Monad.Except (MonadError(..)) import Control.Monad.Trans.Maybe as Utils (MaybeT(..)) -import Control.Monad.Catch hiding (throwM) +import Control.Monad.Catch (catchIf) import Language.Haskell.TH import Language.Haskell.TH.Instances () @@ -497,6 +497,12 @@ hoistMaybe = maybe mzero return catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a catchIfMaybeT p act = catchIf p (lift act) (const mzero) +catchMaybeT :: forall p m e a. (MonadCatch m, Exception e) => p e -> m a -> MaybeT m a +catchMaybeT _ act = catch (lift act) (const mzero :: e -> MaybeT m a) + +catchMPlus :: forall p m e a. (MonadPlus m, MonadCatch m, Exception e) => p e -> m a -> m a +catchMPlus _ = handle (const mzero :: e -> m a) + mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x:xs