diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 492d82350..a5796ccca 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/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 \ No newline at end of file +CsvColumnLmsResultSuccess: Zeitstempel der erfolgreichen Teilnahme +LmsResultInsert: Neues LMS Ergebnis +LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 660368785..13dbe9ea4 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/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 \ No newline at end of file +CsvColumnLmsResultSuccess: Timestamp of successful completion +LmsResultInsert: New LMS result +LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key \ No newline at end of file diff --git a/models/lms.model b/models/lms.model index 900128696..cc51f2d18 100644 --- a/models/lms.model +++ b/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 diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index 80fecf2ae..979e474eb 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/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?! - toField = Csv.toField . iso8601Show +--instance {-# OVERLAPPABLE #-} ISO8601 t => Csv.ToField t where -- Error: overlaps Csv.ToField String, but no instance ISO8601 String exists?! +-- 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) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index f4aab2e5f..b18a9847a 100644 --- a/src/Handler/LMS.hs +++ b/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 - (getKeyBy404 $ UniqueSchoolShort sid qsh) - ((view _2 <$>) . mkUserlistTable) + lmsTable <- runDB $ do + qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + view _2 <$> mkUserlistTable qid siteLayoutMsg MsgMenuLmsUserlist $ do setTitleI MsgMenuLmsUserlist $(widgetFile "lms-userlist") diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 350abfdf3..ff3d566da 100644 --- a/src/Handler/LMS/Result.hs +++ b/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.mkContainsFilter $ views (to queryLmsResult) (E.^. LmsResultIdent)) + [ ("ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ 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 - dbtCsvDecode = Nothing {- - dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later - { dbtCsvRowKey = const $ return Nothing -- always generate a fres key, or should we use ident? - , dbtCsvComputeActions = \case - DBCsvDiffMissing{} - -> return () -- no deletion - DBCsvDiffExisting{} - -> return () -- no deletion - DBCsvDiffNew{dbCsvNewKey, dbCsvNew} - -> _insert - , dbtCsvClassifyAction = const () -- there is only one action: insert into table - , dbtCsvCoarsenActionClass = const () -- 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 = _savetodb - , dbtCsvRenderKey = _renderKey -- what is the purpose? - , dbtCsvRenderActionClass = _renderActioCalss -- what is the purpose? - , dbtCsvRenderException = _renderException - } - -} + dbtCsvEncode = Nothing + dbtCsvDecode = Just $ DBTCsvDecode -- Just save to DB; Job will process data later + { dbtCsvRowKey = \LmsResultTableCsv{..} -> + fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess + , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first + DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do + now <- liftIO getCurrentTime + --let LmsResultTableCsv{..} = dbCsvNew + --let csvLRTident = error "TODO" + -- csvLRTsuccess = error "TODO" + yield $ LmsResultInsertData + { lmsResultInsertIdent = csvLRTident dbCsvNew + , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew + , lmsResultInsertTimestamp = now + } + DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew} -> error "UniqueLmsResult was found, but Key no longer exists." + DBCsvDiffMissing{} -> return () -- no deletion + 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 diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 108f08d03..14693fe6a 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/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 --- toField = Csv.toField . iso8601Show +instance Csv.ToField ZonedTime where + toField = Csv.toField . iso8601Show --- overlaps instance from Data.Time.Clock.Instances -instance {-# OVERLAPS #-} Csv.FromField ZonedTime where +-- also see Data.Time.Clock.Instances +instance Csv.FromField ZonedTime where parseField = parse <=< Csv.parseField where parse t = asum $ do diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 56e65cea9..d62851469 100644 --- a/src/Model/Types/Lms.hs +++ b/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) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 5d87e8989..49b100a44 100644 --- a/test/Database/Fill.hs +++ b/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