From 3d3ac9d77ccdbd6c91691871328a4569e61c53db Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 15 Feb 2022 18:15:39 +0100 Subject: [PATCH] chore(lms): make model compile again, sort out model errors --- models/lms.model | 63 ++++++++++++++++-------------- src/Data/Time/Clock/Instances.hs | 27 +++++++++---- src/Handler/LMS.hs | 2 +- src/Handler/LMS/Result.hs | 67 ++++++++++++++++---------------- src/Handler/Utils/DateTime.hs | 10 +++-- src/Handler/Utils/Table/Cells.hs | 8 +++- src/Model/Types/Lms.hs | 24 +++++++++--- 7 files changed, 118 insertions(+), 83 deletions(-) diff --git a/models/lms.model b/models/lms.model index ad53cbf03..d0e496bbc 100644 --- a/models/lms.model +++ b/models/lms.model @@ -3,65 +3,70 @@ Qualification shorthand (CI Text) name (CI Text) description StoredMarkup Maybe -- user-defined large Html, ought to contain full description - validDuration Word Maybe -- qualification is valid for this number of months - auditDuration Word Maybe -- number of month to keep audit log + validDuration Word Maybe -- qualification is valid for this number of months + auditDuration Word Maybe -- number of month to keep audit log refreshWithin CalendarDiffDays Maybe -- refresher is scheduled within this number of month before expiry - -- refreshInvitation StoredMarkup -- fest verdrahtet I18N-MSGs, nur Anzeige auf Webseite - -- expiryNotification StoredMarkup Maybe - elearningOnly Bool -- successful E-learing automatically increases validity + elearningOnly Bool -- successful E-learing automatically increases validity + -- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page + -- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead UniqueSchoolShort school shorthand -- must be unique per school and shorthand UniqueSchoolName school name -- must be unique per school and name deriving Generic --- Verknüpfung mit Exams fehlt only - -QualificationUser - user User - qualification QualficationId - validUntil UTCTime - firstHeld UTCTime -- timestamp qualification earned - lastRefresh UTCTIme -- lastRefresh > validUntil possible, indicates E-Learning success, but needs more (e.g. an exam) - UniqueQualificationUser qualification user - QualificationEdit user User time UTCTime qualification QualificationId OnDeleteCascade OnUpdateCascade deriving Generic +-- TODO: connect Qualification with Exams! + +QualificationUser + user User + qualification QualificationId + validUntil UTCTime + lastRefresh UTCTime -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False + firstHeld UTCTime -- first time the qualification was earned, should never change + UniqueQualificationUser qualification user + deriving Generic + + + -- LMS Interface Tables, need regular processing by background jobs --- Logging? LmsUser qualification QualificationId user UserId ident LmsIdent pin Text - resetPin Bool - deleted Bool + resetPin Bool -- should the pin be reset? + delete Bool -- should the ident be deleted? TODO: do we need this? started UTCTime Maybe - ended UTCTime Maybe + submitted UTCTime Maybe -- ident was sent to LMS (should happen only once) + ended UTCTime Maybe -- ident was deleted in LMS UniqueLmsUser qualification ident deriving Generic -LmsAudit - qualifaction QualifactionId - ident LmsIdent - lastSeen UTCTime - notificationType LmsNotification - +-- LmsUserlist stores LMS upload ofr later processing only LmsUserlist - qualification QualificationId + qualification QualificationId ident LmsIdent failed Bool timestamp UTCTime default=now() - UniqueLmsUserlist qualification ident deriving Generic --- QualificationId is redundant here; but known due to external upload +-- LmsUserlist stores LMS upload ofr later processing only LmsResult qualification QualificationId ident LmsIdent success Day timestamp UTCTime default=now() - UniqueLmsResult qualification ident + deriving Generic + +-- Logs all processed rows from LmsUserlist and LmsResult +LmsAudit + qualification QualificationId + ident LmsIdent + notificationType LmsNotification + received UTCTime + processed UTCTime default=now() deriving Generic diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index 8ff9d721b..80fecf2ae 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/src/Data/Time/Clock/Instances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Time.Clock.Instances @@ -32,7 +33,7 @@ instance PersistField NominalDiffTime where instance PersistFieldSql NominalDiffTime where sqlType _ = sqlType (Proxy @Rational) - +deriving instance Generic Day deriving instance Generic UTCTime instance Hashable UTCTime @@ -40,14 +41,26 @@ instance PathPiece UTCTime where toPathPiece = pack . iso8601Show fromPathPiece = iso8601ParseM . unpack -instance Csv.ToField UTCTime where - toField = Csv.toField . iso8601Show +-- 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 +{- + • Overlapping instances for Csv.ToField String + arising from a use of ‘Csv.toField’ + Matching instances: + instance ISO8601 t => Csv.ToField t + -- Defined at src/Data/Time/Clock/Instances.hs:45:11 + instance Csv.ToField [Char] + -- Defined in ‘cassava-0.5.2.0:Data.Csv.Conversion’ + • In the first argument of ‘(.)’, namely ‘Csv.toField’ + In the expression: Csv.toField . iso8601Show + In an equation for ‘Csv.toField’: + Csv.toField = Csv.toField . iso8601Show +-} -instance Csv.FromField UTCTime where +instance {-# OVERLAPPABLE #-} ISO8601 t => Csv.FromField t where -- overlapped for ZonedTime in Handler.Utils.DateTime 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 5b33023ca..bddfd6ff3 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -150,7 +150,7 @@ mkUserlistTable qid = do dbtRowKey = (E.^. LmsUserlistId) 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 "ident") (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ getLmsIdent lmsUserlistIdent , sortable (Just "failed") (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed ] dbtSorting = Map.fromList diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index d5f2cbae4..ce1439cd0 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -28,7 +28,7 @@ import Database.Esqueleto.Utils.TH type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification) - `E.InnerJoin` E.SqlExpr (Entity LmsResult) + `E.InnerJoin` E.SqlExpr (Entity LmsResult) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) @@ -46,7 +46,7 @@ queryUser = $(sqlLOJproj 3 3) type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User)) -instance HasEntity LmsResultTableData LmsResult where +instance HasEntity LmsResultTableData LmsResult where hasEntity = _dbrOutput . _2 {- MaybeHasUser only! @@ -61,43 +61,43 @@ resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult) resultLmsResult = _dbrOutput . _2 resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser) -resultLmsUser = _dbrOutput . _3 . _Just +resultLmsUser = _dbrOutput . _3 . _Just resultUser :: Traversal' LmsResultTableData (Entity User) -resultUser = _dbrOutput . _4 . _Just +resultUser = _dbrOutput . _4 . _Just -- required for import only -data LmsResultTableCsv = LmsResultTableCsv - { csvLRTident :: LmsIdent - , csvLRTsuccess :: UTCTime +data LmsResultTableCsv = LmsResultTableCsv + { csvLRTident :: LmsIdent + , csvLRTsuccess :: Day } deriving Generic -makeLenses_ ''LmsResultTableCsv +makeLenses_ ''LmsResultTableCsv --- csv without headers -instance Csv.ToRecord LmsResultTableCsv -- default suffices -instance Csv.FromRecord LmsResultTableCsv -- default suffices +-- 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" ] +lmsResultTableCsvHeader = Csv.header [ "identification", "day-success" ] -instance ToNamedRecord LmsResultTableCsv where - toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord - [ "identification" Csv..= csvLRTident - , "timestamp-success" Csv..= csvLRTsuccess +instance ToNamedRecord LmsResultTableCsv where + toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord + [ "identification" Csv..= csvLRTident + , "day-success" Csv..= csvLRTsuccess ] -instance FromNamedRecord LmsResultTableCsv where +instance FromNamedRecord LmsResultTableCsv where parseNamedRecord (lsfHeaderTranslate -> csv) = LmsResultTableCsv <$> csv Csv..: "identification" - <*> csv Csv..: "timestamp-success" + <*> csv Csv..: "day-success" -instance CsvColumnsExplained LmsResultTableCsv where +instance CsvColumnsExplained LmsResultTableCsv where csvColumnsExplanations _ = mconcat - [ single "identification" MsgCsvColumnLmsResultIdent + [ single "identification" MsgCsvColumnLmsResultIdent , single "timestamp-success" MsgCsvColumnLmsResultSuccess ] where @@ -106,16 +106,16 @@ instance CsvColumnsExplained LmsResultTableCsv where mkResultTable :: QualificationId -> DB (Any, Widget) -mkResultTable qid = do - let +mkResultTable qid = do + let resultDBTable = DBTable{..} where - dbtSQLQuery = runReaderT $ do + dbtSQLQuery = runReaderT $ do qualification <- asks queryQualification - lmsResult <- asks queryLmsResult + lmsResult <- asks queryLmsResult lmsUser <- asks queryLmsUser user <- asks queryUser - lift $ do + 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 @@ -123,15 +123,15 @@ mkResultTable qid = do 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 + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just "sucess") (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success ] -- TODO: add more columns for manual debugging view !!! - dbtSorting = Map.fromList + dbtSorting = Map.fromList [ ("ident" , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) , ("success", SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) -- , ("success", SortColumn . views queryLmsResult (E.^. LmsResultSuccess)) - ] + ] dbtFilter = Map.fromList [ -- ("ident" , FilterColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) ] @@ -144,14 +144,13 @@ mkResultTable qid = do 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 + resultDBTableValidator = def & defaultSorting [SortAscBy "ident"] dbTable resultDBTableValidator resultDBTable getLmsResultR :: QualificationId -> Handler Html -getLmsResultR qid = do - lmsTable <- runDB $ view _2 <$> mkResultTable qid +getLmsResultR qid = do + lmsTable <- runDB $ view _2 <$> mkResultTable qid siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsResult $(widgetFile "lms-result") - \ No newline at end of file diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 1c752536e..108f08d03 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,10 +317,12 @@ 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 -instance Csv.ToField ZonedTime where - toField = Csv.toField . iso8601Show +-- generic instance from Data.Time.Clock.Instances suffices +--instance Csv.ToField ZonedTime where +-- toField = Csv.toField . iso8601Show -instance Csv.FromField ZonedTime where +-- overlaps instance from Data.Time.Clock.Instances +instance {-# OVERLAPS #-} Csv.FromField ZonedTime where parseField = parse <=< Csv.parseField where parse t = asum $ do diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index de4a266c0..3f99e4b99 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -131,11 +131,15 @@ modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget timeCell :: IsDBTable m a => UTCTime -> DBCell m a timeCell t = cell $ formatTime SelFormatTime t >>= toWidget +dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a +dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget + dateCell :: IsDBTable m a => UTCTime -> DBCell m a dateCell t = cell $ formatTime SelFormatDate t >>= toWidget -dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a -dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget +dayCell :: IsDBTable m a => Day -> DBCell m a +dayCell utctDay = cell $ formatTime SelFormatDate UTCTime{..} >>= toWidget + where utctDayTime = 0 -- | Show a date, and highlight date earlier than given watershed with an icon and cell class Warning -- diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index b16ca0cd7..ddb9fa894 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -1,6 +1,6 @@ {-| Module: Model.Types.Lms -Description: Types for Lms +Description: Types for Learning Management System Interface operated by Know how! AG -} module Model.Types.Lms @@ -8,11 +8,23 @@ module Model.Types.Lms ) where import Import.NoModel +import Database.Persist.Sql +import qualified Data.Csv as Csv +import Utils.Lens.TH +newtype LmsIdent = LmsIdent { getLmsIdent :: Text } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (NFData, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) -type LmsIdent = Text +makeLenses_ ''LmsIdent -data LmsNotfication = Blocked | Successs | Alive - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving (Universe, Finite, NFData) - \ No newline at end of file +data LmsNotification = LmsAlive | LmsBlocked | LmsSuccesss Day + deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + , omitNothingFields = True + , sumEncoding = TaggedObject "lmsaudit" "lmsaction" + } ''LmsNotification +derivePersistFieldJSON ''LmsNotification