160 lines
7.6 KiB
Haskell
160 lines
7.6 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.SAP
|
|
( getQualificationSAPDirectR
|
|
, compileBlocks -- for Test in Handler.SAPSpec only
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Csv
|
|
import Handler.Utils.Profile
|
|
|
|
import qualified Data.Text as Text (intercalate)
|
|
import qualified Data.Csv as Csv
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
data SapUserTableCsv = SapUserTableCsv -- for csv export only
|
|
{ csvSUTpersonalNummer :: Text
|
|
, csvSUTqualifikation :: Text
|
|
, csvSUTgültigVon :: Day
|
|
, csvSUTgültigBis :: Day
|
|
-- , csvSUTsupendiertBis :: Maybe Day
|
|
, csvSUTausprägung :: Text
|
|
}
|
|
deriving (Show, Generic)
|
|
makeLenses_ ''SapUserTableCsv
|
|
|
|
sapUserTableCsvHeader :: Csv.Header
|
|
sapUserTableCsvHeader = Csv.header
|
|
[ "PersonalNummer"
|
|
, "Qualifikation"
|
|
, "GültigVon"
|
|
, "GültigBis"
|
|
-- , "SupendiertBis"
|
|
, "Ausprägung"
|
|
]
|
|
|
|
instance ToNamedRecord SapUserTableCsv where
|
|
toNamedRecord SapUserTableCsv{..} = Csv.namedRecord
|
|
[ "PersonalNummer" Csv..= csvSUTpersonalNummer
|
|
, "Qualifikation" Csv..= csvSUTqualifikation
|
|
, "GültigVon" Csv..= csvSUTgültigVon
|
|
, "GültigBis" Csv..= csvSUTgültigBis
|
|
-- , "SupendiertBis" Csv..= csvSUTsupendiertBis
|
|
, "Ausprägung" Csv..= csvSUTausprägung
|
|
]
|
|
|
|
-- | 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)
|
|
-- 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
|
|
getQualificationSAPDirectR = do
|
|
now <- liftIO getCurrentTime
|
|
fdate <- formatTime' "%Y%m%d_%H-%M" now
|
|
userAuthConf <- getsYesod $ view _appUserAuthConf
|
|
|
|
let
|
|
ldapSources = case userAuthConf of
|
|
UserAuthConfSingleSource (AuthSourceConfLdap LdapConf{..})
|
|
-> singleton $ AuthSourceIdLdap ldapConfSourceId
|
|
_other -> mempty
|
|
ldapCutoff = addDiffDaysRollOver (fromMonths $ -3) now
|
|
|
|
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.where_ . E.exists $ do
|
|
externalUser <- E.from $ E.table @ExternalUser
|
|
E.where_ $ externalUser E.^. ExternalUserUser E.==. user E.^. UserIdent
|
|
E.&&. externalUser E.^. ExternalUserSource `E.in_` E.valList ldapSources
|
|
E.&&. externalUser E.^. ExternalUserLastSync E.>=. E.val ldapCutoff
|
|
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 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)
|
|
{ csvIncludeHeader = True
|
|
, csvDelimiter = ','
|
|
, csvUseCrLf = True
|
|
}
|
|
csvOpts = def { csvFormat = fmtOpts }
|
|
csvSheetName = "fradrive_sap_" <> fdate <> ".csv"
|
|
nr = length qualUsers
|
|
msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
|
|
quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers
|
|
$logInfoS "SAP" msg
|
|
let logInt = runDB $ logInterface "SAP" quals True (Just nr) ""
|
|
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
|
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
|
|
|
|
|
|
-- direct Download see:
|
|
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
|