diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 068c6b2d1..f32d016e8 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -122,6 +122,8 @@ MenuCourseEventEdit: Kursarttermin bearbeiten MenuLanguage: Sprache MenuQualifications: Qualifikationen +MenuQualificationEdit: Bearbeiten +MenuQualificationNew: Neue Qualifikation erstellen MenuLms !ident-ok: E‑Learning MenuLmsUser: Benutzerqualifikationen MenuLmsUserSchool: Bereichs Benutzerqualifikationen diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 608dd289e..c2d78331e 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -122,6 +122,8 @@ MenuCourseEventEdit: Edit course category occurrence MenuLanguage: Language MenuQualifications: Qualifications +MenuQualificationEdit: Edit +MenuQualificationNew: Create new qualification MenuLms: E‑learning MenuLmsUser: User Qualifications MenuLmsUserSchool: Department User Qualifications diff --git a/routes b/routes index 21b3dd7c0..e98c74113 100644 --- a/routes +++ b/routes @@ -280,11 +280,13 @@ !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -/qualification QualificationAllR GET !free -/qualification/#SchoolId QualificationSchoolR GET !free -/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free +/qualification QualificationAllR GET !free +/qualification/#SchoolId QualificationSchoolR GET !free +!/qualification/#SchoolId/new QualificationNewR GET POST -- not free +/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free +/qualification/#SchoolId/#QualificationShorthand/edit QualificationEditR GET POST -- not free -- /qualification/#SchoolId/#QualificationShorthand/#CryptoUUIDUser QualificationUserR GET -- see LmsUserR -/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement +/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement -- LMS diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 095553921..a96d74073 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -186,12 +186,14 @@ breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing -breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs +breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh return (CI.original $ unSchoolKey ssh, Just QualificationAllR) +breadcrumb (QualificationNewR ssh ) = i18nCrumb MsgMenuQualificationNew $ Just $ QualificationSchoolR ssh breadcrumb (QualificationR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ QualificationSchoolR ssh) $ do guardM . lift . existsBy $ SchoolQualificationShort ssh qsh return (CI.original qsh, Just $ QualificationSchoolR ssh) +breadcrumb (QualificationEditR ssh qsh) = i18nCrumb MsgMenuQualificationEdit $ Just $ QualificationR ssh qsh breadcrumb QualificationSAPDirectR = i18nCrumb MsgMenuSap $ Just QualificationAllR -- never displayed breadcrumb LmsAllR = i18nCrumb MsgMenuLms Nothing @@ -2420,6 +2422,20 @@ pageActions ParticipantsListR = return , navChildren = [] } ] +pageActions QualificationAllR = do + schools <- useRunDB $ selectList [] [Asc SchoolShorthand] -- selectKeysList here mysteriously leads to runtime error: InternalError "selectKeysImpl:" School: keyFromValues failed + return [ NavPageActionSecondary { navLink = defNavLink (SomeMessage $ unSchoolKey sid) (QualificationSchoolR sid) } | Entity{entityKey=sid} <- schools ] +pageActions (QualificationSchoolR sid) = return + [ NavPageActionSecondary { + navLink = defNavLink MsgMenuQualificationNew $ QualificationNewR sid + } + ] +pageActions (QualificationR sid qsh) = return + [ NavPageActionSecondary { + navLink = defNavLink MsgMenuQualificationEdit $ QualificationEditR sid qsh + } + ] + pageActions (LmsR sid qsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgMenuLmsLearners $ LmsLearnersR sid qsh diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index b8e72abd7..d271019d1 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -112,6 +112,9 @@ resultAllQualificationTotal = _dbrOutput . _3 . _unValue resultAllQualificationOrphans :: Lens' AllQualificationTableData Word64 resultAllQualificationOrphans = _dbrOutput . _4 . _unValue +resultAllQualificationOrphans :: Lens' AllQualificationTableData Word64 +resultAllQualificationOrphans = _dbrOutput . _4 . _unValue + mkLmsAllTable :: Bool -> DB (Any, Widget) mkLmsAllTable isAdmin = do diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 67d686446..6fabad5b0 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,6 +9,8 @@ module Handler.Qualification ( getQualificationAllR , getQualificationSchoolR , getQualificationR, postQualificationR + , getQualificationNewR, postQualificationNewR + , getQualificationEditR, postQualificationEditR ) where @@ -34,18 +36,22 @@ import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH - -- import Handler.Utils.Qualification (validQualification) +import Handler.Qualification.Edit as Handler.Qualification getQualificationSchoolR :: SchoolId -> Handler Html -getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) +-- getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) +getQualificationSchoolR ssh = do + qualiTable <- runDB $ view _2 <$> mkQualificationAllTable (Just ssh) + let heading = SomeMessages [SomeMessage MsgMenuQualifications, SomeMessage $ unSchoolKey ssh] + siteLayoutMsg heading $ do + setTitleI heading + $(widgetFile "qualification-all") getQualificationAllR :: Handler Html getQualificationAllR = do - isAdmin <- hasReadAccessTo AdminR - qualiTable <- runDB $ do - view _2 <$> mkQualificationAllTable isAdmin + qualiTable <- runDB $ view _2 <$> mkQualificationAllTable Nothing siteLayoutMsg MsgMenuQualifications $ do setTitleI MsgMenuQualifications $(widgetFile "qualification-all") @@ -61,9 +67,10 @@ resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal = _dbrOutput . _3 . _unValue -mkQualificationAllTable :: Bool -> DB (Any, Widget) -mkQualificationAllTable isAdmin = do - svs <- getSupervisees +mkQualificationAllTable :: Maybe SchoolId -> DB (Any, Widget) +mkQualificationAllTable ssh = do + isAdmin <- hasReadAccessTo AdminR + svs <- getSupervisees False now <- liftIO getCurrentTime let resultDBTable = DBTable{..} @@ -77,6 +84,7 @@ mkQualificationAllTable isAdmin = do cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser + whenIsJust ssh $ E.where_ . ((quali Ex.^. QualificationSchool) E.==.) . E.val return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) dbtProj = dbtProjId @@ -125,13 +133,13 @@ mkQualificationAllTable isAdmin = do ] dbtFilter = mconcat [ - fltrSchool $ to (E.^. QualificationSchool) - , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) + -- fltrSchool $ to (E.^. QualificationSchool) + singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) ] dbtFilterUI = mconcat [ - fltrSchoolUI - , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) + -- guardMonoid (isNothing ssh) fltrSchoolUI + \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def @@ -355,7 +363,7 @@ mkQualificationTable :: -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do - svs <- getSupervisees + svs <- getSupervisees True now <- liftIO getCurrentTime -- lookup all companies cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do diff --git a/src/Handler/Qualification/Edit.hs b/src/Handler/Qualification/Edit.hs index 3ad537260..36a3403db 100644 --- a/src/Handler/Qualification/Edit.hs +++ b/src/Handler/Qualification/Edit.hs @@ -112,4 +112,4 @@ handleQualificationEdit ssh templ = do $maybe _ <- templ

_{MsgQualificationEditNote} - |] \ No newline at end of file + |] diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index bffa9a2ea..80ad8f6ac 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -216,12 +216,15 @@ getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do E.where_ $ usr E.^. UserId `E.in_` E.vals uids return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId --- | return underlings for currently logged in user -getSupervisees :: DB (Set UserId) -getSupervisees = do - uid <- requireAuthId - svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] - return $ Set.insert uid $ Set.fromAscList svs +-- | return uid and underlings for currently logged in user, empty if not logged in +getSupervisees :: Bool -> DB (Set UserId) +getSupervisees forceLogin = do + mbuid <- if forceLogin + then Just <$> requireAuthId -- forces login + else maybeAuthId + flip foldMapM mbuid $ \uid -> do + svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] + return $ Set.insert uid $ Set.fromAscList svs computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256