diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0ce223de9..b8ebb3d65 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -2,12 +2,12 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -workflow: - rules: - - if: $CI_COMMIT_BRANCH == $CI_DEFAULT_BRANCH - - if: $CI_MERGE_REQUEST_ID - - if: $CI_COMMIT_TAG =~ /^v/ - - if: $CI_COMMIT_TAG =~ /^t/ +# workflow: +# rules: +# - if: $CI_COMMIT_BRANCH == $CI_DEFAULT_BRANCH +# - if: $CI_MERGE_REQUEST_ID +# - if: $CI_COMMIT_TAG =~ /^v/ +# - if: $CI_COMMIT_TAG =~ /^t/ default: image: diff --git a/CHANGELOG.md b/CHANGELOG.md index c855e7e52..5d9b7616d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,35 @@ 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) + + +### Bug Fixes + +* **build:** Update ParticipantInvite.hs ([f888da3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f888da3ab0df45bb3c515ebb7cbb43569fdaa1fa)) +* **build:** Update ParticipantInvite.hs ([fa4f9b2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa4f9b24475261afc1e534541c8878a85e6a1b10)) +* **build:** Update Utils.hs ([87f0b2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/87f0b2edab2bcf696b7b776e47272ef2204c0b75)) + ## [27.4.41](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.40...v27.4.41) (2023-10-04) diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index b11ff586a..a3c630c46 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -94,6 +94,7 @@ UserHijack: Sitzung übernehmen UserAddSupervisor: Ansprechpartner hinzufügen UserSetSupervisor: Ansprechpartner ersetzen UserRemoveSupervisor: Alle Ansprechpartner entfernen +UserIsSupervisor: Ist Ansprechpartner AuthKindLDAP: Fraport AG Kennung AuthKindPWHash: FRADrive Kennung AuthKindNoLogin: Kein Login möglich diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 9b33bfdc7..10c42830d 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -94,6 +94,7 @@ UserHijack: Hijack session UserAddSupervisor: Add supervisor UserSetSupervisor: Replace supervisors UserRemoveSupervisor: Set to unsupervised +UserIsSupervisor: Is supervisor AuthKindLDAP: Fraport AG account AuthKindPWHash: FRADrive account AuthKindNoLogin: No login diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index fdf42b885..86b07953e 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -16,7 +16,7 @@ TableTerm !ident-ok: Jahr TableCourseSchool: Bereich TableSubmissionGroup: Feste Abgabegruppe TableNoSubmissionGroup: Keine feste Abgabegruppe -TableMatrikelNr: AVS Nr +TableMatrikelNr: AVS Personennummer TableSex: Geschlecht TableBirthday: Geburtsdatum TableSchool: Bereich diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index b4fe83d34..8a9c79bf8 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -16,7 +16,7 @@ TableTerm: Year TableCourseSchool: Department TableSubmissionGroup: Registered submission group TableNoSubmissionGroup: No registered submission group -TableMatrikelNr: AVS No +TableMatrikelNr: AVS person no TableSex: Sex TableBirthday: Birthday TableSchool: Department diff --git a/nix/docker/version.json b/nix/docker/version.json index ab442fe54..77bb560f7 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.41" + "version": "27.4.45" } diff --git a/package-lock.json b/package-lock.json index 1d862bddd..fe4b59685 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.41", + "version": "27.4.45", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 9168488ce..3d3e428b0 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.41", + "version": "27.4.45", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 0e94d2098..42efdc6bb 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.41 +version: 27.4.45 dependencies: - base - yesod diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 8360410a8..50dbc8811 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -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) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index dc9f5159e..139e955e1 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -24,7 +24,7 @@ module Database.Esqueleto.Utils , mkContainsFilter, mkContainsFilterWith , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus , mkDayFilter, mkDayFilterFrom, mkDayFilterTo - , mkExistsFilter + , mkExistsFilter, mkExistsFilterWithComma , anyFilter, allFilter , ascNullsFirst, descNullsLast , orderByList @@ -45,7 +45,7 @@ module Database.Esqueleto.Utils , unKey , selectCountRows, selectCountDistinct , selectMaybe - , day, day', interval, diffDays, diffTimes + , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift , explicitUnsafeCoerceSqlExprValue , module Database.Esqueleto.Utils.TH @@ -421,6 +421,17 @@ mkExistsFilter query row criterias | Set.null criterias = true | otherwise = any (E.exists . query row) $ Set.toList criterias +mkExistsFilterWithComma :: PathPiece a + => (Text -> a) + -> (t -> a -> E.SqlQuery ()) + -> t + -> Set.Set Text + -> E.SqlExpr (E.Value Bool) +mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias) + | Set.null criterias = true + | otherwise = any (E.exists . query row) (cast <$> Set.toList criterias) + + -- | Combine several filters, using logical or anyFilter :: Foldable f => f (t -> cs -> E.SqlExpr (E.Value Bool)) @@ -656,6 +667,9 @@ day = E.unsafeSqlCastAs "date" day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day) day' = E.unsafeSqlCastAs "date" +dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day)) +dayMaybe = E.unsafeSqlCastAs "date" + interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day -- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index e7b4fda22..a2a1db42f 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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 diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index 53393abb0..5806edd60 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/src/Handler/Admin/Crontab.hs @@ -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 \ No newline at end of file diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index d31cd0d41..82ebe492f 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -49,11 +49,19 @@ tutorialTemplateNames Nothing = ["Vorlage", "Template"] tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]] tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName -tutorialDefaultName Nothing = CI.mk . tshow -- Don't use user date display setting, so that tutorial default names conform to all users +tutorialDefaultName Nothing = formatDayForTutName tutorialDefaultName (Just ttyp) = let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing +formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user +-- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this +formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow + where + d2u '-' = '_' + d2u c = c + + data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe ButtonCourseRegisterMode diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 66ccf51a6..ae49a06c5 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -424,7 +424,7 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left E.where_ $ E.isJust (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! - 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 type of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser) @@ -739,7 +739,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 diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 083d8572d..6be31bf20 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -225,9 +225,9 @@ mkPJTable = do dbtFilter = mconcat [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) - , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) - , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) , single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 5c2acdd0a..3dde9b54d 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -102,7 +102,6 @@ instance RenderMessage UniWorX NotificationTriggerKind where where mr = renderMessage f ls - makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template html = do MsgRenderer mr <- getMsgRenderer @@ -169,7 +168,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm template = wFormToAForm $ do mbUid <- liftHandler maybeAuthId - isAdmin <- lift . lift $ hasReadAccessTo AdminR + isAdmin <- checkAdmin let sectionIsHidden :: NotificationTriggerKind -> DB Bool @@ -370,13 +369,13 @@ validateSettings User{..} = do userPrefersPostal' <- use _stgPrefersPostal guardValidation MsgUserPrefersPostalInvalid $ - not $ userPrefersPostal' && postalNotSet + not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment) userPinPassword' <- use _stgPinPassword let pinBad = validCmdArgument =<< userPinPassword' pinMinChar = 5 pinLength = maybe 0 length userPinPassword' - pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else liftHandler $ hasReadAccessTo AdminR -- admins are allowed to ignore pin requirements + pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else checkAdmin -- admins are allowed to ignore pin requirements whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk guardValidation (MsgPDFPasswordTooShort pinMinChar) pinOk @@ -450,9 +449,12 @@ serveProfileR (uid, user@User{..}) = do formResult res $ \SettingsForm{..} -> do now <- liftIO getCurrentTime + isAdmin <- checkAdmin + thisUser <- fromMaybe uid <$> maybeAuthId + let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid) runDBJobs $ do update uid $ - [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- Note that DisplayEmail changes must be confirmed, see 472 + [ UserDisplayEmail =. stgDisplayEmail | not changeEmailByUser ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below [ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++ [ UserDisplayName =. stgDisplayName , UserMaxFavourites =. stgMaxFavourites @@ -472,7 +474,7 @@ serveProfileR (uid, user@User{..}) = do , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] updateFavourites Nothing - when (stgDisplayEmail /= userDisplayEmail) $ do + when changeEmailByUser $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail let diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6553bb300..689a96e2b 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -617,14 +617,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 diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 79e69d222..be4ad973a 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -6,6 +6,7 @@ module Handler.SAP ( getQualificationSAPDirectR + , compileBlocks -- for Test in Handler.SAPSpec only ) where @@ -18,8 +19,9 @@ import Handler.Utils.Profile -- import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv import Database.Esqueleto.Experimental ((:&)(..)) -import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E @@ -55,22 +57,39 @@ instance ToNamedRecord SapUserTableCsv where ] -- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted) --- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo -sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv] -sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l - -- , let persNoAsInt = readMay =<< persNo -- also see Handler.Utils.Profile.validFraportPersonalNumber - -- , persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export - -- , persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export - , let res = SapUserTableCsv - { csvSUTpersonalNummer = persNo - , csvSUTqualifikation = sapId - , csvSUTgültigVon = firstHeld - , csvSUTgültigBis = validUntil - -- , csvSUTsupendiertBis = blocked - , csvSUTausprägung = "J" - } - , validFraportPersonalNumber pn - ] +-- temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo +sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv] +sapRes2csv = concatMap procRes + where + procRes (E.Value pn@(Just persNo), E.Value (Just sapId), E.Value firstHeld, E.Value validUntil, E.Value (fromMaybe [] -> qubFroms), E.Value (fromMaybe [] -> qubUnblocks)) + | validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber + = let mkSap (dfrom,duntil) = SapUserTableCsv + { csvSUTpersonalNummer = persNo + , csvSUTqualifikation = sapId + , csvSUTgültigVon = dfrom + , csvSUTgültigBis = duntil + , csvSUTausprägung = "J" + } + in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks + procRes _ = [] + +-- | compute a series of valid periods, assume that lists is already sorted by Day +-- the lists encodes qualification_user_blocks with block=False/unblock=True +compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] +compileBlocks dStart dEnd = go (dStart, True) + where + go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] + 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 @@ -78,23 +97,36 @@ getQualificationSAPDirectR = do now <- liftIO getCurrentTime fdate <- formatTime' "%Y%m%d_%H-%M" now let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now - qualUsers <- runDB $ Ex.select $ do - (qual :& qualUser :& user) <- - Ex.from $ Ex.table @Qualification - `Ex.innerJoin` Ex.table @QualificationUser - `Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification) - `Ex.innerJoin` Ex.table @User - `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId) - Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId) - Ex.&&. E.isJust (user Ex.^. UserCompanyPersonalNumber) - Ex.&&. E.isJust (user Ex.^. UserLastLdapSynchronisation) - Ex.&&. (E.justVal ldap_cutoff Ex.<=. user Ex.^. UserLastLdapSynchronisation) + qualUsers <- runDB $ E.select $ do + (qual :& qualUser :& user :& qualBlock) <- + E.from $ E.table @Qualification + `E.innerJoin` E.table @QualificationUser + `E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) + `E.innerJoin` E.table @User + `E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId) + `E.leftJoin` E.table @QualificationUserBlock + `E.on` (\(_ :& qualUser :& _ :& qualBlock) -> + qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + E.&&. E.val now E.>~. qualBlock E.?. QualificationUserBlockFrom + ) + E.where_ $ E.isJust (qual E.^. QualificationSapId) + E.&&. E.isJust (user E.^. UserCompanyPersonalNumber) + E.&&. E.isJust (user E.^. UserLastLdapSynchronisation) + E.&&. (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation) + E.groupBy ( user E.^. UserCompanyPersonalNumber + , qualUser E.^. QualificationUserFirstHeld + , qualUser E.^. QualificationUserValidUntil + , qual E.^. QualificationSapId + ) + let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId] + -- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder return - ( user Ex.^. UserCompanyPersonalNumber - , qualUser Ex.^. QualificationUserFirstHeld - , qualUser Ex.^. QualificationUserValidUntil - -- , qualUser Ex.^. QualificationUserBlockedDue - , qual Ex.^. QualificationSapId + ( user E.^. UserCompanyPersonalNumber + , qual E.^. QualificationSapId + , qualUser E.^. QualificationUserFirstHeld + , qualUser E.^. QualificationUserValidUntil + , E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom ) blockOrder + , E.arrayAggWith E.AggModeAll ( qualBlock E.?. QualificationUserBlockUnblock) blockOrder ) let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers fmtOpts = (review csvPreset CsvPresetRFC) diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index f9be59482..5a02a6d35 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -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) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 23ca1e78d..d856a29c4 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -101,7 +101,7 @@ postUsersR = do (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr - , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity 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" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity 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 E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -265,15 +265,9 @@ postUsersR = do Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) - , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if - | Set.null criteria -> E.true - | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria - ) - , ( "personal-number", FilterColumn $ \user (criteria :: Set.Set Text) -> if - | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? - | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria - ) - , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if + , ( "personal-number" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber)) + , ( "matriculation" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches + , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if -- exact filter on table UserAvs | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? | otherwise -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria ) @@ -312,26 +306,32 @@ postUsersR = do E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId) E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria) ) - , ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion -> - E.from $ \usrAvs -> -- do - E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^.UserId - E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. - (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) + -- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter + -- E.from $ \usrAvs -> -- do + -- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser + -- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. + -- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) + -- ) + , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of + Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor + Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor + _ -> E.val True :: E.SqlExpr (E.Value Bool) ) ] , dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) - , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent) - , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) - -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr) - , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) - , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment) - , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) - , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) - , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) - , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) - , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) + [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) + , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent) + , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlus) -- contains filter on UserMatrikelnummer + -- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo & setTooltip MsgTableFilterCommaPlus) -- exact filter on table UserAvs + , prismAForm (singletonFilter "company-department") mPrev $ aopt textField (fslI MsgCompanyDepartment) + , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) + , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor) + , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) + , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = DBParamsForm diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index d13be8cee..2460eb65d 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -38,6 +38,10 @@ import Handler.Utils.Term as Handler.Utils import Control.Monad.Logger +-- | default check if the user an active admin +checkAdmin :: (MonadHandler m, MonadAP (HandlerFor (HandlerSite m) )) => m Bool +checkAdmin = liftHandler $ hasReadAccessTo AdminR + -- | Prefix a message with a short course id, -- eg. for window title bars, etc. diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index ea9812c68..f104f0073 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index dc9e8199a..7ff482a96 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -312,6 +312,9 @@ citext2lower = Text.toLower . CI.original citext2string :: CI Text -> String citext2string = Text.unpack . CI.original +string2citext :: String -> CI Text +string2citext = CI.mk . Text.pack + -- | Convert or remove all non-ascii characters, e.g. for filenames text2asciiAlphaNum :: Text -> Text text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) @@ -665,6 +668,11 @@ lastMaybe' l = fmap snd $ l ^? _Snoc minimumMaybe :: (MonoFoldable mono, Ord (Element mono)) => mono -> Maybe (Element mono) minimumMaybe = fmap minimum . fromNullable +zipMaybes :: [Maybe a] -> [Maybe b] -> [(a,b)] +zipMaybes (Just x:xs) (Just y:ys) = (x,y) : zipMaybes xs ys +zipMaybes (_:xs) (_:ys) = zipMaybes xs ys +zipMaybes _ _ = [] + -- | Merge/Add any attribute-value pair to an existing list of such pairs. -- If the attribute exists, the new valu will be prepended, separated by a single empty space insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs new file mode 100644 index 000000000..ffa84ff18 --- /dev/null +++ b/test/Handler/SAPSpec.hs @@ -0,0 +1,127 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.SAPSpec where + +import TestImport +-- import ModelSpec () +-- import CryptoID + +import Handler.SAP + +{- +data BlockIntervalTest = BlockIntervalTest Day Day [(Day,Bool)] + deriving (Show, Eq, Ord) + +instance Arbitrary BlockIntervalTest where + arbitrary = do + blocks <- arbitrary + case blocks of + [] -> do + dFrom <- arbitrary + dUntil <- arbitrary `suchThat` (dFrom <) + return $ BlockIntervalTest dFrom dUntil [] + ((h,_):t') -> do + let ds = ncons h (fst <$> t') + dmin = minimum ds + dmax = maximum ds + dFrom <- arbitrary `suchThat` (<= dmin) + dUntil <- arbitrary `suchThat` (>= dmax) + return $ BlockIntervalTest dFrom dUntil $ sort blocks + + shrink (BlockIntervalTest dFrom dUntil []) + = [BlockIntervalTest dF dU [] | dF <- shrink dFrom, dU <- shrink dUntil, dF < dU] + shrink (BlockIntervalTest dFrom dUntil blocks) + = [BlockIntervalTest dFrom dUntil b | b <- shrink blocks, all ((dFrom <=) . fst) b] +-} + +{- These alternative implementations do NOT meet the specifications and thus cannot be used for testing +compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] +compileBlocks dfrom duntil [] = [(dfrom, duntil)] +compileBlocks dfrom duntil [(d,False)] + | dend <- min duntil d, dfrom < dend = [(dfrom, dend)] -- redundant, but common case + | otherwise = [] +compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs) + | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock + | d1 == d2 = compileBlocks dfrom duntil (p2:bs) -- eliminate same day changes + | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later +compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock +compileBlocks dfrom duntil ((d,False):bs) + | dfrom >= d = compileBlocks dfrom duntil bs -- should only occur if blocks/unblock happened on same day + + +cmpBlocks :: BlockIntervalTest -> [(Day,Day)] +cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks + where + cleanBlocks ((_,True):r) = cleanBlocks r + cleanBlocks (b1@(d1,False):b2@(d2,True):r) + | d1 < d1 = b1:b2:cleanBlocks r + | otherwise = cleanBlocks r + cleanBlocks (b1@(_,False): (_,False):r) = cleanBlocks (b1:r) + cleanBlocks r@[(_,False)] = r + cleanBlocks [] = [] + + makePeriods a b ((d1,False):(d2,True):r) + | b > d2 = (a,d1):makePeriods d2 b r + | otherwise = [(a,d1)] + makePeriods a b [(d,False)] = [(a,min b d)] + makePeriods a b _ = [(a,b)] +-} + + +spec :: Spec +spec = do + describe "SAP.compileBlocks" $ do + it "works on examples" . example $ do + let wA = fromGregorian 2002 1 11 + wE = fromGregorian 2025 4 30 + 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)] + compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)] + compileBlocks wA wE [(w1,True)] `shouldBe` [(wA,wE)] + compileBlocks wA wE [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] + compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,wE)] + compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)] + compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)] + compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)] + compileBlocks wA wE [(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)] + compileBlocks wA wE [(w1,False),(succ w1,True),(succ w1,False),(w2,True)] `shouldBe` [(wA,succ w1),(w2,wE)] + 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 + d1 <- arbitrary + d2 <- arbitrary `suchThat` (d1 <) + d3 <- arbitrary `suchThat` (d1 <) + return (d1,d2,d3) + b <- generate arbitrary + let test = compileBlocks d1 d2 [(d3,b)] + test `shouldBe` bool [(d1,min d2 d3)] [(d1,d2)] b + + it "identifies two correct intervals" $ do + (d1,d2,d3,d4) <- generate $ do + d1 <- arbitrary + d2 <- arbitrary `suchThat` (d1 <) + d3 <- arbitrary `suchThat` (d1 <) + d4 <- arbitrary `suchThat` (d3 <) + return (d1,d2,d3,d4) + 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