diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2f13a93f9..2a429a9ae 100644 --- a/messages/uniworx/de.msg +++ b/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. diff --git a/models/courses b/models/courses index fb9b06462..a731e778d 100644 --- a/models/courses +++ b/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 diff --git a/routes b/routes index 381a9486a..4f1ce19bd 100644 --- a/routes +++ b/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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 2dab7cf8d..ae1628b45 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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 diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 5596f31ee..cc1f5d7b9 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/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) diff --git a/src/Foundation.hs b/src/Foundation.hs index c776faea6..60fb249f1 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index ed3b194ac..6145f379f 100644 --- a/src/Handler/Course.hs +++ b/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 +
+ _{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| -

^{nameWidget userDisplayName userSurname} +

^{nameWidget userDisplayName userSurname} + #{mailtoHtml userEmail} +
+ +
+ ^{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" diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 60a06c165..afb17d135 100644 --- a/src/Handler/Profile.hs +++ b/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 diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 34ab467ac..4424c97b0 100644 --- a/src/Handler/SystemMessage.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 42ed1b985..4b2a3b1fb 100644 --- a/src/Handler/Utils.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 48935471c..1e40e4ffe 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 52e8b5dfe..25279fb96 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/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) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 9413e5e36..68f25cf20 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -218,6 +218,7 @@ data FormIdentifier | FIDDelete | FIDCourseRegister | FIDuserRights + | FIDcUserNote | FIDbuttonForm deriving (Eq, Ord, Read, Show) diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index b12d90359..c365611f9 100644 --- a/src/Utils/TH.hs +++ b/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