diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index dc9f5159e..70cdaaecc 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 66ccf51a6..cdd720509 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) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index dc251a6b7..01d856095 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -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) diff --git a/src/Utils.hs b/src/Utils.hs index 4f8b5ff03..7ff482a96 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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)]