diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index bce996fef..29ece4994 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -24,7 +24,7 @@ TableQualificationBlockedDue: Suspendiert TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und wer hat das veranlasst? LmsUser: Inhaber TableLmsEmail: E-Mail -TableLmsIdent: Identifikation +TableLmsIdent: LMS Identifikation TableLmsElearning: E-Learning TableLmsPin: E-Learning Pin TableLmsResetPin: Pin zurücksetzen? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 3a95b25bf..b109b6dd5 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -24,7 +24,7 @@ TableQualificationBlockedDue: Suspended TableQualificationBlockedTooltip: When was the qualification temporarily suspended and who requested this? LmsUser: Licensee TableLmsEmail: Email -TableLmsIdent: Identifier +TableLmsIdent: LMS Identifier TableLmsPin: E-learning pin TableLmsElearning: E-learning TableLmsResetPin: Reset pin? diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 3aa1542d5..b945c7793 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -303,16 +303,16 @@ postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html postProblemAvsSynchR = getProblemAvsSynchR getProblemAvsSynchR = do -- TODO: just for Testing - -- now <- liftIO getCurrentTime - -- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now) - -- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes, AvsPersonId 12345678] - -- setTo1 = Set.fromList [AvsPersonId minutes] - -- setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678] + now <- liftIO getCurrentTime + let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now) + setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes, AvsPersonId 12345678] + setTo1 = Set.fromList [AvsPersonId minutes] + setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678] - (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case - Right res -> return res - Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) - redirect AdminR + -- (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case + -- Right res -> return res + -- Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) + -- redirect AdminR unknownLicenceOwners' <- whenNonEmpty setTo0 $ \neZeros -> runDB $ E.select $ do @@ -343,11 +343,20 @@ getProblemAvsSynchR = do Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect ProblemAvsSynchR - ((_,tb0),(_,tb1),(_,tb2)) <- runDB $ (,,) - <$> mkLicenceTable AvsLicenceVorfeld setTo0 (Just LicenceTableChangeAvs) + ((r0,tb0),(r1,tb1),(r2,tb2)) <- runDB $ (,,) + <$> mkLicenceTable AvsNoLicence setTo0 (Just LicenceTableChangeAvs) <*> mkLicenceTable AvsLicenceVorfeld setTo1 (Just LicenceTableChangeAvs) <*> mkLicenceTable AvsLicenceRollfeld setTo2 (Just LicenceTableChangeAvs) + -- for debugging + let sres x = case x of + FormSuccess (tda, ids) -> addMessage Info $ toHtml $ "Received " <> tshow (Set.size ids) <> " ids for " <> tshow tda + _ -> pure () + sres r0 + sres r1 + sres r2 + -- end debugging + siteLayoutMsg MsgAvsTitleLicenceSynch $ do setTitleI MsgAvsTitleLicenceSynch $(i18nWidgetFile "avs-synchronisation") @@ -360,6 +369,9 @@ type LicenceTableExpr = ( E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Maybe (Entity Qualification)) ) +queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs) +queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 1) + queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User) queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 1) @@ -369,7 +381,7 @@ queryQualUser = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 2) queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification)) queryQualification = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2) -type LicenceTableData = DBRow (Entity User, Maybe (Entity QualificationUser), AvsPersonId) +type LicenceTableData = DBRow (Entity User, Maybe (Entity QualificationUser), AvsPersonId, Maybe (Entity Qualification)) resultUser :: Lens' LicenceTableData (Entity User) resultUser = _dbrOutput . _1 @@ -380,6 +392,9 @@ resultQualUser = _dbrOutput . _2 . _Just resultAvsPID :: Traversal' LicenceTableData AvsPersonId resultAvsPID = _dbrOutput . _3 +resultQualification :: Traversal' LicenceTableData (Entity Qualification) +resultQualification = _dbrOutput . _4 . _Just + instance HasEntity LicenceTableData User where hasEntity = resultUser @@ -387,25 +402,31 @@ instance HasUser LicenceTableData where hasUser = resultUser . _entityVal -mkLicenceTable :: AvsLicence -> Set AvsPersonId -> Maybe LicenceTableAction -> DB (FormResult (LicenceTableActionData, Set UserId), Widget) +mkLicenceTable :: AvsLicence -> Set AvsPersonId -> Maybe LicenceTableAction -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) mkLicenceTable aLic apids defAct = do currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute now <- liftIO getCurrentTime let nowaday = utctDay now dbtIdent = "drivingLicenceSynch" :: Text dbtStyle = def + fltrLic qual = if + -- | aLic == AvsNoLicence -> E.true -- could be R, F, both or none at all, but has licence in AVS + | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS + | otherwise -> E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence) -- if we suggest granting that licence, this join should deliver a value too + -- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution: dbtSQLQuery = \((usrAvs `E.InnerJoin` user) `E.LeftOuterJoin` (qualUser `E.InnerJoin` qual)) -> do E.on $ qual E.?. QualificationId E.==. qualUser E.?. QualificationUserQualification E.on $ user E.^. UserId E.=?. qualUser E.?. QualificationUserUser E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser - E.where_ $ E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence) - E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) - return (user, qualUser, usrAvs E.^. UserAvsPersonId) - dbtRowKey = queryUser >>> (E.^. UserId) -- ((_usrAvs `E.InnerJoin` usr) `E.LeftOuterJoin` _) = usr E.^. UserId - dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api) -> return (user, qualUsr, api) + E.where_ $ fltrLic qual E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) + return (user, qualUser, usrAvs E.^. UserAvsPersonId, qual) + dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) + --dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api, quali) -> return (user, qualUsr, api, quali) + dbtProj = dbtProjSimple $ pure . over _3 E.unValue dbtColonnade = mconcat - [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) + [ dbSelect (applying _2) id $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal , colUserNameLink AdminUserR + , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview $ resultQualification . _entityVal -> q) -> cellMaybe qualificationShortCell q , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d @@ -414,10 +435,11 @@ mkLicenceTable aLic apids defAct = do ] dbtSorting = mconcat [ single $ sortUserNameLink queryUser - , single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) - , single ("last-refresh", SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) - , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) - , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue)) + , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) + , single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) + , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) + , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) + , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue)) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -425,7 +447,7 @@ mkLicenceTable aLic apids defAct = do ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) ] acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData) acts = mconcat @@ -450,8 +472,8 @@ mkLicenceTable aLic apids defAct = do dbtCsvDecode = Nothing dbtExtraReps = [] validator = def -- & defaultSorting [SortDescBy "column-label"] - postprocess :: FormResult (First LicenceTableActionData, DBFormResult UserId Bool LicenceTableData) - -> FormResult ( LicenceTableActionData, Set UserId) + postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool)) + -> FormResult ( LicenceTableActionData, Set AvsPersonId) postprocess inp = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index ac31a99cb..fb3bccc90 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -277,6 +277,13 @@ qualificationCell Qualification{..} = anchorCell link name link = QualificationR qualificationSchool qualificationShorthand name = citext2widget qualificationName +qualificationShortCell :: IsDBTable m a => Qualification -> DBCell m a +qualificationShortCell Qualification{..} = anchorCell link name + where + link = QualificationR qualificationSchool qualificationShorthand + name = citext2widget qualificationShorthand + + qualificationDescrCell :: IsDBTable m a => Qualification -> DBCell m a qualificationDescrCell q@Qualification{..} = qualificationCell q <> desc where diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index ca1ad2599..316bb45a8 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -183,7 +183,7 @@ discernAvsCardPersonalNo _ = Nothing -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId` newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int deriving (Eq, Ord, Generic, Typeable) - deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary) instance E.SqlString AvsPersonId -- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API; instance FromJSON AvsPersonId where diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 728a3a08c..9f6ff5a98 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -1,4 +1,3 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later