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/config/settings.yml b/config/settings.yml index 72965a276..75d5af052 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -13,9 +13,12 @@ detailed-logging: "_env:DETAILED_LOGGING:false" should-log-all: "_env:LOG_ALL:false" minimum-log-level: "_env:LOGLEVEL:warn" auth-dummy-login: "_env:DUMMY_LOGIN:false" -auth-pwfile: "_env:PWFILE:" allow-deprecated: "_env:ALLOW_DEPRECATED:false" +auth-pw-hash: + algorithm: "pbkdf2" + strength: 14 + # Optional values with the following production defaults. # In development, they default to true. # reload-templates: false @@ -42,7 +45,7 @@ ldap: timeout: "_env:LDAPTIMEOUT:5" user-defaults: - favourites: 12 + max-favourites: 12 theme: Default date-time-format: "%a %d %b %Y %R" date-format: "%d.%m.%Y" diff --git a/db.hs b/db.hs index 4a2a1bf7c..3bb77bcf5 100755 --- a/db.hs +++ b/db.hs @@ -66,8 +66,8 @@ fillDb = do winter2017 = TermIdentifier 2017 Winter summer2018 = TermIdentifier 2018 Summer gkleen <- insert User - { userPlugin = "LDAP" - , userIdent = "G.Kleen@campus.lmu.de" + { userIdent = "G.Kleen@campus.lmu.de" + , userAuthentication = AuthLDAP , userMatrikelnummer = Nothing , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" @@ -80,8 +80,8 @@ fillDb = do , userDownloadFiles = userDefaultDownloadFiles } fhamann <- insert User - { userPlugin = "LDAP" - , userIdent = "felix.hamann@campus.lmu.de" + { userIdent = "felix.hamann@campus.lmu.de" + , userAuthentication = AuthLDAP , userMatrikelnummer = Nothing , userEmail = "felix.hamann@campus.lmu.de" , userDisplayName = "Felix Hamann" @@ -94,8 +94,8 @@ fillDb = do , userDownloadFiles = userDefaultDownloadFiles } jost <- insert User - { userPlugin = "LDAP" - , userIdent = "jost@tcs.ifi.lmu.de" + { userIdent = "jost@tcs.ifi.lmu.de" + , userAuthentication = AuthLDAP , userMatrikelnummer = Nothing , userEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" @@ -108,8 +108,8 @@ fillDb = do , userDownloadFiles = userDefaultDownloadFiles } void . insert $ User - { userPlugin = "LDAP" - , userIdent = "max@campus.lmu.de" + { userIdent = "max@campus.lmu.de" + , userAuthentication = AuthLDAP , userMatrikelnummer = Nothing , userEmail = "max@campus.lmu.de" , userDisplayName = "Max Musterstudent" @@ -122,8 +122,8 @@ fillDb = do , userDownloadFiles = userDefaultDownloadFiles } void . insert $ User - { userPlugin = "LDAP" - , userIdent = "tester@campus.lmu.de" + { userIdent = "tester@campus.lmu.de" + , userAuthentication = AuthLDAP , userMatrikelnummer = Just "999" , userEmail = "tester@campus.lmu.de" , userDisplayName = "Tina Tester" @@ -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/dummy/de.msg b/messages/dummy/de.msg new file mode 100644 index 000000000..f3ca7cae1 --- /dev/null +++ b/messages/dummy/de.msg @@ -0,0 +1 @@ +DummyIdent: Nutzer-Kennung \ No newline at end of file diff --git a/messages/pw-hash/de.msg b/messages/pw-hash/de.msg new file mode 100644 index 000000000..9fb1eb5e4 --- /dev/null +++ b/messages/pw-hash/de.msg @@ -0,0 +1,2 @@ +PWHashIdent: Identifikation +PWHashPassword: Passwort \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e66535980..1bd1ddd42 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -5,6 +5,7 @@ BtnRegister: Anmelden BtnDeregister: Abmelden BtnHijack: Sitzung übernehmen +Aborted: Abgebrochen Registered: Angemeldet RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis @@ -41,10 +42,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 +53,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 +72,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 +122,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 +169,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 +190,7 @@ Users: Benutzer HomeHeading: Aktuelle Termine LoginHeading: Authentifizierung LoginTitle: Authentifizierung -ProfileHeading: Benutzerprofil und Einstellungen +ProfileHeading: Benutzereinstellungen ProfileDataHeading: Gespeicherte Benutzerdaten ImpressumHeading: Impressum @@ -196,7 +202,7 @@ MatrikelNr: Matrikelnummer Theme: Oberflächen Design Favoriten: Anzahl gespeicherter Favoriten Plugin: Plugin -Ident: Identifizierung +Ident: Identifikation Settings: Individuelle Benutzereinstellungen SettingsUpdate: Einstellungen wurden gespeichert. @@ -218,11 +224,14 @@ NoCorrector: Kein Korrektor RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt. UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt. CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden: +SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt! + CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert: NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden. RatingBy: Korrigiert von +AssignedTime: Zuteilung AchievedBonusPoints: Erreichte Bonuspunkte AchievedNormalPoints: Erreichte Punkte AchievedPassPoints: Erreichte Punkte @@ -280,8 +289,23 @@ SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert: SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}. LDAPLoginTitle: Campus-Login +PWHashLoginTitle: Uni2Work-Login +PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2Work-Team spezielle Logindaten erhalten haben. Normale Nutzer melden sich bitte via Campus-Login an! 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..594b69fad 100644 --- a/models +++ b/models @@ -1,6 +1,6 @@ User json - plugin Text - ident Text + ident (CI Text) + authentication AuthenticationMode matrikelnummer Text Maybe email (CI Text) displayName Text @@ -11,7 +11,7 @@ User json dateFormat DateTimeFormat "default='%d.%m.%Y'" timeFormat DateTimeFormat "default='%R'" downloadFiles Bool default=false - UniqueAuthentication plugin ident + UniqueAuthentication ident UniqueEmail email deriving Show UserAdmin @@ -41,7 +41,7 @@ StudyTerms Primary key Term json name TermIdentifier -- unTermKey :: TermId -> TermIdentifier - start Day -- TermKey :: TermIdentifier -< TermId + start Day -- TermKey :: TermIdentifier -> TermId end Day holidays [Day] lectureStart Day @@ -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,11 @@ 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 + ratingAssigned UTCTime Maybe -- time assigned corrector + ratingTime UTCTime Maybe -- "Just" here indicates done! deriving Show SubmissionEdit user UserId diff --git a/routes b/routes index 014a25e28..6116665dc 100644 --- a/routes +++ b/routes @@ -39,7 +39,7 @@ /info VersionR GET !free /profile ProfileR GET POST !free !free -/profile/data ProfileDataR GET !free !free +/profile/data ProfileDataR GET POST !free !free /term TermShowR GET !free /term/current TermCurrentR GET !free @@ -55,10 +55,15 @@ -- For Pattern Synonyms see Foundation /course/ CourseListR GET !free !/course/new CourseNewR GET POST !lecturer +!/course/new/#{Maybe TermId}/#{Maybe SchoolId}/#{Maybe CourseShorthand} CourseNewTemplateR GET !lecturer /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !free /register CRegisterR POST !timeANDcapacity /edit CEditR GET POST + /delete CDeleteR GET POST !lecturerANDempty + /users CUsersR GET + /user/#CryptoUUIDUser CUserR GET + /correctors CHiWisR GET /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials !/ex/new SheetNewR GET POST @@ -77,10 +82,6 @@ /correctors SCorrR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector --- /user/#CryptoUUIDUser --- /users --- /correctors - /corrections CorrectionsR GET POST !corrector !lecturer /corrections/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index c5b69f55f..9c4cb5a54 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -206,13 +206,10 @@ handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a db = handler . runDB -addPWEntry :: FilePath {-^ Password file -} - -> User +addPWEntry :: User -> Text {-^ Password -} -> IO () -addPWEntry pwFile User{..} (Text.encodeUtf8 -> pw) = do - (Text.decodeUtf8 -> pwHash) <- makePassword pw 14 - let pwEntry = PWEntry{ pwUser = User{ userPlugin = "PWFile", .. }, .. } - newUser = userIdent - c <- either (const []) id <$> Yaml.decodeFileEither pwFile - Yaml.encodeFile pwFile $ pwEntry : [ c' | c'@(PWEntry{pwUser=User{..}}) <- c, userIdent /= newUser ] +addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do + PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings + (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength + void $ insert User{..} diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs new file mode 100644 index 000000000..809db8647 --- /dev/null +++ b/src/Auth/Dummy.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , TemplateHaskell + , FlexibleContexts + , TypeFamilies + , OverloadedStrings + #-} + +module Auth.Dummy + ( dummyLogin + , DummyMessage(..) + ) where + +import Import.NoFoundation +import Database.Persist.Sql (SqlBackendCanRead) + +import Utils.Form + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + + +data DummyMessage = MsgDummyIdent + + +dummyForm :: ( RenderMessage site FormMessage + , RenderMessage site DummyMessage + , YesodPersist site + , SqlBackendCanRead (YesodPersistBackend site) + , Button site SubmitButton + , Show (ButtonCssClass site) + ) => AForm (HandlerT site IO) (CI Text) +dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing + <* submitButton + where + userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent] + toOption (Entity _ User{..}) = Option (CI.original userIdent) userIdent (CI.original userIdent) + +dummyLogin :: ( YesodAuth site + , YesodPersist site + , SqlBackendCanRead (YesodPersistBackend site) + , RenderMessage site FormMessage + , RenderMessage site DummyMessage + , Button site SubmitButton + , Show (ButtonCssClass site) + ) => AuthPlugin site +dummyLogin = AuthPlugin{..} + where + apName = "dummy" + -- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent + apDispatch "POST" [] = do + ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm + case loginRes of + FormFailure errs -> do + lift . forM_ errs $ addMessage Error . toHtml + redirect LoginR + FormMissing -> redirect LoginR + FormSuccess ident -> + lift . setCredsRedirect $ Creds "dummy" (CI.original ident) [] + apDispatch _ _ = notFound + apLogin toMaster = do + (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm + $(widgetFile "widgets/dummy-login-form") diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index ec0493e8f..32c185519 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards , OverloadedStrings , TemplateHaskell + , ViewPatterns , TypeFamilies , FlexibleContexts , FlexibleInstances @@ -20,6 +21,9 @@ import Import.NoFoundation import Control.Lens import Network.Connection +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + import qualified Control.Monad.Catch as Exc import Utils.Form @@ -31,7 +35,10 @@ import qualified Data.Text.Encoding as Text import qualified Yesod.Auth.Message as Msg -data CampusLogin = CampusLogin { campusIdent, campusPassword :: Text } +data CampusLogin = CampusLogin + { campusIdent :: CI Text + , campusPassword :: Text + } data CampusMessage = MsgCampusIdentNote | MsgCampusIdent @@ -60,7 +67,7 @@ campusForm :: ( RenderMessage site FormMessage , Show (ButtonCssClass site) ) => AForm (HandlerT site IO) CampusLogin campusForm = CampusLogin - <$> areq textField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing + <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing <*> areq passwordField (fslI MsgCampusPassword) Nothing <* submitButton @@ -79,10 +86,10 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..} ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm case loginRes of FormFailure errs -> do - forM_ errs $ addMessage "error" . toHtml + forM_ errs $ addMessage Error . toHtml redirect LoginR FormMissing -> redirect LoginR - FormSuccess CampusLogin{..} -> do + FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) Ldap.bind ldap ldapDn ldapPassword diff --git a/src/Auth/PWFile.hs b/src/Auth/PWFile.hs deleted file mode 100644 index 541be7718..000000000 --- a/src/Auth/PWFile.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude - , QuasiQuotes - , TemplateHaskell - , ViewPatterns - , RecordWildCards - , OverloadedStrings - , FlexibleContexts - , TypeFamilies - #-} - -module Auth.PWFile - ( maintenanceLogin - ) where - -import Import.NoFoundation -import Database.Persist.Sql (IsSqlBackend) - -import qualified Data.Yaml as Yaml - -import qualified Data.Text.Encoding as Text - -import Yesod.Auth.Util.PasswordStore (verifyPassword) - - -maintenanceLogin :: ( YesodAuth site - , YesodPersist site - , IsSqlBackend (YesodPersistBackend site) - , PersistUniqueWrite (YesodPersistBackend site) - ) => FilePath -> AuthPlugin site -maintenanceLogin fp = AuthPlugin{..} - where - apName = "PWFile" - apLogin = mempty - apDispatch "GET" [] = do - authData <- lookupBasicAuth - pwdata <- liftIO $ Yaml.decodeFileEither fp - - addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|] - - case pwdata of - Left err -> $logDebugS "Auth" $ tshow err - Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries" - - case (authData, pwdata) of - (Nothing, _) -> do - notAuthenticated - (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata') - | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ] - <- [ pwe | pwe@PWEntry{..} <- pwdata' - , let User{..} = pwUser - , userIdent == usr - , userPlugin == apName - ] - , verifyPassword pw pwHash - -> lift $ do - runDB . void $ insertUnique pwUser - setCredsRedirect $ Creds apName userIdent [] - _ -> permissionDenied "Invalid auth" - apDispatch _ _ = notFound - diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs new file mode 100644 index 000000000..ba7198710 --- /dev/null +++ b/src/Auth/PWHash.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE NoImplicitPrelude + , QuasiQuotes + , TemplateHaskell + , ViewPatterns + , RecordWildCards + , OverloadedStrings + , FlexibleContexts + , TypeFamilies + #-} + +module Auth.PWHash + ( hashLogin + , PWHashMessage(..) + ) where + +import Import.NoFoundation +import Database.Persist.Sql (SqlBackendCanRead) + +import Utils.Form + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import Yesod.Auth.Util.PasswordStore (verifyPasswordWith) + +import qualified Yesod.Auth.Message as Msg + + +data HashLogin = HashLogin + { hashIdent :: CI Text + , hashPassword :: Text + } + +data PWHashMessage = MsgPWHashIdent + | MsgPWHashPassword + + +hashForm :: ( RenderMessage site FormMessage + , RenderMessage site PWHashMessage + , Button site SubmitButton + , Show (ButtonCssClass site) + ) => AForm (HandlerT site IO) HashLogin +hashForm = HashLogin + <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing + <*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing + <* submitButton + + +hashLogin :: ( YesodAuth site + , YesodPersist site + , SqlBackendCanRead (YesodPersistBackend site) + , RenderMessage site FormMessage + , RenderMessage site PWHashMessage + , Button site SubmitButton + , Show (ButtonCssClass site) + ) => PWHashAlgorithm -> AuthPlugin site +hashLogin pwHashAlgo = AuthPlugin{..} + where + apName = "PWHash" + apDispatch "POST" [] = do + ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm + case loginRes of + FormFailure errs -> do + forM_ errs $ addMessage Error . toHtml + redirect LoginR + FormMissing -> redirect LoginR + FormSuccess HashLogin{..} -> do + user <- lift . runDB . getBy $ UniqueAuthentication hashIdent + case user of + Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent }) + | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic. + lift . setCredsRedirect $ Creds apName userIdent [] + other -> do + $logDebugS "PWHash" $ tshow other + loginErrorMessageI LoginR Msg.InvalidLogin + -- apDispatch "GET" [] = do + -- authData <- lookupBasicAuth + -- pwdata <- liftIO $ Yaml.decodeFileEither fp + + -- addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|] + + -- case pwdata of + -- Left err -> $logDebugS "Auth" $ tshow err + -- Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries" + + -- case (authData, pwdata) of + -- (Nothing, _) -> do + -- notAuthenticated + -- (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata') + -- | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ] + -- <- [ pwe | pwe@PWEntry{..} <- pwdata' + -- , let User{..} = pwUser + -- , userIdent == usr + -- , userPlugin == apName + -- ] + -- , verifyPassword pw pwHash + -- -> lift $ do + -- runDB . void $ insertUnique pwUser + -- setCredsRedirect $ Creds apName userIdent [] + -- _ -> permissionDenied "Invalid auth" + apDispatch _ _ = notFound + apLogin toMaster = do + (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm + $(widgetFile "widgets/hash-login-form") + diff --git a/src/Foundation.hs b/src/Foundation.hs index 5f78d7f56..105c859ab 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -24,7 +24,8 @@ import Text.Jasmine (minifym) import Yesod.Auth.Message import Yesod.Auth.Dummy import Auth.LDAP -import Auth.PWFile +import Auth.PWHash +import Auth.Dummy import qualified Network.Wai as W (requestMethod, pathInfo) @@ -81,7 +82,7 @@ import Utils import Utils.Form import Utils.Lens -import Data.Aeson +import Data.Aeson hiding (Error) import Data.Aeson.TH import qualified Data.Yaml as Yaml @@ -166,6 +167,8 @@ data MenuTypes -- Semantische Rolle: -- Messages mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" +mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de" +mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. @@ -178,6 +181,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) @@ -302,7 +311,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req [("free", trueAP) ,("deprecated", APHandler $ \r _ -> do $logWarnS "AccessControl" ("deprecated route: " <> tshow r) - addMessageI "error" MsgDeprecatedRoute + addMessageI Error MsgDeprecatedRoute allow <- appAllowDeprecated . appSettings <$> getYesod return $ bool (Unauthorized "Deprecated Route") Authorized allow ) @@ -677,7 +686,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 +746,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 @@ -844,12 +853,6 @@ pageActions (CourseListR) = ] pageActions (CourseR tid ssh csh CShowR) = [ PageActionPrime $ MenuItem - { menuItemLabel = "Kurs Editieren" - , menuItemIcon = Nothing - , menuItemRoute = CourseR tid ssh csh CEditR - , menuItemAccessCallback' = return True - } - , PageActionPrime $ MenuItem { menuItemLabel = "Übungsblätter" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetListR @@ -871,12 +874,24 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemRoute = CourseR tid ssh csh CCorrectionsR , menuItemAccessCallback' = return True } - , PageActionSecondary $ MenuItem + , PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetNewR , menuItemAccessCallback' = return True } + , PageActionSecondary $ MenuItem + { menuItemLabel = "Kurs editieren" + , menuItemIcon = Nothing + , menuItemRoute = CourseR tid ssh csh CEditR + , menuItemAccessCallback' = return True + } + , PageActionSecondary $ MenuItem + { menuItemLabel = "Neuen Kurs klonen" + , menuItemIcon = Nothing + , menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh) + , menuItemAccessCallback' = return True + } ] pageActions (CourseR tid ssh csh SheetListR) = [ PageActionPrime $ MenuItem @@ -1133,20 +1148,16 @@ instance YesodAuth UniWorX where authenticate Creds{..} = runDB $ do let - (userPlugin, userIdent) - | isDummy - , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent - = (dummyPlugin, dummyIdent) - | otherwise - = (credsPlugin, credsIdent) + userIdent = CI.mk credsIdent + uAuth = UniqueAuthentication userIdent + isDummy = credsPlugin == "dummy" - isPWFile = credsPlugin == "PWFile" - uAuth = UniqueAuthentication userPlugin userIdent + isPWHash = credsPlugin == "PWHash" excHandlers - | isDummy || isPWFile + | isDummy || isPWHash = [ C.Handler $ \err -> do - addMessage "error" (toHtml $ tshow (err :: CampusUserException)) + addMessage Error (toHtml $ tshow (err :: CampusUserException)) $logErrorS "LDAP" $ tshow err acceptExisting ] @@ -1170,7 +1181,7 @@ instance YesodAuth UniWorX where flip catches excHandlers $ case appLdapConf of Just ldapConf -> fmap (either id id) . runExceptT $ do - ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra + ldapData <- campusUser ldapConf $ Creds credsPlugin (CI.original userIdent) credsExtra $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData let @@ -1178,6 +1189,10 @@ instance YesodAuth UniWorX where userEmail' = lookup (Attr "mail") ldapData userDisplayName' = lookup (Attr "displayName") ldapData userSurname' = lookup (Attr "sn") ldapData + + userAuthentication + | isPWHash = error "PWHash should only work for users that are already known" + | otherwise = AuthLDAP userEmail <- if | Just [bs] <- userEmail' @@ -1250,8 +1265,8 @@ instance YesodAuth UniWorX where authPlugins (appSettings -> AppSettings{..}) = catMaybes [ campusLogin <$> appLdapConf - , maintenanceLogin <$> appAuthPWFile - , authDummy <$ guard appAuthDummyLogin + , Just . hashLogin $ pwHashAlgorithm appAuthPWHash + , dummyLogin <$ guard appAuthDummyLogin ] authHttpManager = getHttpManager diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index d0682f855..156961629 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -53,9 +53,9 @@ postAdminTestR :: Handler Html postAdminTestR = do ((btnResult,_), _) <- runFormPost $ buttonForm case btnResult of - (FormSuccess CreateInf) -> setMessage "Informatik-Knopf gedrückt" - (FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt" - _other -> return () + (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" + (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" + _other -> addMessage Warning "KEIN Knopf erkannt" getAdminTestR @@ -66,6 +66,6 @@ getAdminUserR uuid = do defaultLayout $ [whamlet|

TODO -

Admin Page for User #{display userDisplayName} +

Admin Page for User ^{nameWidget userDisplayName userSurname} |] diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index d4692c59d..94aab5738 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -123,8 +123,13 @@ colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) -colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let - cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName) +colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let + csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 + link cid = CourseR tid ssh csh $ CUserR cid + cell = listCell (Map.toList users) $ \(userId, User{..}) -> do + anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname) in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) @@ -143,6 +148,16 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=( return $ CSubmissionR tid ssh csh sheetName cid CorrectionR in anchorCellM mkRoute $(widgetFile "widgets/rating") +colAssigned :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> + maybe mempty timeCell submissionRatingAssigned + +colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> + maybe mempty timeCell submissionRatingTime + + + type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) @@ -243,7 +258,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler case actionRes of - FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs + FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs FormMissing -> return () FormSuccess (CorrDownloadData, subs) -> do ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable @@ -251,26 +266,38 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = sendResponse =<< submissionMultiArchive ids FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do subs <- mapM decrypt $ Set.toList subs' + now <- liftIO getCurrentTime runDB $ do alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] when (not $ null alreadyAssigned) $ do mr <- (toHtml . ) <$> getMessageRender alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) - addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) + addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) when (not $ null unassigned) $ do - num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid] - addMessageI "success" $ MsgUpdatedAssignedCorrectorSingle num + num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] + [ SubmissionRatingBy =. Just uid + , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned + ] + addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num + (E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do + E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission + E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs + E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser) + return (E.countRows :: E.SqlExpr (E.Value Int64)) + when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors redirect currentRoute FormSuccess (CorrSetCorrectorData Nothing, subs') -> do subs <- mapM decrypt $ Set.toList subs' runDB $ do - num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing - , SubmissionRatingComment =. Nothing - , SubmissionRatingBy =. Nothing - , SubmissionRatingTime =. Nothing - ] - addMessageI "success" $ MsgRemovedCorrections num + num <- updateWhereCount [SubmissionId <-. subs] + [ SubmissionRatingPoints =. Nothing + , SubmissionRatingComment =. Nothing + , SubmissionRatingBy =. Nothing + , SubmissionRatingAssigned =. Nothing + , SubmissionRatingTime =. Nothing + ] + addMessageI Success $ MsgRemovedCorrections num redirect currentRoute FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do subs <- mapM decrypt $ Set.toList subs' @@ -279,16 +306,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = when (not $ null alreadyAssigned) $ do mr <- (toHtml . ) <$> getMessageRender alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) - addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) + addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) when (not $ null unassigned) $ do (assigned, unassigned) <- assignSubmissions shid (Just unassigned) when (not $ null assigned) $ - addMessageI "success" $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) + addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) when (not $ null unassigned) $ do mr <- (toHtml . ) <$> getMessageRender unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) - addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) + addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) redirect currentRoute fmap toTypedContent . defaultLayout $ do @@ -341,7 +368,9 @@ postCorrectionsR = do , colCourse , colSheet , colSubmissionLink + , colAssigned , colRating + , colRated ] -- Continue here psValidator = def & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information @@ -355,15 +384,17 @@ getCCorrectionsR = postCCorrectionsR postCCorrectionsR tid ssh csh = do Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh let whereClause = courseIs cid - colonnade = mconcat + colonnade = mconcat -- should match getSSubsR for consistent UX [ colSelect , dbRow , colSheet - , colCorrector , colSMatrikel , colSubmittors , colSubmissionLink , colRating + , colRated + , colCorrector + , colAssigned ] -- Continue here psValidator = def correctionsR whereClause colonnade psValidator $ Map.fromList @@ -376,13 +407,16 @@ getSSubsR = postSSubsR postSSubsR tid ssh csh shn = do shid <- runDB $ fetchSheetId tid ssh csh shn let whereClause = sheetIs shid - colonnade = mconcat + colonnade = mconcat -- should match getCCorrectionsR for consistent UX [ colSelect , dbRow - , colCorrector + , colSMatrikel , colSubmittors , colSubmissionLink , colRating + , colRated + , colCorrector + , colAssigned ] psValidator = def correctionsR whereClause colonnade psValidator $ Map.fromList @@ -427,7 +461,7 @@ postCorrectionR tid ssh csh shn cid = do case corrResult of FormMissing -> return () - FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs + FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess (ratingPoints, ratingComment) -> do runDB $ do uid <- liftHandlerT requireAuthId @@ -436,23 +470,25 @@ postCorrectionR tid ssh csh shn cid = do let rated = isJust $ void ratingPoints <|> void ratingComment update sub [ SubmissionRatingBy =. (uid <$ guard rated) +-- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload +-- , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes? , SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingPoints =. ratingPoints , SubmissionRatingComment =. ratingComment ] - addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated + addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR case uploadResult of FormMissing -> return () - FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs + FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess fileSource -> do uid <- requireAuthId runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True - addMessageI "success" MsgRatingFilesUpdated + addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR defaultLayout $ do @@ -482,16 +518,16 @@ postCorrectionsUploadR = do case uploadRes of FormMissing -> return () - FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs + FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess files -> do uid <- requireAuthId subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True if - | null subs -> addMessageI "warning" MsgNoCorrectionsUploaded + | null subs -> addMessageI Warning MsgNoCorrectionsUploaded | otherwise -> do subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission] mr <- (toHtml .) <$> getMessageRender - addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) + addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) defaultLayout $ do diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b12ebe9c0..154c75d10 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 @@ -57,7 +59,7 @@ colDescription = sortable Nothing (i18nCell MsgCourseDescription) $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> case courseDescription of Nothing -> mempty - (Just descr) -> cell $ modalStatic descr + (Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr) colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) @@ -71,7 +73,11 @@ colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) ( case courseDescription of Nothing -> mempty (Just descr) -> cell - [whamlet| ^{modalStatic descr} |] + [whamlet| + $newline never + + ^{modal "Beschreibung" (Right $ toWidget descr)} + |] ) colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) @@ -302,50 +308,113 @@ postCRegisterR tid ssh csh = do (FormSuccess codeOk) | registered -> do runDB $ deleteBy $ UniqueParticipant aid cid - addMessageI "info" MsgCourseDeregisterOk + addMessageI Info MsgCourseDeregisterOk | codeOk -> do actTime <- liftIO $ getCurrentTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime - when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk - | otherwise -> addMessageI "danger" MsgCourseSecretWrong + when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk + | otherwise -> addMessageI Warning MsgCourseSecretWrong (_other) -> return () -- TODO check this! redirect $ CourseR tid ssh csh CShowR -getCourseNewR :: Handler Html +getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do - -- TODO: Defaults für Semester hier ermitteln und übergeben - courseEditHandler True Nothing + uid <- requireAuthId + params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button + <$> iopt termNewField "tid" + <*> iopt ciField "ssh" + <*> iopt ciField "csh" + let noTemplateAction = courseEditHandler True Nothing + case params of + FormMissing -> noTemplateAction + FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) + >> noTemplateAction + FormSuccess (mbTid,mbSsh,mbCsh) -> + getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh + +getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html +getCourseNewTemplateR mbTid mbSsh mbCsh = do + uid <- requireAuthId + oldCourses <- runDB $ do + E.select $ E.from $ \course -> do + whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid + whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh + whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh + let lecturersCourse = + E.exists $ E.from $ \lecturer -> do + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId + let lecturersSchool = + E.exists $ E.from $ \user -> do + E.where_ $ user E.^. UserLecturerUser E.==. E.val uid + E.&&. user 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_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer + , 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 + <*> ifMaybeM mbCsh True (\csh -> (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 $ fromJust mbCsh + 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 +getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCEditR = pgCEditR True +postCEditR = pgCEditR False + +pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html +pgCEditR isGetReq tid ssh csh = do course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh - courseEditHandler True course - -postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -postCEditR 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 -courseDeleteHandler = undefined +getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCDeleteR = error "TODO: implement getCDeleteR" +postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +postCDeleteR = error "TODO: implement getCDeleteR" {- TODO | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler , Just cid <- cfCourseId res -> do runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! let cti = toPathPiece $ cfTerm res - addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|] + addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|] 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 @@ -373,10 +442,10 @@ courseEditHandler isGet course = do runDB $ do insert_ $ CourseEdit aid now cid insert_ $ Lecturer aid cid - addMessageI "info" $ MsgCourseNewOk tid ssh csh + addMessageI Info $ MsgCourseNewOk tid ssh csh redirect $ TermCourseListR tid Nothing -> - addMessageI "danger" $ MsgCourseNewDupShort tid ssh csh + addMessageI Warning $ MsgCourseNewDupShort tid ssh csh (FormSuccess res@( CourseForm { cfCourseId = Just cid @@ -389,14 +458,14 @@ courseEditHandler isGet course = do success <- runDB $ do old <- get cid case old of - Nothing -> addMessageI "error" MsgInvalidInput $> False + Nothing -> addMessageI Error MsgInvalidInput $> False (Just oldCourse) -> do updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have Course { courseName = cfName res , 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 @@ -407,14 +476,14 @@ courseEditHandler isGet course = do } ) case updOkay of - (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid ssh csh) $> False + (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False Nothing -> do insert_ $ CourseEdit aid now cid - addMessageI "success" $ MsgCourseEditOk tid ssh csh + addMessageI Success $ MsgCourseEditOk tid ssh csh return True when success $ redirect $ CourseR tid ssh csh CShowR - (FormFailure _) -> addMessageI "warning" MsgInvalidInput + (FormFailure _) -> addMessageI Warning MsgInvalidInput (FormMissing) -> return () actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute defaultLayout $ do @@ -438,9 +507,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,19 +530,30 @@ 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] [] ] + + termsField <- liftHandlerT $ case template of + -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin + (Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course + _courseOld@Course{..} <- runDB $ get404 cid + mayEditTerm <- isAuthorized TermEditR True + mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True + return $ if + | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField + | otherwise -> termsSetField [cfTerm cform] + _allOtherCases -> return termsAllowedField (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (cfCourseId =<< template) - <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) + <*> areq ciField (fslI MsgCourseName) (cfName <$> template) <*> aopt htmlField (fslI MsgCourseDescription & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) <*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template) - <*> areq (ciField textField) (fslI MsgCourseShorthand + <*> areq ciField (fslI MsgCourseShorthand -- & 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) @@ -523,3 +602,22 @@ validateCourse (CourseForm{..}) = -- ) -- , ] ] + + + +getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCUsersR tid ssh csh = undefined -- TODO + + +getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html +getCUserR tid ssh csh uuid = do + uid <- decrypt uuid + User{..} <- runDB $ get404 uid + defaultLayout $ + [whamlet| +

TODO +

Lecturer's Page for User ^{nameWidget userDisplayName userSurname} + |] + +getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCHiWisR tid ssh csh = undefined -- TODO diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 2826e2c81..73aa370d2 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -107,7 +107,7 @@ homeAnonymous = do , dbtIdent = "upcomingdeadlines" :: Text } let features = $(widgetFile "featureList") - addMessage "danger" "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" + addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" defaultLayout $ do $(widgetFile "dsgvDisclaimer") $(widgetFile "home") @@ -207,7 +207,7 @@ homeUser uid = do , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtIdent = "upcomingdeadlines" :: Text } - addMessage "danger" "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." + addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." defaultLayout $ do -- setTitle "Willkommen zum Uni2work Test!" $(widgetFile "homeUser") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 701f3ea4e..874971fec 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -87,14 +87,14 @@ getProfileR = do , OffsetBy $ stgMaxFavourties ] mapM_ delete oldFavs - addMessageI "info" $ MsgSettingsUpdate + addMessageI Info $ MsgSettingsUpdate redirect ProfileR -- TODO: them change does not happen without redirect - (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml + (FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml _ -> 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 @@ -148,27 +140,78 @@ postProfileR = do -- TODO getProfileR +postProfileDataR :: Handler Html +postProfileDataR = do + ((btnResult,_), _) <- runFormPost $ buttonForm + case btnResult of + (FormSuccess BtnDelete) -> do + (uid, User{..}) <- requireAuthPair + addMessage Warning "Delete-Knopf gedrückt" + addMessage Error "Löschen der Daten wurde noch nicht implementiert." + -- first determine all submission that solely depend on this user: + -- SubmissionGroup / SubmissionGroupUser + -- Submission / SubmissionUser + -- runDB $ deleteCascade uid + (FormSuccess BtnAbort ) -> do + addMessageI Info MsgAborted + redirect ProfileDataR + _other -> return () + getProfileDataR + getProfileDataR :: Handler Html getProfileDataR = do (uid, User{..}) <- requireAuthPair -- mr <- getMessageRender - -- Tabelle mit eigenen Kursen (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- 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.|] + -- Delete Button + (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete) + -- TODO: move this into a Message and/or Widget-File + let delWdgt = [whamlet| +
+

+ Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen? +
+ Während der Testphase von Uni2work können Sie hiermit + Ihren Account bei Uni2work vollständig löschen. + Mit Ihrem Campus-Account können Sie sich aber danach + jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird. +
+ Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht, + wenn die Dateien ausschließlich Ihnen zugeordnet sind. + Dateien aus Gruppenabgaben werden also erst dann gelöscht, + wenn alle Gruppenmitglieder Ihren Account gelöscht haben. +
+ Achtung: + Auch abgegebene Hausübungen werden gelöscht! + Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat, + kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen. + (Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen + Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann + auch nicht mehr rekonstruiert/berücksichtigt werden.) +
+ Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas + eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation + aufbewahrt werden müssen. +
+ ^{btnWdgt} + |] defaultLayout $ do $(widgetFile "profileData") $(widgetFile "dsgvDisclaimer") @@ -417,7 +460,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 +469,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 +488,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 +508,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 +530,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..510e92117 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 @@ -30,7 +31,7 @@ import Handler.Utils -- import Colonnade hiding (fromMaybe, singleton, bool) import qualified Yesod.Colonnade as Yesod import Text.Blaze (text) --- +-- -- import qualified Data.UUID.Cryptographic as UUID import qualified Data.Conduit.List as C @@ -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 (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 @@ -306,7 +305,7 @@ getSShowR tid ssh csh shn = do return (hasHints, hasSolution) cTime <- Just <$> liftIO getCurrentTime visibleFrom <- traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom sheet - when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $ + when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $ maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom defaultLayout $ do setTitleI $ MsgSheetTitle tid ssh csh shn @@ -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,23 +440,28 @@ 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 whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking insert_ $ SheetEdit aid actTime sid - addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName + addMessageI Success $ 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 @@ -475,7 +481,7 @@ getSDelR tid ssh csh shn = do (FormSuccess BtnDelete) -> do runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! - addMessageI "info" $ MsgSheetDelOk tid ssh csh shn + addMessageI Info $ MsgSheetDelOk tid ssh csh shn redirect $ CourseR tid ssh csh SheetListR _other -> do submissionno <- runDB $ do @@ -516,7 +522,7 @@ insertSheetFile' sid ftype fs = do fid <- insert file void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step - + data CorrectorForm = CorrectorForm { cfUserId :: UserId , cfUserName :: Text @@ -541,9 +547,9 @@ defaultLoads shid = do return . E.min_ $ sheetEdit E.^. SheetEditTime E.where_ $ sheet E.^. SheetCourse E.==. E.val cId - + E.orderBy [E.desc creationTime] - + return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState) where toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads @@ -566,7 +572,7 @@ correctorForm shid = do (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if | Map.null currentLoads' - , null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted) + , null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted) | otherwise -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads' deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads') @@ -602,19 +608,19 @@ correctorForm shid = do FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email) case mUid of - Nothing -> loads'' <$ addMessageI "error" (MsgEMailUnknown email) + Nothing -> loads'' <$ addMessageI Error (MsgEMailUnknown email) Just uid | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads'' - | otherwise -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email) - FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs + | otherwise -> loads'' <$ addMessageI Warning (MsgCorrectorExists email) + FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs _ -> return loads'' let deletions' = deletions `Set.difference` Map.keysSet loads - + names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys loads) return $ (user E.^. UserId, user E.^. UserDisplayName) - + let constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm constructFields (uid, uname, (state, Load{..})) = do @@ -685,7 +691,7 @@ correctorForm shid = do |] } ]) - + -- Eingabebox für Korrektor hinzufügen -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen @@ -697,11 +703,11 @@ getSCorrR tid ssh csh shn = do ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton case res of - FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs + FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess res -> runDB $ do deleteWhere [SheetCorrectorSheet ==. shid] insertMany_ $ Set.toList res - addMessageI "success" MsgCorrectorsUpdated + addMessageI Success MsgCorrectorsUpdated FormMissing -> return () let diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index a39a5a62e..b64be4126 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -27,47 +27,51 @@ 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 - <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy + <$> fileUpload + <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (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,10 +144,10 @@ 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 + addMessageI Info $ MsgSubmissionAlreadyExists redirect $ CSubmissionR tid ssh csh shn cID SubShowR (Just smid) -> do void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) @@ -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,15 @@ 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 + , submissionRatingAssigned = 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 @@ -248,7 +259,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do return smid cID <- encrypt smid return $ Just cID - (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml) + (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml) _other -> return Nothing case mCID of diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index c14b796eb..1720eec1f 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -167,12 +167,12 @@ termEditHandler term = do -- VOR INTERNATIONALISIERUNG: -- let tid = termToText $ termName res -- let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert." --- addMessage "success" [shamlet| #{msg} |] +-- addMessage Success [shamlet| #{msg} |] -- MIT INTERNATIONALISIERUNG: - addMessageI "success" $ MsgTermEdited tid + addMessageI Success $ MsgTermEdited tid redirect TermShowR (FormMissing ) -> return () - (FormFailure _) -> addMessageI "warning" MsgInvalidInput + (FormFailure _) -> addMessageI Warning MsgInvalidInput let actionUrl = TermEditR defaultLayout $ do setTitleI MsgTermEditHeading @@ -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/Users.hs b/src/Handler/Users.hs index ccedb3f71..8208d1a1f 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -14,6 +14,8 @@ import Handler.Utils import Utils.Lens +import qualified Data.CaseInsensitive as CI + import qualified Data.Map as Map import qualified Data.Set as Set @@ -116,7 +118,7 @@ postAdminHijackUserR cID = do permissionDenied "Cannot escalate admin status to additional schools" get404 uid - setCredsRedirect $ Creds "dummy" (userPlugin <> ":" <> userIdent) [] + setCredsRedirect $ Creds "dummy" (CI.original userIdent) [] | otherwise -> error "This should be impossible by definition of `hijackUserForm`" - FormFailure errs -> toTypedContent <$> mapM_ (addMessage "error" . toHtml) errs + FormFailure errs -> toTypedContent <$> mapM_ (addMessage Error . toHtml) errs FormMissing -> return $ toTypedContent () diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 8e51adff9..394359b27 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..c5ba85946 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} @@ -111,7 +112,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 +121,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 @@ -157,7 +154,7 @@ combinedButtonField btns inner csrf = do -} -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ())) -buttonForm :: (Button UniWorX a) => Form a +buttonForm :: (Button UniWorX a, Show a) => Form a buttonForm csrf = do buttonIdent <- newFormIdent let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing @@ -168,12 +165,15 @@ buttonForm csrf = do $forall bView <- btnViews ^{fvInput bView} |] + $logDebugS "FormResult" $ tshow results return (accResult results,widget) where accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a accResult = Foldable.foldr accResult' FormMissing accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a + -- TODO: Does not work for Forms with more than 3 buttons, since all deliver FormFailure except for one! + -- TODO: Maybe change buttonField? accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] accResult' (FormSuccess (Just x)) _ = FormSuccess x accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success? @@ -187,8 +187,7 @@ buttonForm csrf = do -- Fields -- ------------ -ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a) -ciField = convertField CI.mk CI.original +-- ciField moved to Utils.Form natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i natFieldI msg = checkBool (>= 0) msg intField @@ -219,26 +218,28 @@ 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 +termsAllowedField :: Field Handler TermId +termsAllowedField = selectField $ do + mayEditTerm <- isAuthorized TermEditR True + let termFilter | Authorized <- mayEditTerm = [] + | otherwise = [TermActive ==. True] + optionsPersistKey termFilter [Desc TermStart] termName + +termsSetField :: [TermId] -> Field Handler TermId +termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName +-- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ] + +termsActiveOrSetField :: [TermId] -> Field Handler TermId +termsActiveOrSetField tids = selectField $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName + where terms = map unTermKey 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 - where - errTextParse :: Text - errTextParse = "Semester: S oder W gefolgt von Jahreszahl" - - errTextFreigabe :: TermIdentifier -> Text - errTextFreigabe ti = "Semester " `T.append` (termToText ti) `T.append` " wurde noch nicht freigegeben." - - checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier) - checkTerm t = case termFromText t of - Left _ -> return $ Left errTextParse - res@(Right _) -> return res - +termNewField = checkMMap (return.termFromText) termToText textField schoolField :: Field Handler SchoolId schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName @@ -249,6 +250,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/Submission.hs b/src/Handler/Utils/Submission.hs index bd4f44daa..32b9e4d65 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -210,7 +210,10 @@ assignSubmissions sid restriction = do $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)" assignSubmission (countsToLoad' q) smid q - forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid] + now <- liftIO getCurrentTime + forM_ (Map.toList subTutor) $ + \(smid, tutid) -> update smid [ SubmissionRatingBy =. Just tutid + , SubmissionRatingAssigned =. Just now ] let assignedSubmissions = Map.keysSet subTutor unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions @@ -325,7 +328,7 @@ extractRatingsMsg = do ignored = Right `Set.map` ignored' unless (null ignored) $ do mr <- (toHtml . ) <$> getMessageRender - addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) + addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) sinkSubmission :: UserId -> Either SheetId SubmissionId @@ -343,11 +346,13 @@ sinkSubmission userId mExists isUpdate = do sId <- lift $ case mExists of Left sheetId -> do let - submissionSheet = sheetId - submissionRatingPoints = Nothing - submissionRatingComment = Nothing - submissionRatingBy = Nothing - submissionRatingTime = Nothing + submissionSheet = sheetId + submissionRatingPoints = Nothing + submissionRatingComment = Nothing + submissionRatingBy = Nothing + submissionRatingAssigned = Nothing + submissionRatingTime = Nothing + sId <- insert Submission{..} -- now <- liftIO getCurrentTime -- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty @@ -466,6 +471,7 @@ sinkSubmission userId mExists isUpdate = do lift $ case isUpdate of False -> insert_ $ SubmissionEdit userId now submissionId True -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] + -- TODO: Should submissionRatingAssigned change here if userId changes? tell $ mempty{ sinkSubmissionTouched = Any True } finalize :: SubmissionSinkState -> YesodDB UniWorX () @@ -586,7 +592,7 @@ sinkMultiSubmission userId isUpdate = do lift . feed sId $ Left f{ fileTitle = fileTitle' } when (not $ null ignored) $ do mr <- (toHtml .) <$> getMessageRender - addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) + addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do cID <- encrypt sId handle (throwM . SubmissionSinkException cID Nothing) $ diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index bb658c68c..65bc11452 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 @@ -70,7 +76,11 @@ courseCell (Course {..}) = anchorCell link name `mappend` desc name = citext2widget courseName desc = case courseDescription of Nothing -> mempty - (Just descr) -> cell [whamlet| ^{modalStatic descr} |] + (Just descr) -> cell [whamlet| + $newline never + + ^{modal "Beschreibung" (Right $ toWidget descr)} + |] sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a sheetCell crse shn = diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c779842d6..3e017472c 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -402,7 +402,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), <* E.offset (psPage * psLimit) <* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter - mapM_ (addMessageI "warning") errs + mapM_ (addMessageI Warning) errs runDB $ do rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery' diff --git a/src/Handler/Utils/Templates.hs b/src/Handler/Utils/Templates.hs index e29d9e3f9..57ab0f1d6 100644 --- a/src/Handler/Utils/Templates.hs +++ b/src/Handler/Utils/Templates.hs @@ -2,30 +2,19 @@ module Handler.Utils.Templates where +import Data.Either (isLeft) + import Import.NoFoundation lipsum :: WidgetT site IO () lipsum = $(widgetFile "widgets/lipsum") -modalStatic :: Html -> WidgetT site IO () -modalStatic modalContent = do - uniqueId <- newIdent - let modalTrigger = cons '#' uniqueId -- SJ: I am confused why this is needed here? - modalId :: Int32 - modalId = 13 - $(widgetFile "widgets/modalStatic") - [whamlet|
?|] -- SJ: confused why ## is needed here either? - -modal :: Text -> Maybe [Char] -> WidgetT site IO () -modal modalTrigger (Just modalContent) = do -- WARNING: ModalContent should not have length 11. SJ: This is possibly bad. See Template! - let - modalId :: Int32 - modalId = 13 - $(widgetFile "widgets/modal") -modal modalTrigger Nothing = do - let - modalId :: Int32 - modalId = 13 - modalContent :: [Char] - modalContent = "placeholder" +modal :: WidgetT site IO () -> Either (Route site) (WidgetT site IO ()) -> WidgetT site IO () +modal modalTrigger modalContent = do + let modalDynamic = isLeft modalContent + modalId <- newIdent + triggerId <- newIdent $(widgetFile "widgets/modal") + case modalContent of + Left route -> [whamlet|^{modalTrigger}|] + Right content -> [whamlet|
^{modalTrigger}|] diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 252e9f8ac..8db4ec779 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -3,7 +3,7 @@ module Import.NoFoundation ( module Import ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 723ccd964..54ec40156 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -168,12 +168,27 @@ 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 }'; + |] + ) + , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|] + , whenM (tableExists "user") $ do + -- <> is standard sql for /= + [executeQQ| + DELETE FROM "user" WHERE "plugin" <> 'LDAP'; + ALTER TABLE "user" DROP COLUMN "plugin"; + ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"'; + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 386d828e7..4f406a148 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -46,12 +46,14 @@ import Data.CaseInsensitive.Instances () import Yesod.Core.Dispatch (PathPiece(..)) import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..)) -import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..)) +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Data.Typeable (Typeable) +import qualified Yesod.Auth.Util.PasswordStore as PWStore + instance PathPiece UUID where fromPathPiece = Data.UUID.Types.fromString . unpack @@ -193,6 +195,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,13 +288,14 @@ 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 , Just (review shortened -> year) <- readMaybe ys , Right season <- seasonFromChar s = Right TermIdentifier{..} - | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" + | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number termToRational :: TermIdentifier -> Rational termToRational TermIdentifier{..} = fromInteger year + seasonOffset @@ -329,9 +338,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 -} @@ -361,11 +370,13 @@ deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Theme" } ''Theme +$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813 + instance Universe Theme where universe = universeDef instance Finite Theme instance PathPiece Theme where - toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) + toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) fromPathPiece = finiteFromPathPiece $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user @@ -381,7 +392,7 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } - deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql) + deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString) data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime deriving (Eq, Ord, Read, Show, Enum, Bounded) @@ -390,6 +401,8 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused deriving (Eq, Ord, Read, Show, Enum, Bounded) +$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813 + deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Corrector" } ''CorrectorState @@ -398,12 +411,25 @@ instance Universe CorrectorState where universe = universeDef instance Finite CorrectorState instance PathPiece CorrectorState where - toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) + toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map toLower . unsafeTail . splitCamel]) fromPathPiece = finiteFromPathPiece derivePersistField "CorrectorState" +data AuthenticationMode = AuthLDAP + | AuthPWHash { authPWHash :: Text } + deriving (Eq, Ord, Read, Show) + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , sumEncoding = UntaggedValue + } ''AuthenticationMode + +derivePersistFieldJSON ''AuthenticationMode + + -- Type synonyms type SchoolName = CI Text @@ -412,3 +438,5 @@ type CourseName = CI Text type CourseShorthand = CI Text type SheetName = CI Text type UserEmail = CI Text + +type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString diff --git a/src/Settings.hs b/src/Settings.hs index ce68f6a75..4649c76f4 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -16,6 +16,7 @@ import ClassyPrelude.Yesod import qualified Control.Exception as Exception import Data.Aeson (Result (..), fromJSON, withObject, (.!=), (.:?)) +import qualified Data.Aeson.Types as Aeson import Data.Aeson.TH import Data.FileEmbed (embedFile) import Data.Yaml (decodeEither') @@ -26,12 +27,13 @@ import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, widgetFileReload) +import qualified Yesod.Auth.Util.PasswordStore as PWStore import qualified Data.Text.Encoding as Text import qualified Ldap.Client as Ldap -import Utils +import Utils hiding (MessageClass(..)) import Control.Lens import Data.Maybe (fromJust) @@ -74,32 +76,36 @@ data AppSettings = AppSettings -- ^ Indicate if auth dummy login should be enabled. , appAllowDeprecated :: Bool -- ^ Indicate if deprecated routes are accessible for everyone - , appAuthPWFile :: Maybe FilePath - -- ^ If set authenticate against a local password file , appMinimumLogLevel :: LogLevel , appUserDefaults :: UserDefaultConf + , appAuthPWHash :: PWHashConf , appCryptoIDKeyFile :: FilePath } - + data UserDefaultConf = UserDefaultConf { userDefaultTheme :: Theme , userDefaultMaxFavourites :: Int , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat , userDefaultDownloadFiles :: Bool } + +data PWHashConf = PWHashConf + { pwHashAlgorithm :: PWHashAlgorithm + , pwHashStrength :: Int + } -instance FromJSON UserDefaultConf where - parseJSON = withObject "UserDefaultConf" $ \o -> do - userDefaultTheme <- o .: "theme" - userDefaultMaxFavourites <- o .: "favourites" - userDefaultDateTimeFormat <- o .: "date-time-format" - userDefaultDateFormat <- o .: "date-format" - userDefaultTimeFormat <- o .: "time-format" - userDefaultDownloadFiles <- o .: "download-files" +instance FromJSON PWHashConf where + parseJSON = withObject "PWHashConf" $ \o -> do + pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text) + pwHashAlgorithm <- if + | pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1 + | pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2 + | otherwise -> fail "Unsupported hash algorithm" + pwHashStrength <- o .: "strength" - return UserDefaultConf{..} + return PWHashConf{..} data LdapConf = LdapConf { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber @@ -108,8 +114,11 @@ data LdapConf = LdapConf , ldapScope :: Ldap.Scope , ldapTimeout :: Int32 } - + deriveFromJSON defaultOptions ''Ldap.Scope +deriveFromJSON defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel + } ''UserDefaultConf instance FromJSON LdapConf where parseJSON = withObject "LdapConf" $ \o -> do @@ -164,9 +173,9 @@ instance FromJSON AppSettings where appSkipCombining <- o .:? "skip-combining" .!= defaultDev appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev - appAuthPWFile <- assertM (not . null) <$> o .:? "auth-pwfile" appUserDefaults <- o .: "user-defaults" + appAuthPWHash <- o .: "auth-pw-hash" appCryptoIDKeyFile <- o .: "cryptoid-keyfile" diff --git a/src/Utils.hs b/src/Utils.hs index c15a0c29a..08343ec80 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -25,6 +25,8 @@ import Utils.DB as Utils import Utils.TH as Utils import Utils.DateTime as Utils import Utils.PathPiece as Utils +import Utils.Message as Utils + import Text.Blaze (Markup, ToMarkup) @@ -130,7 +132,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 +302,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 +332,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/src/Utils/Form.hs b/src/Utils/Form.hs index 208d42caf..9a96781ef 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -20,6 +20,9 @@ import qualified Text.Blaze.Internal as Blaze (null) import qualified Data.Text as T import qualified Data.Char as Char +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + import Web.PathPieces ------------------- @@ -118,6 +121,20 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass) setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg } +addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a +addDatalist field mValues = field + { fieldView = \fId fName fAttrs fRes fReq -> do + listId <- newIdent + values <- map toPathPiece . otoList <$> mValues + fieldView field fId fName (("list", listId) : fAttrs) fRes fReq + [whamlet| + $newline never + + $forall value <- values +
  • Kurse anlegen -

    Funktionen zum Testen @@ -33,9 +32,5 @@ ^{btnWdgt}

  • Modals: - ^{modal ".toggler1" Nothing} -     Klick mich für Ajax-Test - - ^{modal ".toggler2" (Just "Test Inhalt für Modal")} -
    Klick mich für Content-Test - + ^{modal "Klick mich für Ajax-Test" (Left UsersR)} + ^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")} diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index 3eba4f9f1..014edc30f 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -7,38 +7,11 @@ $newline never - #{pageTitle pc} - <meta name="description" content=""> - <meta name="author" content=""> - <meta name="viewport" content="width=device-width,initial-scale=1"> ^{pageHead pc} - \<!--[if lt IE 9]> - \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script> - \<![endif]--> - <script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/js-cookie/2.0.3/js.cookie.min.js"> - <script> - /* The `defaultCsrfMiddleware` Middleware added in Foundation.hs adds a CSRF token to the request cookies. */ - /* AJAX requests should add that token to a header to be validated by the server. */ - /* See the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package for details. */ - var csrfHeaderName = "#{TE.decodeUtf8 $ CI.foldedCase defaultCsrfHeaderName}"; - - var csrfCookieName = "#{TE.decodeUtf8 defaultCsrfCookieName}"; - var csrfToken = Cookies.get(csrfCookieName); - - - if (csrfToken) { - \ $.ajaxPrefilter(function( options, originalOptions, jqXHR ) { - \ if (!options.crossDomain) { - \ jqXHR.setRequestHeader(csrfHeaderName, csrfToken); - \ } - \ }); - } - - <body .no-js .theme--#{toPathPiece currentTheme} :isAuth:.logged-in> <!-- removes no-js class from body if client supports javascript --> <script> diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 34285a821..97968130e 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -113,7 +113,7 @@ a:hover { ul { - list-style-type: none; + margin-left: 20px; } h1, h2, h3, h4, h5 { @@ -424,8 +424,17 @@ input[type="button"].btn-info:hover, } /* LIST MODIFIERS */ -.list--inline li { - display: inline-block; +.list--iconless { + list-style-type: none; + margin-left: 0; +} + +.list--inline { + margin-left: 0; + + li { + display: inline-block; + } } .list--comma-separated li { diff --git a/templates/login.hamlet b/templates/login.hamlet index ad6ff756f..f3cf5ece8 100644 --- a/templates/login.hamlet +++ b/templates/login.hamlet @@ -3,6 +3,11 @@ $forall AuthPlugin{..} <- plugins <section> <h2>_{MsgLDAPLoginTitle} ^{apLogin toParent} + $elseif apName == "PWHash" + <section> + <h2>_{MsgPWHashLoginTitle} + <p>_{MsgPWHashLoginNote} + ^{apLogin toParent} $elseif apName == "dummy" <section> <h2>_{MsgDummyLoginTitle} diff --git a/templates/multiFileField.hamlet b/templates/multiFileField.hamlet index 62123a11e..649a9b47e 100644 --- a/templates/multiFileField.hamlet +++ b/templates/multiFileField.hamlet @@ -16,5 +16,5 @@ $# new files <label for=#{fieldId}_zip>ZIPs automatisch entpacken <input type=checkbox id=#{fieldId}_zip name=#{fieldName} value=#{unpackZips}> <div class="js-tooltip"> - <div class="tooltip__handle">? + <div class="tooltip__handle"> <div class="tooltip__content">Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu. diff --git a/templates/profile.hamlet b/templates/profile.hamlet index f5bfae509..45510425a 100644 --- a/templates/profile.hamlet +++ b/templates/profile.hamlet @@ -3,33 +3,29 @@ <dl .deflist.profile-dl> <dt .deflist__dt> _{MsgName} <dd .deflist__dd> ^{nameWidget userDisplayName userSurname} - <dt .deflist__dt> _{MsgMatrikelNr} - <dd .deflist__dd> #{display userMatrikelnummer} + $maybe matnr <- userMatrikelnummer + <dt .deflist__dt> _{MsgMatrikelNr} + <dd .deflist__dd> #{matnr} <dt .deflist__dt> _{MsgEMail} <dd .deflist__dd> #{display userEmail} <dt .deflist__dt> _{MsgIdent} <dd .deflist__dd> #{display userIdent} - <dt .deflist__dt> _{MsgPlugin} - <dd .deflist__dd> #{display userPlugin} $if not $ null admin_rights <dt .deflist__dt> Administrator <dd .deflist__dd> <ul .list-ul> - $forall institute <- admin_rights - <li .list-ul__item>#{display institute} + $forall (E.Value institute) <- admin_rights + <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 - <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 + $forall (E.Value institute) <- lecturer_rights <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 +44,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> #{display field} - <td .table__td> #{display fieldtype} - <td .table__td> #{display semester} - - $if not $ null participant - <dt .deflist__dt> Teilnehmer - <dd .deflist__dd> - <dl .deflist> - $forall (E.Value tid, E.Value ssh, E.Value csh, E.Value regSince) <- participant - <dt .deflist__dt> - <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh} - <dd .deflist__dd> - seit ^{formatTimeW SelFormatDateTime regSince} + <td .table__td> + $maybe name <- E.unValue degree + #{display name} + $nothing + #{display degreeKey} + <td .table__td> + $maybe name <- E.unValue field + #{display name} + $nothing + #{display fieldKey} + <td .table__td>_{E.unValue fieldtype} + <td .table__td>#{display semester} ^{settingsForm} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index d50327a83..8d2b42a71 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -1,13 +1,4 @@ <div .container> - <div .alerts> - <div .alert .alert-danger> - <div .alert__content> - TODO: Alle Benutzerbezogenen Daten sollen hier angezeigt - und verlinkt werden - (alle Abgaben, Klausurnoten, etc.) - - <em> TODO: Hier alle Daten in Tabellen anzeigen! - $if hasRows <div .container> <h2> Eigene Kurse @@ -24,6 +15,11 @@ <div .container> ^{examTable} + <div .container> + <h2> Eigene Übungsgruppen + <div .container> + ^{ownTutorialTable} + <div .container> <h2> Übungsgruppen <div .container> @@ -47,9 +43,15 @@ <div .container> ^{correctionsTable} - <h2> - <em> TODO: Knopf zum Löschen aller Daten erstellen + <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> + ^{modal "Alle Benutzerbezogenen Daten löschen" (Right delWdgt)} <p> <h4>Hinweise: <ul> diff --git a/templates/standalone/alerts.julius b/templates/standalone/alerts.julius index 28b3f7c29..a07a002e6 100644 --- a/templates/standalone/alerts.julius +++ b/templates/standalone/alerts.julius @@ -3,25 +3,75 @@ window.utils = window.utils || {}; - window.utils.alert = function(alertEl) { - var closeEl = document.createElement('DIV'); - var dataDecay = alertEl.dataset.decay; - var autoDecay = 30; - if (dataDecay) { - autoDecay = parseInt(dataDecay, 10); - } - closeEl.classList.add('alert__close'); - closeEl.addEventListener('click', function(event) { - alertEl.classList.add('alert--invisible'); - }); - alertEl.insertBefore(closeEl, alertEl.children[0]); + var ALERT_INVISIBLE_CLASS = 'alert--invisible'; + var TOGGLER_INVISIBLE_CLASS = 'alerts__toggler--visible'; - // auto-hide info and success-alerts after 3 seconds - if (autoDecay > 0 && !alertEl.matches('.alert-danger, .alert-warning')) { - window.setTimeout(function() { - alertEl.classList.add('alert--invisible'); - }, autoDecay * 1000); + window.utils.alerts = function(alertsEl) { + + var alerts = Array.from(alertsEl.querySelectorAll('.alert')); + var toggler; + var showingToggler = false; + + function makeToggler() { + toggler = document.createElement('DIV'); + toggler.classList.add('alerts__toggler'); + toggler.addEventListener('click', function() { + alerts.forEach(function(alert) { + alert.classList.remove(ALERT_INVISIBLE_CLASS); + toggler.classList.remove(TOGGLER_INVISIBLE_CLASS); + }); + checkToggler(); + }); + alertsEl.appendChild(toggler); } + + function makeAlert(alertEl) { + var iconEl = document.createElement('DIV'); + var closeEl = document.createElement('DIV'); + var dataDecay = alertEl.dataset.decay; + var autoDecay = 30; + if (dataDecay) { + autoDecay = parseInt(dataDecay, 10); + } + iconEl.classList.add('alert__icon'); + closeEl.classList.add('alert__close'); + closeEl.addEventListener('click', function(event) { + closeAlert(alertEl); + }); + alertEl.insertBefore(iconEl, alertEl.children[0]); + alertEl.insertBefore(closeEl, alertEl.children[0]); + + // auto-hide info and success-alerts after 3 seconds + if (autoDecay > 0 && !alertEl.matches('.alert-warning, .alert-error')) { + window.setTimeout(function() { + closeAlert(alertEl); + }, autoDecay * 1000); + } + } + + function closeAlert(alertEl) { + alertEl.classList.add(ALERT_INVISIBLE_CLASS); + checkToggler(); + } + + function checkToggler() { + var hidden = true; + alerts.forEach(function(alert) { + if (hidden && !alert.classList.contains(ALERT_INVISIBLE_CLASS)) { + hidden = false; + } + }); + if (!showingToggler) { + showingToggler = true; + window.setTimeout(function() { + toggler.classList.toggle(TOGGLER_INVISIBLE_CLASS, hidden); + showingToggler = false; + }, 120); + } + } + + makeToggler(); + alerts.map(makeAlert); } })(); @@ -29,7 +79,5 @@ document.addEventListener('DOMContentLoaded', function() { // setup alerts - Array.from(document.querySelectorAll('.alert')).forEach(function(alertEl) { - window.utils.alert(alertEl); - }); + window.utils.alerts(document.querySelector('.alerts')); }); diff --git a/templates/standalone/alerts.lucius b/templates/standalone/alerts.lucius index 9501f1329..c1660b903 100644 --- a/templates/standalone/alerts.lucius +++ b/templates/standalone/alerts.lucius @@ -3,100 +3,152 @@ .alert Regular Info Alert Disappears automatically after 30 seconds - Disappears after x seconds if explicitly specified via data-decay='x' on html element + Disappears after x seconds if explicitly specified via data-decay='x' Can be told not to disappear with data-decay='0' - .alert-warning, .alert-error - Warning or Error alert - These don't disappear, only difference is color - .alert-warning is orange regardless of user's selected theme - .alert-error is red regardless of user's selected theme + .alert-success + Disappears automatically after 30 seconds + + .alert-warning + Does not disappear + Orange regardless of user's selected theme + + .alert-error + Does not disappear + Red regardless of user's selected theme */ .alerts { position: fixed; - bottom: 5%; - right: 0; + bottom: 0; + right: 5%; z-index: 20; text-align: right; display: flex; flex-direction: column; } +.alerts__toggler { + width: 40px; + height: 40px; + position: absolute; + top: 400px; + left: 50%; + transform: translateX(-50%); + cursor: pointer; + + &::before { + content: '\f077'; + position: absolute; + font-family: "Font Awesome 5 Free"; + left: 50%; + top: 0; + height: 30px; + display: flex; + align-items: center; + justify-content: center; + width: 30px; + color: var(--color-lightblack); + font-size: 30px; + transform: translateX(-50%); + } +} + +.alerts__toggler--visible { + top: -40px; + opacity: 1; + transition: top .5s cubic-bezier(0.73, 1.25, 0.61, 1), + opacity .5s cubic-bezier(0.73, 1.25, 0.61, 1); +} + +@media (max-width: 425px) { + + .alerts { + left: 5%; + } +} + .alert { position: relative; - display: inline-block; - background-color: var(--color-dark); + display: block; + background-color: var(--color-lightblack); font-size: 1rem; color: var(--color-lightwhite); z-index: 0; - max-height: 200px; - transition: all .3s ease-in-out; - padding-left: 20px; - margin-left: 20px; + padding: 0 50px; + padding-right: 60px; animation: slide-in-alert .2s ease-out forwards; - margin-bottom: 20px; - - &:hover { - - .alert__content { - - &::after { - opacity: 1; - } - } - } + margin-bottom: 10px; + transition: margin-bottom .2s ease-out; } @keyframes slide-in-alert { from { - left: 120%; + transform: translateY(120%); } to { - left: 0; + transform: translateY(0); + } +} + +@keyframes slide-out-alert { + from { + transform: translateY(0); + max-height: 200px; + } + to { + transform: translateY(250%); + opacity: 0; + max-height: 0; + overflow: hidden; } } @media (min-width: 425px) { .alert { - margin-left: 80px; - max-width: 420px; + max-width: 400px; } } -@media (min-width: 768px) { - - .alert { - padding-left: 30px; - margin-left: 40px; - min-width: 400px; - } -} - -@media (min-width: 1024px) { - - .alert { - min-width: 350px; - } +.alert--invisible { + animation: slide-out-alert .2s ease-out forwards; + margin-bottom: 0; } .alert__content { - padding: 8px 1.5em; + padding: 8px 0; min-height: 40px; position: relative; display: flex; font-weight: 600; - justify-content: flex-end; align-items: center; text-align: left; } -@media (max-width: 768px) { +.alert__icon { + text-align: right; + position: absolute; + left: 0px; + top: 0; + width: 50px; + height: 100%; + z-index: 40; - .alert__content { - padding: 4px 7px; - padding-left: 25px; + &::before { + content: '\f05a'; + position: absolute; + font-family: "Font Awesome 5 Free"; + font-size: 24px; + top: 50%; + left: 50%; + display: flex; + align-items: center; + justify-content: center; + transform: translate(-50%, -50%); + border-radius: 50%; + width: 30px; + height: 30px; } } @@ -104,7 +156,7 @@ cursor: pointer; text-align: right; position: absolute; - left: 0px; + right: 0px; top: 0; width: 60px; height: 100%; @@ -145,18 +197,26 @@ } } +.alert-success { + background-color: var(--color-success); + + .alert__icon::before { + content: '\f058'; + } +} + .alert-warning { background-color: var(--color-warning); + + .alert__icon::before { + content: '\f06a'; + } } -.alert-danger, .alert-error { background-color: var(--color-error); -} -.alert--invisible { - max-height: 0; - transform: translateX(120%); - margin-bottom: 0; - overflow: hidden; + .alert__icon::before { + content: '\f071'; + } } diff --git a/templates/standalone/inputs.lucius b/templates/standalone/inputs.lucius index ad6771a38..470efdb1b 100644 --- a/templates/standalone/inputs.lucius +++ b/templates/standalone/inputs.lucius @@ -30,6 +30,16 @@ } } +.form-group--submit .form-group__input { + grid-column: 2; +} + +@media (max-width: 768px) { + .form-group--submit .form-group__input { + grid-column: 1; + } +} + .form-group--has-error { background-color: rgba(255, 0, 0, 0.1); @@ -187,6 +197,7 @@ input[type="checkbox"]:checked::after { .checkbox, .radio { position: relative; + display: inline-block; [type="checkbox"], [type="radio"] { diff --git a/templates/standalone/modal.julius b/templates/standalone/modal.julius index 01a564ca4..8bac72f12 100644 --- a/templates/standalone/modal.julius +++ b/templates/standalone/modal.julius @@ -6,12 +6,11 @@ window.utils.modal = function(modal) { var overlay = document.createElement('div'); var closer = document.createElement('div'); - var trigger = document.querySelector(modal.dataset.trigger); + var trigger = document.querySelector('#' + modal.dataset.trigger); var origParent = modal.parentNode; function open(event) { // disable modals for narrow screens - if (window.innerWidth < 768) return true; if (event) { event.preventDefault(); } @@ -20,7 +19,6 @@ document.body.insertBefore(modal, null); document.body.insertBefore(overlay, modal); overlay.classList.add('modal__overlay--open'); - toggleScroll(false); if (modal.dataset.closeable === 'true') { closer.classList.add('modal__closer'); @@ -30,8 +28,8 @@ } } - // open this modal with an event: - // document.dispatchEvent(new CustomEvent('modal-open', { dateils: {for: 'modal-13'}})) + // you can open this modal via event + // example: document.dispatchEvent(new CustomEvent('modal-open', { details: { for: 'modal-[id]' }})) function openOnEvent(event) { if (event.detail.for === modal.getAttribute('id')) { open(); @@ -43,7 +41,6 @@ overlay.remove(); origParent.insertBefore(modal, null); modal.classList.remove('modal--open'); - toggleScroll(true); closer.removeEventListener('click', close, false); } }; @@ -56,27 +53,20 @@ trigger.classList.add('modal__trigger'); trigger.addEventListener('click', open, false); } - // if there is no content specified for the modal we assume that - // the content is supposed to be the page the trigger links to. - // so we check if the trigger has a href-attribute, fetch that page - // and replace the modal content with the response - var replaceMe = modal.querySelector('.replace-me'); - var replaceWith = trigger ? trigger.getAttribute('href') : ''; - if (replaceMe) { - replaceMe.classList.remove('replace-me'); - replaceMe.innerText = '...loading'; - if (replaceWith.length > 0) { - fetch(replaceWith, { - credentials: 'same-origin' + + if (modal.dataset.dynamic === 'True') { + var dynamicContentURL = trigger.getAttribute('href'); + if (dynamicContentURL.length > 0) { + fetch(dynamicContentURL, { + credentials: 'same-origin', }).then(function(response) { return response.text(); }).then(function(body) { var modalContent = document.createElement('div'); modalContent.innerHTML = body; - var main = modalContent.querySelector('.main__content'); + var main = modalContent.querySelector('.main__content-body'); if (main) { - replaceMe.innerText = ''; - replaceMe.insertBefore(main, null); + modal.appendChild(main); } else { replaceMe.innerHTML = body; } @@ -88,11 +78,6 @@ } setup(); }; - - // make sure document doesn't scroll when modal is active - function toggleScroll(scrollable) { - document.body.classList.toggle('no-scroll', !scrollable); - } })(); document.addEventListener('DOMContentLoaded', function() { diff --git a/templates/standalone/modal.lucius b/templates/standalone/modal.lucius index 2ccec226b..589083ece 100644 --- a/templates/standalone/modal.lucius +++ b/templates/standalone/modal.lucius @@ -4,14 +4,15 @@ top: 50%; transform: translate(-50%, -50%) scale(0.8, 0.8); display: block; - background-color: rgba(255, 255, 255, 0.9); + background-color: rgba(255, 255, 255, 0.99); min-width: 60vw; min-height: 100px; max-height: calc(100vh - 30px); - border-radius: 7px; + border-radius: 2px; z-index: -1; color: var(--color-font); padding: 20px; + padding-right: 65px; overflow: auto; opacity: 0; transition: all .15s ease; @@ -81,7 +82,3 @@ color: white; } } - -.no-scroll { - overflow: hidden; -} diff --git a/templates/standalone/tooltip.lucius b/templates/standalone/tooltip.lucius index 27e85f270..d85415d97 100644 --- a/templates/standalone/tooltip.lucius +++ b/templates/standalone/tooltip.lucius @@ -19,6 +19,23 @@ text-align: center; margin: 0 10px; cursor: default; + position: relative; + + &::before { + content: '\f128'; + position: absolute; + top: 0; + left: 0; + font-family: "Font Awesome 5 Free"; + top: 50%; + left: 50%; + transform: translate(-50%, -50%); + font-size: 15px; + } + + &:hover { + background-color: var(--color-light); + } } .tooltip__content { diff --git a/templates/submission.hamlet b/templates/submission.hamlet index d5044150b..aeaf9ca2f 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -1,12 +1,17 @@ $maybe cID <- mcid <section> - <h2> - <a href=@{urlArchive cID}>Archiv - (<a href=@{urlOriginal cID}>Original</a>) + $case sheetUploadMode + $of Upload _ + <h2> + <a href=@{urlArchive cID}>Archiv + (<a href=@{urlOriginal cID}>Original</a>) - $maybe fileTable <- mFileTable - <h3>_{MsgSubmissionFiles} - ^{fileTable} + $maybe fileTable <- mFileTable + <h3>_{MsgSubmissionFiles} + ^{fileTable} + $of _ + <p> + _{MsgSubmissionNoUploadExpected} $if not (null lastEdits) <h3>_{MsgLastEdits} diff --git a/templates/widgets/asidenav.hamlet b/templates/widgets/asidenav.hamlet index 346b356f5..f75a8f162 100644 --- a/templates/widgets/asidenav.hamlet +++ b/templates/widgets/asidenav.hamlet @@ -9,13 +9,13 @@ $newline never _{MsgWinterTermShort year} $of Summer _{MsgSummerTermShort year} - <ul .asidenav__list.js-show-hide__target> + <ul .asidenav__list.js-show-hide__target.list--iconless> $forall (Course{..}, courseRoute, pageActions) <- favouriteTerm tid <li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active> <a .asidenav__link-wrapper href=@{courseRoute}> <div .asidenav__link-shorthand>#{courseShorthand} <div .asidenav__link-label>#{courseName} - <ul .asidenav__nested-list> + <ul .asidenav__nested-list.list--iconless> $forall action <- pageActions $case action $of PageActionPrime (MenuItem{..}) diff --git a/templates/widgets/dummy-login-form.hamlet b/templates/widgets/dummy-login-form.hamlet new file mode 100644 index 000000000..f44f82d91 --- /dev/null +++ b/templates/widgets/dummy-login-form.hamlet @@ -0,0 +1,2 @@ +<form method=POST action=@{toMaster $ PluginR "dummy" []} enctype=#{loginEnctype}> + ^{login} diff --git a/templates/widgets/form.hamlet b/templates/widgets/form.hamlet index a28adabf4..2c0cfc9b8 100644 --- a/templates/widgets/form.hamlet +++ b/templates/widgets/form.hamlet @@ -3,6 +3,7 @@ $newline never $case formLayout $of FormStandard $forall view <- views + $# TODO: add class 'form-group--submit' if this is the submit-button view <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error> $if not (Blaze.null $ fvLabel view) <label .form-group__label for=#{fvId view}>#{fvLabel view} @@ -10,5 +11,5 @@ $case formLayout ^{fvInput view} $maybe tooltip <- fvTooltip view <div .js-tooltip> - <div .tooltip__handle>? + <div .tooltip__handle> <div .tooltip__content>^{tooltip} diff --git a/templates/widgets/hash-login-form.hamlet b/templates/widgets/hash-login-form.hamlet new file mode 100644 index 000000000..203a02f2e --- /dev/null +++ b/templates/widgets/hash-login-form.hamlet @@ -0,0 +1,2 @@ +<form method=POST action=@{toMaster $ PluginR "PWHash" []} enctype=#{loginEnctype}> + ^{login} diff --git a/templates/widgets/modal.hamlet b/templates/widgets/modal.hamlet index 9dc569101..a971aab83 100644 --- a/templates/widgets/modal.hamlet +++ b/templates/widgets/modal.hamlet @@ -1,8 +1,5 @@ -<div .modal.js-modal #modal-#{modalId} data-trigger=#{modalTrigger} data-closeable=true> - $# primitive way of checking if this is supposed to be add a placeholder for async data. - $# modalContent is 'placeholder' if there should be a placeholder only. - $# 'placeholder' has length 11. - $if 11 == length modalContent - <div .replace-me> - $else - #{modalContent} +<div .modal.js-modal #modal-#{modalId} data-trigger=#{triggerId} data-closeable=true data-dynamic=#{modalDynamic}> + $case modalContent + $of Right content + ^{content} + $of Left _ diff --git a/templates/widgets/modalStatic.hamlet b/templates/widgets/modalStatic.hamlet deleted file mode 100644 index a9b8e3587..000000000 --- a/templates/widgets/modalStatic.hamlet +++ /dev/null @@ -1,2 +0,0 @@ -<div .modal.js-modal #modal-#{modalId} data-trigger=#{modalTrigger} data-closeable=true> - #{modalContent} diff --git a/templates/widgets/navbar.lucius b/templates/widgets/navbar.lucius index 43e895c40..81200d4e8 100644 --- a/templates/widgets/navbar.lucius +++ b/templates/widgets/navbar.lucius @@ -41,7 +41,7 @@ background: linear-gradient(to top, var(--color-dark) 0%,var(--color-darker) 100%); /* W3C, IE10+, FF16+, Chrome26+, Opera12+, Safari7+ */ color: white; margin-right: 40px; - z-index: 10; + z-index: 20; box-shadow: 0 0 4px rgba(0, 0, 0, 0.2); overflow: auto; transition: all .2s cubic-bezier(0.03, 0.43, 0.58, 1); diff --git a/templates/widgets/pageactionprime.lucius b/templates/widgets/pageactionprime.lucius index 7694e55d0..5dba2f4c4 100644 --- a/templates/widgets/pageactionprime.lucius +++ b/templates/widgets/pageactionprime.lucius @@ -6,6 +6,7 @@ .pagenav__list { display: block; + margin-left: 0; } .pagenav__list-item {