From 37a15672c9d6496b8780075233b0092b95d26ae2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 28 Jan 2025 16:35:56 +0100 Subject: [PATCH] chore(qualification): prepare stub for edit handler also fix some minor navigation issues --- .../utils/navigation/menu/de-de-formal.msg | 2 ++ .../uniworx/utils/navigation/menu/en-eu.msg | 2 ++ routes | 12 ++++--- src/Foundation/Navigation.hs | 20 +++++++++-- src/Handler/LMS.hs | 2 +- src/Handler/Qualification.hs | 36 +++++++++++-------- src/Handler/Qualification/Edit.hs | 32 +++++++++++++++++ src/Handler/Utils/Users.hs | 15 ++++---- 8 files changed, 93 insertions(+), 28 deletions(-) create mode 100644 src/Handler/Qualification/Edit.hs diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index d17443990..acb8e0edb 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -123,6 +123,8 @@ MenuCourseEventEdit: Kursarttermin bearbeiten MenuLanguage: Sprache MenuQualifications: Qualifikationen +MenuQualificationEdit: Bearbeiten +MenuQualificationNew: Neue Qualifikation erstellen MenuLms !ident-ok: E‑Learning MenuLmsEdit: Bearbeiten E‑Learning MenuLmsUser: Benutzerqualifikationen diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 892295635..5cc1960f0 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -123,6 +123,8 @@ MenuCourseEventEdit: Edit course type occurrence MenuLanguage: Language MenuQualifications: Qualifications +MenuQualificationEdit: Edit +MenuQualificationNew: Create new qualification MenuLms: E‑learning MenuLmsEdit: Edit e‑learning MenuLmsUser: User Qualifications diff --git a/routes b/routes index 86cf31ccf..78a8537c2 100644 --- a/routes +++ b/routes @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Wolfgang Witt , Steffen Jost +-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Wolfgang Witt , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -279,11 +279,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 10ef1c4c7..f898aa0a4 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 @@ -184,12 +184,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 @@ -2423,6 +2425,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 134c7e361..5455abdff 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -112,7 +112,7 @@ resultAllQualificationTotal = _dbrOutput . _3 . _unValue mkLmsAllTable :: Bool -> Int -> DB (Any, Widget) mkLmsAllTable isAdmin lmsDeletionDays = do - svs <- getSupervisees + svs <- getSupervisees True let resultDBTable = DBTable{..} where diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 14a0fdf75..a0a4aeb34 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 @@ -360,7 +368,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 new file mode 100644 index 000000000..3c5284577 --- /dev/null +++ b/src/Handler/Qualification/Edit.hs @@ -0,0 +1,32 @@ +-- SPDX-FileCopyrightText: 2025 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances +{-# LANGUAGE TypeApplications #-} + +module Handler.Qualification.Edit + ( getQualificationNewR, postQualificationNewR + , getQualificationEditR, postQualificationEditR + ) + where + +import Import + +-- import Database.Esqueleto.Experimental ((:&)(..)) +-- import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma + + +getQualificationNewR, postQualificationNewR :: SchoolId -> Handler Html +getQualificationNewR = postQualificationNewR +postQualificationNewR ssh = handleQualificationEdit ssh Nothing + +getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html +getQualificationEditR = postQualificationEditR +postQualificationEditR ssh qsh = do + qent <- runDBRead $ getBy404 $ SchoolQualificationShort ssh qsh + handleQualificationEdit ssh $ Just qent + + +handleQualificationEdit :: SchoolId -> Maybe (Entity Qualification) -> Handler Html +handleQualificationEdit _ _ = error "todo" \ No newline at end of file diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 86d3f40df..6e62c4aa6 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -212,12 +212,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