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

chore(sap): transmit multiple block/unblocks

Browse Source
This commit is contained in:
Steffen Jost 2023-10-13 15:32:19 +00:00
parent cfec7874e6
commit 11861c4d01
4 changed files with 76 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/Database/Esqueleto/Utils.hs
View File

@ -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
@ -656,6 +656,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

2
src/Handler/LMS.hs
View File

@ -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)

107
src/Handler/SAP.hs
View File

@ -18,8 +18,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,26 +56,43 @@ 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), Maybe (Entity QualificationUserBlock))] -> [SapUserTableCsv]
sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId), mbQualUserBlock) <- 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 = getMaxValidDay mbQualUserBlock validUntil
-- , csvSUTsupendiertBis = blocked
, csvSUTausprägung = "J"
}
, validFraportPersonalNumber pn
]
where
getMaxValidDay :: Maybe (Entity QualificationUserBlock) -> Day -> Day
getMaxValidDay (Just Entity{entityVal=QualificationUserBlock{qualificationUserBlockUnblock=False, qualificationUserBlockFrom=bd}}) = min $ utctDay bd
getMaxValidDay _ = id
-- 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 dfrom duntil [] = [(dfrom, duntil )]
compileBlocks dfrom duntil [(d,False)] = [(dfrom, min duntil d)] -- redundant, but common case
compileBlocks dfrom duntil (p1@(d1,u1):(d2,u2):bs)
| u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock
| 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) = compileBlocks dfrom (min duntil d) bs -- should only occur if blocks/unblock happened on same day
-- Alternative Version constructed first, probably more efficient, but GHC does not recognize pattern matching as complete
-- compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
-- compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs)
-- | u1 == u2 = compileBlocks dfrom duntil (p1:bs)
-- | u2, d1 < duntil
-- , d2 < duntil = (dfrom,d1) : compileBlocks d2 duntil bs
-- compileBlocks dfrom duntil ((d1,True):bs) = compileBlocks dfrom duntil bs
-- compileBlocks dfrom duntil [(d1,False)] = [(dfrom, min duntil d1)]
-- compileBlocks dfrom duntil _ = [(dfrom,duntil)]
-- | Deliver all employess with a successful LDAP synch within the last 3 months
getQualificationSAPDirectR :: Handler TypedContent
@ -82,29 +100,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
qualUsers <- runDB $ E.select $ do
(qual :& qualUser :& user :& qualBlock) <-
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.leftJoin` Ex.table @QualificationUserBlock
`Ex.on` (\(_ :& qualUser :& _ :& qualBlock) ->
qualBlock Ex.?. QualificationUserBlockQualificationUser E.?=. qualUser Ex.^. QualificationUserId
Ex.&&. qualBlock `isLatestBlockBefore` Ex.val now
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
)
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)
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
, qualBlock
( 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)

5
src/Utils.hs
View File

@ -668,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)]