chore(lms): remove obsolete lms handlers v1

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -84,14 +84,8 @@ CsvColumnLmsDate: Datum des E‑Learning Ereignisses
 CsvColumnLmsResetTries: Anzahl der bisher verbrauchten E‑Learning Prüfungsversuche zurücksetzen
 CsvColumnLmsLock: E‑Learning Login gesperrt
 CsvColumnLmsResult !ident-ok: LMS Status
-LmsUserlistInsert: Neuer LMS User
-LmsUserlistUpdate: LMS User Aktualisierung
-LmsResultInsert: Neues LMS Ergebnis
-LmsResultUpdate: LMS Ergebnis Aktualisierung
 LmsReportInsert: Neues LMS Ereignis
 LmsReportUpdate: LMS Ereignis Aktualisierung
-LmsResultCsvExceptionDuplicatedKey: CSV-Import LmsResult fand uneindeutigen Schlüssel
-LmsUserlistCsvExceptionDuplicatedKey: CSV-Import LmsUserlist fand uneindeutigen Schlüssel
 LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel
 LmsDirectUpload: Direkter Upload für automatisierte Systeme
 LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.

messages/uniworx/categories/qualification/en-eu.msg

@@ -84,14 +84,8 @@ CsvColumnLmsResetTries: Reset number of used up e‑learning exam attempts
 CsvColumnLmsDate: Date of e‑learning event
 CsvColumnLmsResult: LMS Status
 CsvColumnLmsLock: E‑learning login is not permitted
-LmsUserlistInsert: New LMS user
-LmsUserlistUpdate: Update of LMS user
-LmsResultInsert: New LMS result
-LmsResultUpdate: Update of LMS result
 LmsReportInsert: New LMS event
 LmsReportUpdate: Update of LMS event
-LmsResultCsvExceptionDuplicatedKey: CSV import LmsResult with ambiguous key
-LmsUserlistCsvExceptionDuplicatedKey: CSV import LmsUserlist with ambiguous key
 LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key
 LmsDirectUpload: Direct upload for automated systems
 LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set.

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -124,8 +124,6 @@ MenuLmsUser: Benutzerqualifikationen
 MenuLmsUserSchool: Bereichs Benutzerqualifikationen
 MenuLmsUserAll: Alle Benutzerqualifikationen
 MenuLmsUsers: Veralteter Export E‑Learning Benutzer
-MenuLmsUserlist: Veraltetes Melden E‑Learning Benutzer
-MenuLmsResult: Veralteter Melden Ergebnisse E‑Learning
 MenuLmsUpload: Hochladen
 MenuLmsDirectUpload: Direkter Upload
 MenuLmsDirectDownload: Direkter Download

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -125,8 +125,6 @@ MenuLmsUser: User Qualifications
 MenuLmsUserSchool: Institute User Qualifications
 MenuLmsUserAll: All User Qualifications
 MenuLmsUsers: Legacy download e‑learning users
-MenuLmsUserlist: Legacy upload e‑learning users
-MenuLmsResult: Legacy upload r‑learning results
 MenuLmsUpload: Upload
 MenuLmsDirectUpload: Direct Upload
 MenuLmsDirectDownload: Direct Download

models/lms.model

@@ -95,25 +95,20 @@ QualificationUserBlock
   --     - delete-flag: isJust LmsUserStatus
   --   Note: REST means that LmsUserResetPin and LmsUserDelete remain unchanged by this GET request!
   --
-  -- 3. REST POST Userlist.csv: just save as is to LmsUserlist
+  -- 3. REST POST Report.csv: just save as is to LmsReport for later processing
   --
-  -- 4. REST POST Ergebnisse.csv: just save as is to LmsResult
+  -- 4. When received: Job LmsReport:               -- Note: containment needs at-once processing
-  --
-  -- 5. When received: Job LmsUserlist:               -- Note: containment needs at-once processing
   --     - For all LmsUser:
   --         + if contained:
   --              set LmsUserReceived to Just now()
-  --              if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now
+  --              if Failed:  set LmsUserStatus to Just LmsBlocked now
+  --              if Success: set LmsUserStatus to Just LmsSuccess now
+  --                          and renew QualificationValidTo
   --         + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now()
   --     - move row to LmsAudit
   --
-  -- 6. When received: Daily Job LmsResult:
+  -- 5. Daily Job: dequeue LMS Users
-  --     - set LmsUserReceived to Just now()             -- always
+  --     - fail and mark expired LmsUser
-  --     - set LmsUserStatus   to Just LmsSuccess now    -- conditional
-  --     -   and renew QualificationValidTo
-  --     - move row to LmsAudit
-  --
-  -- 7. Daily Job: dequeue LMS Users
   --     - remove from LmsUser after audit Period has passed
 
 LmsUser
@@ -144,24 +139,6 @@ LmsUser
 --   UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history
 --   deriving Generic
 
--- DEPRECATED V1 LmsUserlist stores LMS upload for later processing only
-LmsUserlist
-  qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  ident             LmsIdent        
-  failed            Bool
-  timestamp         UTCTime         default=now()
-  UniqueLmsUserlist qualification ident
-  deriving Generic Show
-
--- DEPRECATED V1 LmsResult stores LMS upload for later processing only
-LmsResult
-  qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  ident             LmsIdent        
-  success           Day             -- BEWARE: timezone is local as submitted by LMS
-  timestamp         UTCTime         default=now()
-  UniqueLmsResult qualification ident -- required by DBTable
-  deriving Generic
-
 -- V2 Stores LMS upload for processing in Background Job
 LmsReport
   qualification     QualificationId OnDeleteCascade OnUpdateCascade

routes

@@ -279,15 +279,6 @@
 /lms/#SchoolId                                              LmsSchoolR              GET
 /lms/#SchoolId/#QualificationShorthand                      LmsR  				          GET POST
 /lms/#SchoolId/#QualificationShorthand/edit                 LmsEditR			          GET POST
--- old V1 LMS Interface
-/lms/#SchoolId/#QualificationShorthand/users                LmsUsersR	              GET
-/lms/#SchoolId/#QualificationShorthand/users/direct         LmsUsersDirectR	        GET       !token -- LMS
-/lms/#SchoolId/#QualificationShorthand/userlist             LmsUserlistR	          GET POST
-/lms/#SchoolId/#QualificationShorthand/userlist/upload      LmsUserlistUploadR	    GET POST  !development
-/lms/#SchoolId/#QualificationShorthand/userlist/direct      LmsUserlistDirectR	        POST  !token -- LMS, also remove JobLmsUserlist constructor
-/lms/#SchoolId/#QualificationShorthand/result               LmsResultR              GET POST
-/lms/#SchoolId/#QualificationShorthand/result/upload        LmsResultUploadR        GET POST  !development
-/lms/#SchoolId/#QualificationShorthand/result/direct        LmsResultDirectR            POST  !token -- LMS, also remove JobLmsResults constructor
 -- new V2 LMS Interface
 /lms/#SchoolId/#QualificationShorthand/learners             LmsLearnersR	          GET
 /lms/#SchoolId/#QualificationShorthand/learners/direct      LmsLearnersDirectR	    GET       !token -- LMS

src/Foundation/Navigation.hs

@@ -185,14 +185,6 @@ breadcrumb (LmsR                ssh  qsh) = useRunDB . maybeT (i18nCrumb MsgBrea
   guardM . lift . existsBy $ SchoolQualificationShort ssh qsh
   return (CI.original qsh, Just $ LmsSchoolR ssh)
 breadcrumb (LmsEditR            ssh  qsh) = i18nCrumb MsgMenuLmsEdit       $ Just $ LmsR          ssh qsh
-breadcrumb (LmsUsersR           ssh  qsh) = i18nCrumb MsgMenuLmsUsers      $ Just $ LmsR          ssh qsh
-breadcrumb (LmsUsersDirectR     ssh  qsh) = i18nCrumb MsgMenuLmsUsers      $ Just $ LmsUsersR     ssh qsh -- never displayed, TypedContent
-breadcrumb (LmsUserlistR        ssh  qsh) = i18nCrumb MsgMenuLmsUserlist   $ Just $ LmsR          ssh qsh
-breadcrumb (LmsUserlistUploadR  ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsUserlistR  ssh qsh
-breadcrumb (LmsUserlistDirectR  ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsUserlistR  ssh qsh -- never displayed
-breadcrumb (LmsResultR          ssh  qsh) = i18nCrumb MsgMenuLmsResult     $ Just $ LmsR          ssh qsh
-breadcrumb (LmsResultUploadR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsResultR    ssh qsh
-breadcrumb (LmsResultDirectR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsResultR    ssh qsh -- never displayed
 -- v2
 breadcrumb (LmsLearnersR        ssh  qsh) = i18nCrumb MsgMenuLmsLearners   $ Just $ LmsR          ssh qsh
 breadcrumb (LmsLearnersDirectR  ssh  qsh) = i18nCrumb MsgMenuLmsLearners   $ Just $ LmsLearnersR  ssh qsh -- never displayed, TypedContent
@@ -2375,27 +2367,7 @@ pageActions (LmsR sid qsh) = return
         [ defNavLink MsgMenuLmsUpload       $ LmsReportUploadR sid qsh
         , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh
         ]
-    }
+    }  
-  , NavPageActionSecondary
-    { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh
-    -- , navChildren =
-    --     [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh
-    --     ]
-    }
-  , NavPageActionSecondary
-    { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh
-    -- , navChildren =
-    --     [ defNavLink MsgMenuLmsUpload       $ LmsUserlistUploadR sid qsh
-    --     , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh
-    --     ]
-    }
-  , NavPageActionSecondary
-    { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh
-    -- , navChildren =
-    --     [ defNavLink MsgMenuLmsUpload       $ LmsResultUploadR sid qsh
-    --     , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh
-    --     ]
-    }
   , NavPageActionSecondary {
       navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh
     }

src/Handler/LMS.hs

@@ -11,13 +11,7 @@ module Handler.LMS
   , getLmsR               , postLmsR
   , getLmsIdentR
   , getLmsEditR           , postLmsEditR
-  -- V1
+  -- V2
-  , getLmsUsersR          , getLmsUsersDirectR
-  , getLmsUserlistR       , postLmsUserlistR
-  , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
-  , getLmsResultR         , postLmsResultR
-  , getLmsResultUploadR   , postLmsResultUploadR  , postLmsResultDirectR
-  -- V1
   , getLmsLearnersR       , getLmsLearnersDirectR
   , getLmsReportR         , postLmsReportR
   , getLmsReportUploadR   , postLmsReportUploadR  , postLmsReportDirectR
@@ -50,10 +44,6 @@ import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
--- V1
-import Handler.LMS.Users    as Handler.LMS
-import Handler.LMS.Userlist as Handler.LMS
-import Handler.LMS.Result   as Handler.LMS
 -- V2
 import Handler.LMS.Learners as Handler.LMS
 import Handler.LMS.Report   as Handler.LMS

src/Handler/LMS/Result.hs

@@ -1,293 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
-
-module Handler.LMS.Result
-  ( getLmsResultR, postLmsResultR
-  , getLmsResultUploadR, postLmsResultUploadR
-  , postLmsResultDirectR
-  )
-  where
-
-import Import
-
-import Handler.Utils
-import Handler.Utils.Csv
-import Handler.Utils.LMS
-
-import qualified Data.Map as Map
-import qualified Data.Csv as Csv
-import qualified Data.Conduit.List as C
-import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
-
-import Jobs.Queue
-
-
-data LmsResultTableCsv = LmsResultTableCsv
-  { csvLRTident   :: LmsIdent
-  , csvLRTsuccess :: LmsDay
-  }
-  deriving Generic
-makeLenses_ ''LmsResultTableCsv
-
--- csv without headers
-instance Csv.ToRecord   LmsResultTableCsv -- default suffices
-instance Csv.FromRecord LmsResultTableCsv -- default suffices
-
--- csv with headers
-lmsResultTableCsvHeader :: Csv.Header
-lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
-
-instance ToNamedRecord LmsResultTableCsv where
-  toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
-    [ csvLmsIdent   Csv..= csvLRTident
-    , csvLmsSuccess Csv..= csvLRTsuccess
-    ]
-
-instance FromNamedRecord LmsResultTableCsv where
-  parseNamedRecord (lsfHeaderTranslate -> csv)
-    = LmsResultTableCsv
-        <$> csv Csv..: csvLmsIdent
-        <*> csv Csv..: csvLmsSuccess
-
-instance CsvColumnsExplained LmsResultTableCsv where
-  csvColumnsExplanations _ = mconcat
-    [ single csvLmsIdent   MsgCsvColumnLmsIdent
-    , single csvLmsSuccess MsgCsvColumnLmsSuccess
-    ]
-    where
-      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
-      single k v = singletonMap k [whamlet|_{v}|]
-
-data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate
-  deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
-embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
-
--- By coincidence the action type is identical to LmsResultTableCsv
-data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
-                        | LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
-  deriving (Eq, Ord, Read, Show, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsResultInsertData -> insert
-  , fieldLabelModifier     = camelToPathPiece'  2     -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
-  , sumEncoding = TaggedObject "action" "data"
-  } ''LmsResultCsvAction
-
-data LmsResultCsvException
-  = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
-  deriving (Show, Generic)
-
-instance Exception LmsResultCsvException
-embedRenderMessage ''UniWorX ''LmsResultCsvException id
-
-mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
-mkResultTable sid qsh qid = do
-  now_day <- utctDay <$> liftIO getCurrentTime
-  dbtCsvName <- csvFilenameLmsResult qsh
-  let dbtCsvSheetName = dbtCsvName
-  let
-    resultDBTable = DBTable{..}
-      where
-        dbtSQLQuery lmsresult = do
-          E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
-          return lmsresult
-        dbtRowKey = (E.^. LmsResultId)
-        dbtProj = dbtProjId
-        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
-          , sortable (Just csvLmsSuccess)   (i18nCell MsgTableLmsSuccess)  $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess            -> success) -> dayCell success
-          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp        -> timestamp) -> dateTimeCell timestamp
-          ]
-        dbtSorting = Map.fromList
-          [ (csvLmsIdent    , SortColumn (E.^. LmsResultIdent))
-          , (csvLmsSuccess  , SortColumn (E.^. LmsResultSuccess))
-          , (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp))
-          ]
-        dbtFilter = Map.fromList
-          [ (csvLmsIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
-          , (csvLmsSuccess, FilterColumn $ E.mkExactFilter                 (E.^. LmsResultSuccess))
-          ]
-        dbtFilterUI = \mPrev -> mconcat
-          [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
-          , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField)  (fslI MsgTableLmsSuccess)
-          ]
-        dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "lms-result"
-        dbtCsvEncode = Just DBTCsvEncode
-          { dbtCsvExportForm   = pure ()
-          , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
-          , dbtCsvName
-          , dbtCsvSheetName
-          , dbtCsvNoExportData = Just id
-          , dbtCsvHeader       = const $ return lmsResultTableCsvHeader
-          , dbtCsvExampleData  = Just
-            [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
-            | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
-            ]
-          }
-          where
-            doEncode' = LmsResultTableCsv
-              <$> view (_dbrOutput . _entityVal . _lmsResultIdent)
-              <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay)
-        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
-          { dbtCsvRowKey = \LmsResultTableCsv{..} ->
-              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident
-          , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
-              DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
-                yield $ LmsResultInsertData
-                        { lmsResultInsertIdent   = csvLRTident   dbCsvNew
-                        , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day
-                        }
-              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
-              DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do
-                let successDay = lms2day csvLRTsuccess
-                when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $
-                  yield $ LmsResultUpdateData
-                          { lmsResultInsertIdent   = csvLRTident
-                          , lmsResultInsertSuccess = successDay
-                          }
-              DBCsvDiffMissing{}  -> return () -- no deletion
-          , dbtCsvClassifyAction      = \case
-              LmsResultInsertData{} -> LmsResultInsert
-              LmsResultUpdateData{} -> LmsResultUpdate
-          , dbtCsvCoarsenActionClass  = \case
-              LmsResultInsert -> DBCsvActionNew
-              LmsResultUpdate -> DBCsvActionExisting
-          , dbtCsvValidateActions     = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
-          , dbtCsvExecuteActions      = do
-            C.mapM_ $ \actionData -> do
-                now <- liftIO getCurrentTime
-                void $ upsert
-                  LmsResult
-                    { lmsResultQualification  =  qid
-                    , lmsResultIdent          =  lmsResultInsertIdent   actionData
-                    , lmsResultSuccess        =  lmsResultInsertSuccess actionData
-                    , lmsResultTimestamp      =  now -- lmsResultInsertTimestamp -- does it matter which one to choose?
-                    }
-                  [ LmsResultSuccess          =. lmsResultInsertSuccess actionData
-                  , LmsResultTimestamp        =. now
-                  ]
-                -- audit $ Transaction.. (add to Audit.Types)
-            lift . queueDBJob $ JobLmsResults qid
-            return $ LmsResultR sid qsh
-          , dbtCsvRenderKey           = const $ \case
-              LmsResultInsertData{..} -> do -- TODO: i18n
-                [whamlet|
-                  $newline never
-                  Insert: Ident #{getLmsIdent lmsResultInsertIdent} #
-                  had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
-                |]
-              LmsResultUpdateData{..} -> do -- TODO: i18n
-                [whamlet|
-                  $newline never
-                  Update: Ident #{getLmsIdent lmsResultInsertIdent} #
-                  had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
-                |]
-          , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
-          , dbtCsvRenderException     = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
-          }
-        dbtExtraReps = []
-
-    resultDBTableValidator = def
-      & defaultSorting [SortAscBy csvLmsIdent]
-  dbTable resultDBTableValidator resultDBTable
-
-getLmsResultR,  postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsResultR = postLmsResultR
-postLmsResultR sid qsh = do
-  let directUploadLink = LmsResultUploadR sid qsh
-  lmsTable <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-    view _2 <$> mkResultTable sid qsh qid
-  siteLayoutMsg MsgMenuLmsResult $ do
-    setTitleI MsgMenuLmsResult
-    $(widgetFile "lms-result")
-
-
--- Direct File Upload/Download
-
-saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int
-saveResultCsv qid i LmsResultTableCsv{..} = do
-    now <- liftIO getCurrentTime
-    void $ upsert
-      LmsResult
-        { lmsResultQualification  =  qid
-        , lmsResultIdent          =  csvLRTident
-        , lmsResultSuccess        =  csvLRTsuccess & lms2day
-        , lmsResultTimestamp      =  now
-        }
-      [ LmsResultSuccess          =. (csvLRTsuccess & lms2day)
-      , LmsResultTimestamp        =. now
-      ]
-    return $ succ i
-
-makeResultUploadForm :: Form FileInfo
-makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV"
-
-getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsResultUploadR = postLmsResultUploadR
-postLmsResultUploadR sid qsh = do
-  ((result,widget), enctype) <- runFormPost makeResultUploadForm
-  case result of
-    FormSuccess file -> do
-      -- content <- fileSourceByteString file
-      -- return $ Just (fileName file, content)
-      nr <- runDB $ do
-        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-        nr <- runConduit $ fileSource file
-                .| decodeCsv
-                .| foldMC (saveResultCsv qid) 0
-        queueJob' $ JobLmsResults qid
-        return nr
-      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
-      redirect $ LmsResultR sid qsh
-    FormFailure errs -> do
-      forM_ errs $ addMessage Error . toHtml
-      redirect $ LmsResultUploadR sid qsh
-    FormMissing ->
-      siteLayoutMsg MsgMenuLmsResult $ do
-        setTitleI MsgMenuLmsUpload
-        [whamlet|$newline never
-          <form method=post enctype=#{enctype}>
-            ^{widget}
-            <p>
-            <input type=submit>
-        |]
-
-
-postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
-postLmsResultDirectR sid qsh = do
-  (_params, files) <- runRequestBody
-  (status, msg) <- case files of
-    [(fhead,file)] -> do
-      lmsDecoder <- getLmsCsvDecoder
-      runDB $ do
-        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-        enr <- try $ runConduit $ fileSource file
-                .| lmsDecoder
-                .| foldMC (saveResultCsv qid) 0
-        case enr of
-          Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
-            $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
-            return (badRequest400, "Exception: " <> tshow e)
-          Right nr -> do
-            let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
-            $logInfoS "LMS" msg
-            when (nr > 0) $ queueJob' $ JobLmsResults qid
-            return (ok200, msg)
-    []     -> do
-      let msg = "Result upload file missing."
-      $logWarnS "LMS" msg
-      return (badRequest400, msg)
-    _other -> do
-      let msg = "Result upload received multiple files; all ignored."
-      $logWarnS "LMS" msg
-      return (badRequest400, msg)
-  sendResponseStatus status msg
-

src/Handler/LMS/Userlist.hs

@@ -1,288 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
-
-module Handler.LMS.Userlist
-  ( getLmsUserlistR, postLmsUserlistR
-  , getLmsUserlistUploadR, postLmsUserlistUploadR
-  , postLmsUserlistDirectR
-  )
-  where
-
-import Import
-
-import Handler.Utils
-import Handler.Utils.Csv
-import Handler.Utils.LMS
-
-import qualified Data.Map as Map
-import qualified Data.Csv as Csv
-import qualified Data.Conduit.List as C
-import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
-
-import Jobs.Queue
-
-data LmsUserlistTableCsv = LmsUserlistTableCsv
-  { csvLULident  :: LmsIdent
-  , csvLULfailed :: LmsBool
-  }
-  deriving Generic
-makeLenses_ ''LmsUserlistTableCsv
-
--- csv without headers
-instance Csv.ToRecord   LmsUserlistTableCsv
-instance Csv.FromRecord LmsUserlistTableCsv
-
--- csv with headers
-instance DefaultOrdered LmsUserlistTableCsv where
-   headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ]
-
-instance ToNamedRecord LmsUserlistTableCsv where
-  toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
-    [ csvLmsIdent   Csv..= csvLULident
-    , csvLmsBlocked Csv..= csvLULfailed
-    ]
-instance FromNamedRecord LmsUserlistTableCsv where
-  parseNamedRecord (lsfHeaderTranslate -> csv)
-    = LmsUserlistTableCsv
-        <$> csv Csv..: csvLmsIdent
-        <*> csv Csv..: csvLmsBlocked
-
-instance CsvColumnsExplained LmsUserlistTableCsv where
-  csvColumnsExplanations _ = mconcat
-    [ single csvLmsIdent   MsgCsvColumnLmsIdent
-    , single csvLmsBlocked MsgCsvColumnLmsLock
-    ]
-    where
-      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
-      single k v = singletonMap k [whamlet|_{v}|]
-
-
-data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate
-  deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
-embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id
-
-data LmsUserlistCsvAction = LmsUserlistInsertData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
-                          | LmsUserlistUpdateData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
-  deriving (Eq, Ord, Read, Show, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsUserlistInsertData -> insert
-  , fieldLabelModifier = camelToPathPiece' 2          -- lmsUserlistInsertIdent -> insert-ident | lmsUserlistInsertFailed -> insert-failed
-  , sumEncoding = TaggedObject "action" "data"
-  } ''LmsUserlistCsvAction
-
-
-data LmsUserlistCsvException
-  = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
-  deriving (Show, Generic)
-
-instance Exception LmsUserlistCsvException
-embedRenderMessage ''UniWorX ''LmsUserlistCsvException id
-
-mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
-mkUserlistTable sid qsh qid = do
-  dbtCsvName <- csvFilenameLmsUserlist qsh
-  let dbtCsvSheetName = dbtCsvName
-  let
-    userlistTable = DBTable{..}
-      where
-        dbtSQLQuery lmslist = do
-          E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
-          return lmslist
-        dbtRowKey = (E.^. LmsUserlistId)
-        dbtProj   = dbtProjId
-        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell    $ lmsUserlistIdent & getLmsIdent
-          , sortable (Just csvLmsBlocked)   (i18nCell MsgTableLmsLock)     $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell    lmsUserlistFailed IconBlocked
-          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell  lmsUserlistTimestamp
-          ]
-        dbtSorting = Map.fromList
-          [ (csvLmsIdent    , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
-          , (csvLmsBlocked  , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
-          , (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
-          ]
-        dbtFilter = Map.fromList
-          [ (csvLmsIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
-          , (csvLmsBlocked, FilterColumn $ E.mkExactFilter                 (E.^. LmsUserlistFailed))
-          ]
-        dbtFilterUI =  \mPrev -> mconcat
-          [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
-          , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsLock)
-          ]
-        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "lms-userlist"
-        dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample
-          where
-            addExample dce = dce{ dbtCsvExampleData = csvExample }
-            csvExample = Just
-              [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl}
-              | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False]
-              ]
-            doEncode' = LmsUserlistTableCsv
-              <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent)
-              <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool)
-        dbtCsvDecode = Just DBTCsvDecode {..}
-          where
-            dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
-              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident
-            dbtCsvComputeActions = \case -- shows a diff first
-              DBCsvDiffNew{dbCsvNew} -> do
-                yield $ LmsUserlistInsertData
-                          { lmsUserlistInsertIdent  =            csvLULident   dbCsvNew
-                          , lmsUserlistInsertFailed = lms2bool $ csvLULfailed  dbCsvNew
-                          }
-              DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do
-                let failedBool = lms2bool csvLULfailed
-                when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $
-                  yield $ LmsUserlistUpdateData
-                            { lmsUserlistInsertIdent  = csvLULident
-                            , lmsUserlistInsertFailed = csvLULfailed & lms2bool
-                            }
-              DBCsvDiffMissing{} -> return () -- no deletion
-            dbtCsvClassifyAction = \case
-               LmsUserlistInsertData{} -> LmsUserlistInsert
-               LmsUserlistUpdateData{} -> LmsUserlistUpdate
-            dbtCsvCoarsenActionClass = \case
-               LmsUserlistInsert -> DBCsvActionNew
-               LmsUserlistUpdate -> DBCsvActionExisting
-            dbtCsvValidateActions = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
-            dbtCsvExecuteActions = do
-              C.mapM_ $ \actionData -> do
-                now <- liftIO getCurrentTime
-                void $ upsert LmsUserlist
-                  {
-                    lmsUserlistQualification  =  qid
-                  , lmsUserlistIdent          =  lmsUserlistInsertIdent   actionData
-                  , lmsUserlistFailed         =  lmsUserlistInsertFailed  actionData
-                  , lmsUserlistTimestamp      =  now
-                  }
-                  [
-                    LmsUserlistFailed         =. lmsUserlistInsertFailed  actionData -- TODO: should we allow a reset from failed: True to False?
-                  , LmsUserlistTimestamp      =. now
-                  ]
-                -- audit
-              lift . queueDBJob $ JobLmsUserlist qid
-              return $ LmsUserlistR sid qsh
-            dbtCsvRenderKey = const $ \case
-              LmsUserlistInsertData{..} -> do -- TODO: i18n
-                [whamlet|
-                  $newline never
-                  Insert: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
-                  $if lmsUserlistInsertFailed
-                    is closed due to failure.
-                  $else
-                    is open.
-                |]
-              LmsUserlistUpdateData{..} -> do -- TODO: i18n
-                [whamlet|
-                  $newline never
-                  Update: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
-                  $if lmsUserlistInsertFailed
-                    is now closed due to failure.
-                  $else
-                    is still open.
-                |]
-            dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
-            dbtCsvRenderException = ap getMessageRender . pure :: LmsUserlistCsvException -> DB Text
-        dbtExtraReps = []
-
-    userlistDBTableValidator = def
-      & defaultSorting [SortAscBy csvLmsIdent]
-
-  dbTable userlistDBTableValidator userlistTable
-
-
-getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsUserlistR = postLmsUserlistR
-postLmsUserlistR sid qsh = do
-  lmsTable <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-    view _2 <$> mkUserlistTable sid qsh qid
-  siteLayoutMsg MsgMenuLmsUserlist $ do
-    setTitleI MsgMenuLmsUserlist
-    lmsTable
-
-
--- Direct File Upload/Download
---  saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) =>
---                      Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b
-saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int
-saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
-    now <- liftIO getCurrentTime
-    void $ upsert
-      LmsUserlist
-        { lmsUserlistQualification  =  qid
-        , lmsUserlistIdent          =  csvLULident
-        , lmsUserlistFailed         =  csvLULfailed & lms2bool
-        , lmsUserlistTimestamp      =  now
-        }
-      [ LmsUserlistFailed           =. (csvLULfailed & lms2bool)
-      , LmsUserlistTimestamp        =. now
-      ]
-    return $ succ i
-
-makeUserlistUploadForm :: Form FileInfo
-makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV"
-
-getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsUserlistUploadR = postLmsUserlistUploadR
-postLmsUserlistUploadR sid qsh = do
-  ((result,widget), enctype) <- runFormPost makeUserlistUploadForm
-  case result of
-    FormSuccess file -> do
-      nr <- runDB $ do
-        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-        nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0
-        queueJob' $ JobLmsUserlist qid
-        return nr
-      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
-      redirect $ LmsUserlistR sid qsh
-    FormFailure errs -> do
-      forM_ errs $ addMessage Error . toHtml
-      redirect $ LmsUserlistUploadR sid qsh
-    FormMissing ->
-      siteLayoutMsg MsgMenuLmsUserlist $ do
-        setTitleI MsgMenuLmsUpload
-        [whamlet|$newline never
-          <form method=post enctype=#{enctype}>
-            ^{widget}
-            <p>
-            <input type=submit>
-        |]
-
-
-postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html
-postLmsUserlistDirectR sid qsh = do
-  (_params, files) <- runRequestBody
-  (status, msg) <- case files of
-    [(fhead,file)] -> do
-      lmsDecoder <- getLmsCsvDecoder
-      runDB $ do
-        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-        enr <- try $ runConduit $ fileSource file
-                .| lmsDecoder
-                .| foldMC (saveUserlistCsv qid) 0
-        case enr of
-          Left (e :: SomeException) -> do
-            $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e
-            return (badRequest400, "Exception: " <> tshow e)
-          Right nr -> do
-            let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
-            $logInfoS "LMS" msg 
-            when (nr > 0) $ queueJob' $ JobLmsUserlist qid
-            return (ok200, msg)
-    []     -> do
-      let msg = "Userlist upload file missing."
-      $logWarnS "LMS" msg
-      return (badRequest400, msg)
-    _other -> do
-      let msg = "Userlist upload received multiple files; all ignored."
-      $logWarnS "LMS" msg
-      return (badRequest400, msg)
-  sendResponseStatus status msg

src/Handler/Utils/LMS.hs

@@ -19,8 +19,6 @@ module Handler.Utils.LMS
   , csvLmsLock
   , csvLmsResult
   , csvFilenameLmsUser
-  , csvFilenameLmsUserlist
-  , csvFilenameLmsResult
   , csvFilenameLmsReport
   , lmsDeletionDate
   , lmsUserToDelete     , _lmsUserToDelete      , lmsUserToDeleteExpr
@@ -109,14 +107,6 @@ csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offe
 csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text
 csvFilenameLmsUser = makeLmsFilename "user"
 
--- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface V2
-csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text
-csvFilenameLmsUserlist = makeLmsFilename "userliste"
-
--- | Filename for Result transmission, contains current datestamp as agreed in LMS interface V1
-csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text
-csvFilenameLmsResult = makeLmsFilename "ergebnisse"
-
 -- | Filename for Report transmission, combining former Userlist and Result as agreed in new LMS interface V2
 csvFilenameLmsReport :: MonadHandler m => QualificationShorthand -> m Text
 csvFilenameLmsReport = makeLmsFilename "report"

src/Jobs/Handler/LMS.hs

@@ -10,8 +10,6 @@ module Jobs.Handler.LMS
   , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser
   , dispatchJobLmsDequeue
   , dispatchJobLmsReports
-  , dispatchJobLmsResults
-  , dispatchJobLmsUserlist
   ) where
 
 import Import
@@ -28,7 +26,7 @@ import qualified Database.Esqueleto.Utils as E
 import qualified Data.Set as Set
 -- import qualified Data.Map as Map
 
-import qualified Data.Time.Zones as TZ
+-- import qualified Data.Time.Zones as TZ
 import Handler.Utils.DateTime
 import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
 import Handler.Utils.Qualification
@@ -134,10 +132,6 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
           ( (E.^. LmsUserIdent)     <$> E.from (E.table @LmsUser    ) ) -- no filter by Qid, since LmsIdents must be unique across all
           `E.union_`
           ( (E.^. LmsReportIdent)   <$> E.from (E.table @LmsReport  ) ) -- V2
-          `E.union_`
-          ( (E.^. LmsResultIdent)   <$> E.from (E.table @LmsResult  ) ) -- V1 DEPRECATED
-          `E.union_`
-          ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- V1 DEPRECATED
         E.orderBy [E.asc lui]
         pure lui
       now <- liftIO getCurrentTime
@@ -261,8 +255,6 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
           when (numdel > 0) $ do
             $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
             deleteWhere [LmsUserQualification     ==. qid, LmsUserIdent     <-. delusers]
-            deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
-            deleteWhere [LmsResultQualification   ==. qid, LmsResultIdent   <-. delusers]
             -- deleteWhere [LmsAuditQualification    ==. qid, LmsAuditIdent    <-. delusers]
           deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
 
@@ -433,120 +425,3 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
             E.<&> E.true)
         repProc <- deleteWhereCount [LmsReportQualification ==. qid]
         $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
-
-
--- DEPRECATED processes received results and lengthen qualifications, if applicable
-dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
-dispatchJobLmsResults qid = JobHandlerAtomic act
-  where
-    -- act :: YesodJobDB UniWorX ()
-    act = hoist lift $ do
-        results <- E.select $ do
-          (quser :& luser :& lresult) <- E.from $
-              E.table @QualificationUser  -- table not needed if renewal from lms completion day is used TODO: decide!
-              `E.innerJoin` E.table @LmsUser
-              `E.on` (\(quser :& luser) ->
-                              luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser
-                        E.&&. luser E.^. LmsUserQualification  E.==. quser   E.^. QualificationUserQualification)
-              `E.innerJoin` E.table @LmsResult
-              `E.on` (\(_ :& luser :& lresult) ->
-                              luser E.^. LmsUserIdent          E.==. lresult E.^. LmsResultIdent
-                        E.&&. luser E.^. LmsUserQualification  E.==. lresult E.^. LmsResultQualification)
-          E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
-            E.&&.    luser E.^. LmsUserQualification           E.==. E.val qid
-            -- E.&&. E.isNothing (luser E.^. LmsUserStatus)  -- do not process learners already having a result WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning
-            E.&&. E.isNothing (luser E.^. LmsUserEnded)   -- do not process closed learners
-          return (quser, luser, lresult)
-        now <- liftIO getCurrentTime
-        let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
-        forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
-          -- three separate DB operations per result is not so nice. All within one transaction though.
-          let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
-              saneDate    = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
-                            -- && qualificationUserLastRefresh <= utctDay lmsUserStarted    NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway
-              -- newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
-          note <- if saneDate && (lmsUserStatus /= Just LmsSuccess)
-            then do
-              -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-              let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent)
-              ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log
-              when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])
-
-              _ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed
-              -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
-
-              update luid
-                [ LmsUserStatus     =. Just LmsSuccess
-                , LmsUserStatusDay  =. Just (utctDayMidnight lmsResultSuccess)
-                , LmsUserReceived   =. Just lmsResultTimestamp
-                ]
-              return Nothing
-            else do
-              let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}  for #{tshow qid}|]
-              $logErrorS "LMS" errmsg
-              return $ Just errmsg
-
-          audit TransactionLmsSuccess -- always log success, since this is only transmitted once
-            { transactionQualification = qid
-            , transactionLmsIdent      = lmsUserIdent
-            , transactionLmsDay        = utctDayMidnight lmsResultSuccess
-            , transactionLmsUser       = lmsUserUser
-            , transactionNote          = note
-            , transactionReceived      = lmsResultTimestamp
-            }
-          delete lrid
-        $logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|]
-
-
--- DEPRECATED processes received input and block qualifications, if applicable
-dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
-dispatchJobLmsUserlist qid = JobHandlerAtomic act
-  where
-    act :: YesodJobDB UniWorX ()
-    act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below
-      now <- liftIO getCurrentTime
-      -- result :: [(Entity LmsUser, Entity LmsUserlist)]
-      results <- E.select $ do
-        (luser :& lulist) <- E.from $
-            E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
-            `E.on` (\(luser :& lulist) ->  luser E.^. LmsUserIdent         E.=?. lulist E.?. LmsUserlistIdent
-                                     E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
-        E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
-                  E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
-        return (luser, lulist)
-      forM_ results $ \case
-        (Entity luid luser, Nothing)
-          | isJust    $ lmsUserReceived luser          -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
-          , isNothing $ lmsUserEnded    luser ->
-              update luid [LmsUserEnded =. Just now]
-          | otherwise -> return ()                     -- users likely not yet started
-
-        (Entity luid luser, Just (Entity _lulid lulist)) -> do
-          let lReceived = lmsUserlistTimestamp lulist
-          update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
-
-          when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
-            queueDBJob JobUserNotification
-              { jRecipient    = lmsUserUser luser
-              , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False }
-              }
-
-          let isBlocked = lmsUserlistFailed lulist
-              oldStatus = lmsUserStatus luser
-              updateStatus = isBlocked && oldStatus /= Just LmsSuccess
-          when updateStatus $ do
-            update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lReceived]
-            ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning)  True
-            when (ok /= 1) $ do
-              uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser
-              $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}]
-            audit TransactionLmsBlocked
-              { transactionQualification = qid
-              , transactionLmsIdent      = lmsUserIdent luser
-              , transactionLmsDay        = lReceived
-              , transactionLmsUser       = lmsUserUser luser
-              , transactionNote          = Just $ "Old status was " <> tshow oldStatus
-              , transactionReceived      = lReceived
-              }
-          delete lulid
-      $logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|]

src/Jobs/Types.hs

@@ -135,8 +135,6 @@ data Job
   | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId }
   | JobLmsQualificationsDequeue
   | JobLmsDequeue     { jQualification :: QualificationId }
-  | JobLmsUserlist    { jQualification :: QualificationId } -- Deprecated, remove together with routes
-  | JobLmsResults     { jQualification :: QualificationId } -- Deprecated, remove together with routes
   | JobLmsReports     { jQualification :: QualificationId }
   | JobPrintAck
   | JobPrintAckAgain
@@ -368,9 +366,7 @@ jobNoQueueSame = \case
   JobLmsEnqueue     {}                -> Just JobNoQueueSame
   JobLmsEnqueueUser {}                -> Just JobNoQueueSame
   JobLmsQualificationsDequeue         -> Just JobNoQueueSame
-  JobLmsDequeue     {}                -> Just JobNoQueueSame
+  JobLmsDequeue     {}                -> Just JobNoQueueSame  
-  JobLmsUserlist    {}                -> Just JobNoQueueSame
-  JobLmsResults     {}                -> Just JobNoQueueSame
   JobLmsReports     {}                -> Just JobNoQueueSame
   JobPrintAck       {}                -> Just JobNoQueueSame
   JobPrintAckAgain  {}                -> Just JobNoQueueSame

src/Utils/Lens.hs

@@ -125,8 +125,6 @@ makeClassyFor_ ''QualificationUser
 makeClassyFor_ ''QualificationUserBlock
 makeClassyFor_ ''LmsUser
 -- makeClassyFor_ ''LmsUserStatus
-makeClassyFor_ ''LmsUserlist
-makeClassyFor_ ''LmsResult
 makeClassyFor_ ''LmsReport
 makeClassyFor_ ''UserAvs
 makeClassyFor_ ''UserAvsCard

test/Database/Fill.hs

@@ -739,12 +739,6 @@ fillDb = do
   insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11)    | Entity uid User{userDisplayName=udn} <- take 200 $ drop  2 matUsers, uid `Set.notMember` qidfUsers]
   insertMany_ [LmsUser qid_f uid (LmsIdent udn) "123456" False now astatus astatusDay now (Just now) (Just now) Nothing False False | Entity uid User{userDisplayName=udn} <- take 200 $ drop 22 matUsers, uid `Set.notMember` qidfUsers
                 , let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome]
-  void . insert' $ LmsResult qid_f (LmsIdent "hijklm" ) (n_day (-1)) now
-  void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now
-  void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now
-  void . insert' $ LmsUserlist qid_f (LmsIdent "hijklm") False now
-  void . insert' $ LmsUserlist qid_f (LmsIdent "abcdef") True  now
-  void . insert' $ LmsUserlist qid_f (LmsIdent "ijk"   ) False now
   void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"   ) "123" False now Nothing Nothing now           Nothing    (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
   void . insert' $ LmsUser qid_f svaupel     (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1)     (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
   void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hiklmn") "@#!" True  now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True