^{revokeUnknownExecWgt} |] - + ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners no_revokes = Set.size revokes oks <- catchAllAvs $ setLicencesAvs revokes - if oks < no_revokes + if oks < no_revokes then addMessageI Error MsgRevokeUnknownLicencesFail - else addMessageI Info MsgRevokeUnknownLicencesOk - redirect ProblemAvsSynchR + else addMessageI Info MsgRevokeUnknownLicencesOk + redirect ProblemAvsSynchR -- licence differences - ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) - <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll - <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld - <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld - <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld - + ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) + <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll + <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld + <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld + <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld + now <- liftIO getCurrentTime - let nowaday = utctDay now + let nowaday = utctDay now procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler () - procRes aLic (LicenceTableChangeAvsData , apids) = do + procRes aLic (LicenceTableChangeAvsData , apids) = do oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids let no_req = Set.size apids mkind = if oks < no_req || no_req < 0 then Warning else Success - addMessageI mkind $ MsgAvsSetLicences aLic oks no_req + addMessageI mkind $ MsgAvsSetLicences aLic oks no_req redirect ProblemAvsSynchR -- reload to update all tables - procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do + procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do oks <- runDB $ do qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic - if qId /= licenceTableChangeFDriveQId + if qId /= licenceTableChangeFDriveQId then return (-1) else do uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] - qualificationUserBlocking licenceTableChangeFDriveQId uids False Nothing (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify + qualificationUserBlocking licenceTableChangeFDriveQId uids False Nothing (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic | oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks | otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks - redirect ProblemAvsSynchR -- must be outside runDB + redirect ProblemAvsSynchR -- must be outside runDB procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do - (n, Qualification{qualificationShorthand}) <- runDB $ do - uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] + (n, Qualification{qualificationShorthand}) <- runDB $ do + uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew (length uids,) <$> get404 licenceTableChangeFDriveQId addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n - redirect ProblemAvsSynchR -- must be outside runDB - + redirect ProblemAvsSynchR -- must be outside runDB + formResult tres2 $ procRes AvsLicenceRollfeld formResult tres1down $ procRes AvsLicenceVorfeld - formResult tres1up $ procRes AvsLicenceVorfeld + formResult tres1up $ procRes AvsLicenceVorfeld formResult tres0 $ procRes AvsNoLicence - + siteLayoutMsg MsgAvsTitleLicenceSynch $ do setTitleI MsgAvsTitleLicenceSynch $(i18nWidgetFile "avs-synchronisation") -type LicenceTableExpr = ( E.SqlExpr (Entity UserAvs) - `E.InnerJoin` E.SqlExpr (Entity User) +type LicenceTableExpr = ( E.SqlExpr (Entity UserAvs) + `E.InnerJoin` E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUser)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) - ) + ) queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs) queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1) @@ -495,13 +496,13 @@ queryQualBlock = $(E.sqlLOJproj 4 4) type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification), Maybe (Entity QualificationUserBlock)) -resultUserAvs :: Lens' LicenceTableData (Entity UserAvs) +resultUserAvs :: Lens' LicenceTableData (Entity UserAvs) resultUserAvs = _dbrOutput . _1 -resultUser :: Lens' LicenceTableData (Entity User) +resultUser :: Lens' LicenceTableData (Entity User) resultUser = _dbrOutput . _2 -resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser) +resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _3 . _Just resultQualification :: Traversal' LicenceTableData (Entity Qualification) @@ -510,46 +511,46 @@ resultQualification = _dbrOutput . _4 . _Just resultQualBlock :: Traversal' LicenceTableData (Entity QualificationUserBlock) resultQualBlock = _dbrOutput . _5 . _Just -instance HasEntity LicenceTableData User where +instance HasEntity LicenceTableData User where hasEntity = resultUser -instance HasUser LicenceTableData where +instance HasUser LicenceTableData where hasUser = resultUser . _entityVal -- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser -- hasQualificationUser = resultQualUser . _entityVal mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) -mkLicenceTable apidStatus dbtIdent aLic apids = do +mkLicenceTable apidStatus dbtIdent aLic apids = do currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [] now <- liftIO getCurrentTime - - let nowaday = utctDay now + + let nowaday = utctDay now avsQids = entityKey <$> avsQualifications - -- fltrLic qual = if + -- fltrLic qual = if -- | 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.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too fltrLic qual = E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) - -- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution: + -- 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.LeftOuterJoin` qual `E.LeftOuterJoin` qblock) -> do E.on $ qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId E.&&. qblock `isLatestBlockBefore` E.val now 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_ $ fltrLic qual - E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) + E.where_ $ fltrLic qual + E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) return (usrAvs, user, qualUser, qual, qblock) dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? -- Not sure what changes here: - dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) + dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) dbtColonnade = mconcat [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal , colUserNameLink AdminUserR , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a - -- , colUserCompany + -- , colUserCompany , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId @@ -573,7 +574,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus ] dbtSorting = mconcat - [ single $ sortUserNameLink queryUser + [ single $ sortUserNameLink queryUser , single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson)) , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) , single $ sortUserCompany queryUser @@ -588,22 +589,22 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now)) - , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> - E.from $ \(usrComp `E.InnerJoin` comp) -> do + , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> + E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId testcrit = maybe testname testnumber $ readMay $ CI.original criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit - ) + ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) ] - + qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt (Entity qualId qual) = do cQualId :: CryptoUUIDQualification <- encrypt qualId @@ -611,17 +612,17 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do { optionDisplay = CI.original $ qualificationName qual , optionInternalValue = qualId , optionExternalValue = tshow cQualId - } + } aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications -- Block identical to Handler/Qualifications TODO: refactor - getBlockReasons unblk = E.select $ do - (quser :& qblock) <- X.from $ E.table @QualificationUser + getBlockReasons unblk = E.select $ do + (quser :& qblock) <- X.from $ E.table @QualificationUser `E.innerJoin` E.table @QualificationUserBlock `X.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) E.where_ $ ((quser E.^. QualificationUserQualification) `E.in_` E.valList avsQids) E.&&. unblk (qblock E.^. QualificationUserBlockUnblock) - E.groupBy (qblock E.^. QualificationUserBlockReason) + E.groupBy (qblock E.^. QualificationUserBlockReason) let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows E.orderBy [E.desc countRows'] E.limit 7 @@ -641,12 +642,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do <*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) - else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData + else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid <*> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing - ] + ] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute @@ -663,11 +664,11 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } validator = def & defaultSorting [SortAscBy "user-name"] postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool)) -> FormResult ( LicenceTableActionData, Set AvsPersonId) - postprocess inp = do + postprocess inp = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) @@ -679,17 +680,17 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do getAdminAvsUserR :: CryptoUUIDUser -> Handler Html getAdminAvsUserR uuid = do uid <- decrypt uuid - Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid + Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid mAvsQuery <- getsYesod $ view _appAvsQuery resWgt <- case mAvsQuery of Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation - Just AvsQuery{..} -> do + Just AvsQuery{..} -> do mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId - mbDataPerson <- lookupAvsUser userAvsPersonId + mbDataPerson <- lookupAvsUser userAvsPersonId return [whamlet|
- Vorläufige Admin Ansicht AVS Daten. - Ansicht zeigt aktuelle Daten. + Vorläufige Admin Ansicht AVS Daten. + Ansicht zeigt aktuelle Daten. Es erfolgte damit aber noch kein Update der FRADrive Daten.
- Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. +
+ Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar. -
+
^{foldMap jsonWidget mbContact} -
+
^{foldMap jsonWidget mbDataPerson}
- |]
+ |]
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
- siteLayout heading $ do
+ siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson
resWgt
+
+instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where
+ hasEntity = _dbrOutput . _2
+
+instance HasUser (DBRow (Entity UserAvs, Entity User)) where
+ hasUser = _dbrOutput . _2 . _entityVal
+
+getProblemAvsErrorR :: Handler Html
+getProblemAvsErrorR = do
+ let
+ avsSyncErrDBTable = DBTable{..}
+ where
+ dbtIdent :: Text
+ dbtIdent = "avs-errors"
+ dbtSQLQuery (usravs `E.InnerJoin` user) = do
+ E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId
+ E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
+ return (usravs, user)
+ qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
+ qerryUsrAvs = $(E.sqlIJproj 2 1)
+ qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
+ qerryUser = $(E.sqlIJproj 2 2)
+ reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
+ reserrUsrAvs = _dbrOutput . _1
+ -- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
+ -- reserrUser = _dbrOutput . _2
+ dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
+ dbtProj = dbtProjId
+ dbtColonnade = dbColonnade $ mconcat
+ [ colUserNameModalHdr MsgLmsUser AdminUserR
+ , sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo)
+ $ avsPersonNoLinkedCell . view reserrUsrAvs
+ , sortable Nothing (i18nCell MsgAvsPersonId)
+ $ numCell . view (reserrUsrAvs . _entityVal . _userAvsPersonId . _AvsPersonId)
+ , sortable (Just "avs-last-synch") (i18nCell MsgLastAvsSynchronisation)
+ $ dateTimeCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynch)
+ , sortable (Just "avs-last-error") (i18nCell MsgLastAvsSynchError)
+ $ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError)
+ ]
+ dbtSorting = mconcat
+ [ single (sortUserNameLink qerryUser)
+ , single ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson))
+ , single ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch))
+ , single ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError))
+ ]
+ dbtFilter = mconcat
+ [ single $ fltrUserNameEmail qerryUser
+ , single ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError))
+ ]
+ dbtFilterUI mPrev = mconcat
+ [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
+ , prismAForm (singletonFilter "avs-last-error" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgLastAvsSynchError)
+ ]
+ dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
+ dbtParams = def
+ dbtCsvEncode = Nothing
+ dbtCsvDecode = Nothing
+ dbtExtraReps = []
+ avsSyncErrDBTableValidator = def & defaultSorting [SortDescBy "avs-last-synch"]
+ mkAvsSynchErrorTable :: DB (Any, Widget)
+ mkAvsSynchErrorTable = dbTable avsSyncErrDBTableValidator avsSyncErrDBTable
+ avsSyncErrTbl <- runDB (snd <$> mkAvsSynchErrorTable)
+ siteLayoutMsg MsgMenuAvsSynchError $ do
+ setTitleI MsgMenuAvsSynchError
+ [whamlet|^{avsSyncErrTbl}|]
+
\ No newline at end of file
diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet
index 8387a3daa..60ffd4d92 100644
--- a/templates/admin-problems.hamlet
+++ b/templates/admin-problems.hamlet
@@ -36,7 +36,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
- _{MsgProblemsHeadingUsers}
+ _{MsgProblemsHeadingNotifications}
+ _{MsgProblemsHeadingMisc}
+
+