feat(users): ldap-synchronise arbitrary subsets of users
This commit is contained in:
Gregor Kleen
parent
8a46a51de2
commit
07895368dd
@ -465,6 +465,8 @@ CloseAlert: Schliessen
|
||||
|
||||
Name: Name
|
||||
MatrikelNr: Matrikelnummer
|
||||
LdapSynced: LDAP-Synchronisiert
|
||||
LdapSyncedBefore: Letzte LDAP-Synchronisation vor
|
||||
NoMatrikelKnown: Keine Matrikelnummer
|
||||
Theme: Oberflächen Design
|
||||
Favoriten: Anzahl gespeicherter Favoriten
|
||||
@ -1433,6 +1435,7 @@ CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ...,
|
||||
CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber
|
||||
|
||||
Action: Aktion
|
||||
ActionNoUsersSelected: Keine Benutzer ausgewählt
|
||||
|
||||
DBCsvDuplicateKey: Zwei Zeilen der CSV-Dateien referenzieren den selben internen Datensatz und können daher nicht verarbeitet werden.
|
||||
DBCsvDuplicateKeyTip: Entfernen Sie eine der unten aufgeführten Zeilen aus Ihren CSV-Dateien und versuchen Sie es erneut.
|
||||
@ -1591,6 +1594,6 @@ SchoolExamOffice: Prüfungsamt
|
||||
|
||||
ApplicationEditTip: Während des Bewerbungszeitraums können eigene Bewerbungen beliebig angepasst und auch wieder zurückgezogen werden.
|
||||
|
||||
BtnAdminSynchroniseLdap: Alle Ldap-Daten synchronisieren
|
||||
LdapSynchronisationQueued: LDAP-Synchronisation angestoßen
|
||||
OldestLdapSynchronisation: Älteste LDAP-Synchronisation
|
||||
UserLdapSync: LDAP-Synchronisieren
|
||||
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer" "Benutzern"} angestoßen
|
||||
UserHijack: Sitzung übernehmen
|
||||
2
routes
2
routes
@ -43,7 +43,7 @@
|
||||
/robots.txt RobotsR GET !free
|
||||
|
||||
/ HomeR GET !free
|
||||
/users UsersR GET -- no tags, i.e. admins only
|
||||
/users UsersR GET POST -- no tags, i.e. admins only
|
||||
/users/#CryptoUUIDUser AdminUserR GET POST
|
||||
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
|
||||
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
|
||||
|
||||
@ -15,6 +15,7 @@ import qualified Data.Binary as Binary
|
||||
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Calendar.Instances ()
|
||||
import Web.PathPieces
|
||||
|
||||
|
||||
instance Hashable DiffTime where
|
||||
@ -31,6 +32,10 @@ instance PersistFieldSql NominalDiffTime where
|
||||
deriving instance Generic UTCTime
|
||||
instance Hashable UTCTime
|
||||
|
||||
instance PathPiece UTCTime where
|
||||
toPathPiece = pack . formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q%z"
|
||||
fromPathPiece = parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%z" . unpack
|
||||
|
||||
|
||||
instance Binary DiffTime where
|
||||
get = fromRational <$> Binary.get
|
||||
|
||||
@ -29,43 +29,15 @@ import qualified Handler.Utils.TermCandidates as Candidates
|
||||
|
||||
-- import qualified Data.UUID.Cryptographic as UUID
|
||||
|
||||
data AdminButton = BtnAdminSynchroniseLdap
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe AdminButton
|
||||
instance Finite AdminButton
|
||||
|
||||
nullaryPathPiece ''AdminButton $ camelToPathPiece' 2
|
||||
|
||||
embedRenderMessage ''UniWorX ''AdminButton id
|
||||
|
||||
instance Button UniWorX AdminButton where
|
||||
btnClasses _ = [BCIsButton, BCPrimary]
|
||||
|
||||
|
||||
getAdminR :: Handler Html
|
||||
getAdminR = do
|
||||
((ldapSyncRes, ldapSyncView), ldapSyncEnctype) <- runFormPost $ buttonForm' [BtnAdminSynchroniseLdap]
|
||||
|
||||
formResult ldapSyncRes $ \case
|
||||
BtnAdminSynchroniseLdap -> do
|
||||
queueJob' $ JobSynchroniseLdap 1 0 0
|
||||
addMessageI Success MsgLdapSynchronisationQueued
|
||||
redirect AdminR
|
||||
|
||||
oldestLdapSync <- fmap (join . preview (_head . _Value)) . runDB . E.select . E.from $ \user -> do
|
||||
E.orderBy [E.desc . E.isNothing $ user E.^. UserLastLdapSynchronisation, E.asc $ user E.^. UserLastLdapSynchronisation]
|
||||
E.limit 1
|
||||
return $ user E.^. UserLastLdapSynchronisation
|
||||
oldestLdapSync' <- for oldestLdapSync $ formatTime SelFormatDateTime
|
||||
|
||||
|
||||
siteLayoutMsg MsgAdminHeading $ do
|
||||
setTitleI MsgAdminHeading
|
||||
wrapForm $(widgetFile "admin/ldapSync") def
|
||||
{ formAction = Just $ SomeRoute AdminR
|
||||
, formSubmit = FormNoSubmit
|
||||
, formEncoding = ldapSyncEnctype
|
||||
}
|
||||
getAdminR = -- do
|
||||
siteLayoutMsg MsgAdminHeading $ do
|
||||
setTitleI MsgAdminHeading
|
||||
[whamlet|
|
||||
This shall become the Administrators' overview page.
|
||||
Its current purpose is to provide links to some important admin functions
|
||||
|]
|
||||
|
||||
-- BEGIN - Buttons needed only here
|
||||
data ButtonCreate = CreateMath | CreateInf -- Dummy for Example
|
||||
|
||||
@ -206,11 +206,10 @@ makeCourseUserTable cid restrict colChoices psValidator = do
|
||||
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = FormSubmit
|
||||
, dbParamsFormAdditional = \csrf -> do
|
||||
(res,vw) <- mreq (selectField optionsFinite) "" Nothing
|
||||
let formWgt = toWidget csrf <> fvInput vw
|
||||
formRes = (, mempty) . First . Just <$> res
|
||||
return (formRes,formWgt)
|
||||
, dbParamsFormAdditional
|
||||
= renderAForm FormStandard
|
||||
$ (, mempty) . First . Just
|
||||
<$> areq (selectField optionsFinite) (fslI MsgAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
|
||||
@ -10,6 +10,7 @@ import Handler.Utils
|
||||
import Handler.Utils.Tokens
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
import qualified Auth.LDAP as Auth
|
||||
|
||||
@ -31,11 +32,10 @@ import Text.Hamlet (ihamlet)
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
|
||||
hijackUserForm :: CryptoUUIDUser -> Form ()
|
||||
hijackUserForm cID csrf = do
|
||||
(uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
|
||||
(btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing
|
||||
return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
|
||||
hijackUserForm :: Form ()
|
||||
hijackUserForm csrf = do
|
||||
(btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing
|
||||
return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvInput btnView])
|
||||
|
||||
-- In case of refactoring, use this:
|
||||
-- instance HasEntity (DBRow (Entity User)) User where
|
||||
@ -43,11 +43,21 @@ hijackUserForm cID csrf = do
|
||||
-- instance HasUser (DBRow (Entity USer)) where
|
||||
-- hasUser = _entityVal
|
||||
|
||||
getUsersR :: Handler Html
|
||||
getUsersR = do
|
||||
data UserAction = UserLdapSync | UserHijack
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe UserAction
|
||||
instance Finite UserAction
|
||||
nullaryPathPiece ''UserAction $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''UserAction id
|
||||
|
||||
getUsersR, postUsersR :: Handler Html
|
||||
getUsersR = postUsersR
|
||||
postUsersR = do
|
||||
let
|
||||
dbtColonnade = dbColonnade . mconcat $
|
||||
dbtColonnade = mconcat $
|
||||
[ dbRow
|
||||
, dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
|
||||
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||
(AdminUserR <$> encrypt uid)
|
||||
(nameWidget userDisplayName userSurname)
|
||||
@ -58,9 +68,10 @@ getUsersR = do
|
||||
-- (AdminUserR <$> encrypt uid)
|
||||
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
|
||||
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
|
||||
, sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
|
||||
, flip foldMap universeF $ \function ->
|
||||
sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
||||
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
|
||||
schools <- liftHandlerT . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
|
||||
E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
|
||||
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
|
||||
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
|
||||
@ -72,29 +83,43 @@ getUsersR = do
|
||||
$forall (E.Value sh) <- schools
|
||||
<li>#{sh}
|
||||
|]
|
||||
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
|
||||
cID <- encrypt uid
|
||||
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
|
||||
myUid <- liftHandlerT maybeAuthId
|
||||
when (mayHijack && Just uid /= myUid) $ do
|
||||
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm cID
|
||||
wrapForm hijackView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ AdminHijackUserR cID
|
||||
, formEncoding = hijackEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormNoSubmit
|
||||
, formAnchor = Nothing :: Maybe Text
|
||||
}
|
||||
, sortable Nothing mempty $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
|
||||
{ formCellAttrs = []
|
||||
, formCellLens = id
|
||||
, formCellContents = do
|
||||
cID <- encrypt uid
|
||||
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
|
||||
myUid <- liftHandlerT maybeAuthId
|
||||
if
|
||||
| mayHijack
|
||||
, Just uid /= myUid
|
||||
-> lift $ do
|
||||
let
|
||||
postprocess :: FormResult () -> FormResult (First UserAction, DBFormResult UserId Bool (DBRow (Entity User)))
|
||||
postprocess (FormSuccess ()) = FormSuccess (First $ Just UserHijack, DBFormResult $ Map.singleton uid (inp, const True))
|
||||
postprocess FormMissing = FormSuccess mempty
|
||||
postprocess (FormFailure errs) = FormFailure errs
|
||||
|
||||
over _1 postprocess <$> hijackUserForm mempty
|
||||
| otherwise
|
||||
-> return mempty
|
||||
}
|
||||
]
|
||||
psValidator = def
|
||||
& defaultSorting [SortAscBy "name", SortAscBy "display-name"]
|
||||
|
||||
((), userList) <- runDB $ do
|
||||
(usersRes, userList) <- runDB $ do
|
||||
schoolOptions <- map (CI.original . schoolName . entityVal &&& CI.original . unSchoolKey . entityKey)
|
||||
<$> selectList [] [Asc SchoolName]
|
||||
|
||||
dbTable psValidator DBTable
|
||||
let
|
||||
postprocess :: FormResult (First UserAction, DBFormResult UserId Bool (DBRow (Entity User))) -> FormResult (UserAction, Set UserId)
|
||||
postprocess inp = do
|
||||
(First (Just act), usrMap) <- inp
|
||||
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||
return (act, usrSet)
|
||||
|
||||
over _1 postprocess <$> dbTable psValidator DBTable
|
||||
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
, dbtRowKey = (E.^. UserId)
|
||||
, dbtColonnade
|
||||
@ -112,6 +137,9 @@ getUsersR = do
|
||||
, ( "auth-ldap"
|
||||
, SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
|
||||
)
|
||||
, ( "ldap-sync"
|
||||
, SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
|
||||
)
|
||||
]
|
||||
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
|
||||
[ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
|
||||
@ -135,33 +163,68 @@ getUsersR = do
|
||||
E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId
|
||||
E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools
|
||||
)
|
||||
, ( "ldap-sync", FilterColumn $ \user criteria -> if
|
||||
| Just criteria' <- fromNullable criteria
|
||||
-> let minTime = minimum (criteria' :: NonNull (Set UTCTime))
|
||||
in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
|
||||
| otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
)
|
||||
]
|
||||
, dbtFilterUI = \mPrev -> mconcat
|
||||
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
|
||||
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
|
||||
-- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt textField (fslI MsgMatrikelNr)
|
||||
, prismAForm (singletonFilter "matriculation" ) mPrev $ aopt matriculationField (fslI MsgMatrikelNr)
|
||||
, prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` radioFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
|
||||
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
|
||||
, prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgMatrikelNr)
|
||||
, prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
|
||||
, prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
|
||||
, prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
|
||||
]
|
||||
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
, dbtParams = def
|
||||
, dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Just $ SomeRoute UsersR
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = FormSubmit
|
||||
, dbParamsFormAdditional
|
||||
= renderAForm FormStandard
|
||||
$ (, mempty) . First . Just
|
||||
<$> areq (selectField $ optionsF [UserLdapSync]) (fslI MsgAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
, dbtIdent = "users" :: Text
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
, dbtCsvDecode = Nothing
|
||||
}
|
||||
|
||||
formResult usersRes $ \case
|
||||
(_, usersSet)
|
||||
| Set.null usersSet -> do
|
||||
addMessageI Info MsgActionNoUsersSelected
|
||||
redirect UsersR
|
||||
(UserLdapSync, userSet) -> do
|
||||
runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid
|
||||
addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
|
||||
redirect UsersR
|
||||
(UserHijack, Set.minView -> Just (uid, _)) ->
|
||||
hijackUser uid >>= sendResponse
|
||||
_other -> error "Should not be possible"
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI MsgUserListTitle
|
||||
$(widgetFile "users")
|
||||
|
||||
hijackUser :: UserId -> Handler TypedContent
|
||||
hijackUser uid = do
|
||||
User{userIdent} <- runDB $ get404 uid
|
||||
setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
|
||||
|
||||
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
|
||||
postAdminHijackUserR cID = do
|
||||
uid <- decrypt cID
|
||||
((hijackRes, _), _) <- runFormPost $ hijackUserForm cID
|
||||
((hijackRes, _), _) <- runFormPost hijackUserForm
|
||||
|
||||
ret <- formResultMaybe hijackRes $ \() -> Just <$> do
|
||||
User{userIdent} <- runDB $ get404 uid
|
||||
setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
|
||||
ret <- formResultMaybe hijackRes $ \() -> Just <$> hijackUser uid
|
||||
|
||||
maybe (redirect UsersR) return ret
|
||||
|
||||
|
||||
@ -31,7 +31,7 @@ module Handler.Utils.Table.Pagination
|
||||
, linkEitherCell, linkEitherCellM, linkEitherCellM'
|
||||
, cellTooltip
|
||||
, listCell
|
||||
, formCell, DBFormResult, getDBFormResult
|
||||
, formCell, DBFormResult(..), getDBFormResult
|
||||
, dbRow, dbSelect
|
||||
, (&)
|
||||
, module Control.Monad.Trans.Maybe
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
module Jobs.Handler.SynchroniseLdap
|
||||
( dispatchJobSynchroniseLdap
|
||||
( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser
|
||||
, SynchroniseLdapException(..)
|
||||
) where
|
||||
|
||||
@ -10,25 +10,23 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
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 -> 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
|
||||
dispatchJobSynchroniseLdap numIterations epoch iteration
|
||||
= runDBJobs . runConduit $
|
||||
readUsers .| filterIteration .| sinkDBJobs
|
||||
where
|
||||
readUsers :: Source (YesodDB UniWorX) UserId
|
||||
readUsers :: Source (YesodJobDB UniWorX) UserId
|
||||
readUsers = selectKeys [] []
|
||||
|
||||
filterIteration :: Conduit UserId (YesodDB UniWorX) User
|
||||
filterIteration :: Conduit UserId (YesodJobDB UniWorX) Job
|
||||
filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
|
||||
let
|
||||
userIteration, currentIteration :: Integer
|
||||
@ -37,19 +35,27 @@ dispatchJobSynchroniseLdap numIterations epoch iteration = do
|
||||
$logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
|
||||
guard $ userIteration == currentIteration
|
||||
|
||||
MaybeT $ get userId
|
||||
return $ JobSynchroniseLdapUser 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)
|
||||
dispatchJobSynchroniseLdapUser :: UserId -> Handler ()
|
||||
dispatchJobSynchroniseLdapUser jUser = do
|
||||
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
|
||||
case (,) <$> appLdapConf <*> appLdapPool of
|
||||
Just (ldapConf, ldapPool) ->
|
||||
runDB . void . runMaybeT . handleExc $ do
|
||||
user@User{userIdent} <- MaybeT $ get jUser
|
||||
|
||||
$logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent}|]
|
||||
|
||||
ldapAttrs <- MaybeT $ campusUser' ldapConf ldapPool user
|
||||
void . lift $ upsertCampusUser ldapAttrs Creds
|
||||
{ credsIdent = CI.original userIdent
|
||||
, credsPlugin = "dummy"
|
||||
, credsExtra = []
|
||||
}
|
||||
Nothing ->
|
||||
throwM SynchroniseLdapNoLdap
|
||||
where
|
||||
handleExc
|
||||
= catchMPlus (Proxy @CampusUserException)
|
||||
. catchMPlus (Proxy @CampusUserConversionException)
|
||||
|
||||
@ -55,6 +55,8 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
|
||||
, jEpoch
|
||||
, jIteration :: Natural
|
||||
}
|
||||
| JobSynchroniseLdapUser { jUser :: UserId
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
| NotificationSheetActive { nSheet :: SheetId }
|
||||
|
||||
@ -489,14 +489,14 @@ reorderField optList = Field{..}
|
||||
withNum t n = tshow n <> "." <> t
|
||||
$(widgetFile "widgets/permutation/permutation")
|
||||
|
||||
optionsFinite :: ( MonadHandler m
|
||||
, Finite a
|
||||
, RenderMessage site a
|
||||
, HandlerSite m ~ site
|
||||
, PathPiece a
|
||||
)
|
||||
=> m (OptionList a)
|
||||
optionsFinite = do
|
||||
optionsF :: ( MonadHandler m
|
||||
, RenderMessage site (Element mono)
|
||||
, HandlerSite m ~ site
|
||||
, PathPiece (Element mono)
|
||||
, MonoFoldable mono
|
||||
)
|
||||
=> mono -> m (OptionList (Element mono))
|
||||
optionsF (otoList -> opts) = do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
mkOption a = Option
|
||||
@ -504,7 +504,17 @@ optionsFinite = do
|
||||
, optionInternalValue = a
|
||||
, optionExternalValue = toPathPiece a
|
||||
}
|
||||
return . mkOptionList $ mkOption <$> universeF
|
||||
return . mkOptionList $ mkOption <$> opts
|
||||
|
||||
|
||||
optionsFinite :: ( MonadHandler m
|
||||
, Finite a
|
||||
, RenderMessage site a
|
||||
, HandlerSite m ~ site
|
||||
, PathPiece a
|
||||
)
|
||||
=> m (OptionList a)
|
||||
optionsFinite = optionsF universeF
|
||||
|
||||
fractionalField :: forall m a.
|
||||
( RealFrac a
|
||||
|
||||
@ -1,10 +0,0 @@
|
||||
<dl>
|
||||
<dt>
|
||||
_{MsgOldestLdapSynchronisation}
|
||||
<dd>
|
||||
$maybe time <- oldestLdapSync'
|
||||
#{time}
|
||||
$nothing
|
||||
_{MsgNever}
|
||||
|
||||
^{ldapSyncView}
|
||||
Loading…
Reference in New Issue
Block a user