chore(lms): delay lms user deletion by setting

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"

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)

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                  

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 :: Day -> LmsUser -> LmsUserTableCsv
-lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
+lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
   { csvLUTident     = lmsUserIdent
   , csvLUTpin       = lmsUserPin
-  , csvLUTresetPin  = lmsUserResetPin    & LmsBool
+  , csvLUTresetPin  = lmsUserResetPin           & LmsBool
-  , csvLUTdelete    = lmsUserToDelete lu & LmsBool
+  , csvLUTdelete    = lmsUserToDelete cutoff lu & LmsBool
-  , csvLUTstaff     = False              & 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

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

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 :: Day -> 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 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 :: Day -> Getter LmsUser Bool
-lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus
+_lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff
-
-_lmsUserToDelete :: Getter LmsUser Bool
-_lmsUserToDelete = to lmsUserToDelete
 
 -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y?
 

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

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 = 

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

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 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 (-1))  (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) 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