diff --git a/ChangeLog.md b/ChangeLog.md index 923e51045..401601e10 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -9,6 +9,8 @@ Unterstützung von Tabellenzusammenfassungen, z.B. Punktsummen 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 diff --git a/db.hs b/db.hs index 4a2a1bf7c..0fe4b8812 100755 --- a/db.hs +++ b/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 } diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e66535980..dd2b2d0f4 100644 --- a/messages/uniworx/de.msg +++ b/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. -CourseEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} 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. -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. +CourseNewOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt. +CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich geändert. +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 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 -SheetNewHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} 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. -SheetTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} -SheetTitleNew tid@TermId ssh@SchoolId courseShortHand@CourseShorthand : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt -SheetEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren -SheetEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} 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}. -SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen? +SheetList tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Übersicht Übungsblätter +SheetNewHeading tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Neues Übungsblatt anlegen +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 csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} +SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt +SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren +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 csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}. +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 -CorrectionHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Korrektur +SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen +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 diff --git a/models b/models index 341499e8f..91261853e 100644 --- a/models +++ b/models @@ -54,14 +54,14 @@ 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 degree StudyDegreeId terms StudyTermsId UniqueDegreeCourse course degree terms -Course +Course name (CI Text) description Html Maybe linkExternal Text Maybe @@ -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 - 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 5f78d7f56..7f25aa50b 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b12ebe9c0..62a2bf89d 100644 --- a/src/Handler/Course.hs +++ b/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 - courseEditHandler True Nothing + uid <- requireAuthId + 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 tid ssh csh = do - course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh - courseEditHandler True course +getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCEditR = pgCEditR True +postCEditR = pgCEditR False -postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -postCEditR tid ssh csh = do +pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html +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 - -- $logDebug "€€€€€€ courseEditHandler started" + +-- | Course Creation and Editing +-- | 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 cid Course{..}) = do - return $ CourseForm +courseToForm :: Entity Course -> CourseForm +courseToForm (Entity cid Course{..}) = 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) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 701f3ea4e..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,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 - ,studyterms E.^. StudyTermsName - ,studyfeat E.^. StudyFeaturesType - ,studyfeat E.^. StudyFeaturesSemester) + return ( ( studydegree E.^. StudyDegreeName + , studydegree E.^. StudyDegreeKey + ) + , ( 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 {..} - diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index efaacf2e1..6cc6daa2f 100644 --- a/src/Handler/Sheet.hs +++ b/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) - <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) - <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) + <*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template) + <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> 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) - (sfHintFrom <$> template) + & setTooltip MsgSheetHintFromTip) (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 - Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget - Nothing -> mempty + $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime , 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) @@ -204,7 +204,7 @@ getSheetListR tid ssh csh = do in textCell $ textPercent $ realToFrac percent _other -> mempty _other -> mempty - ] + ] psValidator = def & defaultSorting [("submission-since", SortAsc)] (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable @@ -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 - return $ sheetEdit E.?. SheetEditTime + , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet ) , ( "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 - _ -> return () + (FormFailure msgs) -> forM_ msgs $ (addMessage "error") . toHtml + _ -> 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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index a39a5a62e..cd8ce6cd4 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -27,46 +27,50 @@ import Handler.Utils.Table.Cells import Network.Mime -import Control.Monad.Trans.Maybe -import Control.Monad.State.Class -import Control.Monad.Trans.State.Strict (StateT) +-- import Control.Monad.Trans.Maybe +-- import Control.Monad.State.Class +-- 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 qualified Yesod.Colonnade as Yesod -import qualified Text.Blaze.Html5.Attributes as HA +-- import Colonnade hiding (bool, fromMaybe) +-- import qualified Yesod.Colonnade as Yesod +-- 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 msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do +makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail]) +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 - E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId) - E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) + 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 (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.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse + E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid + 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) - let unpackZips = True -- undefined -- TODO - ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies + return (csheet,buddies,lastEdits) + ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode 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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index c14b796eb..4247d8a71 100644 --- a/src/Handler/Term.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 8e51adff9..1c02d4235 100644 --- a/src/Handler/Utils.hs +++ b/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|^{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 + diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index e1fab772b..ed570c134 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 @@ -219,11 +218,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} return . fromRational $ round (sci * 100) % 100 -termActiveField :: Field Handler TermId -termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName +termsActiveField :: Field Handler TermId +termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName -termActiveOld :: Field Handler TermIdentifier -termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName +termsSetField :: [TermId] -> Field Handler TermId +-- 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{..} 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/Migration.hs b/src/Model/Migration.hs index 723ccd964..5b45329f9 100644 --- a/src/Model/Migration.hs +++ b/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 }'; + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 386d828e7..7a37a93b7 100644 --- a/src/Model/Types.hs +++ b/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 = checkMMap (return . termFromText) termToText textField - -- TODO: this is too simple and inconvenient, use selector and year picker + termField :: Field (HandlerT UniWorX IO) TermIdentifier + termField = checkMMap (return . termFromText) termToText textField + See Handler.Utils.Form.termsField and termActiveField -} diff --git a/src/Utils.hs b/src/Utils.hs index c15a0c29a..50a95d4b1 100644 --- a/src/Utils.hs +++ b/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 -- --------------- diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index ce23adae7..380bb8b2a 100644 --- a/src/Utils/DB.hs +++ b/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 diff --git a/templates/profile.hamlet b/templates/profile.hamlet index f5bfae509..de4a91cc5 100644 --- a/templates/profile.hamlet +++ b/templates/profile.hamlet @@ -3,8 +3,9 @@
_{MsgName}
^{nameWidget userDisplayName userSurname} -
_{MsgMatrikelNr} -
#{display userMatrikelnummer} + $maybe matnr <- userMatrikelnummer +
_{MsgMatrikelNr} +
#{matnr}
_{MsgEMail}
#{display userEmail}
_{MsgIdent} @@ -15,21 +16,18 @@
Administrator