fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Steffen Jost 2022-02-18 17:54:24 +01:00
parent e821b416f0
commit fea453a87e
9 changed files with 100 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -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

4
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -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

3
models/lms.model
View File

@ -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

22
src/Data/Time/Clock/Instances.hs
View File

@ -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)

8
src/Handler/LMS.hs
View File

@ -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")

80
src/Handler/LMS/Result.hs
View File

@ -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

11
src/Handler/Utils/DateTime.hs
View File

@ -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

7
src/Model/Types/Lms.hs
View File

@ -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)

2
test/Database/Fill.hs
View File

@ -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