Merge branch 'master' into 186-nutzer-ohne-ldap

ChangeLog.md

@@ -10,6 +10,8 @@
 
     Intelligente Verteilung von Abgaben auf Korrektoren (z.B. bei Krankheit)
     
+    Übungsblätter können Abgabe von Dateien verbieten und angeben ob ZIP-Archive entpackt werden sollen
+
   * Version 06.08.2018
   
     Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen

db.hs

@@ -196,11 +196,11 @@ fillDb = do
   void . insert $ DegreeCourse ffp sdMst sdInf
   void . insert $ Lecturer jost   ffp
   void . insert $ Lecturer gkleen ffp
-  sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
-  sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
-  sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
   -- EIP
   eip <- insert Course
@@ -284,6 +284,7 @@ fillDb = do
     , sheetVisibleFrom = Just now
     , sheetActiveFrom = now
     , sheetActiveTo = (14 * nominalDay) `addUTCTime` now 
+    , sheetUploadMode = Upload True
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     }

messages/uniworx/de.msg

@@ -41,10 +41,10 @@ CourseRegisterOk: Sie wurden angemeldet
 CourseDeregisterOk: Sie wurden abgemeldet
 CourseSecretWrong: Falsches Kennwort
 CourseSecret: Zugangspasswort
-CourseNewOk        tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt.
+CourseNewOk        tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.
-CourseEditOk       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich geändert.
+CourseEditOk       tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich geändert.
-CourseNewDupShort  tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
+CourseNewDupShort  tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
-CourseEditDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
+CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
 FFSheetName: Name
 TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
 TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
@@ -52,7 +52,7 @@ CourseListTitle: Alle Kurse
 TermCourseListTitle   tid@TermId: Kurse #{display tid}
 TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
 CourseNewHeading: Neuen Kurs anlegen
-CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren
+CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
 CourseEditTitle: Kurs editieren/anlegen
 CourseMembers: Teilnehmer
 CourseMembersCount num@Int64: #{display num}
@@ -71,20 +71,25 @@ CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
 CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
 CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
 
+NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
+NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
+NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{display csh} bekannt.
+NoSuchCourse: Keinen passenden Kurs gefunden.
 
 Sheet: Blatt
-SheetList          tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter
+SheetList          tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Übersicht Übungsblätter
-SheetNewHeading    tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen
+SheetNewHeading    tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Neues Übungsblatt anlegen
-SheetNewOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
+SheetNewOk         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{csh} erfolgreich erstellt.
-SheetTitle         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
+SheetTitle         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}
-SheetTitleNew      tid@TermId ssh@SchoolId courseShortHand@CourseShorthand                    : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt
+SheetTitleNew      tid@TermId ssh@SchoolId csh@CourseShorthand                    : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt
-SheetEditHead      tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren
+SheetEditHead      tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
-SheetEditOk        tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert.
+SheetEditOk        tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert.
-SheetNameDup       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}.
+SheetNameDup       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
-SheetDelHead       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
+SheetDelHead       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen?
 SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
-SheetDelOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht.
+SheetDelOk         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
 
+SheetUploadMode: Abgabe von Dateien
 SheetExercise: Aufgabenstellung
 SheetHint: Hinweis
 SheetHintFrom: Hinweis ab
@@ -116,12 +121,12 @@ Deadline: Abgabe
 Done: Eingereicht
 
 Submission: Abgabenummer
-SubmissionsCourse tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{courseShortHand}
+SubmissionsCourse tid@TermId ssh@SchoolId csh@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{csh}
 SubmissionsSheet sheetName@SheetName: Abgaben für #{sheetName}
 SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
 SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
-SubmissionEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
+SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
-CorrectionHead     tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Korrektur
+CorrectionHead     tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
 SubmissionMember g@Int: Mitabgebende(r) ##{display g}
 SubmissionArchive: Zip-Archiv der Abgabedatei(en)
 SubmissionFile: Datei zur Abgabe
@@ -163,7 +168,7 @@ TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
 
 AddCorrector: Zusätzlicher Korrektor
 CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
-SheetCorrectorsTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
+SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
 CountTutProp: Tutorien zählen gegen Proportion
 Corrector: Korrektor
 Correctors: Korrektoren
@@ -184,7 +189,7 @@ Users: Benutzer
 HomeHeading: Aktuelle Termine
 LoginHeading: Authentifizierung
 LoginTitle: Authentifizierung
-ProfileHeading: Benutzerprofil und Einstellungen
+ProfileHeading: Benutzereinstellungen
 ProfileDataHeading: Gespeicherte Benutzerdaten
 ImpressumHeading: Impressum
 
@@ -285,3 +290,16 @@ DummyLoginTitle: Development-Login
 CorrectorNormal: Normal
 CorrectorMissing: Abwesend
 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
+
+SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
+
+FieldPrimary: Hauptfach
+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
@@ -108,6 +108,7 @@ Sheet
     activeTo        UTCTime
     hintFrom        UTCTime Maybe
     solutionFrom    UTCTime Maybe
+    uploadMode      UploadMode
     CourseSheet course name
 SheetEdit
     user            UserId
@@ -132,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

@@ -178,6 +178,12 @@ instance RenderMessage UniWorX TermIdentifier where
     Winter -> renderMessage' $ MsgWinterTerm year
     where renderMessage' = renderMessage foundation ls
 
+instance RenderMessage UniWorX StudyFieldType where
+  renderMessage foundation ls = \case
+    FieldPrimary -> renderMessage' MsgFieldPrimary
+    FieldSecondary -> renderMessage' MsgFieldSecondary
+    where renderMessage' = renderMessage foundation ls
+
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving (Eq, Ord, Read, Show)
 
@@ -677,7 +683,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb TermCurrentR           = return ("Aktuell"   , Just TermShowR)
   breadcrumb TermEditR              = return ("Neu"       , Just TermCurrentR)
   breadcrumb (TermEditExistR tid)   = return ("Editieren" , Just $ TermCourseListR tid)
-  breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
+  breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Nothing)
 
   breadcrumb (TermSchoolCourseListR tid ssh)  = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
 
@@ -737,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

@@ -20,6 +20,7 @@ import Import
 import Control.Lens
 import Utils.Lens
 import Utils.TH
+-- import Utils.DB
 import Handler.Utils
 import Handler.Utils.Table.Cells
 
@@ -28,6 +29,7 @@ import qualified Data.Text as T
 import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
+import Data.Maybe
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
@@ -313,21 +315,78 @@ 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 "ssh"
+  let noTemplateAction = courseEditHandler True Nothing
+  case params of
+    FormMissing      -> noTemplateAction
+    FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml)
+                        >> noTemplateAction
+    FormSuccess (csh,mbTid,mbSsh) -> do
+      tid <- ifMaybeM mbTid Nothing $ \tid ->
+        case termFromText tid of
+          Left err -> addMessage "error" (toHtml err) >> return Nothing
+          Right t  -> return $ Just $ TermKey t
+      getCourseNewTemplateR tid (SchoolKey <$> mbSsh) csh
+
+getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> CourseShorthand -> Handler Html
+getCourseNewTemplateR mbTid mbSsh csh = do
+  uid <- requireAuthId
+  oldCourses <- runDB $ do
+    E.select $ E.from $ \course -> do
+      E.where_                            $ course E.^. CourseShorthand  E.==. E.val csh
+      whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
+      whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
+      let lecturersSchool =
+            E.exists $ E.from $ \lecturer -> do
+              E.where_ $ lecturer E.^. UserLecturerUser   E.==. E.val uid
+                  E.&&.  lecturer E.^. UserLecturerSchool E.==. course E.^. CourseSchool
+      let courseCreated c =
+            E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
+              E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
+              return $ E.min_ $ edit E.^. CourseEditTime
+      E.orderBy [ E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
+                , E.desc $ courseCreated course]                                     -- most recent created course
+      E.limit 1
+      return course
+  template <- case listToMaybe oldCourses of
+    (Just oldTemplate) ->
+        let newTemplate = (courseToForm oldTemplate) in
+        return $ Just $ newTemplate
+            { cfCourseId   = Nothing
+            , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
+            , cfRegFrom    = Nothing
+            , cfRegTo      = Nothing
+            , cfDeRegUntil = Nothing
+            }
+    Nothing -> do
+        (tidOk,sshOk,cshOk) <- runDB $ (,,)
+            <$> ifMaybeM mbTid True existsKey
+            <*> ifMaybeM mbSsh True existsKey
+            <*> ((not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+        unless tidOk $ addMessageI "warning" $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
+        unless sshOk $ addMessageI "warning" $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
+        unless cshOk $ addMessageI "warning" $ MsgNoSuchCourseShorthand csh
+        when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse
+        return Nothing
+  courseEditHandler True template
 
 postCourseNewR :: Handler Html
-postCourseNewR = courseEditHandler False Nothing
+postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course.
 
-getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCEditR tid ssh csh = do
+getCEditR  = pgCEditR True
-  course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
+postCEditR = pgCEditR False
-  courseEditHandler True course
 
-postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html
-postCEditR tid ssh csh = do
+pgCEditR isGetReq tid ssh csh = do
   course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
-  courseEditHandler False course
+  -- IMPORTANT: both GET and POST Handler must use the same template,
+  --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
+  courseEditHandler isGetReq $ courseToForm <$> course
 
 
 courseDeleteHandler :: Handler Html -- not called anywhere yet
@@ -341,11 +400,14 @@ courseDeleteHandler = undefined
             redirect $ TermCourseListR $ cfTerm res
 -}
 
-courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
+
-courseEditHandler isGet course = do
+-- | Course Creation and Editing
-    -- $logDebug "€€€€€€ courseEditHandler started"
+-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
+-- |            since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
+courseEditHandler :: Bool -> Maybe CourseForm -> Handler Html
+courseEditHandler isGet mbCourseForm = do
     aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
-    ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm
+    ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm
     case result of
       (FormSuccess res@(
         CourseForm  { cfCourseId = Nothing
@@ -396,7 +458,7 @@ courseEditHandler isGet course = do
                             ,  courseDescription     = cfDesc       res
                             ,  courseLinkExternal    = cfLink       res
                             ,  courseShorthand       = cfShort      res
-                            ,  courseTerm            = cfTerm       res
+                            ,  courseTerm            = cfTerm       res -- dangerous
                             ,  courseSchool          = cfSchool     res
                             ,  courseCapacity        = cfCapacity   res
                             ,  courseRegisterSecret  = cfSecret     res
@@ -438,9 +500,8 @@ data CourseForm = CourseForm
         , cfDeRegUntil :: Maybe UTCTime
         }
 
-courseToForm :: MonadCrypto m => Entity Course -> m CourseForm
+courseToForm :: Entity Course -> CourseForm
-courseToForm (Entity cid Course{..}) = do
+courseToForm (Entity cid Course{..}) = CourseForm
-  return $ CourseForm
     { cfCourseId   = Just cid
     , cfName       = courseName
     , cfDesc       = courseDescription
@@ -462,8 +523,11 @@ 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] []
         ]
+    let termsField = case template of
+          (Just cform) | (Just _) <- cfCourseId cform -> termsSetField [cfTerm cform]
+          _allOtherCases -> termsActiveField
     (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
       <$> pure (cfCourseId =<< template)
       <*> areq (ciField textField) (fslI MsgCourseName)          (cfName     <$> template)
@@ -474,7 +538,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
             -- & addAttr "disabled" "disabled"
             & setTooltip MsgCourseShorthandUnique)
                                                 (cfShort  <$> template)
-      <*> areq termActiveField              (fslI MsgCourseSemester)    (cfTerm     <$> template)
+      <*> areq termsField                   (fslI MsgCourseSemester)    (cfTerm     <$> template)
       <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool)      (cfSchool   <$> template)
       <*> aopt (natField "Kapazität")       (fslI MsgCourseCapacity
             & setTooltip MsgCourseCapacityTip)                          (cfCapacity <$> 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,20 +114,18 @@ 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
                 E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
-                return  (studydegree E.^. StudyDegreeName
+                return  ( ( studydegree E.^. StudyDegreeName
-                        ,studyterms  E.^. StudyTermsName
+                          , studydegree E.^. StudyDegreeKey
-                        ,studyfeat   E.^. StudyFeaturesType
+                          )
-                        ,studyfeat   E.^. StudyFeaturesSemester)
+                        , ( studyterms  E.^. StudyTermsName
+                          , studyterms  E.^. StudyTermsKey
+                          )
+                        , studyfeat   E.^. StudyFeaturesType
+                        , studyfeat   E.^. StudyFeaturesSemester)
             )
   let formText  = Just MsgSettings
       actionUrl = ProfileR
@@ -160,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")
@@ -417,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
@@ -426,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
@@ -434,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))
@@ -454,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)]
@@ -472,4 +481,3 @@ mkCorrectionsTable =
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
               in  dbTableWidget' validator $ DBTable {..}
 
-

src/Handler/Sheet.hs

@@ -22,6 +22,7 @@ import System.FilePath (takeFileName)
 
 import Handler.Utils
 -- import Handler.Utils.Zip
+import Handler.Utils.Table.Cells
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -81,6 +82,7 @@ data SheetForm = SheetForm
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
+      , sfUploadMode   :: UploadMode
       , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
       , sfHintF        :: Maybe (Source Handler (Either FileId File))
@@ -106,11 +108,11 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
     mr <- getMsgRenderer
     ctime <- liftIO $ getCurrentTime
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
-      <$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template)
+      <$> areq (ciField textField) (fslI MsgSheetName)    (sfName        <$> template)
       <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
-      <*> sheetTypeAFormReq   (fslI MsgSheetType)                (sfType <$> template)
+      <*> sheetTypeAFormReq   (fslI MsgSheetType)         (sfType        <$> template)
-      <*> sheetGroupAFormReq  (fslI MsgSheetGroup) (sfGrouping <$> template)
+      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
-      <*> aopt htmlField      (fslI MsgSheetMarking) (sfMarkingText <$> template)
+      <*> aopt htmlField      (fslI MsgSheetMarking)      (sfMarkingText <$> template)
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
                                                               ((sfVisibleFrom  <$> template) <|> pure (Just ctime))
@@ -118,10 +120,10 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
+      <*> areq uploadModeField (fslI MsgSheetUploadMode)      ((sfUploadMode   <$> template) <|> pure (Upload True))
       <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
-            & setTooltip MsgSheetHintFromTip)
+            & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
-                                                              (sfHintFrom     <$> template)
       <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetSolutionFrom  "Datum, sonst nur für Korrektoren"
             & setTooltip MsgSheetSolutionFromTip)
@@ -151,27 +153,25 @@ getSheetListR tid ssh csh = do
   muid <- maybeAuthId
   Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
   let
+    lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
+        E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
+        return . E.max_ $ sheetEdit E.^. SheetEditTime
     sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission)))
     sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
       E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
       E.on $  (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
         E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
-      let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do
-            E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId
-            return . E.max_ $ sheetEdit' E.^. SheetEditTime
       E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
-      return (sheet, sheetEdit, submission)
+      return (sheet, lastSheetEdit sheet, submission)
     sheetCol = widgetColonnade . mconcat $
       [ sortable (Just "name") (i18nCell MsgSheet)
           $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
       , sortable (Just "last-edit") (i18nCell MsgLastEdit)
-          $ \(_, E.Value mEditTime, _) -> case mEditTime of
+          $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
-            Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
-            Nothing -> mempty
       , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
-          $ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget
+          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
-          $ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo   >>= toWidget
+          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
       , sortable Nothing (i18nCell MsgSheetType)
           $ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType
       , sortable Nothing (i18nCell MsgSubmission)
@@ -217,8 +217,7 @@ getSheetListR tid ssh csh = do
         , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
         )
       , ( "last-edit"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
-            return $ sheetEdit E.?. SheetEditTime
         )
       , ( "submission-since"
         , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
@@ -367,6 +366,7 @@ getSheetNewR tid ssh csh = do
           , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
           , sfActiveFrom   = addOneWeek     sheetActiveFrom
           , sfActiveTo     = addOneWeek     sheetActiveTo
+          , sfUploadMode   = sheetUploadMode
           , sfSheetF       = Nothing
           , sfHintFrom     = addOneWeek <$> sheetHintFrom
           , sfHintF        = Nothing
@@ -400,6 +400,7 @@ getSEditR tid ssh csh shn = do
         , sfVisibleFrom  = sheetVisibleFrom
         , sfActiveFrom   = sheetActiveFrom
         , sfActiveTo     = sheetActiveTo
+        , sfUploadMode   = sheetUploadMode
         , sfSheetF       = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
         , sfHintFrom     = sheetHintFrom
         , sfHintF        = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
@@ -428,7 +429,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
         actTime <- liftIO getCurrentTime
         cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
         let newSheet = Sheet
-              { sheetCourse     = cid
+              { sheetCourse       = cid
               , sheetName         = sfName
               , sheetDescription  = sfDescription
               , sheetType         = sfType
@@ -439,10 +440,11 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               , sheetActiveTo     = sfActiveTo
               , sheetHintFrom     = sfHintFrom
               , sheetSolutionFrom = sfSolutionFrom
+              , sheetUploadMode   = sfUploadMode
               }
         mbsid <- dbAction newSheet
         case mbsid of
-          Nothing    -> False <$ addMessageI "danger" (MsgSheetNameDup tid ssh csh sfName)
+          Nothing    -> False <$ addMessageI "error" (MsgSheetNameDup tid ssh csh sfName)
           (Just sid) ->  do -- save files in DB:
             whenIsJust sfSheetF    $ insertSheetFile' sid SheetExercise
             whenIsJust sfHintF     $ insertSheetFile' sid SheetHint
@@ -450,12 +452,16 @@ handleSheetEdit tid ssh csh msId template dbAction = do
             whenIsJust sfMarkingF  $ insertSheetFile' sid SheetMarking
             insert_ $ SheetEdit aid actTime sid
             addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName
+            -- Sanity checks generating warnings only, but not errors!
+            warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
             return True
       when saveOkay $ redirect $ case msId of
         Just _  -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
         Nothing -> CSheetR tid ssh csh sfName SCorrR
-    (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
+    (FormFailure msgs) -> forM_ msgs $ (addMessage "error") . toHtml
-    _ -> return ()
+    _ -> runDB $ warnTermDays tid $ (join . (flip fmap template))
+          <$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]
+
   let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
                         (MsgSheetTitle    tid ssh csh) mbshn
 --   let formTitle = pageTitle -- no longer used in template

src/Handler/Submission.hs

@@ -27,46 +27,50 @@ import Handler.Utils.Table.Cells
 
 import Network.Mime
 
-import Control.Monad.Trans.Maybe
+-- import Control.Monad.Trans.Maybe
-import Control.Monad.State.Class
+-- import Control.Monad.State.Class
-import Control.Monad.Trans.State.Strict (StateT)
+-- import Control.Monad.Trans.State.Strict (StateT)
 
 import Data.Monoid (Any(..))
 import Data.Maybe (fromJust)
-import qualified Data.Maybe
+-- import qualified Data.Maybe
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
+-- import qualified Data.CaseInsensitive as CI
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
 
 import qualified Data.Conduit.List as Conduit
-import Data.Conduit.ResumableSink
+-- import Data.Conduit.ResumableSink
 
-import Data.Set (Set)
+-- import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Bifunctor
+-- import Data.Bifunctor
 
 import System.FilePath
 
-import Colonnade hiding (bool, fromMaybe)
+-- import Colonnade hiding (bool, fromMaybe)
-import qualified Yesod.Colonnade as Yesod
+-- import qualified Yesod.Colonnade as Yesod
-import qualified Text.Blaze.Html5.Attributes as HA
+-- import qualified Text.Blaze.Html5.Attributes as HA
 
 -- DEPRECATED: We always show all edits!
 -- numberOfSubmissionEditDates :: Int64
 -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
 
 
-makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
+makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
-makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
+makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do
+    let
+      fileUpload = case uploadMode of
+        NoUpload -> pure Nothing
+        (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
     flip (renderAForm FormStandard) html $ (,)
-      <$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+      <$> fileUpload
       <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
                                     | g <- [1..(max groupNr $ length buddies)]             -- groupNr might have decreased meanwhile
                                     | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
@@ -113,7 +117,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
   maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
 
   (Entity shid Sheet{..}, buddies, lastEdits)  <- runDB $ do
-    sheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
+    csheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
     case msmid of
       Nothing     -> do
         submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@@ -127,12 +131,12 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
             -- fetch buddies from previous submission in this course
             buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
               E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
-              let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser `E.InnerJoin` submissionEdit) -> do
+              let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do
-                    E.on (submissionEdit E.^. SubmissionEditSubmission   E.==. submission E.^. SubmissionId)
+                    E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
-                    E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
+                    E.on (subUser        E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
                     E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
-                    E.where_ $  submissionUser E.^. SubmissionUserUser E.==. E.val uid
+                    E.where_ $  subUser E.^. SubmissionUserUser E.==. E.val uid
-                          E.&&. sheet          E.^.        SheetCourse E.==. E.val sheetCourse
+                          E.&&. sheet   E.^.        SheetCourse E.==. E.val sheetCourse
                     E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
                     E.limit 1
                     return $ submission E.^. SubmissionId
@@ -140,7 +144,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
                     E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
               E.orderBy  [E.asc $ user E.^. UserEmail]
               return $ user E.^. UserEmail
-            return (sheet, map E.unValue buddies, [])
+            return (csheet, map E.unValue buddies, [])
           (E.Value smid:_) -> do
             cID <- encrypt smid
             addMessageI "info" $ MsgSubmissionAlreadyExists
@@ -172,9 +176,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
                               else E.nothing
               return $ (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
-        return (sheet,buddies,lastEdits)
+        return (csheet,buddies,lastEdits)
-  let unpackZips = True -- undefined -- TODO
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
-  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies
   mCID <- runDB $ do
     res' <- case res of
       (FormMissing )           -> return $ FormMissing
@@ -231,7 +234,14 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
               -> return smid
             (Just files, _)  -- new files
               -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
-            _ -> error "Impossible, because of definition of `makeSubmissionForm`"
+            (Nothing, Nothing) -- new submission, no file upload requested
+              -> insert Submission
+                  { submissionSheet = shid
+                  , submissionRatingPoints = Nothing
+                  , submissionRatingComment = Nothing
+                  , submissionRatingBy = Nothing
+                  , submissionRatingTime = Nothing
+                  }
           -- Determine members of pre-registered group
           groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
             E.on $ submissionGroup E.^. SubmissionGroupId  E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup

src/Handler/Term.hs

@@ -180,9 +180,9 @@ termEditHandler term = do
 
 newTermForm :: Maybe Term -> Form Term
 newTermForm template html = do
-    renderMessage <- getMessageRender
+    mr <- getMessageRender
     (result, widget) <- flip (renderAForm FormStandard) html $ Term
-      <$> areq termNewField (fslpI MsgTerm (renderMessage MsgTermPlaceholder)) (termName  <$> template)
+      <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (termName  <$> template)
       <*> areq dayField  (fsl ("Erster Tag" :: Text)) (termStart <$> template)
       <*> areq dayField  (fsl ("Letzer Tag" :: Text)) (termEnd   <$> template)
       <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined

src/Handler/Utils.hs

@@ -12,6 +12,8 @@ module Handler.Utils
 import Import
 
 import qualified Data.Text as T
+-- import qualified Data.Set (Set)
+import qualified Data.Set as Set
 
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
@@ -34,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
@@ -52,3 +59,17 @@ nameWidget displayName surname
             |]
       [] -> error "Data.Text.splitOn returned empty list in violation of specification."
 
+
+warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
+warnTermDays tid times = do
+  Term{..} <- get404 tid
+  let alldays       = Set.map utctDay $ Set.fromList $ catMaybes times
+      warnholidays  = Set.intersection alldays $ Set.fromList termHolidays
+      outoftermdays = Set.filter (\d -> d < termStart        || d > termEnd       ) alldays
+      outoflecture  = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
+                        `Set.difference` outoftermdays -- out of term implies out of lecture-time
+      warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI "warning" $ msg tid dt
+  forM_ warnholidays  $ warnI MsgDayIsAHoliday
+  forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
+  forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
+

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
 
@@ -219,11 +218,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
       return . fromRational $ round (sci * 100) % 100
 
 
-termActiveField :: Field Handler TermId
+termsActiveField :: Field Handler TermId
-termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
+termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
 
-termActiveOld :: Field Handler TermIdentifier
+termsSetField :: [TermId] -> Field Handler TermId
-termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
+-- termsSetField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName
+termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
+
+-- termActiveOld :: Field Handler TermIdentifier
+-- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
 
 termNewField :: Field Handler TermIdentifier
 termNewField = checkMMap checkTerm termToText textField
@@ -249,6 +252,13 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
 schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
 schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
 
+uploadModeField :: Field Handler UploadMode
+uploadModeField = selectFieldList
+  [ (MsgUploadModeNone    , NoUpload      )
+  , (MsgUploadModeNoUnpack, Upload   False)
+  , (MsgUploadModeUnpack  , Upload   True )
+  ]
+
 zipFileField :: Bool -- ^ Unpack zips?
              -> Field Handler (Source Handler File)
 zipFileField doUnpack = Field{..}

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/Migration.hs

@@ -168,12 +168,18 @@ customMigrations = Map.fromListWith (>>)
     , whenM (tableExists "user") $ do
         userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
         [executeQQ|
-          ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ' ';
+          ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT '';
         |]
         forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
           Just name -> update uid [UserSurname =. name]
           _other    -> error $ "Empty userDisplayName found"
     )
+  , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
+    , whenM (tableExists "sheet") $ do
+        [executeQQ|
+          ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
+        |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -193,6 +193,12 @@ instance DisplayAble DA where
 -}
 
 
+data UploadMode = NoUpload | Upload { unpackZips :: Bool }
+  deriving (Show, Read, Eq, Ord)
+
+deriveJSON defaultOptions ''UploadMode
+derivePersistFieldJSON ''UploadMode
+
 data ExamStatus = Attended | NoShow | Voided
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "ExamStatus"
@@ -280,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
@@ -329,9 +336,9 @@ instance FromJSON TermIdentifier where
   parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
 
 {- Must be defined in a later module:
-termField :: Field (HandlerT UniWorX IO) TermIdentifier
+    termField :: Field (HandlerT UniWorX IO) TermIdentifier
-termField = checkMMap (return . termFromText) termToText textField
+    termField = checkMMap (return . termFromText) termToText textField
-  -- TODO: this is too simple and inconvenient, use selector and year picker
+   See Handler.Utils.Form.termsField and termActiveField
 -}
 
 

src/Utils.hs

@@ -130,7 +130,7 @@ withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >>
 
 
 -- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
-{-# DEPRECATED display "Create RenderMessage Instances instead!" #-}
+{- (not so sure we really want to get rid of display?!) DEPRECATED display "Create RenderMessage Instances instead!" -}
 class DisplayAble a where
   display :: a -> Text
   -- Default definitions for types belonging to Show (allows empty instance declarations)
@@ -300,6 +300,13 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
 whenIsJust (Just x) f = f x
 whenIsJust Nothing  _ = return ()
 
+ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
+ifMaybeM Nothing dft _  = return dft
+ifMaybeM (Just x) _ act = act x
+
+maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
+maybeM dft act mb = mb >>= maybe dft act
+
 maybeT :: Monad m => m a -> MaybeT m a -> m a
 maybeT x m = runMaybeT m >>= maybe x return
 
@@ -323,6 +330,27 @@ instance Ord a => Ord (NTop (Maybe a)) where
 
 
 
+------------
+-- Either --
+------------
+
+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 --
 ---------------

src/Utils/DB.hs

@@ -37,8 +37,11 @@ getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does
 
 existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
   => Unique record -> ReaderT backend m Bool
-existsBy = fmap isJust . getBy
+existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record
 
+existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
+  => Key record -> ReaderT backend m Bool
+existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
 
 myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq  record which is not needed anyway)
     :: (MonadIO m

templates/profile.hamlet

@@ -3,8 +3,9 @@
   <dl .deflist.profile-dl>
       <dt .deflist__dt> _{MsgName}
       <dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
-      <dt .deflist__dt> _{MsgMatrikelNr}
+      $maybe matnr <- userMatrikelnummer
-      <dd .deflist__dd> #{display userMatrikelnummer}
+        <dt .deflist__dt> _{MsgMatrikelNr}
+        <dd .deflist__dd> #{matnr}
       <dt .deflist__dt> _{MsgEMail}
       <dd .deflist__dd> #{display userEmail}
       <dt .deflist__dt> _{MsgIdent}
@@ -15,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>
@@ -48,21 +46,19 @@
               <th .table__th> Studienart
               <th .table__th> Semester
 
-            $forall (degree,field,fieldtype,semester) <- studies
+            $forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies
               <tr.table__row>
-                <td .table__td> #{display degree}
+                <td .table__td>
-                <td .table__td> #{display field}
+                  $maybe name <- E.unValue degree
-                <td .table__td> #{display fieldtype}
+                    #{display name}
-                <td .table__td> #{display semester}
+                  $nothing
-
+                    #{display degreeKey}
-    $if not $ null participant
+                <td .table__td>
-      <dt .deflist__dt> Teilnehmer
+                  $maybe name <- E.unValue field
-      <dd .deflist__dd>
+                    #{display name}
-        <dl .deflist>
+                  $nothing
-          $forall (E.Value tid, E.Value ssh, E.Value csh, E.Value regSince) <- participant
+                    #{display fieldKey}
-            <dt .deflist__dt>
+                <td .table__td>_{E.unValue fieldtype}
-                <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
+                <td .table__td>#{display semester}
-            <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
 

templates/submission.hamlet

@@ -1,12 +1,17 @@
 $maybe cID <- mcid
   <section>
-    <h2>
+    $case sheetUploadMode
-      <a href=@{urlArchive cID}>Archiv
+      $of Upload _
-      (<a href=@{urlOriginal cID}>Original</a>)
+        <h2>
+          <a href=@{urlArchive cID}>Archiv
+          (<a href=@{urlOriginal cID}>Original</a>)
 
-    $maybe fileTable <- mFileTable
+        $maybe fileTable <- mFileTable
-      <h3>_{MsgSubmissionFiles}
+          <h3>_{MsgSubmissionFiles}
-      ^{fileTable}
+          ^{fileTable}
+      $of _
+        <p>
+          _{MsgSubmissionNoUploadExpected}
 
     $if not (null lastEdits)
       <h3>_{MsgLastEdits}