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

Merge branch 'master' into fradrive/company

Browse Source
This commit is contained in:
Steffen Jost 2023-10-20 16:45:42 +00:00
commit 603f04f026
14 changed files with 72 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
CHANGELOG.md
View File

@ -2,6 +2,24 @@
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.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18)
### Bug Fixes
* **hoogle:** remove erroneous comment ([c011d88](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c011d887cece8338920355b540aa4b233e0b994f))
* **sap:** yet another fix for finding date intervals ([fde97b0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fde97b048ab04ab59c9e3f2a2f74bb2c1e996b22))
## [27.4.44](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.43...v27.4.44) (2023-10-18)
### Bug Fixes
* **sap:** combine immediate next day licence chnages for SAP ([f4adfdf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f4adfdf87270930d4ca6611f2a9956613fcace53))
* **sap:** combine immediate next day licence chnages for SAP ([cbb44f1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbb44f106ad59e0a53ca04963ade5544120b7e21))
* **sap:** combineBlocks yet another bug squashed ([3924d14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3924d14abd868305b42c9d04913536b4999dc45b))
* **sap:** compileBlocks ([b4a88ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6))
## [27.4.43](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.42...v27.4.43) (2023-10-13)
## [27.4.42](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.41...v27.4.42) (2023-10-12)

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{
"version": "27.4.43"
"version": "27.4.45"
}

2
package-lock.json generated
View File

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

2
package.json
View File

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

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 27.4.43
version: 27.4.45
dependencies:
- base
- yesod

9
src/Audit/Types.hs
View File

@ -212,7 +212,7 @@ data Transaction
}
| TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well!
{ transactionUser :: UserId -- qualification holder that is updated
, transactionQualificationUser :: QualificationUserId -- könnte entfernt werden
, transactionQualificationUser :: QualificationUserId -- not really necessary, maybe remove?
, transactionQualification :: QualificationId
, transactionQualificationValidUntil :: Day
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
@ -226,7 +226,12 @@ data Transaction
{ transactionUser :: UserId -- qualification holder that is updated
-- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser
, transactionQualification :: QualificationId
, transactionQualificationBlock :: QualificationUserBlock -- TODO --
, transactionQualificationBlock :: QualificationUserBlock -- full information about block
}
| TransactionQualificationUserScheduleRenewal
{ transactionUser :: UserId -- qualification holder that is updated
, transactionQualification :: QualificationId
, transactionQualificationScheduleRenewal :: Maybe Bool -- TRUE=will be notified upon expiry, FALSE=won't be notified; always JUST, for compatibility with TransactionQualificationUserEdit
}
deriving (Eq, Ord, Read, Show, Generic)

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

@ -431,8 +431,7 @@ getProblemAvsSynchR = do
<*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
now <- liftIO getCurrentTime
let nowaday = utctDay now
procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
procRes aLic (LicenceTableChangeAvsData , apids) = do
oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
let no_req = Set.size apids
@ -458,7 +457,7 @@ getProblemAvsSynchR = 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
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId now licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew "Admin Resolution"
(length uids,) <$> get404 licenceTableChangeFDriveQId
addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
redirect ProblemAvsSynchR -- must be outside runDB

2
src/Handler/Admin/Crontab.hs
View File

@ -220,5 +220,5 @@ postAdminJobsR = do
getJobName :: Value -> Maybe Text
getJobName (Object o)
| Just (String s) <- HashMap.lookup "job" o = Just s -- $ kebabToCamel s
| Just (String s) <- HashMap.lookup "job" o = Just s -- (kebabToCamel s)
getJobName _ = Nothing

2
src/Handler/LMS.hs
View File

@ -735,7 +735,7 @@ postLmsR sid qsh = do
, QualificationUserUser <-. usersList
, QualificationUserValidUntil <. cutoff
] []
forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
fromIntegral <$> (if isReset
then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective

16
src/Handler/Qualification.hs
View File

@ -614,14 +614,20 @@ postQualificationR sid qsh = do
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
reloadKeepGetParams $ QualificationR sid qsh
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do
(action, selectedUsers) | isExpiryAct action -> do
let isUnexpire = action == QualificationActUnexpireData
upd <- runDB $ updateWhereCount
[QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
[QualificationUserScheduleRenewal =. isUnexpire]
upd <- runDB $ do
forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
{ transactionUser = uid
, transactionQualification = qid
, transactionQualificationScheduleRenewal = Just isUnexpire
}
updateWhereCount
[QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
[QualificationUserScheduleRenewal =. isUnexpire]
let msgKind = if upd > 0 then Success else Warning
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
addMessageI msgKind msgVal

16
src/Handler/SAP.hs
View File

@ -79,18 +79,18 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
compileBlocks dStart dEnd = go (dStart, True)
where
go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
go b@(d,s) ((d1,s1):r1@((d2,_s2):_r2))
| d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go b r1 -- ignore unnecessary change
go b@(d,s) ((d1,s1):r1)
| d1 >= dEnd = go b [] -- remaining days extend validity
| s, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found
| s == s1 = go b r1 -- no change
| otherwise = go (d1,s1) r1 -- ignore invalid interval
go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
| s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd change
| d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change
go (d,s) ((d1,s1):r1)
| dEnd <= d1 = go (d ,s ) [] -- remaining dates extend validity
| s, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found
| s == s1 = go (d ,s ) r1 -- no change
| otherwise = go (d1,s1) r1 -- ignore invalid interval
go (d,s) []
| s = [(d,dEnd)]
| otherwise = []
-- | Deliver all employess with a successful LDAP synch within the last 3 months
getQualificationSAPDirectR :: Handler TypedContent
getQualificationSAPDirectR = do

5
src/Handler/Tutorial/Users.hs
View File

@ -139,8 +139,9 @@ postTUsersR tid ssh csh tutn = do
(TutorialUserGrantQualificationData{..}, selectedUsers)
| tuQualification `Set.member` courseQids -> do
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
today <- utctDay <$> liftIO getCurrentTime
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
today <- liftIO getCurrentTime
let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserRenewQualificationData{..}, selectedUsers)

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

@ -133,8 +133,9 @@ selectRelevantBlock cutoff quid =
------------------------
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking
upsertQualificationUser qualificationUserQualification startTime qualificationUserValidUntil mbScheduleRenewal reason qualificationUserUser = do
let qualificationUserLastRefresh = utctDay startTime
Entity quid _ <- upsert
QualificationUser
{ qualificationUserFirstHeld = qualificationUserLastRefresh
@ -149,7 +150,8 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
, QualificationUserLastRefresh =. qualificationUserLastRefresh
]
)
authUsr <- liftHandler maybeAuthId
insert_ $ QualificationUserBlock quid True startTime reason authUsr
audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid
, transactionQualification = qualificationUserQualification

17
test/Handler/SAPSpec.hs
View File

@ -79,6 +79,7 @@ spec = do
w0 = fromGregorian 2001 9 22
w1 = fromGregorian 2023 9 22
w2 = fromGregorian 2023 10 16
wF = fromGregorian 2023 10 17
w3 = fromGregorian 2023 11 17
w4 = fromGregorian 2024 01 21
compileBlocks wA wE [] `shouldBe` [(wA,wE)]
@ -94,6 +95,10 @@ spec = do
compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)]
compileBlocks wA wE [(w0,True),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)]
compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)]
compileBlocks wA wE [(w1,False),(w2,True),(wF,True ),(w3,False)] `shouldBe` [(wA,w1),(w2,w3)]
compileBlocks wA wE [(w1,True),(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
compileBlocks wA wE [(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
compileBlocks wA wE [(w2,False),(wF,False)] `shouldBe` [(wA,w2) ]
it "handles basic intervals" $ do
(d1,d2,d3) <- generate $ do
@ -112,9 +117,11 @@ spec = do
d3 <- arbitrary `suchThat` (d1 <)
d4 <- arbitrary `suchThat` (d3 <)
return (d1,d2,d3,d4)
b <- generate arbitrary
let test = compileBlocks d1 d2 [(d3,b),(d4,not b)]
result | b = [(d1, min d2 d4)]
| d2 > d4 = [(d1,d3),(d4,d2)]
| otherwise = [(d1, min d2 d3)]
b3 <- generate arbitrary
b4 <- generate arbitrary
let test = compileBlocks d1 d2 [(d3,b3),(d4,b4)]
result | b3, b4 = [(d1, d2)]
| b3 = [(d1, min d2 d4)]
| b4, d2 > d4 = [(d1,d3),(d4,d2)]
| otherwise = [(d1, min d2 d3)]
test `shouldBe` result