chore(avs): fix problem listing no fd licence but in avs
This commit is contained in:
Steffen Jost
parent
b83fbc114a
commit
d6cdda10c1
@ -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?
|
||||
|
||||
@ -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?
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,4 +1,3 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user