feat(ldap): automatically synchronise user data from ldap

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"

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

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 ]
 

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

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

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)

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

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 }

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

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

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