From 41810dbd75a2c66d1c8368856d370876542eb57e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 Mar 2023 15:52:03 +0000 Subject: [PATCH] chore(lms): delay lms user deletion by setting --- config/settings.yml | 1 + src/Audit/Types.hs | 2 +- src/Handler/Admin/Avs.hs | 2 +- src/Handler/LMS/Users.hs | 24 +++++++++++++----------- src/Handler/Utils/Avs.hs | 2 +- src/Handler/Utils/LMS.hs | 26 +++++++++++++++++++------- src/Handler/Utils/Table/Cells.hs | 2 +- src/Model/Types/Lms.hs | 4 ++-- src/Settings.hs | 2 ++ test/Database/Fill.hs | 4 ++-- 10 files changed, 43 insertions(+), 26 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 1f547b1dc..f5714203d 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -150,6 +150,7 @@ lms-direct: download-header: "_env:LMSDOWNLOADHEADER:true" download-delimiter: "_env:LMSDOWNLOADDELIMITER:," download-cr-lf: "_env:LMSDOWNLOADCRLF:true" + deletion-days: "_env:LMSDELETIONDAYS:7" avs: host: "_env:AVSHOST:skytest.fra.fraport.de" diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 195f1d878..4ba414ea8 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -199,7 +199,7 @@ data Transaction } | TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well! { transactionUser :: UserId -- qualification holder that is updated - , transactionQualificationUser :: QualificationUserId + , transactionQualificationUser :: QualificationUserId -- könnte entfernt werden , transactionQualification :: QualificationId , transactionQualificationValidUntil :: Day , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index e4609bd0a..24c574276 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -391,7 +391,7 @@ getProblemAvsSynchR = do let nowaday = utctDay now procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler () procRes aLic (LicenceTableChangeAvsData , apids) = catchAllAvs $ do - oks <- setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids + oks <- setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids -- catch here let no_req = Set.size apids mkind = if oks < no_req then Warning else Success addMessageI mkind $ MsgAvsSetLicences aLic oks no_req diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index e3542f2b4..5af247638 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -34,13 +34,13 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only makeLenses_ ''LmsUserTableCsv -- | Mundane conversion needed for direct download without dbTable onlu -lmsUser2csv :: LmsUser -> LmsUserTableCsv -lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv +lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv +lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv { csvLUTident = lmsUserIdent , csvLUTpin = lmsUserPin - , csvLUTresetPin = lmsUserResetPin & LmsBool - , csvLUTdelete = lmsUserToDelete lu & LmsBool - , csvLUTstaff = False & LmsBool + , csvLUTresetPin = lmsUserResetPin & LmsBool + , csvLUTdelete = lmsUserToDelete cutoff lu & LmsBool + , csvLUTstaff = False & LmsBool } -- csv without headers @@ -84,7 +84,8 @@ instance CsvColumnsExplained LmsUserTableCsv where mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserTable _sid qsh qid = do - dbtCsvName <- csvFilenameLmsUser qsh + cutoff <- liftHandler lmsDeletionDate + dbtCsvName <- csvFilenameLmsUser qsh let dbtCsvSheetName = dbtCsvName let userDBTable = DBTable{..} @@ -100,14 +101,14 @@ mkUserTable _sid qsh qid = do , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset - , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser + , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff -> del ) -> ifIconCell del IconRemoveUser , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty ] dbtSorting = Map.fromList [ (csvLmsIdent , SortColumn (E.^. LmsUserIdent)) , (csvLmsPin , SortColumn (E.^. LmsUserPin)) , (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin)) - , (csvLmsDelete , SortColumn lmsUserToDeleteExpr) + , (csvLmsDelete , SortColumn (lmsUserToDeleteExpr cutoff)) ] dbtFilter = Map.fromList [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) @@ -132,7 +133,7 @@ mkUserTable _sid qsh qid = do <$> view (_dbrOutput . _entityVal . _lmsUserIdent) <*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) - <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) + <*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool) <*> const (LmsBool False) dbtCsvDecode = Nothing @@ -154,6 +155,7 @@ getLmsUsersR sid qsh = do getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR sid qsh = do $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid + cutoff <- lmsDeletionDate lms_users <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent] @@ -170,11 +172,11 @@ getLmsUsersDirectR sid qsh = do , csvLUTstaff = LmsBool False } -} - LmsConf{..} <- getsYesod $ view _appLmsConf + LmsConf{..} <- getsYesod $ view _appLmsConf let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users --csvRenderedHeader = lmsUserTableCsvHeader --cvsRendered = CsvRendered {..} - csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users + csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users fmtOpts = def { csvIncludeHeader = lmsDownloadHeader , csvDelimiter = lmsDownloadDelimiter , csvUseCrLf = lmsDownloadCrLf diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 091266a06..9702307b3 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -129,7 +129,7 @@ setLicenceAvs apid lic = do --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => Set AvsPersonLicence -> m Int -setLicencesAvs persLics = do +setLicencesAvs persLics = do -- exceptT (return 0 <$ addMessage Error . text2Html . tshow) return $ do AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery aux aqsl 0 persLics where diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 9467a5812..55cbc18ca 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -17,6 +17,7 @@ module Handler.Utils.LMS , csvFilenameLmsUser , csvFilenameLmsUserlist , csvFilenameLmsResult + , lmsDeletionDate , lmsUserToDelete, _lmsUserToDelete , lmsUserToDeleteExpr , lmsUserStatusWidget @@ -33,6 +34,7 @@ import Data.Csv (HasHeader(..), FromRecord) import qualified Data.Set as Set (notMember) import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E import Control.Monad.Random.Class (uniform) import Control.Monad.Trans.Random (evalRandTIO) @@ -101,15 +103,25 @@ makeLmsFilename ftag (citext2lower -> qsh) = do getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime +-- +lmsDeletionDate :: Handler Day +lmsDeletionDate = do + LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf + addDays (fromIntegral $ negate lmsDeletionDays) . utctDay <$> liftIO getCurrentTime + -- | Decide whether LMS platform should delete an identifier -lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) -lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) +lmsUserToDeleteExpr :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) +lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded) + E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) + E.&&. E.explicitUnsafeCoerceSqlExprValue "timestamp" ((lmslist E.^. LmsUserStatus) E.#>>. "{day}") E.<. E.val cutoff + +-- | Is everything since cutoff day or before? +lmsUserToDelete :: Day -> LmsUser -> Bool +lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatus= Just lstat} = lmsStatusDay lstat < cutoff +lmsUserToDelete _ _ = False -lmsUserToDelete :: LmsUser -> Bool -lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus - -_lmsUserToDelete :: Getter LmsUser Bool -_lmsUserToDelete = to lmsUserToDelete +_lmsUserToDelete :: Day -> Getter LmsUser Bool +_lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index c9ac58c8b..b01fa44f9 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -370,7 +370,7 @@ qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlocked qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a qualificationBlockedCell Nothing = mempty qualificationBlockedCell (Just QualificationBlocked{..}) - | 12 >= length qualificationBlockedReason = mkCellWith textCell + | 32 >= length qualificationBlockedReason = mkCellWith textCell | otherwise = mkCellWith modalCell where mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index a191f248b..1a011c8e7 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -48,7 +48,7 @@ instance Ord LmsStatus where isLmsSuccess :: LmsStatus -> Bool isLmsSuccess LmsSuccess{} = True -isLmsSuccess _other = False +isLmsSuccess _other = False makeLenses_ ''LmsStatus @@ -96,7 +96,7 @@ data QualificationBlockStandardReason instance Show QualificationBlockStandardReason where show QualificationBlockFailedELearning = "E-Learning durchgefallen" - show QualificationBlockReturnedByCompany = "Zurückgebeben durch Firma" + show QualificationBlockReturnedByCompany = "Rückgabe Firma" qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text qualificationBlockedReasonText = diff --git a/src/Settings.hs b/src/Settings.hs index 2d5ab05de..9d58ca747 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -317,6 +317,7 @@ data LmsConf = LmsConf , lmsDownloadHeader :: Bool , lmsDownloadDelimiter :: Char , lmsDownloadCrLf :: Bool + , lmsDeletionDays :: Int } deriving (Show) data AvsConf = AvsConf @@ -516,6 +517,7 @@ instance FromJSON LmsConf where lmsDownloadHeader <- o .: "download-header" lmsDownloadDelimiter <- o .: "download-delimiter" lmsDownloadCrLf <- o .: "download-cr-lf" + lmsDeletionDays <- o .: "deletion-days" return LmsConf{..} makeLenses_ ''LmsConf diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 44c8ccd57..492bc7f73 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -593,8 +593,8 @@ fillDb = do void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing - void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing - void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing + void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing + void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing