chore(qualification): prepare stub for edit handler

also fix some minor navigation issues

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

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

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                                            QualificationAllR         GET       !free
-/qualification/#SchoolId                                QualificationSchoolR        GET       !free
+/qualification/#SchoolId                                  QualificationSchoolR      GET       !free
-/qualification/#SchoolId/#QualificationShorthand        QualificationR              GET POST  !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

src/Foundation/Navigation.hs

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

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

src/Handler/Qualification.hs

@@ -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 $ view _2 <$> mkQualificationAllTable Nothing
-  qualiTable <- runDB $ do
-    view _2 <$> mkQualificationAllTable isAdmin
   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 :: Maybe SchoolId -> DB (Any, Widget)
-mkQualificationAllTable isAdmin = do
+mkQualificationAllTable ssh = do
-  svs <- getSupervisees
+  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)
+            -- fltrSchool $ to (E.^. QualificationSchool)
-          , singletonMap "qelearning"   . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart)
+            singletonMap "qelearning"   . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart)
           ]
         dbtFilterUI = mconcat
           [
-            fltrSchoolUI
+            -- guardMonoid (isNothing ssh) fltrSchoolUI
-          , \mPrev -> prismAForm (singletonFilter "qelearning"   . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning)
+            \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

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
+-- | return uid and underlings for currently logged in user, empty if not logged in
-getSupervisees :: DB (Set UserId)
+getSupervisees :: Bool -> DB (Set UserId)
-getSupervisees = do
+getSupervisees forceLogin = do
-  uid <- requireAuthId
+  mbuid <- if forceLogin
-  svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
+    then Just <$> requireAuthId -- forces login
-  return $ Set.insert uid $ Set.fromAscList svs
+    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