chore(lms): WIP towards new interface

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

@@ -129,6 +129,8 @@ MenuLmsUpload: Hochladen
 MenuLmsDirectUpload: Direkter Upload
 MenuLmsDirectDownload: Direkter Download
 MenuLmsFake: Testnutzer generieren
+MenuLmsLearners: Export Benutzer E‑Learning
+MenuLmsReport: Ergebnisse E‑Learning
 
 MenuSap: SAP Schnittstelle
 

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

@@ -129,7 +129,9 @@ MenuLmsResult: Upload E‑Learning Results
 MenuLmsUpload: Upload
 MenuLmsDirectUpload: Direct Upload
 MenuLmsDirectDownload: Direct Download
-MenuLmsFake: Generate test users
+MenuLmsFake: Generate Test Users
+MenuLmsLearners: E‑Learning Users
+MenuLmsReport: E‑Learning Results
 
 MenuSap: SAP Interface 
 

models/lms.model

@@ -151,3 +151,13 @@ LmsResult
   timestamp         UTCTime         default=now()
   UniqueLmsResult qualification ident -- required by DBTable
   deriving Generic
+
+LmsReport
+  qualification     QualificationId OnDeleteCascade OnUpdateCascade
+  ident             LmsIdent
+  date              Day Maybe       -- BEWARE: timezone is local as submitted by LMS
+  result            Int             -- (0|1|2) 0=too many ties, 1=open, 2=success
+  lock              Int             -- (0|1)
+  timestamp         UTCTime         default=now()
+  UniqueLmsReport qualification ident -- required by DBTable
+  deriving Generic

routes

@@ -273,6 +273,7 @@
 /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
@@ -281,6 +282,13 @@
 /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
+-- new V2 LMS Interface
+/lms/#SchoolId/#QualificationShorthand/learners             LmsLearnersR	          GET
+/lms/#SchoolId/#QualificationShorthand/learners/direct      LmsLearnersDirectR	    GET       !token -- LMS 
+/lms/#SchoolId/#QualificationShorthand/report               LmsReportR              GET POST
+/lms/#SchoolId/#QualificationShorthand/report/upload        LmsReportUploadR        GET POST  !development
+/lms/#SchoolId/#QualificationShorthand/report/direct        LmsReportDirectR            POST  !token -- LMS
+-- other lms routes 
 /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent      LmsIdentR               GET       -- redirect to LmsR with filter-parameter
 /lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR                GET
 /lmsuser/#CryptoUUIDUser                                    LmsUserAllR             GET

src/Foundation/Navigation.hs

@@ -186,6 +186,13 @@ breadcrumb (LmsUserlistDirectR  ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Jus
 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
+breadcrumb (LmsReportR          ssh  qsh) = i18nCrumb MsgMenuLmsReport     $ Just $ LmsR          ssh qsh
+breadcrumb (LmsReportUploadR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsReportR    ssh qsh
+breadcrumb (LmsReportDirectR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsReportR    ssh qsh -- never displayed
+-- 
 breadcrumb (LmsIdentR           ssh  qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect
 breadcrumb (LmsUserR            ssh _qsh u ) = i18nCrumb MsgMenuLmsUser       $ Just $ LmsUserSchoolR u ssh
 breadcrumb (LmsUserSchoolR    u _          ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u

src/Handler/LMS.hs

@@ -12,11 +12,17 @@ module Handler.LMS
   , getLmsR               , postLmsR
   , getLmsIdentR
   , getLmsEditR           , postLmsEditR
+  -- V1
   , getLmsUsersR          , getLmsUsersDirectR
   , getLmsUserlistR       , postLmsUserlistR
   , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
   , getLmsResultR         , postLmsResultR
   , getLmsResultUploadR   , postLmsResultUploadR  , postLmsResultDirectR
+  -- V1
+  , getLmsLearnersR       , getLmsLearnersDirectR
+  , getLmsReportR         , postLmsReportR
+  , getLmsReportUploadR   , postLmsReportUploadR  , postLmsReportDirectR
+  --
   , getLmsFakeR           , postLmsFakeR
   , getLmsUserR
   , getLmsUserSchoolR
@@ -45,10 +51,13 @@ import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 import Database.Persist.Sql (deleteWhereCount)
-
+-- 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
 import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!
 
 

src/Handler/LMS/Learners.hs

@@ -0,0 +1,197 @@
+-- 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.Learners
+  ( getLmsLearnersR
+  , getLmsLearnersDirectR
+  )
+  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.Experimental as Ex -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
+
+data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
+  { csvLUTident :: LmsIdent
+  , csvLUTpin   :: Text
+  , csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool
+  }
+  deriving Generic
+makeLenses_ ''LmsUserTableCsv
+
+-- | Mundane conversion needed for direct download without dbTable onlu
+lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv
+lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
+  { csvLUTident     = lmsUserIdent
+  , csvLUTpin       = lmsUserPin
+  , csvLUTresetPin  = lmsUserResetPin           & LmsBool
+  , csvLUTdelete    = lmsUserToDelete cutoff lu & LmsBool
+  , csvLUTstaff     = False                     & LmsBool
+  }
+
+-- csv without headers
+instance Csv.ToRecord   LmsUserTableCsv
+instance Csv.FromRecord LmsUserTableCsv
+
+-- csv with headers
+lmsUserTableCsvHeader :: Csv.Header
+lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ]
+
+instance ToNamedRecord LmsUserTableCsv where
+  toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
+    [ csvLmsIdent     Csv..= csvLUTident
+    , csvLmsPin       Csv..= csvLUTpin
+    , csvLmsResetPin  Csv..= csvLUTresetPin
+    , csvLmsDelete    Csv..= csvLUTdelete
+    , csvLmsStaff     Csv..= csvLUTstaff
+    ]
+instance FromNamedRecord LmsUserTableCsv where
+  parseNamedRecord (lsfHeaderTranslate -> csv)
+    = LmsUserTableCsv
+        <$> csv Csv..: csvLmsIdent
+        <*> csv Csv..: csvLmsPin
+        <*> csv Csv..: csvLmsResetPin
+        <*> csv Csv..: csvLmsDelete
+        <*> csv Csv..: csvLmsStaff
+
+instance CsvColumnsExplained LmsUserTableCsv where
+  csvColumnsExplanations _ = mconcat
+    [ single csvLmsIdent    MsgCsvColumnLmsIdent
+    , single csvLmsPin      MsgCsvColumnLmsPin
+    , single csvLmsResetPin MsgCsvColumnLmsResetPin
+    , single csvLmsDelete   MsgCsvColumnLmsDelete
+    , single csvLmsStaff    MsgCsvColumnLmsStaff
+    ]
+    where
+      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
+      single k v = singletonMap k [whamlet|_{v}|]
+
+
+
+mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
+mkUserTable _sid qsh qid = do
+  cutoff <- liftHandler lmsDeletionDate
+  dbtCsvName <- csvFilenameLmsUser qsh  
+  let dbtCsvSheetName = dbtCsvName
+  let
+    userDBTable = DBTable{..}
+      where
+        dbtSQLQuery lmsuser = do
+          E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid
+              E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
+          return lmsuser
+        dbtRowKey = (E.^. LmsUserId)
+        dbtProj = dbtProjId
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident
+          , 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 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 cutoff))
+          ]
+        dbtFilter = Map.fromList
+          [ (csvLmsIdent    , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
+          , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast             (E.^. LmsUserResetPin))
+          ]
+        dbtFilterUI = \mPrev -> mconcat
+          [ prismAForm (singletonFilter csvLmsIdent    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
+          , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgTableLmsResetPin)
+          ]
+        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "lms-user"
+        dbtCsvEncode = Just DBTCsvEncode {..}
+          where
+            dbtCsvExportForm   = pure ()
+            dbtCsvNoExportData = Just id
+            dbtCsvExampleData  = Nothing
+            dbtCsvHeader       = const $ return lmsUserTableCsvHeader
+            dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
+            doEncode' = LmsUserTableCsv
+              <$> view (_dbrOutput . _entityVal . _lmsUserIdent)
+              <*> view (_dbrOutput . _entityVal . _lmsUserPin)
+              <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
+              <*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool)
+              <*> const (LmsBool False)
+
+        dbtCsvDecode = Nothing
+        dbtExtraReps = []
+
+    userDBTableValidator = def
+      & defaultSorting [SortAscBy csvLmsIdent]
+  dbTable userDBTableValidator userDBTable
+
+getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsLearnersR sid qsh = do
+  lmsTable <- runDB $ do
+    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
+    view _2 <$> mkUserTable sid qsh qid
+  siteLayoutMsg MsgMenuLmsUsers $ do
+    setTitleI MsgMenuLmsUsers
+    lmsTable
+
+getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
+getLmsLearnersDirectR 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
+               -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
+               ] [Asc LmsUserStarted, Asc LmsUserIdent]    
+
+    {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
+      Ex.select $ do
+        lmsuser <- Ex.from $ Ex.table @LmsUser
+        Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid
+            Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded)
+        pure $ LmsUserTableCsv
+          { csvLUTident    = lmsuser Ex.^. LmsUserIdent
+          , csvLUTpin      = lmsuser Ex.^. LmsUserPin
+          , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin
+          , csvLUTdelete   = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus)
+          , csvLUTstaff    = LmsBool False
+          }
+      -}
+  LmsConf{..} <- getsYesod $ view _appLmsConf  
+  let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
+      --csvRenderedHeader = lmsUserTableCsvHeader
+      --cvsRendered = CsvRendered {..}
+      csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users
+      fmtOpts = (review csvPreset CsvPresetRFC)
+                    { csvIncludeHeader  = lmsDownloadHeader
+                    , csvDelimiter      = lmsDownloadDelimiter
+                    , csvUseCrLf        = lmsDownloadCrLf
+                    }
+      csvOpts = def { csvFormat = fmtOpts }
+  csvSheetName <- csvFilenameLmsUser qsh
+  let nr  = length lms_users
+      msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"  
+  $logInfoS "LMS" msg
+  addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
+  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered  
+
+-- direct Download see:
+-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/LMS/Report.hs

@@ -0,0 +1,301 @@
+-- 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.Report
+  ( getLmsReportR, postLmsReportR
+  , getLmsReportUploadR, postLmsReportUploadR
+  , postLmsReportDirectR
+  )
+  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 LmsReportTableCsv = LmsReportTableCsv
+  { csvLRident  :: LmsIdent
+  , csvLRdate   :: Maybe LmsDay
+  , csvLRresult :: Int
+  , csvLRlock   :: Int
+  }
+  deriving Generic
+makeLenses_ ''LmsReportTableCsv
+
+-- csv without headers
+instance Csv.ToRecord   LmsReportTableCsv -- default suffices
+instance Csv.FromRecord LmsReportTableCsv -- default suffices
+
+-- csv with headers
+lmsReportTableCsvHeader :: Csv.Header
+lmsReportTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsDate, csvLmsResult, csvLmsLock ]
+
+instance ToNamedRecord LmsReportTableCsv where
+  toNamedRecord LmsReportTableCsv{..} = Csv.namedRecord
+    [ csvLmsIdent   Csv..= csvLRident
+    , csvLmsDate    Csv..= csvLRdate
+    , csvLmsResult  Csv..= csvLRresult
+    , csvLmsLock    Csv..= csvLRlock
+    ]
+
+instance FromNamedRecord LmsReportTableCsv where
+  parseNamedRecord (lsfHeaderTranslate -> csv)
+    = LmsReportTableCsv
+        <$> csv Csv..: csvLmsIdent
+        <*> csv Csv..: csvLmsDate
+        <*> csv Csv..: csvLmsResult
+        <*> csv Csv..: csvLmsLock
+
+instance CsvColumnsExplained LmsReportTableCsv where
+  csvColumnsExplanations _ = mconcat
+    [ single csvLmsIdent    MsgCsvColumnLmsIdent
+    , single csvLmsDate     MsgCsvColumnLmsDate
+    , single csvLmsResult   MsgCsvColumnLmsResult
+    , single csvLmsLock     MsgCsvColumnLmsLock
+    ]
+    where
+      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
+      single k v = singletonMap k [whamlet|_{v}|]
+
+data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate
+  deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
+embedRenderMessage ''UniWorX ''LmsReportCsvActionClass id
+
+-- By coincidence the action type is identical to LmsReportTableCsv
+data LmsReportCsvAction = LmsReportInsertData { lmsReportInsertIdent :: LmsIdent, lmsReportInsertDate :: Maybe Day, lmsReportInsertResult :: Int, lmsReportInsertLock :: Int }
+                        | LmsReportUpdateData { lmsReportInsertIdent :: LmsIdent, lmsReportInsertDate :: Maybe Day, lmsReportInsertResult :: Int, lmsReportInsertLock :: Int }
+  deriving (Eq, Ord, Read, Show, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsReportInsertData -> insert
+  , fieldLabelModifier     = camelToPathPiece'  2     -- lmsReportInsertIdent -> insert-ident | lmsReportInsertSuccess -> insert-success
+  , sumEncoding = TaggedObject "action" "data"
+  } ''LmsReportCsvAction
+
+data LmsReportCsvException
+  = LmsReportCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
+  deriving (Show, Generic)
+
+instance Exception LmsReportCsvException
+embedRenderMessage ''UniWorX ''LmsReportCsvException id
+
+mkReportTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
+mkReportTable sid qsh qid = do
+  now_day <- utctDay <$> liftIO getCurrentTime
+  dbtCsvName <- csvFilenameLmsReport qsh
+  let dbtCsvSheetName = dbtCsvName
+  let
+    reportDBTable = DBTable{..}
+      where
+        dbtSQLQuery lmsReport = do
+          E.where_ $ lmsReport E.^. LmsReportQualification E.==. E.val qid
+          return lmsReport
+        dbtRowKey = (E.^. LmsReportId)
+        dbtProj = dbtProjId
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \(view $ _dbrOutput . _entityVal . _lmsReportIdent . _getLmsIdent -> ident) -> textCell ident
+          , sortable (Just csvLmsSuccess)   (i18nCell MsgTableLmsSuccess)  $ \(view $ _dbrOutput . _entityVal . _lmsReportSuccess            -> success) -> dayCell success
+          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp        -> timestamp) -> dateTimeCell timestamp
+          ]
+        dbtSorting = Map.fromList
+          [ (csvLmsIdent    , SortColumn (E.^. LmsReportIdent))
+          , (csvLmsSuccess  , SortColumn (E.^. LmsReportSuccess))
+          , (csvLmsTimestamp, SortColumn (E.^. LmsReportTimestamp))
+          ]
+        dbtFilter = Map.fromList
+          [ (csvLmsIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsReportIdent))
+          , (csvLmsSuccess, FilterColumn $ E.mkExactFilter                 (E.^. LmsReportSuccess))
+          ]
+        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-Report"
+        dbtCsvEncode = Just DBTCsvEncode
+          { dbtCsvExportForm   = pure ()
+          , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
+          , dbtCsvName
+          , dbtCsvSheetName
+          , dbtCsvNoExportData = Just id
+          , dbtCsvHeader       = const $ return lmsReportTableCsvHeader
+          , dbtCsvExampleData  = Just
+            [ LmsReportTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
+            | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
+            ]
+          }
+          where
+            doEncode' = LmsReportTableCsv
+              <$> view (_dbrOutput . _entityVal . _lmsReportIdent)
+              <*> view (_dbrOutput . _entityVal . _lmsReportSuccess . _lmsDay)
+        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
+          { dbtCsvRowKey = \LmsReportTableCsv{..} ->
+              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsReport qid csvLRTident
+          , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
+              DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
+                yield $ LmsReportInsertData
+                        { lmsReportInsertIdent   = csvLRTident   dbCsvNew
+                        , lmsReportInsertSuccess = csvLRTsuccess dbCsvNew & lms2day
+                        }
+              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsReport was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
+              DBCsvDiffExisting{dbCsvNew = LmsReportTableCsv{..}, dbCsvOld} -> do
+                let successDay = lms2day csvLRTsuccess
+                when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportSuccess) $
+                  yield $ LmsReportUpdateData
+                          { lmsReportInsertIdent   = csvLRTident
+                          , lmsReportInsertSuccess = successDay
+                          }
+              DBCsvDiffMissing{}  -> return () -- no deletion
+          , dbtCsvClassifyAction      = \case
+              LmsReportInsertData{} -> LmsReportInsert
+              LmsReportUpdateData{} -> LmsReportUpdate
+          , dbtCsvCoarsenActionClass  = \case
+              LmsReportInsert -> DBCsvActionNew
+              LmsReportUpdate -> 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
+                  LmsReport
+                    { lmsReportQualification  =  qid
+                    , lmsReportIdent          =  lmsReportInsertIdent   actionData
+                    , lmsReportSuccess        =  lmsReportInsertSuccess actionData
+                    , lmsReportTimestamp      =  now -- lmsReportInsertTimestamp -- does it matter which one to choose?
+                    }
+                  [ LmsReportSuccess          =. lmsReportInsertSuccess actionData
+                  , LmsReportTimestamp        =. now
+                  ]
+                -- audit $ Transaction.. (add to Audit.Types)
+            lift . queueDBJob $ JobLmsReports qid
+            return $ LmsReportR sid qsh
+          , dbtCsvRenderKey           = const $ \case
+              LmsReportInsertData{..} -> do -- TODO: i18n
+                [whamlet|
+                  $newline never
+                  Insert: Ident #{getLmsIdent lmsReportInsertIdent} #
+                  had success on ^{formatTimeW SelFormatDate lmsReportInsertSuccess}
+                |]
+              LmsReportUpdateData{..} -> do -- TODO: i18n
+                [whamlet|
+                  $newline never
+                  Update: Ident #{getLmsIdent lmsReportInsertIdent} #
+                  had success on ^{formatTimeW SelFormatDate lmsReportInsertSuccess}
+                |]
+          , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
+          , dbtCsvRenderException     = ap getMessageRender . pure :: LmsReportCsvException -> DB Text
+          }
+        dbtExtraReps = []
+
+    ReportDBTableValidator = def
+      & defaultSorting [SortAscBy csvLmsIdent]
+  dbTable ReportDBTableValidator ReportDBTable
+
+getLmsReportR,  postLmsReportR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsReportR = postLmsReportR
+postLmsReportR sid qsh = do
+  let directUploadLink = LmsReportUploadR sid qsh
+  lmsTable <- runDB $ do
+    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
+    view _2 <$> mkReportTable sid qsh qid
+  siteLayoutMsg MsgMenuLmsReport $ do
+    setTitleI MsgMenuLmsReport
+    $(widgetFile "lms-Report")
+
+
+-- Direct File Upload/Download
+
+saveReportCsv :: QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
+saveReportCsv qid i LmsReportTableCsv{..} = do
+    now <- liftIO getCurrentTime
+    void $ upsert
+      LmsReport
+        { lmsReportQualification  =  qid
+        , lmsReportIdent          =  csvLRTident
+        , lmsReportSuccess        =  csvLRTsuccess & lms2day
+        , lmsReportTimestamp      =  now
+        }
+      [ LmsReportSuccess          =. (csvLRTsuccess & lms2day)
+      , LmsReportTimestamp        =. now
+      ]
+    return $ succ i
+
+makeReportUploadForm :: Form FileInfo
+makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV"
+
+getLmsReportUploadR, postLmsReportUploadR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsReportUploadR = postLmsReportUploadR
+postLmsReportUploadR sid qsh = do
+  ((Report,widget), enctype) <- runFormPost makeReportUploadForm
+  case Report of
+    FormSuccess file -> do
+      -- content <- fileSourceByteString file
+      -- return $ Just (fileName file, content)
+      nr <- runDBJobs $ do
+        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
+        nr <- runConduit $ fileSource file
+                .| decodeCsv
+                .| foldMC (saveReportCsv qid) 0
+        queueDBJob $ JobLmsReports qid
+        return nr
+      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
+      redirect $ LmsReportR sid qsh
+    FormFailure errs -> do
+      forM_ errs $ addMessage Error . toHtml
+      redirect $ LmsReportUploadR sid qsh
+    FormMissing ->
+      siteLayoutMsg MsgMenuLmsReport $ do
+        setTitleI MsgMenuLmsUpload
+        [whamlet|$newline never
+          <form method=post enctype=#{enctype}>
+            ^{widget}
+            <p>
+            <input type=submit>
+        |]
+
+
+postLmsReportDirectR :: SchoolId -> QualificationShorthand -> Handler Html
+postLmsReportDirectR sid qsh = do
+  (_params, files) <- runRequestBody
+  (status, msg) <- case files of
+    [(fhead,file)] -> do
+      lmsDecoder <- getLmsCsvDecoder
+      runDBJobs $ do
+        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
+        enr <- try $ runConduit $ fileSource file
+                .| lmsDecoder
+                .| foldMC (saveReportCsv qid) 0
+        case enr of
+          Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
+            $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
+            return (badRequest400, "Exception: " <> tshow e)
+          Right nr -> do
+            let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
+            $logInfoS "LMS" msg
+            when (nr > 0) $ queueDBJob $ JobLmsReports qid
+            return (ok200, msg)
+    []     -> do
+      let msg = "Report upload file missing."
+      $logWarnS "LMS" msg
+      return (badRequest400, msg)
+    _other -> do
+      let msg = "Report upload received multiple files; all ignored."
+      $logWarnS "LMS" msg
+      return (badRequest400, msg)
+  sendResponseStatus status msg
+

src/Handler/Utils/LMS.hs

@@ -7,6 +7,7 @@
 module Handler.Utils.LMS
   ( getLmsCsvDecoder
   , csvLmsIdent
+  , csvLmsDate
   , csvLmsTimestamp
   , csvLmsBlocked
   , csvLmsSuccess
@@ -14,9 +15,13 @@ module Handler.Utils.LMS
   , csvLmsResetPin
   , csvLmsDelete
   , csvLmsStaff
+  , csvLmsResetTries
+  , csvLmsLock
+  , csvLmsResult
   , csvFilenameLmsUser
   , csvFilenameLmsUserlist
   , csvFilenameLmsResult
+  , csvFilenameLmsReport
   , lmsDeletionDate
   , lmsUserToDelete, _lmsUserToDelete
   , lmsUserToDeleteExpr
@@ -56,45 +61,63 @@ getLmsCsvDecoder = do
 
 -- generic Column names
 csvLmsIdent   :: IsString a => a
-csvLmsIdent = fromString "user" -- "Benutzerkennung"
+csvLmsIdent = fromString "user" -- "Benutzerkennung" V1, V2
+
+csvLmsDate   :: IsString a => a
+csvLmsDate = fromString "date" -- "Datum", V2
 
 csvLmsTimestamp   :: IsString a => a
-csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel"
+csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" V1
 
 -- for Users Table
 csvLmsPin :: IsString a => a
-csvLmsPin      = fromString "pin" -- "PIN"
+csvLmsPin      = fromString "pin" -- "PIN" V1, V2
 
 csvLmsResetPin :: IsString a => a
-csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen"
+csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen" V1, V2
 
 csvLmsDelete :: IsString a => a
-csvLmsDelete   = fromString "delete" -- "Account löschen"
+csvLmsDelete   = fromString "delete" -- "Account löschen" V1, V2
 
 csvLmsStaff :: IsString a => a
-csvLmsStaff    = fromString "staff" -- "Mitarbeiter"
+csvLmsStaff    = fromString "staff" -- "Mitarbeiter" V1, V2
 
--- for Userlist Table
+csvLmsResetTries :: IsString a => a
+csvLmsResetTries = fromString "reset_tries" -- Anzahl Versuche zurücksetzen, V2
+
+csvLmsLock :: IsString a => a
+csvLmsLock = fromString "lock" -- Ist der Login derzeit gesperrt? V2
+
+-- for Userlist Table V1
 csvLmsBlocked :: IsString a => a
-csvLmsBlocked = fromString "blocked" -- "Sperrung"
+csvLmsBlocked = fromString "blocked" -- "Sperrung" V1
 
--- for Result Table
+-- for Result Table V1 
 csvLmsSuccess :: IsString a => a
-csvLmsSuccess = fromString "success" -- "Datum"
+csvLmsSuccess = fromString "success" -- "Datum" V1
+
+-- for Report Table V2
+csvLmsResult :: IsString a => a
+csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offen, 2=Bestanden V2
 
 
--- | Filename for User transmission, contains current datestamp as agreed in LMS interface
+
+-- | Filename for User transmission, contains current datestamp as agreed in LMS interface V1 & V2
 csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text
 csvFilenameLmsUser = makeLmsFilename "user"
 
--- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface
+-- | 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
+-- | 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"
+
 -- | Create filenames as specified by the LMS interface agreed with Know How AG
 makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand ->  m Text
 makeLmsFilename ftag (citext2lower -> qsh) = do