diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index b16a7d255..2d639b739 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -185,7 +185,7 @@ Users: Benutzer HomeHeading: Aktuelle Termine LoginHeading: Authentifizierung LoginTitle: Authentifizierung -ProfileHeading: Benutzerprofil und Einstellungen +ProfileHeading: Benutzereinstellungen ProfileDataHeading: Gespeicherte Benutzerdaten ImpressumHeading: Impressum @@ -290,6 +290,7 @@ CorrectorExcused: Entschuldigt DayIsAHoliday tid@TermId date@Text: #{date} ist ein Feiertag DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszeit des #{display tid} DayIsOutOfTerm tid@TermId date@Text: #{date} liegt nicht im #{display tid} + UploadModeNone: Kein Upload UploadModeUnpack: Upload, einzelne Datei UploadModeNoUnpack: Upload, ZIP-Archive entpacken @@ -297,4 +298,4 @@ UploadModeNoUnpack: Upload, ZIP-Archive entpacken SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. FieldPrimary: Hauptfach -FieldSecondary: Nebenfach \ No newline at end of file +FieldSecondary: Nebenfach diff --git a/models b/models index 62f4d0e43..91261853e 100644 --- a/models +++ b/models @@ -54,7 +54,7 @@ School json shorthand (CI Text) UniqueSchool name UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text - Primary shorthand -- newtype Key School = School { unSchoolKey :: SchoolShorthand } + Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } deriving Eq DegreeCourse json course CourseId @@ -133,10 +133,10 @@ File deriving Show Eq Submission sheet SheetId - ratingPoints Points Maybe - ratingComment Text Maybe - ratingBy UserId Maybe - ratingTime UTCTime Maybe + ratingPoints Points Maybe -- "Just" does not mean done + ratingComment Text Maybe -- "Just" does not mean done + ratingBy UserId Maybe -- assigned corrector + ratingTime UTCTime Maybe -- "Just" here indicates done! deriving Show SubmissionEdit user UserId diff --git a/src/Foundation.hs b/src/Foundation.hs index d4f8890b1..7f25aa50b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -743,7 +743,7 @@ defaultLinks = -- Define the menu items of the header. , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem - { menuItemLabel = "Profile" + { menuItemLabel = "Profil" , menuItemIcon = Just "cogs" , menuItemRoute = ProfileR , menuItemAccessCallback' = isJust <$> maybeAuthPair diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b12ebe9c0..758ff76d9 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -313,8 +313,33 @@ postCRegisterR tid ssh csh = do getCourseNewR :: Handler Html getCourseNewR = do - -- TODO: Defaults für Semester hier ermitteln und übergeben - courseEditHandler True Nothing + uid <- requireAuthId + params <- runInputGetResult $ (,,) + <$> ireq ciTextField "csh" + <*> iopt textField "tid" + <*> iopt ciTextField "sid" + template <- case params of + FormMissing -> return Nothing + FormFailure [] -> return Nothing + FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml) >> return Nothing + FormSuccess (csh,mbTid,mbSid) -> do + oldCourses <- runDB $ do + E.select $ E.from $ \(course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseSchool E.==. lecturer E.^. UserLecturerSchool + E.where_ $ course E.^. CourseShorthand E.==. E.val csh + E.&&. lecturer E.^. UserLecturerUser E.==. E.val uid -- only search courses for lecturer's school (admin does not help here) + whenIsJust (SchoolKey <$> mbSid) $ + \sid -> E.where_ $ course E.^. CourseSchool E.==. E.val sid + whenIsJust (mbTid >>= tidFromText) $ + \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid + let courseCreated c = E.sub_select . E.from $ \edit -> do + E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId + return $ E.min_ $ edit E.^. CourseEditTime -- oldest edit must be creation + E.orderBy [E.desc $ courseCreated course] -- most recent courses + E.limit 1 + return course + return $ listToMaybe oldCourses + courseEditHandler True template postCourseNewR :: Handler Html postCourseNewR = courseEditHandler False Nothing @@ -343,6 +368,7 @@ courseDeleteHandler = undefined courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html courseEditHandler isGet course = do + -- isGet <- isWriteRequest -- $logDebug "€€€€€€ courseEditHandler started" aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm @@ -462,7 +488,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do userId <- liftHandlerT requireAuthId (fmap concat . sequence) [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] - , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] + , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] ] (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (cfCourseId =<< template) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 649c748ae..11a180cfb 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -94,7 +94,7 @@ getProfileR = do _ -> return () - (admin_rights,lecturer_rights,lecture_owner,lecture_corrector,participant,studies) <- runDB $ (,,,,,) <$> + (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$> (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do E.where_ $ adright E.^. UserAdminUser E.==. E.val uid E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId @@ -107,12 +107,6 @@ getProfileR = do return (school E.^. SchoolShorthand) ) <*> - (E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do - E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid - E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId - return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand) - ) - <*> (E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet @@ -120,12 +114,6 @@ getProfileR = do return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) ) <*> - (E.select $ E.from $ \(participant `E.InnerJoin` course) -> do - E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid - E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId - return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, participant E.^. CourseParticipantRegistration) - ) - <*> (E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId @@ -164,15 +152,17 @@ getProfileDataR = do -- Tabelle mit allen Teilnehmer: Kurs (link), Datum enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Klausuren und Noten - examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO + examTable <- return [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|] -- Tabelle mit allen Abgaben und Abgabe-Gruppen submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgabegruppen submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Korrektor-Aufgaben correctionsTable <- mkCorrectionsTable uid + -- Tabelle mit allen eigenen Tutorials + ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|] -- Tabelle mit allen Tutorials - tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO + tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|] defaultLayout $ do $(widgetFile "profileData") $(widgetFile "dsgvDisclaimer") @@ -421,7 +411,7 @@ mkSubmissionGroupTable = mkCorrectionsTable :: UserId -> Handler Widget --- Table listing all corrections made by the given user +-- Table listing sum of corrections made by the given user per sheet mkCorrectionsTable = let dbtIdent = "corrections" :: Text dbtStyle = def @@ -430,6 +420,17 @@ mkCorrectionsTable = -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a) withType = id + corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do + E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) + return $ E.countRows + + corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do + E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) + E.&&. (E.not_ $ E.isNothing $ submission E.^. SubmissionRatingTime) + return $ E.countRows + dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId @@ -438,7 +439,7 @@ mkCorrectionsTable = , course E.^. CourseSchool , course E.^. CourseShorthand ) - return (crse, sheet E.^. SheetName, corrector) + return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet)) dbtProj = \x -> return $ x & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) @@ -458,6 +459,10 @@ mkCorrectionsTable = correctorStateCell <$> view (_dbrOutput . _3 . _entityVal) , sortable (toNothing "cload") (i18nCell MsgCorProportion) $ correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal) + , sortable (toNothing "assigned") (i18nCell MsgCorProportion) $ + int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue) + , sortable (toNothing "corrected") (i18nCell MsgCorProportion) $ + int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue) ] validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)] @@ -476,4 +481,3 @@ mkCorrectionsTable = in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator $ DBTable {..} - diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 42306d918..1c02d4235 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -36,6 +36,11 @@ downloadFiles = do AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings return userDefaultDownloadFiles +tidFromText :: Text -> Maybe TermId +tidFromText = (fmap TermKey) . maybeRight . termFromText + +simpleLink :: Widget -> Route UniWorX -> Widget +simpleLink lbl url = [whamlet|^{lbl}|] nameWidget :: Text -> Text -> Widget nameWidget displayName surname diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 28064466d..74f54c2fa 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -111,7 +111,7 @@ instance Button UniWorX AdminHijackUserButton where -- instance PathPiece LinkButton where -- LinkButton route = ??? -linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget +linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink linkButton lbl cls url = [whamlet| ^{lbl} |] -- [whamlet| --
@@ -120,10 +120,6 @@ linkButton lbl cls url = [whamlet| -simpleLink :: Widget -> Route UniWorX -> Widget -simpleLink lbl url = [whamlet| ^{lbl} |] - - {- combinedButtonField :: Button a => [a] -> Form m -> Form (a,m) combinedButtonField btns inner csrf = do @@ -190,6 +186,9 @@ buttonForm csrf = do ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a) ciField = convertField CI.mk CI.original +ciTextField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m (CI Text) +ciTextField = ciField textField + natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i natFieldI msg = checkBool (>= 0) msg intField @@ -222,6 +221,9 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} termActiveField :: Field Handler TermId termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName +termsField :: [TermId] -> Field Handler TermId +termsField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName + termActiveOld :: Field Handler TermIdentifier termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index bb658c68c..0b74f7e01 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -35,6 +35,12 @@ userCell displayName surname = cell $ nameWidget displayName surname maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a maybeTimeCell = maybe mempty timeCell +numCell :: (IsDBTable m a, Num b, DisplayAble b) => b -> DBCell m a +numCell = textCell . display + +int64Cell :: (IsDBTable m a) => Int64-> DBCell m a +int64Cell = numCell + termCell :: IsDBTable m a => TermId -> DBCell m a termCell tid = anchorCell link name where diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 5d5f9e5a9..6f43c5258 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -286,6 +286,7 @@ shortened = iso shorten expand termToText :: TermIdentifier -> Text termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened) +-- also see Hander.Utils.tidFromText termFromText :: Text -> Either Text TermIdentifier termFromText t | (s:ys) <- Text.unpack t diff --git a/src/Utils.hs b/src/Utils.hs index d8b098139..68e449618 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -323,6 +323,27 @@ instance Ord a => Ord (NTop (Maybe a)) where +----------- +-- Maybe -- +----------- + +maybeLeft :: Either a b -> Maybe a +maybeLeft (Left a) = Just a +maybeLeft _ = Nothing + +maybeRight :: Either a b -> Maybe b +maybeRight (Right b) = Just b +maybeRight _ = Nothing + +whenIsLeft :: Monad m => Either a b -> (a -> m ()) -> m () +whenIsLeft (Left x) f = f x +whenIsLeft (Right _) _ = return () + +whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m () +whenIsRight (Right x) f = f x +whenIsRight (Left _) _ = return () + + --------------- -- Exception -- --------------- diff --git a/templates/profile.hamlet b/templates/profile.hamlet index 40b468cd8..de4a91cc5 100644 --- a/templates/profile.hamlet +++ b/templates/profile.hamlet @@ -16,21 +16,18 @@
Administrator