fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'test'

Browse Source
This commit is contained in:
Steffen Jost 2023-09-21 13:02:14 +00:00
commit e59a2fc373
8 changed files with 48 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
CHANGELOG.md
View File

@ -2,41 +2,14 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [27.4.34](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.18...v27.4.34) (2023-09-20) ## [27.4.35](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.34...t27.4.35) (2023-09-21)
## [27.4.34](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.33...t27.4.34) (2023-09-21)
### Bug Fixes ### Bug Fixes
* **apc:** apc cannot distinguish ij from ji, partial fix only. Needs new font ([b4ba0a3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4ba0a30dc7c513bb9e3c567ca771d5d75de4343)) * **lms:** treat simultaneous blocks/unblocks correctly ([11752dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/11752dc5ac96f36ebf9a4cad43fa4e4b55c1b21c))
* **block:** negate condition to test ([9cf7f39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9cf7f3965aa95f0b8f2a1574dbad90c0257edafd))
* **build:** add missing file ([1fd24f6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1fd24f608dc9202fa98f52f7908f4be908a18efc))
* **build:** prevent migration on non-existing table ([5bb49cd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bb49cd88941e510a50759efaad88690f841ca47))
* **build:** refix test commits somehow ([34ada53](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/34ada53de0cc5804468791854e824b730fcc84de))
* **build:** v2 ([ac77aa1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ac77aa176a3c3977c4a802e5ed534fa2850528fe))
* **lms:** accept success for no-status learners and print several more debug messages processing reports ([a7ed659](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a7ed659866de1d4a178bbe4e8f9cd8fbc629c724))
* **lms:** ensure lms uniqueness across all qualifications ([b85c8bd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b85c8bd74f8db526fb1cbb43ff12a24b93c07eb3))
* **lms:** filter by status ([a74c3d8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a74c3d80cada4f9d224365727dab9676cc905f54))
* **lms:** negate learner locking condition ([a452b03](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a452b032c43dbdfd086ffa4793c83ecc32c450f8))
* **lms:** reset e-learning more lenient ([8b0737e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8b0737e2aabc7153ae3a3df4f97f86ffc8592e7a))
* **lms:** simultaneous block/unblock lets unblock win in all situations ([ecd1a0f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ecd1a0fc210d1340bff5c79d8bb676a47654b509))
* **qualification:** new block/unblock mechanism working now ([5397c7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5397c7be353fc1b1e8310f66b49a9b93ee890253))
* **time:** midnight timezone conversion bug eliminated ([dfa07a9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dfa07a95eb29f1fceec258a466e1e7c779ff6e5c))
* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) and also add some convenience ([35096ac](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/35096ace01a2bc2a2d666794bb1ff92f52b3edec))
* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) working now ([88bf21c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88bf21c9c5de3755ea6591c97dc1f99a928914d5))
## [27.4.17](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.16...v27.4.17) (2023-07-15)
## [27.4.16](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.15...v27.4.16) (2023-07-15)
## [27.4.15](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.15) (2023-07-15)
### Bug Fixes
* **build:** major qualfication block quirks fixed ([ab48e40](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ab48e40ac7e5024b7847b3995e6ae16d1c401c60))
* **build:** minor ([f9930f2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f9930f2a00d1e0f0af9b7f2af7c387bcc09cef5a))
* **db:** migration qualification block ([3d59527](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3d595271d979f29ed8bbc546f495e5ad1deae5ca))
* **test:** LmsStatus is no longer a semigroup ([bf8cd4f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bf8cd4fa899bccd4a37906a4d899aca6ca25d726))
## [27.4.33](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.32...t27.4.33) (2023-09-20) ## [27.4.33](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.32...t27.4.33) (2023-09-20)

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{ {
"version": "27.4.34" "version": "27.4.35"
} }

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "27.4.34", "version": "27.4.35",
"lockfileVersion": 1, "lockfileVersion": 1,
"requires": true, "requires": true,
"dependencies": { "dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "27.4.34", "version": "27.4.35",
"description": "", "description": "",
"keywords": [], "keywords": [],
"author": "", "author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx name: uniworx
version: 27.4.34 version: 27.4.35
dependencies: dependencies:
- base - base
- yesod - yesod

25
src/Handler/LMS.hs
View File

@ -318,7 +318,7 @@ queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBloc
queryQualBlock = $(sqlLOJproj 2 2) queryQualBlock = $(sqlLOJproj 2 2)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany]) type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool)
resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
@ -338,6 +338,9 @@ resultPrintAck = _dbrOutput . _5 . _unValue . _Just
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _6 resultCompanyUser = _dbrOutput . _6
resultValidQualification :: Lens' LmsTableData Bool
resultValidQualification = _dbrOutput . _7 . _unValue
instance HasEntity LmsTableData User where instance HasEntity LmsTableData User where
hasEntity = resultUser hasEntity = resultUser
@ -396,14 +399,15 @@ isResetRestartAct LmsActRestartData{} = True
isResetRestartAct other = isResetAct other isResetRestartAct other = isResetAct other
lmsTableQuery :: QualificationId -> LmsTableExpr lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
, E.SqlExpr (Entity LmsUser) , E.SqlExpr (Entity LmsUser)
, E.SqlExpr (Maybe (Entity QualificationUserBlock)) , E.SqlExpr (Maybe (Entity QualificationUserBlock))
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
, E.SqlExpr (E.Value Bool)
) )
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
-- RECALL: another outer join on PrintJob did not work out well, since -- RECALL: another outer join on PrintJob did not work out well, since
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
-- - using notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all; -- - using notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all;
@ -420,8 +424,8 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOute
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser)) E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this!
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
return (qualUser, user, lmsUser, qualBlock, printAcknowledged) return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
mkLmsTable :: ( Functor h, ToSortable h mkLmsTable :: ( Functor h, ToSortable h
@ -443,11 +447,11 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "lms" dbtIdent = "lms"
dbtSQLQuery = lmsTableQuery qid dbtSQLQuery = lmsTableQuery now qid
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks) -> do dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr) return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
dbtColonnade = cols cmpMap dbtColonnade = cols cmpMap
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
@ -642,7 +646,10 @@ postLmsR sid qsh = do
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row qualificationValidReasonCell'' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row (row ^. resultValidQualification) -- TODO: resultValidQualification for debugging only
-- DEBUG
-- , sortable Nothing (i18nCell MsgQualificationValidIndicator) $ \(view resultValidQualification -> b) -> iconBoolCell b -- TODO: just for debugging
-- DEBUG
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid , sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid

9
src/Handler/Utils/Qualification.hs
View File

@ -75,9 +75,12 @@ quserToNotify quser cutoff =
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
newerBlock <- E.from $ E.table @QualificationUserBlock newerBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser E.&&. ((E.just(newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom)
E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins
E.&&. (newerBlock E.^. QualificationUserBlockFrom E.=?. qualBlock E.?. QualificationUserBlockFrom)
))
) )
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` -- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)

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

@ -366,6 +366,24 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
| otherwise = dateCell tstamp | otherwise = dateCell tstamp
uid = qu ^. hasQualificationUser . _qualificationUserUser uid = qu ^. hasQualificationUser . _qualificationUserUser
qualificationValidReasonCell'' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> Bool -> DBCell m c
qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icErr <> foldMap blc qb
where
quValid = isValidQualification d qu qb
icErr = cell . toWidget . isBad $ quValid /= extValid
ic = cell . toWidget $ iconQualificationBlock quValid
blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
| showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
| qualificationUserBlockUnblock = mempty
| otherwise = spacerCell <> dateCell qualificationUserBlockFrom
dc tstamp
| Just toLink <- mbToLink = cell $ do
uuid <- liftHandler $ encrypt uid
modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid)
-- anchorCellM (toLink <$> encrypt uid)
| otherwise = dateCell tstamp
uid = qu ^. hasQualificationUser . _qualificationUserUser
lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name
where where