First part of issue #187 implemented.

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
+FieldSecondary: Nebenfach

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
+    ratingPoints    Points  Maybe -- "Just" does not mean done
-    ratingComment   Text    Maybe 
+    ratingComment   Text    Maybe -- "Just" does not mean done
-    ratingBy        UserId  Maybe
+    ratingBy        UserId  Maybe -- assigned corrector
-    ratingTime      UTCTime Maybe   
+    ratingTime      UTCTime Maybe -- "Just" here indicates done!
     deriving Show
 SubmissionEdit
     user            UserId

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

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
+  uid <- requireAuthId
-  courseEditHandler True Nothing
+  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)

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 {..}
 
-

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|<a href=@{url}>^{lbl}|]
 
 nameWidget :: Text -> Text -> Widget
 nameWidget displayName surname

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| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
 --   [whamlet|
 --     <form method=post action=@{url}>
@@ -120,10 +120,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
 --   |]
   --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
 
-simpleLink :: Widget -> Route UniWorX -> Widget
-simpleLink lbl url = [whamlet| <a href=@{url}>^{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
 

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

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

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

templates/profile.hamlet

@@ -16,21 +16,18 @@
       <dt .deflist__dt> Administrator
       <dd .deflist__dd>
         <ul .list-ul>
-          $forall institute <- admin_rights
+          $forall (E.Value institute) <- admin_rights
-            <li .list-ul__item>#{display institute}
+            <li .list-ul__item>
+              <a href=@{SchoolShowR $ SchoolKey institute}>
+                #{display institute}
     $if not $ null lecturer_rights
       <dt .deflist__dt> Lehrberechtigt
       <dd .deflist__dd>
         <ul .list-ul>
-          $forall institute <- lecturer_rights
+          $forall (E.Value institute) <- lecturer_rights
-            <li .list-ul__item>#{display institute}
-    $if not $ null lecture_owner
-      <dt .deflist__dt> Eigene Kurse
-      <dd .deflist__dd>
-        <ul .list-ul>
-          $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_owner
             <li .list-ul__item>
-              <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
+              <a href=@{SchoolShowR $ SchoolKey institute}>
+                #{display institute}
     $if not $ null lecture_corrector
       <dt .deflist__dt> Korrektor
       <dd .deflist__dd>
@@ -64,14 +61,4 @@
                 <td .table__td>_{E.unValue fieldtype}
                 <td .table__td>#{display semester}
 
-    $if not $ null participant
-      <dt .deflist__dt> Teilnehmer
-      <dd .deflist__dd>
-        <dl .deflist>
-          $forall (E.Value tid, E.Value ssh, E.Value csh, E.Value regSince) <- participant
-            <dt .deflist__dt>
-                <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
-            <dd .deflist__dd>
-                seit ^{formatTimeW SelFormatDateTime regSince}
-
   ^{settingsForm}

templates/profileData.hamlet

@@ -6,8 +6,6 @@
         und verlinkt werden
         (alle Abgaben, Klausurnoten, etc.)
 
-  <em> TODO: Hier alle Daten in Tabellen anzeigen!
-
   $if hasRows
     <div .container>
       <h2> Eigene Kurse
@@ -24,6 +22,11 @@
     <div .container>
       ^{examTable}
 
+  <div .container>
+    <h2> Eigene Übungsgruppen
+    <div .container>
+      ^{ownTutorialTable}
+
   <div .container>
     <h2> Übungsgruppen
     <div .container>
@@ -47,6 +50,13 @@
     <div .container>
       ^{correctionsTable}
 
+    <h4> Hinweis:
+    Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt;
+    auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier nicht aufgeführt werden.
+    Hier finden Sie eine
+    <a href=@{CorrectionsR}>Auflistung aller tatsächlich zugewiesenen Korrekturen
+    .
+
   <h2>
         <em> TODO: Knopf zum Löschen aller Daten erstellen