chore(lms): work on stub for csv import of LmsResult

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

@@ -2,4 +2,6 @@ TableLmsIdent: Identifikation
 TableLmsFailed: Gesperrt
 TableLmsSuccess: Bestanden
 CsvColumnLmsResultIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
-CsvColumnLmsResultSuccess: Zeitstempel der erfolgreichen Teilnahme
+CsvColumnLmsResultSuccess: Zeitstempel der erfolgreichen Teilnahme
+LmsResultInsert: Neues LMS Ergebnis 
+LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel

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

@@ -2,4 +2,6 @@ TableLmsIdent: Identifier
 TableLmsFailed: Blocked
 TableLmsSuccess: Completed
 CsvColumnLmsResultIdent: E-Learing identifier, unique for each qualfication and user
-CsvColumnLmsResultSuccess: Timestamp of successful completion
+CsvColumnLmsResultSuccess: Timestamp of successful completion
+LmsResultInsert: New LMS result
+LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key

models/lms.model

@@ -115,13 +115,14 @@ LmsResult
   ident             LmsIdent
   success           Day
   timestamp         UTCTime default=now()
+  UniqueLmsResult qualification ident success 
   deriving Generic
 
 -- Logs all processed rows from LmsUserlist and LmsResult
 LmsAudit 
   qualification     QualificationId
   ident             LmsIdent
-  notificationType  LmsStatus               -- LmsOpen | LmsBlocked | LmsSuccess Day 
+  notificationType  LmsStatus               -- LmsOpen | LmsBlocked | LmsSuccess Day   
   received          UTCTime                 -- timestamp from LmsUserlist/LmsResult
   processed         UTCTime default=now()
   deriving Generic

src/Data/Time/Clock/Instances.hs

@@ -42,8 +42,8 @@ instance PathPiece UTCTime where
   fromPathPiece = iso8601ParseM . unpack
 
 -- UTCTime, Day, etc. 
-instance {-# OVERLAPPABLE #-} ISO8601 t => Csv.ToField t where  -- Error: overlaps Csv.ToField String, but no instance ISO8601 String exists?!  
+--instance {-# OVERLAPPABLE #-} ISO8601 t => Csv.ToField t where  -- Error: overlaps Csv.ToField String, but no instance ISO8601 String exists?!  
-  toField = Csv.toField . iso8601Show 
+--  toField = (Csv.toField::String -> Field) . iso8601Show 
 {-
     • Overlapping instances for Csv.ToField String
         arising from a use of ‘Csv.toField’
@@ -57,10 +57,24 @@ instance {-# OVERLAPPABLE #-} ISO8601 t => Csv.ToField t where  -- Error: overla
       In an equation for ‘Csv.toField’:
           Csv.toField = Csv.toField . iso8601Show
 -}
+--
+--instance {-# OVERLAPPABLE #-} ISO8601 t => Csv.FromField t where -- overlapped for ZonedTime in Handler.Utils.DateTime
+--  parseField = iso8601ParseM <=< Csv.parseField
+--
 
-instance {-# OVERLAPPABLE #-} ISO8601 t => Csv.FromField t where -- overlapped for ZonedTime in Handler.Utils.DateTime
+instance Csv.ToField UTCTime where
+  toField = Csv.toField . iso8601Show 
+
+instance Csv.FromField UTCTime where
   parseField = iso8601ParseM <=< Csv.parseField
-  
+
+instance Csv.ToField Day where
+  toField = Csv.toField . iso8601Show 
+
+instance Csv.FromField Day where
+  parseField = iso8601ParseM <=< Csv.parseField
+
+
 -- CalendarDiffDays
 --
 -- CalendarDiffDays is basically a pair of Integers, we are stored in the DB as an Array of Word (Word8 probably suffices already)

src/Handler/LMS.hs

@@ -140,6 +140,8 @@ getLmsR sid qsh = do
     $(widgetFile "lms")
 
 
+
+
 mkUserlistTable :: QualificationId -> DB (Any, Widget)
 mkUserlistTable qid = do
   let 
@@ -176,9 +178,9 @@ mkUserlistTable qid = do
 
 getLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
 getLmsUserlistR sid qsh = do  
-  (_qid, lmsTable) <- runDB $ bind2
+  lmsTable <- runDB $ do
-    (getKeyBy404 $ UniqueSchoolShort sid qsh)
+    qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
-    ((view _2 <$>) . mkUserlistTable)    
+    view _2 <$> mkUserlistTable qid 
   siteLayoutMsg MsgMenuLmsUserlist $ do
     setTitleI MsgMenuLmsUserlist
     $(widgetFile "lms-userlist")

src/Handler/LMS/Result.hs

@@ -104,9 +104,31 @@ instance CsvColumnsExplained LmsResultTableCsv where
       single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
       single k v = singletonMap k [whamlet|_{v}|]
 
+data LmsResultCsvActionClass = LmsResultInsert 
+  deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
+embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
+
+data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day, lmsResultInsertTimestamp :: UTCTime }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 2 . dropEnd 1 . splitCamel
+  , fieldLabelModifier = camelToPathPiece' 2
+  , sumEncoding = TaggedObject "action" "data"
+  } ''LmsResultCsvAction
+
+data LmsResultCsvException 
+  = LmsResultCsvExceptionDuplicatedKey 
+  deriving (Show, Generic, Typeable)
+
+instance Exception LmsResultCsvException
+embedRenderMessage ''UniWorX ''LmsResultCsvException id 
+
+
 
 mkResultTable :: QualificationId -> DB (Any, Widget)
 mkResultTable qid = do
+  --now <- liftIO getCurrentTime
   let
     resultDBTable = DBTable{..}
       where
@@ -129,38 +151,48 @@ mkResultTable qid = do
           ] -- TODO: add more columns for manual debugging view !!!
         dbtSorting = Map.fromList
           [ ("ident"  , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
-          -- , ("success", SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
+       -- , ("success", SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
           , ("success", SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
           ]
         dbtFilter = Map.fromList
-          [ -- singletonMap "ident" . FilterColumn . E.mkContainsFilter $ views (to queryLmsResult) (E.^. LmsResultIdent)          
+          [ ("ident"      , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
-            ("ident", FilterColumn . E.mkContainsFilter $ views (to queryLmsResult) (E.^. LmsResultIdent))
+          , ("success"    , FilterColumn . E.mkExactFilter                 $ views (to queryLmsResult) (E.^. LmsResultSuccess))
+          ]
+        dbtFilterUI = \mPrev -> mconcat 
+          [ prismAForm (singletonFilter "ident"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
+          , prismAForm (singletonFilter "success" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsIdent)
           ]
-        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
+        dbtCsvEncode = Nothing
-        dbtCsvDecode = Nothing {-
+        dbtCsvDecode = Just $ DBTCsvDecode -- Just save to DB; Job will process data later
-        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
+          { dbtCsvRowKey = \LmsResultTableCsv{..} -> 
-          { dbtCsvRowKey = const $ return Nothing -- always generate a fres key, or should we use ident? 
+            fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess
-          , dbtCsvComputeActions = \case 
+          , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
-              DBCsvDiffMissing{}
+              DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do 
-                -> return () -- no deletion
+                now <- liftIO getCurrentTime
-              DBCsvDiffExisting{}
+                --let LmsResultTableCsv{..} = dbCsvNew 
-                -> return () -- no deletion
+                --let csvLRTident = error "TODO"
-              DBCsvDiffNew{dbCsvNewKey, dbCsvNew}
+                --    csvLRTsuccess = error "TODO"
-                -> _insert      
+                yield $ LmsResultInsertData
-          , dbtCsvClassifyAction     = const ()   -- there is only one action: insert into table
+                        { lmsResultInsertIdent      = csvLRTident   dbCsvNew
-          , dbtCsvCoarsenActionClass = const ()   -- there is only one action: insert into table
+                        , lmsResultInsertSuccess    = csvLRTsuccess dbCsvNew
-          , dbtCsvValidateActions    = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
+                        , lmsResultInsertTimestamp  = now
-          , dbtCsvExecuteActions = _savetodb
+                        }                              
-          , dbtCsvRenderKey = _renderKey -- what is the purpose?
+              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew} -> error "UniqueLmsResult was found, but Key no longer exists."
-          , dbtCsvRenderActionClass = _renderActioCalss -- what is the purpose?
+              DBCsvDiffMissing{}  -> return () -- no deletion
-          , dbtCsvRenderException = _renderException
+              DBCsvDiffExisting{} -> return () -- no merge                              
-          }
+          , dbtCsvClassifyAction = \case 
-          -}
+              LmsResultInsertData{} -> LmsResultInsert
+          , dbtCsvCoarsenActionClass  = const DBCsvActionNew   -- there is only one action: insert into table
+          , dbtCsvValidateActions     = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
+          , dbtCsvExecuteActions      = error "TODO"
+          , dbtCsvRenderKey           = error "TODO" -- what is the purpose?
+          , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
+          , dbtCsvRenderException     = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
+          }                    
         dbtExtraReps = []
 
     resultDBTableValidator = def

src/Handler/Utils/DateTime.hs

@@ -28,7 +28,7 @@ import Data.Time.Zones
 import qualified Data.Time.Zones as TZ
 
 import qualified Data.Time.Format as Time
--- import Data.Time.Format.ISO8601 (iso8601Show)
+import Data.Time.Format.ISO8601 (iso8601Show)
 
 import qualified Data.Set as Set
 
@@ -317,12 +317,11 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail
 formatGregorianW :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX ()
 formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
 
--- generic instance from Data.Time.Clock.Instances suffices 
+instance Csv.ToField ZonedTime where 
---instance Csv.ToField ZonedTime where 
+  toField = Csv.toField . iso8601Show
---  toField = Csv.toField . iso8601Show
 
--- overlaps instance from Data.Time.Clock.Instances
+-- also see Data.Time.Clock.Instances
-instance {-# OVERLAPS #-} Csv.FromField ZonedTime where
+instance Csv.FromField ZonedTime where
   parseField = parse <=< Csv.parseField
     where
       parse t = asum $ do

src/Model/Types/Lms.hs

@@ -17,9 +17,14 @@ newtype LmsIdent = LmsIdent { getLmsIdent :: Text }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
 instance E.SqlString LmsIdent where
-
 makeLenses_ ''LmsIdent
 
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1  
+  , fieldLabelModifier = camelToPathPiece' 2
+  , omitNothingFields = True  
+  } ''LmsIdent 
+
 -- TODO: is this a good idea? Maybe just an ordinary Enum and a separate Day Column in the DB would be better, especially since LmsBlocked should really also encode a Day
 data LmsStatus = LmsOpen | LmsBlocked | LmsSuccess Day 
   deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)

test/Database/Fill.hs

@@ -456,6 +456,8 @@ fillDb = do
     void . insert' $ UserSchool uid mi False
   for_ [jost] $ \uid ->
     void . insert' $ UserSchool uid avn False
+
+  -- void . insert'
   let
     sdBsc = StudyDegreeKey' 82
     sdMst = StudyDegreeKey' 88