chore(lms): make model compile again, sort out model errors
This commit is contained in:
Steffen Jost
parent
aa73359893
commit
3d3ac9d77c
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
--
|
||||
|
||||
@ -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)
|
||||
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user