diff --git a/models/lms.model b/models/lms.model index 4ba5e8159..5f5104107 100644 --- a/models/lms.model +++ b/models/lms.model @@ -1,20 +1,34 @@ Qualification - name (CI Text) - shorthand (CI Text) - -- to be expanded later + school SchoolId + name (CI Text) + shorthand (CI Text) + description StoredMarkup Maybe -- user-defined large Html, ought to contain full description + validDuration CalendarDiffDays Maybe -- qualification is valid for this time + refreshWithin CalendarDiffDays Maybe -- refresher is scheduled within this duration before expiry + refreshInvitation StoredMarkup Maybe -- email/letter to send + expiryNotification StoredMarkup Maybe + UniqueSchoolName name shorthand -- must be unique per school and name + UniqueSchoolShort school shorthand -- must be unique per school and shorthand + -- to be expanded later + deriving Generic + +QualificationEdit + user User + time UTCTime + qualification QualificationId OnDeleteCascade OnUpdateCascade deriving Generic -- LMS Interface Tables, need regular processing by background jobs LmsUser qualification QualificationId - user UserId - ident LmsIdent + user UserId + ident LmsIdent pin Text resetPin Bool delete Bool started UTCTime - UniqueLmsUser qualification ident + UniqueLmsUser qualification ident deriving Generic LmsUserlist diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index fa152557f..36dc03b45 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/src/Data/Time/Clock/Instances.hs @@ -10,6 +10,7 @@ import Database.Persist.Sql import Data.Proxy import Data.Time.Clock +import Data.Time.Calendar import Data.Time.Calendar.Instances () import Web.PathPieces @@ -44,3 +45,29 @@ instance Csv.ToField UTCTime where instance Csv.FromField UTCTime where parseField = iso8601ParseM <=< Csv.parseField + +deriving instance Generic CalendarDiffDays +-- deriving instance Hashable CalendarDiffDays + +instance PersistField CalendarDiffDays where + toPersistValue CalendarDiffDays{..} = toPersistValue $ both coerceI64 (cdMonths, cdDays) + where + coerceI64 :: Integer -> Word + coerceI64 = fromIntegral + + -- cannot be imported from utils due to cyclic dependencies and Data.Tuple.Extra is not yet a dependency + both :: (a -> b) -> (a, a) -> (b, b) + both f (x,y) = (f x, f y) + + fromPersistValue v = + case fromPersistValue v of + Right (cdMonths, cdDays) -> Right CalendarDiffDays{cdMonths = coerce64I cdMonths, cdDays = coerce64I cdDays} + Left e -> Left e + where + coerce64I :: Word -> Integer + coerce64I = toInteger + +type WordPair = (Word, Word) +instance PersistFieldSql CalendarDiffDays where + sqlType _ = sqlType (Proxy @WordPair) + diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 86d03405e..d5f2cbae4 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -127,13 +127,14 @@ mkResultTable qid = do [ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent -> ident) -> textCell ident , sortable (Just "sucess") (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dateTimeCell success ] -- TODO: add more columns for manual debugging view !!! - dbtSorting = mempty - {- Map.fromList - [ ("ident" , SortColumn $ \reslist -> reslist E.^. LmsResultIdent) - , ("success", SortColumn $ \reslist -> reslist E.^. LmsResultSuccess) + 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)) ] - -} - dbtFilter = mempty -- TODO !!! continue here !!! dbtFilterUI = const mempty -- TODO !!! continue here !!! Manual filtering useful to deal with user complaints! dbtStyle = def dbtParams = def