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

chore(lms): delay lms user deletion by setting

Browse Source
This commit is contained in:
Steffen Jost 2023-03-17 15:52:03 +00:00
parent 56c3c8fe40
commit 41810dbd75
10 changed files with 43 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
config/settings.yml
View File

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

2
src/Audit/Types.hs
View File

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

2
src/Handler/Admin/Avs.hs
View File

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

24
src/Handler/LMS/Users.hs
View File

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

2
src/Handler/Utils/Avs.hs
View File

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

26
src/Handler/Utils/LMS.hs
View File

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

2
src/Handler/Utils/Table/Cells.hs
View File

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

4
src/Model/Types/Lms.hs
View File

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

2
src/Settings.hs
View File

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

4
test/Database/Fill.hs
View File

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