chore(qualifications): expand model to include CalendarDiffDays

models/lms.model

@@ -1,9 +1,23 @@
 Qualification
-  name              (CI Text)
+  school              SchoolId
-  shorthand         (CI Text)
+  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

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

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
+        dbtSorting = Map.fromList 
-          {-  Map.fromList 
+          [ ("ident"  , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
-          [ ("ident"  , SortColumn $ \reslist -> reslist E.^. LmsResultIdent)
+          , ("success", SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
-          , ("success", SortColumn $ \reslist -> reslist 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