Merge branch 'master' into fradrive/fraport-corporate-design
This commit is contained in:
commit
d0d92998d7
@ -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:
|
||||
|
||||
29
CHANGELOG.md
29
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)
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "27.4.41"
|
||||
"version": "27.4.45"
|
||||
}
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.41",
|
||||
"version": "27.4.45",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.41",
|
||||
"version": "27.4.45",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 27.4.41
|
||||
version: 27.4.45
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)]
|
||||
|
||||
127
test/Handler/SAPSpec.hs
Normal file
127
test/Handler/SAPSpec.hs
Normal file
@ -0,0 +1,127 @@
|
||||
-- SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@faport.de>
|
||||
--
|
||||
-- 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
|
||||
Loading…
Reference in New Issue
Block a user