fradrive/src/Handler/SAP.hs

-- SPDX-FileCopyrightText: 2022 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.CaseInsensitive as CI
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.Legacy as E
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 qualifications 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
  let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
  qualUsers <- runDBRead $ 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      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