chore(lms): make model compile again, sort out model errors

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
+  validDuration       Word Maybe                -- qualification is valid for this number of months
-  auditDuration       Word Maybe    -- number of month to keep audit log
+  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
+  elearningOnly       Bool                      -- successful E-learing automatically increases validity
-  -- expiryNotification  StoredMarkup Maybe
+  -- refreshInvitation   StoredMarkup           -- hard-coded I18N-MSGs used instead, but displayed on qualification page
-  elearningOnly       Bool     -- successful E-learing automatically increases validity
+  -- 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
+  resetPin          Bool                    -- should the pin be reset?
-  deleted           Bool
+  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
+-- LmsUserlist stores LMS upload ofr later processing only 
-  qualifaction      QualifactionId
-  ident             LmsIdent
-  lastSeen          UTCTime
-  notificationType  LmsNotification
-
 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

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
+-- UTCTime, Day, etc. 
-  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 . 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)

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

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 
+data LmsResultTableCsv = LmsResultTableCsv
-  { csvLRTident   :: LmsIdent 
+  { csvLRTident   :: LmsIdent
-  , csvLRTsuccess :: UTCTime
+  , csvLRTsuccess :: Day
   }
   deriving Generic
-makeLenses_ ''LmsResultTableCsv 
+makeLenses_ ''LmsResultTableCsv
 
--- csv without headers 
+-- csv without headers
-instance Csv.ToRecord   LmsResultTableCsv -- default suffices 
+instance Csv.ToRecord   LmsResultTableCsv -- default suffices
-instance Csv.FromRecord 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 
+instance ToNamedRecord LmsResultTableCsv where
-  toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord 
+  toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
-    [ "identification"    Csv..= csvLRTident
+    [ "identification" Csv..= csvLRTident
-    , "timestamp-success" Csv..= csvLRTsuccess
+    , "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 
+mkResultTable qid = do
-  let 
+  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 
+        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just "ident")  (i18nCell MsgTableLmsIdent)   $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent   -> ident)   -> textCell ident 
+          [ sortable (Just "ident")  (i18nCell MsgTableLmsIdent)   $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
-          , sortable (Just "sucess") (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dateTimeCell success
+          , 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  
+getLmsResultR qid = do
-  lmsTable <- runDB $ view _2 <$> mkResultTable qid 
+  lmsTable <- runDB $ view _2 <$> mkResultTable qid
   siteLayoutMsg MsgMenuLmsResult $ do
     setTitleI MsgMenuLmsResult
     $(widgetFile "lms-result")
-    

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
+-- generic instance from Data.Time.Clock.Instances suffices 
-  toField = Csv.toField . iso8601Show
+--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

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
+dayCell :: IsDBTable m a => Day -> DBCell m a
-dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
+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
 --

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
+data LmsNotification = LmsAlive | LmsBlocked | LmsSuccesss Day 
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
-  deriving (Universe, Finite, NFData) 
+
-  
+deriveJSON  defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1  
+  , fieldLabelModifier = camelToPathPiece' 1
+  , omitNothingFields = True
+  , sumEncoding = TaggedObject "lmsaudit" "lmsaction"
+  } ''LmsNotification
+derivePersistFieldJSON ''LmsNotification