fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(qualification): prepare stub for edit handler

Browse Source 
also fix some minor navigation issues
This commit is contained in:
Steffen Jost 2025-01-28 16:35:56 +01:00
parent 4f745d4676
commit 37a15672c9
8 changed files with 93 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -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

2
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -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

12
routes
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
--
-- 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

20
src/Foundation/Navigation.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

2
src/Handler/LMS.hs
View File

@ -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

36
src/Handler/Qualification.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <S.Jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-25 Steffen Jost <S.Jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

32
src/Handler/Qualification/Edit.hs Normal file
View File

@ -0,0 +1,32 @@
-- SPDX-FileCopyrightText: 2025 Steffen Jost <S.Jost@fraport.de>
--
-- 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"

15
src/Handler/Utils/Users.hs
View File

@ -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