diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 255106768..f507f651c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 \ No newline at end of file +UserLdapSync: LDAP-Synchronisieren +SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer" "Benutzern"} angestoßen +UserHijack: Sitzung übernehmen \ No newline at end of file diff --git a/routes b/routes index 2461c235c..293577bf9 100644 --- a/routes +++ b/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 diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index 9629800d1..88ad3c047 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/src/Data/Time/Clock/Instances.hs @@ -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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 75af736a3..9d8c03552 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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 diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 0549a0745..fc7b82a36 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 0b5b3bdac..a9d46dfae 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -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
  • #{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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 764c4f214..9aad2bdeb 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index b7d695614..a3f53551e 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -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) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 0e2953c6e..6b3209f6f 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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 } diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 12ee53e22..578c09217 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -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 diff --git a/templates/admin/ldapSync.hamlet b/templates/admin/ldapSync.hamlet deleted file mode 100644 index 11c7afebd..000000000 --- a/templates/admin/ldapSync.hamlet +++ /dev/null @@ -1,10 +0,0 @@ -
    -
    - _{MsgOldestLdapSynchronisation} -
    - $maybe time <- oldestLdapSync' - #{time} - $nothing - _{MsgNever} - -^{ldapSyncView}