Course user notes working, but needs model refactor

messages/uniworx/de.msg

@@ -95,6 +95,10 @@ CourseFilterNone: Egal
 CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
 CourseDeleted: Kurs gelöscht
 CourseUserNote: Notiz
+CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
+CourseUserNoteSaved: Notizänderungen gespeichert
+CourseUserNoteDeleted: Teilnehmernotiz gelöscht
+
 
 NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
 NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.

models/courses

@@ -40,12 +40,20 @@ CourseParticipant                      -- course enrolement
     registration UTCTime               -- time of last enrolement for this course
     field        StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
     UniqueParticipant user course
+-- Replace the last two by the following, once an audit log is available
+-- CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student
+--     course       CourseId
+--     user         UserId
+--     note         Html          -- arbitrary user-defined text; visible only to lecturer of this course
+--     time         UTCTime       -- PROBLEM: deleted note has no modification date
+--     editor       UserId        -- who edited this note last
+--     UniqueCourseUserNote user course
 CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student
     course       CourseId
     user         UserId
     note         Text          -- arbitrary user-defined text; visible only to lecturer of this course
-    UniqueCourseUserNotes user course
-CourseUserNoteEdit             -- who edited a participants course note whenl
+    UniqueCourseUserNote user course
+CourseUserNoteEdit             -- who edited a participants course note when
     user         UserId
     time         UTCTime
-    note         CourseUserNoteId
+    note         CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more

routes

@@ -76,7 +76,7 @@
   /edit                       CEditR          GET POST
   /delete                     CDeleteR        GET POST        !lecturerANDempty
   /users                      CUsersR         GET
-  /users/#CryptoUUIDUser      CUserR          GET             !lecturerANDparticipant
+  /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR         GET
   /notes                      CNotesR         GET POST        !corrector
   /subs                       CCorrectionsR   GET POST

src/Database/Esqueleto/Utils.hs

@@ -54,13 +54,20 @@ all :: Foldable f =>
 all test = F.foldr (\needle acc -> acc E.&&. test needle) true
 
 
-
 -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
 $(sqlInTuples [2..16])
 
+-- | Example for usage of unValueN
+_example_unValueN :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
+_example_unValueN = $(unValueN 3)
+
+-- | Example for usage of unValueNIs
+_example_unValueNIs :: (E.Value a, b, E.Value c) -> (a,b,c)
+_example_unValueNIs = $(unValueNIs 3 [1,3])
+
 -- | Example for usage of sqlIJproj
--- queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
--- queryFeaturesDegree  = $(sqlIJproj 3 2)
+_queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
+_queryFeaturesDegree  = $(sqlIJproj 3 2)
 
 
 -- | generic filter creation for dbTable

src/Database/Esqueleto/Utils/TH.hs

@@ -1,6 +1,7 @@
 module Database.Esqueleto.Utils.TH
   ( SqlIn(..)
   , sqlInTuple, sqlInTuples
+  , unValueN, unValueNIs
   , sqlIJproj, sqlLOJproj
   ) where
 
@@ -48,6 +49,30 @@ sqlInTuple arity = do
       ]
     ]
 
+-- | Generic unValuing of Tuples of Values, i.e.
+--   $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
+unValueN :: Int -> ExpQ
+unValueN arity = do
+    vs <- replicateM arity $ newName "v"
+    let pat = tupP $ map varP vs
+    let uvE v = [e|E.unValue $(varE v)|]
+    let rhs = tupE $ map uvE vs
+    lam1E pat rhs
+
+-- | Generic unValuing of certain indices of a Tuple, i.e.
+--   $(unValueNIs 3 [1,3]) :: (E.Value a, b, E.Value c) -> (a,b,c)
+unValueNIs :: Int -> [Int] -> ExpQ
+unValueNIs arity uvIdx = do
+    vs <- replicateM arity $ newName "v"
+    let pat = tupP $ map varP vs
+    let rhs = tupE $ map uvEi $ zip vs [1..]
+    lam1E pat rhs
+  where
+    uvEi (v,i) | i `elem` uvIdx = [e|E.unValue $(varE v)|]
+               | otherwise      = varE v
+
+
+
 -- | Generic projections for InnerJoin-tuples
 --   gives I-th element of N-tuple of left-associative InnerJoin-pairs,
 --   i.e. @$(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)

src/Foundation.hs

@@ -1147,7 +1147,7 @@ instance YesodBreadcrumbs UniWorX where
   --         (CourseR tid ssh csh CRegisterR) -- is POST only
   breadcrumb (CourseR tid ssh csh CEditR)     = return ("Editieren"  , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CUsersR)    = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
-  breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CShowR)
+  breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
   breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen"    , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu",         Just $ CourseR tid ssh csh SheetListR)

src/Handler/Course.hs

@@ -807,7 +807,7 @@ getCUsersR tid ssh csh = do
           , sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
           , colUserComment tid ssh csh
           ]
-        psValidator = def
+        psValidator = def & defaultSortingByName
     Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh
     numParticipants <- count [CourseParticipantCourse ==. cid]
     participantTable <- makeCourseUserTable cid colChoices psValidator
@@ -819,9 +819,9 @@ getCUsersR tid ssh csh = do
     $(widgetFile "course-participants")
 
 
-
-getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
-getCUserR _tid _ssh _csh uCId = do
+getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
+getCUserR = postCUserR
+postCUserR tid ssh csh uCId = do
   -- Has authorization checks (OR):
   --
   --   - User is current member of course
@@ -831,20 +831,72 @@ getCUserR _tid _ssh _csh uCId = do
   --   - User is corrector for course
   --   - User is a tutor for course
   --   - User is a lecturer for course
+  let currentRoute = CourseR tid ssh csh (CUserR uCId)
+  dozentId <- requireAuthId
   uid <- decrypt uCId
-  User{..} <- runDB $ get404 uid
+  -- DB reads
+  (cid, User{..}, thisUniqueNote, noteText, noteEdits ) <- runDB $ do
+    cid  <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+    user <- get404 uid
+    let thisUniqueNote = UniqueCourseUserNote uid cid
+    mbNoteEnt <- getBy thisUniqueNote
+    (noteText,noteEdits) <- case mbNoteEnt of
+      Nothing -> return (Nothing,[])
+      (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
+        noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
+          E.on     $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
+          E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
+          E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
+          E.limit 1 -- more will be shown, if changed here
+          return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
+        return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
+    return (cid,user,thisUniqueNote,noteText,noteEdits)
+  let editByWgt = [whamlet|
+          $forall (etime,_eemail,ename,_esurname) <- noteEdits
+            <br>
+            _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
+        |] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
+
+  ((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
+      (aopt (annotateField editByWgt textField) (fslpI MsgCourseUserNote "Text" & setTooltip MsgCourseUserNoteTooltip) $ Just noteText)
+      <*  submitButton
+  formResult noteRes $ \mbNote -> (do
+    let note = foldMap id mbNote -- Maybe Text to maybe empty Text
+    now <- liftIO getCurrentTime
+    if null note
+      then do
+        runDB $ do
+          -- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
+          maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
+          deleteBy thisUniqueNote
+        addMessageI Info MsgCourseUserNoteDeleted
+      else do
+        runDB $ do
+          (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
+          void . insert $ CourseUserNoteEdit dozentId now noteKey
+        addMessageI Success MsgCourseUserNoteSaved
+    )
+
+
 
   -- USE src/utils/Form.formResult
   defaultLayout -- TODO
     [whamlet|
-      <p>^{nameWidget userDisplayName userSurname}
+      <h2>^{nameWidget userDisplayName userSurname}
+      #{mailtoHtml userEmail}
+      <section>
+        <a id="note-form">
+        <form method=post action=@{currentRoute}#note-form enctype=#{noteEnctype}>
+          ^{noteView}
     |]
 
+
 getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCHiWisR = error "CHiWisR: Not implemented"
 
 getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 -- NOTE: The route getNotesR is abused for correctorORlecturer access rights!
 -- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared?
+-- If they are shared, adjust MsgCourseUserNoteTooltip
 getCNotesR  = error "CNotesR: Not implemented"
 postCNotesR = error "CNotesR: Not implemented"

src/Handler/Profile.hs

@@ -130,7 +130,7 @@ getProfileDataR = do
     dataWidget
     $(widgetFile "dsgvDisclaimer")
 
-makeProfileData :: (Entity User) -> DB Widget
+makeProfileData :: Entity User -> DB Widget
 makeProfileData (Entity uid User{..}) = do
   -- MsgRenderer mr <- getMsgRenderer
   admin_rights <- E.select $ E.from $ \(adright `E.InnerJoin` school) -> do

src/Handler/SystemMessage.hs

@@ -3,7 +3,6 @@ module Handler.SystemMessage where
 import Import
 
 import qualified Data.Map.Lazy as Map
-import qualified Data.Text as Text
 
 import qualified Data.Set as Set
 
@@ -16,13 +15,7 @@ import Utils.Lens
 
 import qualified Database.Esqueleto as E
 
-
-htmlField' :: Field (HandlerT UniWorX IO) Html
-htmlField' = htmlField
-  { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
-  }
-
-
+-- htmlField' moved to Handler.Utils.Form/Fields
 
 getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
 getMessageR = postMessageR

src/Handler/Utils.hs

@@ -91,6 +91,12 @@ wrapMailto (original -> email) linkText
 mailtoHtml :: CI Text -> Html
 mailtoHtml email = wrapMailto email $ toHtml email
 
+-- | Generic i18n text for "edited at sometime by someone"
+editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
+editedByW fmt tm usr  = do
+  ft <- handlerToWidget $ formatTime fmt tm
+  [whamlet|_{MsgEditedBy usr ft}|]
+
 -- | Prefix a message with a short course id,
 --   eg. for window title bars, etc.
 --   This function should help to make this consistent everywhere

src/Handler/Utils/Form.hs

@@ -12,7 +12,7 @@ import Handler.Utils.DateTime
 
 import Import hiding (cons)
 import qualified Data.Char as Char
-
+import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
 
 -- import Yesod.Core
@@ -141,6 +141,16 @@ buttonForm = identifyForm FIDbuttonForm buttonFormAux -- TODO: distinguish diffe
 -- Fields --
 ------------
 
+-- | add some additional text immediately after the field widget; probably not a good idea to use
+annotateField :: ToWidget (HandlerSite m) wgt => wgt -> Field m a -> Field m a
+annotateField ann field@Field{fieldView=fvf} =
+  let fvf' idt nmt atts ei bl =
+        [whamlet|
+          ^{fvf idt nmt atts ei bl}
+          ^{ann}
+        |]
+  in field { fieldView=fvf'}
+
 -- ciField moved to Utils.Form
 
 routeField :: ( Monad m
@@ -148,6 +158,12 @@ routeField :: ( Monad m
               ) => Field m (Route UniWorX)
 routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField
 
+-- | Variant that simply removes leading and trailing white space
+htmlField' :: Field (HandlerT UniWorX IO) Html
+htmlField' = htmlField
+  { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
+  }
+
 natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
 natFieldI msg = checkBool (>= 0) msg intField
 

src/Handler/Utils/Table/Columns.hs

@@ -66,8 +66,8 @@ sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>>
 
 defaultSortingByName :: PSValidator m x -> PSValidator m x
 defaultSortingByName =
-  defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
-  -- defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
+  -- defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
+  defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
 
 -- | Alias for sortUserName for consistency
 fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t)

src/Utils/Form.hs

@@ -218,6 +218,7 @@ data FormIdentifier
   | FIDDelete
   | FIDCourseRegister
   | FIDuserRights
+  | FIDcUserNote
   | FIDbuttonForm
   deriving (Eq, Ord, Read, Show)
 

src/Utils/TH.hs

@@ -24,7 +24,7 @@ projNI n i = do
   x <- newName "x"
   let rhs = varE x
   let pat = tupP $ replicate (pred i) wildP ++ varP x : replicate (n-i) wildP
-  lamE [pat] rhs
+  lam1E pat rhs
 
 
 -- | Generic projections N-tuples that are actually left-associative pairs
@@ -83,6 +83,14 @@ uncurryN n = do
   return $ LamE pat rhs
 
 
+afterN :: Int -> ExpQ -- apply a function after another of arity N, i.e. $(afterN 1) = (.)
+afterN n = do
+  f <- newName "f"
+  g <- newName "g"
+  --let rhs = [|$(curryN n) (g . ($(uncurryN n) f))|]
+  lamE [(varP g),(varP f)] [|$(curryN n) ($(varE g) . ($(uncurryN n) $(varE f)))|]
+
+
 -- Special Show-Instances for Themes
 deriveShowWith :: (String -> String) -> Name -> Q [Dec]
 deriveShowWith = deriveSimpleWith ''Show 'show