fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(avs): fix problem listing no fd licence but in avs

Browse Source
This commit is contained in:
Steffen Jost 2022-12-19 16:15:17 +01:00
parent b83fbc114a
commit d6cdda10c1
6 changed files with 58 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/qualification/de-de-formal.msg
View File

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

2
messages/uniworx/categories/qualification/en-eu.msg
View File

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

74
src/Handler/Admin/Avs.hs
View File

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

7
src/Handler/Utils/Table/Cells.hs
View File

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

2
src/Model/Types/Avs.hs
View File

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

1
src/Model/Types/Lms.hs
View File

@ -1,4 +1,3 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later