chore(lms): display lmsresultlist compiles but incomplete

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

@@ -0,0 +1,5 @@
+TableLmsIdent: Identifikation
+TableLmsFailed: Gesperrt
+TableLmsSuccess: Bestanden
+CsvColumnLmsResultIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
+CsvColumnLmsResultSuccess: Zeitstempel der erfolgreichen Teilnahme

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

@@ -0,0 +1,5 @@
+TableLmsIdent: Identifier 
+TableLmsFailed: Blocked
+TableLmsSuccess: Completed
+CsvColumnLmsResultIdent: E-Learing identifier, unique for each qualfication and user
+CsvColumnLmsResultSuccess: Timestamp of successful completion

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -61,6 +61,4 @@ SelectColumn: Auswahl
 CsvExport: CSV-Export
 TableProportion c@Text of'@Text prop@Rational !ident-ok: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%)
 TableProportionNoRatio c@Text of'@Text !ident-ok: #{c}/#{of'}
-TableExamFinished: Ergebnisse sichtbar ab
+TableExamFinished: Ergebnisse sichtbar ab
-TableLmsIdent: Identifikation
-TableLmsFailed: Gesperrt

messages/uniworx/utils/table_column/en-eu.msg

@@ -61,6 +61,4 @@ SelectColumn: Selection
 CsvExport: CSV export
 TableProportion c of' prop: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%)
 TableProportionNoRatio c of': #{c}/#{of'}
-TableExamFinished: Results visible from
+TableExamFinished: Results visible from
-TableLmsIdent: Identifier 
-TableLmsFailed: Blocked

models/lms.model

@@ -24,6 +24,7 @@ LmsUserlist
   UniqueLmsUserlist qualification ident
   deriving Generic
 
+-- QualificationId is redundant here; but known due to external upload
 LmsResult
   qualification     QualificationId
   ident             LmsIdent

src/Foundation/I18n.hs

@@ -14,6 +14,7 @@ module Foundation.I18n
   , UniWorXMetricsMessage(..), UniWorXNewsMessage(..), UniWorXSchoolMessage(..), UniWorXSystemMessageMessage(..)
   , UniWorXTermMessage(..), UniWorXSendMessage(..), UniWorXSiteLayoutMessage(..), UniWorXErrorMessage(..)
   , UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..)
+  , UniWorXQualificationMessage(..)
   , UniWorXAuthorshipStatementMessage(..)
   , ShortTermIdentifier(..)
   , MsgLanguage(..)
@@ -180,6 +181,7 @@ mkMessageAddition ''UniWorX "ModelTypes" "messages/uniworx/categories/model_type
 mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-formal"
 mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal"
 mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal"
+mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal"
 mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal"
 mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "de-de-formal"
 mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal"

src/Handler/LMS.hs

@@ -5,8 +5,8 @@
 
 module Handler.LMS
   ( getLmsR
-  , getLmsUserlistR
+  , getLmsUserlistR  
-  , getLmsResultR
+  , getLmsResultR  
   )
   where
 
@@ -21,6 +21,9 @@ import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
+import Handler.LMS.Result as Handler.LMS
+
+
 type LmsUserIdent = Text -- Unique random use-once identifier for each individual e-learning course; i.e. users may have several active LmsUserIdents at once!
 
 data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
@@ -145,7 +148,7 @@ mkUserlistTable qid = do
           E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
           return lmslist
         dbtRowKey = (E.^. LmsUserlistId)
-        dbtProj   = dbtProjFilteredPostId
+        dbtProj   = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
         dbtColonnade = dbColonnade $ mconcat 
           [ sortable (Just "ident")  (i18nCell MsgTableLmsIdent)  $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell  lmsUserlistIdent
           , sortable (Just "failed") (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed
@@ -178,11 +181,6 @@ getLmsUserlistR qid = do
     $(widgetFile "lms-userlist")
 
 
-
+-- See Module Handler.LMS.Result for 
-getLmsResultR :: QualificationId -> Handler Html
+-- getLmsResultR :: QualificationId -> Handler Html
-getLmsResultR _qid = do  
-  let lmsTable = [whamlet|TODO|]  -- TODO: remove me, just for debugging
-  siteLayoutMsg MsgMenuLmsResult $ do
-    setTitleI MsgMenuLmsResult
-    $(widgetFile "lms-result")
     

src/Handler/LMS/Result.hs

@@ -0,0 +1,156 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
+{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
+{-# OPTIONS -Wno-unused-imports #-}        -- TODO: remove me, for debugging only
+{-# OPTIONS -Wno-redundant-constraints #-} -- TODO: remove me, for debugging only
+
+
+module Handler.LMS.Result
+  ( getLmsResultR
+  )
+  where
+
+import Import
+
+import Handler.Utils
+import Handler.Utils.Csv
+
+import qualified Data.Map as Map
+import qualified Data.Csv as Csv
+import qualified Data.Conduit.List as C
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text.Lens as Text
+import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
+
+
+
+type LmsResultTableExpr = (             E.SqlExpr (Entity Qualification)
+                          `E.InnerJoin` E.SqlExpr (Entity LmsResult)                           
+                          ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
+                            `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
+
+queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification)
+queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
+
+queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult)
+queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
+
+queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
+queryLmsUser = $(sqlLOJproj 3 2)
+
+queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryUser = $(sqlLOJproj 3 3)
+
+type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User))
+
+instance HasEntity LmsResultTableData LmsResult where 
+  hasEntity = _dbrOutput . _2
+
+{- MaybeHasUser only!
+instance HasUser LmsResultTableData where
+  hasUser = _dbrOutput . _4 . _entityVal
+-}
+
+resultQualification :: Lens' LmsResultTableData (Entity Qualification)
+resultQualification = _dbrOutput . _1
+
+resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult)
+resultLmsResult = _dbrOutput . _2
+
+resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser)
+resultLmsUser = _dbrOutput . _3 . _Just 
+
+resultUser :: Traversal' LmsResultTableData (Entity User)
+resultUser = _dbrOutput . _4 . _Just 
+
+-- required for import only
+data LmsResultTableCsv = LmsResultTableCsv 
+  { csvLRTident   :: LmsIdent 
+  , csvLRTsuccess :: UTCTime
+  }
+  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 [ "identification", "timestamp-success" ]
+
+instance ToNamedRecord LmsResultTableCsv where 
+  toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord 
+    [ "identification"    Csv..= csvLRTident
+    , "timestamp-success" Csv..= csvLRTsuccess
+    ]
+
+instance FromNamedRecord LmsResultTableCsv where 
+  parseNamedRecord (lsfHeaderTranslate -> csv)
+    = LmsResultTableCsv
+        <$> csv Csv..: "identification"
+        <*> csv Csv..: "timestamp-success"
+
+
+instance CsvColumnsExplained LmsResultTableCsv where 
+  csvColumnsExplanations _ = mconcat
+    [ single "identification"     MsgCsvColumnLmsResultIdent 
+    , single "timestamp-success"  MsgCsvColumnLmsResultSuccess
+    ]
+    where
+      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
+      single k v = singletonMap k [whamlet|_{v}|]
+
+
+mkResultTable :: QualificationId -> DB (Any, Widget)
+mkResultTable qid = do 
+  let 
+    resultDBTable = DBTable{..}
+      where
+        dbtSQLQuery = runReaderT $ do 
+          qualification <- asks queryQualification
+          lmsResult     <- asks queryLmsResult        
+          lmsUser       <- asks queryLmsUser
+          user          <- asks queryUser
+          lift $ do 
+            E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification
+            E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent)
+            E.on $ lmsUser E.?. LmsUserUser  E.==. user E.?. UserId
+            E.where_ $ qualification E.^. QualificationId E.==. E.val qid
+          return (qualification, lmsResult, lmsUser, user)
+        dbtRowKey = queryLmsResult >>> (E.^. LmsResultId)
+        dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
+        dbtColonnade = dbColonnade $ mconcat 
+          [ sortable (Just "ident")  (i18nCell MsgTableLmsIdent)   $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent   -> ident)   -> textCell ident 
+          , sortable (Just "sucess") (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dateTimeCell success
+          ] -- TODO: add more columns for manual debugging view !!!
+        dbtSorting = mempty
+          {-  Map.fromList 
+          [ ("ident"  , SortColumn $ \reslist -> reslist E.^. LmsResultIdent)
+          , ("success", SortColumn $ \reslist -> reslist E.^. LmsResultSuccess)
+          ]
+          -}
+        dbtFilter = mempty          -- TODO !!! continue here !!!  
+        dbtFilterUI = const mempty  -- TODO !!! continue here !!! Manual filtering useful to deal with user complaints!
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "lms-userlist"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing      -- TODO !!! continue here !!! CSV Import is the purpose of this page! Just save to DB, create Job to deal with it later!
+        dbtExtraReps = []
+
+    resultDBTableValidator = def 
+      & defaultSorting [SortAscBy "ident"]
+  dbTable resultDBTableValidator resultDBTable
+
+getLmsResultR :: QualificationId -> Handler Html
+getLmsResultR qid = do  
+  lmsTable <- runDB $ view _2 <$> mkResultTable qid 
+  siteLayoutMsg MsgMenuLmsResult $ do
+    setTitleI MsgMenuLmsResult
+    $(widgetFile "lms-result")
+