diff --git a/.directory b/.directory new file mode 100644 index 000000000..59c2c250d --- /dev/null +++ b/.directory @@ -0,0 +1,6 @@ +[Dolphin] +Timestamp=2018,3,14,10,57,55 +Version=4 + +[Settings] +HiddenFilesShown=true diff --git a/.kateproject b/.kateproject new file mode 100644 index 000000000..1d90b01b0 --- /dev/null +++ b/.kateproject @@ -0,0 +1,4 @@ +{ + "name": "ReWorX" +, "files": [ { "git": 1, "filters": ["*.hs", "*.hamlet", "*.lucius", "*.cassius", "*.julius"], "recursive": 1 } ] +} diff --git a/Datenschutznotizen.txt b/Datenschutznotizen.txt index 4ffa87b2f..6849c77c2 100644 --- a/Datenschutznotizen.txt +++ b/Datenschutznotizen.txt @@ -1,10 +1,11 @@ * Datensparsamkeit: nur Speichern was notwendig ist; Dokumentieren, warum was gespeichert wird! * Verfügbarkeit: Backup / aktuelles System; nicht nur eine Person, Anfragen werden organisiert beantwortet * Integrität: Konsistenzcheck bei Datenübertragen (z.B. LDAP), Sicherheit vor bösen Absichten, Änderungen protokolliert -* Vertraulichkeit: Jeder Benutzer sollte nur auf das zugreifen was unbedingt nötig ist; Backup Verschlüsselung +* Vertraulichkeit: Jeder Benutzer sollte nur auf das zugreifen was unbedingt nötig ist; Backup; Verschlüsselung jeglicher Übermittlung * Nichtverkettbarkeit: (eher irrelevant für unseren Anwendungsfall) * Transparenz: User weiß was über ihn gespeichert wird; Dokumentation; Vorfälle schnell melden? -* Intervenierbarkeit: Korrektur/Löschpflichten - auch im Backup; z.B. Korrekturen bei Einspielen des Backups einpflegen; Backup Verschlüsselung; Bei Löschanforderungen muss teilweise gelöscht werden (nur was Notenrelevant muss aufgehoben werden, Hausaufgaben werden gelöscht; Anzeige gelöschter Teilnehmer) +* Intervenierbarkeit: Korrektur/Löschpflichten - auch im Backup; z.B. Korrekturen bei Einspielen des Backups einpflegen; Backup Verschlüsselung; Bei Löschanforderungen muss teilweise gelöscht werden (nur was Notenrelevant muss aufgehoben werden, Hausaufgaben werden gelöscht; Anzeige gelöschter Teilnehmer). +Was sind die Aufbewahrungsfristen für Hausübungen? Wie bei Klausuren? * Wer ist Datenschutzverantwortlicher? Steffen!?! => Sofort anzeigen, wenn etwas schiefläuft. @@ -20,7 +21,8 @@ Aktionen: - Regularien für Prozess; Aufbewahrungsfristen, Verwaltungsrechtliche Fragen, Bayrisches E-Goverment Gesetz, Daten signierbar/verifizieren; -> Aktuelle Archivierung von prüfungsrelevanten Daten (Klausur-Lagerung) ist nicht Gesetz-Konform; da Papier-Lagerung nicht konform ist. - + Wo ist dokumentiert, welche Klausur wo gelagert wird?! + diff --git a/FragenSJ.txt b/FragenSJ.txt new file mode 100644 index 000000000..c2219f2c1 --- /dev/null +++ b/FragenSJ.txt @@ -0,0 +1,38 @@ +** Sicherheitsabfragen? + - Verschlüsselung des Zugriffs? + + - SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage + POST löscht. + Ist das so sinnvoll? + Sicherheitsabfrage als PopUpMessage? + + - Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq? + (Sheet.hs -> fetchSheet) + + - Handler.Sheet.postSheetDelR: deleteCascade für Files? Klappt das? + Kann man abfragen, was bei deleteCascade alles gelöscht wird? + + + +** i18n: + - i18n der + Links -> MenuItems verwenden wie bisher + Page Titles -> setTitleI + Buttons? -> Kann leicht geändert werden! + Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel? + +** Page pageActions - Berechtigungen prüfen? + => Eigener Constructor statt NavbarLeft/Right?! + + +** FORMS + 3 - Sheets: Multiple Files -> wird später gemacht + - Versionen für Studenten/Korrektoren/Lecturers/Admins + -> ja über isAuthorizedDB siehe unten, + -> Lecturer kann gleich auf Edit-Seite gehen wie in UniWorX + + +Freischaltung von Teilen einer Webseite: + - Freigabe der Links über Authorisierung in der Foundation + - Anzeige der Links nach Authorisierung wie in menItemAccessCallback + - möglichst direkt isAuthorizedDB in einem runDB aufrufen!!! diff --git a/README.md b/README.md index 2fbf8207f..348fcc55f 100644 --- a/README.md +++ b/README.md @@ -1,21 +1,24 @@ # Quick Start Guide -Assuming Ubuntu or similar +The following Description applies to Ubuntu or similar. + +## Clone repository + Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`. ## LDAP - install:
- `sudo apt-get install slapd ldap-utils` + install: + `sudo apt-get install slapd ldap-utils` ## PostgreSQL - install:
- `sudo apt-get install postgresql` + install: + `sudo apt-get install postgresql` - switch to user *postgres* (got created during installation):
- `sudo -i -u postgres` + switch to user *postgres* (got created during installation): + `sudo -i -u postgres` - add db user *uniworx*:
- `createuser --interactive` + add db user *uniworx*: + `createuser --interactive` you'll get a prompt: @@ -24,49 +27,60 @@ Assuming Ubuntu or similar Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?] ``` - create database *uniworx*:
- `createdb uniworx` + create database *uniworx*: + `createdb uniworx` - to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*:
- `sudo adduser uniworx` + to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*: + `sudo adduser uniworx` - log-in as new user *uniworx*:
- `sudo -i -u uniworx` + log-in as new user *uniworx*: + `sudo -i -u uniworx` you can now use `psql uniworx` to execute SQL-commands and such. - you might for example want to add a test-account to be able to login on the page:
- `INSERT INTO user (plugin, ident, matrikelnummer, email, display_name) VALUES ('LDAP', '[YOUR_EMAIL_ADDRESS]', null, '[YOUR_EMAIL_ADDRESS]', '[YOUR_NAME]');` - ## stack - Install with:
- `curl -sSL https://get.haskellstack.org/ | sh` + Install with: + `curl -sSL https://get.haskellstack.org/ | sh` - setup stack and install dependencies:
- `stack setup` + setup stack and install dependencies: + `stack setup` - There might be packages missing during setup. You most probably simply need to install them and try again.
- Instructions are easy to find via search engine of your choice and the specific error you got.
- Example from experience: For LDAP `ldab` and `lber` header files were missing. + During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using + `sudo apt-get install libsasl2-dev libldap2-dev` - Build the app:
- `stack build` + If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.* + Go ahead an install `libpq-dev` with + `sudo apt-get install libpq-dev` - Run the app (with environment variable DUMMY_LUGIN set to true):
- `env DUMMY_LOGIN=true stack exec -- yesod devel` + Build the app: + `stack build` - `Devel application launched: http://localhost:3000`
+ This might take a few minutes if not hours... be prepared. + + install yesod: + `stack install yesod-bin --install-ghc` + +## Add Dumy-Data and run the app + After building the app you can prepare the database and add some dummy data: + `./fill-db.hs` + + Run the app: + `./start.sh` + + `Devel application launched: http://localhost:3000` means you are good to go. + If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login. + *** # Sources and more infos - PostgreSQl:
+ PostgreSQl: https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-16-04 - stack:
https://docs.haskellstack.org/en/stable/README/#how-to-install + stack: https://docs.haskellstack.org/en/stable/README/#how-to-install - ldap:
https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/ + ldap: https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/ *** @@ -86,5 +100,19 @@ psql -U uniworx -d uniworx -h 127.0.0.1 -w --Zeige Tabellen \dt +--Zeige Tabellen Inhalt: +TABEL "user"; +-- Die Anführungszeichen können manchmal weggelassen werden, aber +-- bei user sind sie notwendig, da es auch Schlüsselwort in sql ist. + --Lösche Tabelle "course" und alle davon abhängigen: DROP TABLE "course" CASCADE; + +-- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer) +INSERT INTO "user_lecturer" (id,"user",school) VALUES (27,5,1); + +-- Beenden: +\q + +-- Hilfe: +\help diff --git a/fill-db.hs b/fill-db.hs index 41631aebb..dd8f42c62 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -14,6 +14,7 @@ main :: IO () main = db $ do now <- liftIO getCurrentTime let + summer2017 = TermIdentifier 2017 Summer winter2017 = TermIdentifier 2017 Winter summer2018 = TermIdentifier 2018 Summer gkleen <- insert User @@ -23,6 +24,29 @@ main = db $ do , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" } + fhamann <- insert User + { userPlugin = "LDAP" + , userIdent = "felix.hamann@campus.lmu.de" + , userMatrikelnummer = Nothing + , userEmail = "felix.hamann@campus.lmu.de" + , userDisplayName = "Felix Hamann" + } + jost <- insert User + { userPlugin = "LDAP" + , userIdent = "jost@tcs.ifi.lmu.de" + , userMatrikelnummer = Nothing + , userEmail = "jost@tcs.ifi.lmu.de" + , userDisplayName = "Steffen Jost" + } + void . insert $ Term + { termName = summer2017 + , termStart = fromGregorian 2017 04 09 + , termEnd = fromGregorian 2017 07 14 + , termHolidays = [] + , termLectureStart = fromGregorian 2017 04 09 + , termLectureEnd = fromGregorian 2018 07 14 + , termActive = False + } void . insert $ Term { termName = winter2017 , termStart = fromGregorian 2017 10 16 @@ -45,9 +69,16 @@ main = db $ do mi <- insert $ School "Institut für Mathematik" "MI" void . insert $ UserAdmin gkleen ifi void . insert $ UserAdmin gkleen mi + void . insert $ UserAdmin fhamann ifi + void . insert $ UserAdmin jost ifi + void . insert $ UserAdmin jost mi void . insert $ UserLecturer gkleen ifi + void . insert $ UserLecturer fhamann ifi + void . insert $ UserLecturer jost ifi ifiBsc <- insert $ Degree "Bachelor Informatik" ifi ifiMsc <- insert $ Degree "Master Informatik" ifi + miBsc <- insert $ Degree "Bachelor Mathematik" mi + -- FFP ffp <- insert Course { courseName = "Fortgeschrittene Funktionale Programmierung" , courseDescription = Nothing @@ -56,16 +87,96 @@ main = db $ do , courseTermId = TermKey summer2018 , courseSchoolId = ifi , courseCapacity = Just 20 - , courseCreated = now - , courseChanged = now - , courseCreatedBy = gkleen - , courseChangedBy = gkleen , courseHasRegistration = True , courseRegisterFrom = Just now , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) } + insert_ $ CourseEdit jost now ffp void . insert $ DegreeCourse ifiBsc ffp void . insert $ DegreeCourse ifiMsc ffp void . insert $ Lecturer gkleen ffp - void . insert $ Corrector gkleen ffp (ByProportion 1) - void . insert $ Sheet ffp "Blatt 1" Nothing NotGraded Nothing now now Nothing Nothing now now gkleen gkleen + insert_ $ Corrector gkleen ffp (ByProportion 1) + sheetkey <- insert $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing + insert_ $ SheetEdit gkleen now sheetkey + -- EIP + eip <- insert Course + { courseName = "Einführung in die Programmierung" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "eip" + , courseTermId = TermKey summer2017 + , courseSchoolId = ifi + , courseCapacity = Just 20 + , courseHasRegistration = False + , courseRegisterFrom = Nothing + , courseRegisterTo = Nothing + } + insert_ $ CourseEdit fhamann now eip + void . insert $ DegreeCourse ifiBsc eip + void . insert $ DegreeCourse ifiMsc eip + void . insert $ Lecturer fhamann eip + -- interaction design + ixd <- insert Course + { courseName = "Interaction Design (User Experience Design I & II)" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "ixd" + , courseTermId = TermKey summer2018 + , courseSchoolId = ifi + , courseCapacity = Just 20 + , courseHasRegistration = True + , courseRegisterFrom = Just now + , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) + } + insert_ $ CourseEdit fhamann now ixd + void . insert $ DegreeCourse ifiBsc ixd + void . insert $ Lecturer fhamann ixd + -- concept development + ux3 <- insert Course + { courseName = "Concept Development (User Experience Design III)" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "ux3" + , courseTermId = TermKey winter2017 + , courseSchoolId = ifi + , courseCapacity = Just 30 + , courseHasRegistration = False + , courseRegisterFrom = Nothing + , courseRegisterTo = Nothing + } + insert_ $ CourseEdit fhamann now ux3 + void . insert $ DegreeCourse ifiBsc ux3 + void . insert $ Lecturer fhamann ux3 + -- promo + pmo <- insert Course + { courseName = "Programmierung und Modellierung" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "pmo" + , courseTermId = TermKey summer2017 + , courseSchoolId = ifi + , courseCapacity = Just 50 + , courseHasRegistration = False + , courseRegisterFrom = Nothing + , courseRegisterTo = Nothing + } + insert_ $ CourseEdit jost now pmo + void . insert $ DegreeCourse ifiBsc pmo + void . insert $ Lecturer jost pmo + -- datenbanksysteme + dbs <- insert Course + { courseName = "Datenbanksysteme" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "dbs" + , courseTermId = TermKey summer2018 + , courseSchoolId = ifi + , courseCapacity = Just 50 + , courseHasRegistration = False + , courseRegisterFrom = Nothing + , courseRegisterTo = Nothing + } + insert_ $ CourseEdit gkleen now dbs + void . insert $ DegreeCourse ifiBsc dbs + void . insert $ Lecturer gkleen dbs + void . insert $ Lecturer jost dbs diff --git a/messages/de.msg b/messages/de.msg index 710f73cae..d56678c38 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -1,4 +1,24 @@ SummerTerm year@Integer: Sommersemester #{tshow year} WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year} PSLimitNonPositive: “pagesize” muss größer als null sein -Page n@Int64 num@Int64: Seite #{tshow n} von #{tshow num} \ No newline at end of file +Page n@Int64 num@Int64: Seite #{tshow n} von #{tshow num} +TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert. +TermNewTitle: Semester editiere/anlegen. +InvalidInput: Eingaben bitte korrigieren. +CourseNewOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt. +CourseEditOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert. +CourseNewDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. +CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. +SheetNewOk tid@TermIdentifier courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt. +SheetTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName} +SheetTitleNew tid@TermIdentifier courseShortHand@Text : #{termToText tid}-#{courseShortHand}: Neues Übungsblatt +SheetEditOk tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} aus Kurs #{termToText tid}-#{courseShortHand} wurde gespeichert. +SheetNameDup tid@TermIdentifier courseShortHand@Text sheetName@Text: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{termToText tid}-#{courseShortHand}. +SheetDelTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} wirklich aus Kurs #{termToText tid}-#{courseShortHand} herauslöschen? +SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben. +SheetDelOk tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. +UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. +UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. +UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. +UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen. +UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. diff --git a/models b/models index b910cb843..ea24256b9 100644 --- a/models +++ b/models @@ -11,7 +11,7 @@ UserAdmin UserLecturer user UserId school SchoolId - UniqueSchoolLecturer school user + UniqueSchoolLecturer user school StudyFeatures user UserId degree StudyDegreeId @@ -30,8 +30,8 @@ StudyTerms name Text Maybe Primary key Term json - name TermIdentifier - start Day + name TermIdentifier -- unTermKey :: TermId -> TermIdentifier + start Day -- TermKey :: TermIdentifier -< TermId end Day holidays [Day] lectureStart Day @@ -61,14 +61,14 @@ Course termId TermId schoolId SchoolId capacity Int Maybe - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId hasRegistration Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo registerFrom UTCTime Maybe registerTo UTCTime Maybe - CourseTermShort termId shorthand + CourseTermShort termId shorthand +CourseEdit + user UserId + time UTCTime + course CourseId Lecturer userId UserId courseId CourseId @@ -90,22 +90,24 @@ CourseParticipant courseId CourseId userId UserId registration UTCTime - UniqueCourseParticipant courseId userId + UniqueParticipant userId courseId Sheet courseId CourseId name Text description Html Maybe type SheetType + grouping SheetGroup markingText Html Maybe + visibleFrom UTCTime Maybe activeFrom UTCTime activeTo UTCTime hintFrom UTCTime Maybe solutionFrom UTCTime Maybe - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId CourseSheet courseId name +SheetEdit + user UserId + time UTCTime + sheet SheetId SheetFile sheetId SheetId fileId FileId @@ -122,11 +124,11 @@ Submission ratingComment Text Maybe ratingBy UserId Maybe ratingTime UTCTime Maybe - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId deriving Show +SubmissionEdit + user UserId + time UTCTime + submission SubmissionId SubmissionFile submissionId SubmissionId fileId FileId @@ -141,10 +143,10 @@ SubmissionUser SubmissionGroup courseId CourseId name Text - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId +SubmissionGroupEdit + user UserId + time UTCTime + submissionGroup SubmissionGroupId SubmissionGroupUser submissionGroupId SubmissionGroupId userId UserId @@ -163,13 +165,12 @@ Booking end UTCTime weekly Bool exceptions [Day] -- only if weekly, begin in exception - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId - bookedFor RoomForId room RoomId +BookingEdit + user UserId + time UTCTime + boooking BookingId Room name Text capacity Int Maybe @@ -195,10 +196,10 @@ Exam deregistrationEnd UTCTime ratingVisible Bool statisticsVisible Bool - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId +ExamEdit + user UserId + time UTCTime + exam ExamId ExamUser userId UserId examId ExamId diff --git a/routes b/routes index 8c074546b..d8d4010e7 100644 --- a/routes +++ b/routes @@ -6,25 +6,29 @@ / HomeR GET POST /profile ProfileR GET -/users UsersR GET +/users UsersR GET !adminAny -/term TermShowR GET -/term/edit TermEditR GET POST -/term/#TermId/edit TermEditExistR GET +/term TermShowR GET +/term/edit TermEditR GET POST !adminAny +/term/#TermId/edit TermEditExistR GET !adminAny /course/ CourseListR GET -!/course/new CourseEditR GET POST -!/course/#TermId CourseListTermR GET -/course/#TermId/#Text/edit CourseEditExistR GET -/course/#TermId/#Text/show CourseShowR GET POST +!/course/new CourseNewR GET POST !lecturerAny +!/course/#TermId CourseListTermR GET +/course/#TermId/#Text CourseR: + /show CourseShowR GET POST + /edit CourseEditR GET POST !lecturer -/course/#TermId/#Text/sheet/ SheetListR GET -/course/#TermId/#Text/sheet/#Text/show SheetShowR GET -/course/#TermId/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR GET -/course/#TermId/#Text/sheet/new SheetNewR GET POST -/course/#TermId/#Text/sheet/#SheetId/edit SheetEditR GET POST -/course/#TermId/#Text/sheet/#SheetId/delete SheetDelR GET POST + /ex SheetR !registered: + / SheetListR GET + /#Text/show SheetShowR GET !time + /#Text/#SheetFileType/#FilePath SheetFileR GET !time + /new SheetNewR GET POST !lecturer + /#Text/edit SheetEditR GET POST !lecturer + /#Text/delete SheetDelR GET POST !lecturer + +-- TODO below /submission SubmissionListR GET POST /submission/#CryptoUUIDSubmission SubmissionR GET POST /submissions.zip SubmissionDownloadMultiArchiveR POST @@ -34,4 +38,4 @@ !/#UUID CryptoUUIDDispatchR GET -- For demonstration -/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET +/course/#CryptoUUIDCourse/edit CourseEditIDR GET diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 25d19fdca..ed2864eab 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -34,5 +34,6 @@ instance PathPiece UUID where decCryptoIDs [ ''SubmissionId , ''CourseId , ''SheetId + , ''FileId ] {- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -} diff --git a/src/Foundation.hs b/src/Foundation.hs index 0bc8713fc..e10d1c515 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} @@ -51,6 +52,11 @@ import Handler.Utils.StudyFeatures import System.FilePath +import Handler.Utils.Templates + +-- infixl 9 :$: +-- pattern a :$: b = a b + -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have @@ -78,18 +84,27 @@ data UniWorX = UniWorX -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") +-- Pattern Synonyms for convenience +pattern CSheetR tid csh ptn = CourseR tid csh (SheetR ptn) + + data MenuItem = MenuItem { menuItemLabel :: Text + , menuItemIcon :: Maybe Text , menuItemRoute :: Route UniWorX , menuItemAccessCallback :: Handler Bool } -data MenuTypes - = NavbarLeft { menuItem :: MenuItem } - | NavbarRight { menuItem :: MenuItem } - | NavbarExtra { menuItem :: MenuItem } +data MenuTypes -- Semantische Rolle: + = NavbarAside { menuItem :: MenuItem } -- TODO + | NavbarExtra { menuItem :: MenuItem } -- TODO + | NavbarRight { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar + | NavbarSecondary { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar + | PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig + | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten --- | A convenient synonym for creating forms. +-- | Convenient Type Synonyms: +type DB a = YesodDB UniWorX a type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) mkMessage "UniWorX" "messages" "de" @@ -145,7 +160,7 @@ instance Yesod UniWorX where isAuthorized TermShowR _ = return Authorized isAuthorized CourseListR _ = return Authorized isAuthorized (CourseListTermR _) _ = return Authorized - isAuthorized (CourseShowR _ _) _ = return Authorized + isAuthorized (CourseR _ _ CourseShowR) _ = return Authorized isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized isAuthorized SubmissionListR _ = isAuthenticated isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated @@ -192,16 +207,28 @@ instance Yesod UniWorX where makeLogger = return . appLogger isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult +isAuthorizedDB route@(routeAttrs -> attrs) writeable + | "adminAny" `member` attrs = adminAccess Nothing + | "lecturerAny" `member` attrs = lecturerAccess Nothing + + + isAuthorizedDB UsersR _ = adminAccess Nothing -isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID +isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName -isAuthorizedDB TermEditR _ = adminAccess Nothing -isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing -isAuthorizedDB CourseEditR _ = lecturerAccess Nothing -isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseEditExistIDR cID) _ = do +isAuthorizedDB TermEditR _ = adminAccess Nothing +isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing +isAuthorizedDB CourseNewR _ = lecturerAccess Nothing +isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized -- +isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor +isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor +isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseEditIDR cID) _ = do courseId <- decrypt cID courseLecturerAccess courseId isAuthorizedDB _route _isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop! @@ -219,29 +246,45 @@ submissionAccess cID = do adminAccess :: Maybe SchoolId -- ^ If @Just@, matched exactly against 'userAdminSchool' -> YesodDB UniWorX AuthResult -adminAccess school = do +adminAccess school = do authId <- lift requireAuthId - adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) [] - return $ if (not $ null adrights) + adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) [] + return $ if (not $ null adrights) then Authorized - else Unauthorized "No admin access" + else Unauthorized "No admin access" -- TODO internationalize lecturerAccess :: Maybe SchoolId -> YesodDB UniWorX AuthResult lecturerAccess school = do authId <- lift requireAuthId - lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) [] + lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) [] return $ if (not $ null lecrights) then Authorized - else Unauthorized "No lecturer access" + else Unauthorized "No lecturer access" -- TODO internationalize + +lecturerAccess' :: SchoolId -> YesodDB UniWorX AuthResult +lecturerAccess' = authorizedFor UniqueSchoolLecturer MsgUnauthorizedSchoolLecturer courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult -courseLecturerAccess courseId = do +courseLecturerAccess = authorizedFor UniqueLecturer MsgUnauthorizedLecturer + +courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult +courseCorrectorAccess = authorizedFor UniqueCorrector MsgUnauthorizedCorrector + +courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult +courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant + +authorizedFor :: ( PersistEntityBackend record ~ BaseBackend backend + , PersistEntity record, PersistUniqueRead backend + , YesodAuth master, RenderMessage master msg + ) + => (AuthId master -> t -> Unique record) -> msg -> t -> ReaderT backend (HandlerT master IO) AuthResult +authorizedFor authType msg courseId = do authId <- lift requireAuthId - users <- map (lecturerUserId . entityVal ) <$> selectList [ LecturerCourseId ==. courseId ] [] - return $ case authId `elem` users of - True -> Authorized - False -> Unauthorized "No lecturer access for this course" + access <- getBy $ authType authId courseId + case access of + (Just _) -> return Authorized + Nothing -> unauthorizedI msg isAuthorizedDB' :: Route UniWorX -> Bool -> YesodDB UniWorX Bool isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite @@ -250,61 +293,82 @@ isAuthorized' :: Route UniWorX -> Bool -> Handler Bool isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite -- Define breadcrumbs. -instance YesodBreadcrumbs UniWorX where +instance YesodBreadcrumbs UniWorX where breadcrumb TermShowR = return ("Semester", Just HomeR) breadcrumb TermEditR = return ("Neu", Just TermShowR) breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) - - breadcrumb CourseListR = return ("Kurs", Just HomeR) - breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) - breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term) - breadcrumb CourseEditR = return ("Neu", Just CourseListR) - breadcrumb (CourseEditExistR _ _) = return ("Editieren", Just CourseListR) - breadcrumb (SheetListR tid csh) = return ("Kurs", Just $ CourseShowR tid csh) - breadcrumb (SheetShowR tid csh _shn) = return ("Übungen", Just $ SheetListR tid csh) + breadcrumb CourseListR = return ("Kurs", Just HomeR) + breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) + breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term) + breadcrumb CourseNewR = return ("Neu", Just CourseListR) + breadcrumb (CourseR _ _ CourseEditR) = return ("Editieren", Just CourseListR) + + breadcrumb (CourseR tid csh (SheetR SheetListR)) = return ("Übungen",Just $ CourseR tid csh CourseShowR) + breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR) + breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR) + breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) + breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR) - + breadcrumb HomeR = return ("ReWorX", Nothing) breadcrumb (AuthR _) = return ("Login", Just HomeR) breadcrumb ProfileR = return ("Profile", Just HomeR) breadcrumb _ = return ("home", Nothing) - + defaultLinks :: [MenuTypes] defaultLinks = -- Define the menu items of the header. - [ NavbarLeft $ MenuItem + [ NavbarRight $ MenuItem { menuItemLabel = "Home" + , menuItemIcon = Just "home" , menuItemRoute = HomeR , menuItemAccessCallback = return True } - , NavbarLeft $ MenuItem - { menuItemLabel = "Kurse" - , menuItemRoute = CourseListR - , menuItemAccessCallback = return True - } - , NavbarRight $ MenuItem - { menuItemLabel = "Users" - , menuItemRoute = UsersR - , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False - } , NavbarRight $ MenuItem { menuItemLabel = "Profile" + , menuItemIcon = Just "profile" , menuItemRoute = ProfileR , menuItemAccessCallback = isJust <$> maybeAuthPair } - , NavbarRight $ MenuItem + , NavbarSecondary $ MenuItem { menuItemLabel = "Login" + , menuItemIcon = Just "login" , menuItemRoute = AuthR LoginR , menuItemAccessCallback = isNothing <$> maybeAuthPair } - , NavbarRight $ MenuItem + , NavbarSecondary $ MenuItem { menuItemLabel = "Logout" + , menuItemIcon = Just "logout" , menuItemRoute = AuthR LogoutR , menuItemAccessCallback = isJust <$> maybeAuthPair } + , NavbarAside $ MenuItem + { menuItemLabel = "Aktuelle Veranstaltungen" + , menuItemIcon = Just "book" + , menuItemRoute = CourseListR -- should be CourseListActiveR or similar in the future + , menuItemAccessCallback = return True + } + , NavbarAside $ MenuItem + { menuItemLabel = "Alte Veranstaltungen" + , menuItemIcon = Just "book" + , menuItemRoute = CourseListR -- should be CourseListInactiveR or similar in the future + , menuItemAccessCallback = return True + } + , NavbarAside $ MenuItem + { menuItemLabel = "Veranstaltungen" + , menuItemIcon = Just "book" + , menuItemRoute = CourseListR + , menuItemAccessCallback = return True + } + , NavbarAside $ MenuItem + { menuItemLabel = "Benutzer" + , menuItemIcon = Just "user" + , menuItemRoute = UsersR + , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False + } ] defaultLinkLayout :: [MenuTypes] -> Widget -> Handler Html @@ -328,12 +392,34 @@ defaultMenuLayout menu widget = do -- value passed to hamletToRepHtml cannot be a widget, this allows -- you to use normal widget features in default-layout. + let + navbar :: Widget + navbar = $(widgetFile "widgets/navbar") + asidenav :: Widget + asidenav = $(widgetFile "widgets/asidenav") + breadcrumbs :: Widget + breadcrumbs = $(widgetFile "widgets/breadcrumbs") + pageactionprime :: Widget + pageactionprime = $(widgetFile "widgets/pageactionprime") + -- functions to determine if there are page-actions + isPageActionPrime :: MenuTypes -> Bool + isPageActionPrime (PageActionPrime _) = True + isPageActionPrime _ = False + hasPageActions :: Bool + hasPageActions = any isPageActionPrime menuTypes + pc <- widgetToPageContent $ do - addStylesheet $ StaticR css_bootstrap_css + addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900" + addScript $ StaticR js_featureChecker_js + addStylesheet $ StaticR css_fonts_css + addStylesheet $ StaticR css_icons_css $(widgetFile "default-layout") + $(widgetFile "standalone/modal") + $(widgetFile "standalone/showHide") + $(widgetFile "standalone/sortable") + $(widgetFile "standalone/inputs") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - -- How to run database actions. instance YesodPersist UniWorX where type YesodPersistBackend UniWorX = SqlBackend @@ -363,7 +449,7 @@ instance YesodAuth UniWorX where $logDebugS "auth" $ tshow ((userPlugin, userIdent), creds) - when isDummy . (throwError =<<) . lift $ + when isDummy . (throwError =<<) . lift $ maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth let @@ -373,7 +459,7 @@ instance YesodAuth UniWorX where userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") return userEmail' userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName' - + let newUser = User{..} userUpdate = [ UserMatrikelnummer =. userMatrikelnummer @@ -388,13 +474,13 @@ instance YesodAuth UniWorX where userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ] fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - + lift $ deleteWhere [StudyFeaturesUser ==. userId] forM_ fs $ \StudyFeatures{..} -> do lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing - + lift $ insertMany_ fs return $ Authenticated userId where @@ -419,7 +505,7 @@ ldapConfig _app@(appSettings -> settings) = LDAPConfig } where principalName :: IsString a => a - principalName = "userPrincipalName" + principalName = "userPrincipalName" identifierModifier _ entry = case lookup principalName $ leattrs entry of Just [n] -> Text.pack n _ -> error "Could not determine user principal name" diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 28250fb7d..c12cc46af 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -9,38 +9,38 @@ module Handler.Course where -import Import +import Import import Handler.Utils -- import Data.Time import qualified Data.Text as T import Data.Function ((&)) -import Yesod.Form.Bootstrap3 +import Yesod.Form.Bootstrap3 import Colonnade hiding (fromMaybe) -import Yesod.Colonnade +import Yesod.Colonnade import qualified Data.UUID.Cryptographic as UUID getCourseListR :: Handler TypedContent -getCourseListR = redirect TermShowR +getCourseListR = redirect TermShowR getCourseListTermR :: TermId -> Handler Html getCourseListTermR tidini = do - (term,courses) <- runDB $ (,) + (term,courses) <- runDB $ (,) <$> get tidini <*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand] when (isNothing term) $ do addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |] redirect TermShowR - -- TODO: several runDBs per TableRow are probably too inefficient! - let colonnadeTerms = mconcat - [ headed "Kürzel" $ (\ckv -> + -- TODO: several runDBs per TableRow are probably too inefficient! + let colonnadeTerms = mconcat + [ headed "Kürzel" $ (\ckv -> let c = entityVal ckv - shd = courseShorthand c + shd = courseShorthand c tid = courseTermId c - in [whamlet| #{shd} |] ) + in [whamlet| #{shd} |] ) -- , headed "Institut" $ [shamlet| #{course} |] , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal , headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal @@ -49,201 +49,237 @@ getCourseListTermR tidini = do partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourseId ==. cid] [whamlet| #{show partiNum} |] ) - , headed " " $ (\ckv -> + , headed " " $ (\ckv -> let c = entityVal ckv - shd = courseShorthand c + shd = courseShorthand c tid = courseTermId c in do - adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False - -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else "" - [whamlet| + adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False + -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else "" + [whamlet| $if adminLink == Authorized - + editieren |] - ) + ) ] - let pageLinks = - [ NavbarLeft $ MenuItem + let pageLinks = + [ PageActionPrime $ MenuItem { menuItemLabel = "Neuer Kurs" - , menuItemRoute = CourseEditR - , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseEditR False + , menuItemIcon = Just "book" + , menuItemRoute = CourseNewR + , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False } - ] + ] + let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses defaultLinkLayout pageLinks $ do --- defaultLayout $ do - setTitle "Semesterkurse" - linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR - encodeWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses) + setTitle "Semesterkurse" + $(widgetFile "courses") getCourseShowR :: TermId -> Text -> Handler Html getCourseShowR tid csh = do mbAid <- maybeAuthId (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh - dependent <- (,,) + dependent <- (,,) <$> get (courseSchoolId course) -- join - <*> count [CourseParticipantCourseId ==. cid] -- join + <*> count [CourseParticipantCourseId ==. cid] -- join <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! Nothing -> return False (Just aid) -> do - regL <- getBy (UniqueCourseParticipant cid aid) + regL <- getBy (UniqueParticipant aid cid) return $ isJust regL) return $ (courseEnt,dependent) - let course = entityVal courseEnt - (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered - defaultLayout $ do + let course = entityVal courseEnt + (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered + let pageActions = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Übungsblätter" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh SheetListR + , menuItemAccessCallback = (== Authorized) <$> isAuthorized (CSheetR tid csh SheetListR) False + } + ] + defaultLinkLayout pageActions $ do setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") - + registerButton :: Bool -> Form () -registerButton registered = renderAForm FormStandard $ - pure () <* bootstrapSubmit regMsg - where +registerButton registered = renderAForm FormStandard $ + pure () <* bootstrapSubmit regMsg + where msg = if registered then "Abmelden" else "Anmelden" regMsg = msg :: BootstrapSubmit Text - + postCourseShowR :: TermId -> Text -> Handler Html postCourseShowR tid csh = do aid <- requireAuthId (cid, registered) <- runDB $ do (Entity cid _) <- getBy404 $ CourseTermShort tid csh - registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid) + registered <- isJust <$> (getBy $ UniqueParticipant aid cid) return (cid, registered) - ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered - case regResult of + ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered + case regResult of (FormSuccess _) - | registered -> do - runDB $ deleteBy $ UniqueCourseParticipant cid aid - addMessage "info" "Sie wurden abgemeldet." + | registered -> do + runDB $ deleteBy $ UniqueParticipant aid cid + addMessage "info" "Sie wurden abgemeldet." | otherwise -> do actTime <- liftIO $ getCurrentTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!" (_other) -> return () -- TODO check this! -- redirect or not?! I guess not, since we want GET now - getCourseShowR tid csh - -getCourseEditR :: Handler Html -getCourseEditR = do + getCourseShowR tid csh + +getCourseNewR :: Handler Html +getCourseNewR = do -- TODO: Defaults für Semester hier ermitteln und übergeben courseEditHandler Nothing - -postCourseEditR :: Handler Html -postCourseEditR = courseEditHandler Nothing - -getCourseEditExistR :: TermId -> Text -> Handler Html -getCourseEditExistR tid csh = do + +postCourseNewR :: Handler Html +postCourseNewR = courseEditHandler Nothing + +getCourseEditR :: TermId -> Text -> Handler Html +getCourseEditR tid csh = do course <- runDB $ getBy $ CourseTermShort tid csh courseEditHandler course -getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html -getCourseEditExistIDR cID = do +postCourseEditR :: TermId -> Text -> Handler Html +postCourseEditR = getCourseEditR + +getCourseEditIDR :: CryptoUUIDCourse -> Handler Html +getCourseEditIDR cID = do cIDKey <- getsYesod appCryptoIDKey courseID <- UUID.decrypt cIDKey cID courseEditHandler =<< runDB (getEntity courseID) - -courseEditHandler :: Maybe (Entity Course) -> Handler Html -courseEditHandler course = do - aid <- requireAuthId - ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course - action <- lookupPostParam "formaction" - case (result,action) of - (FormSuccess res, fAct) - | fAct == formActionDelete - , Just cid <- cfCourseId res -> do + +courseDeleteHandler :: Handler Html -- not called anywhere yet +courseDeleteHandler = undefined +{- 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!|] redirect $ CourseListTermR $ cfTerm res - | fAct == formActionSave - , Just cid <- cfCourseId res -> do - let tid = cfTerm res - actTime <- liftIO getCurrentTime - updateokay <- runDB $ do - exists <- getBy $ CourseTermShort tid $ cfShort res - let upokay = isNothing exists - when upokay $ update cid - [ CourseName =. cfName res - , CourseDescription =. cfDesc res - , CourseLinkExternal =. cfLink res - , CourseShorthand =. cfShort res -- TODO: change here should generate a warning, or only allowed for Admins?! - , CourseTermId =. tid -- TODO: change here should generate a warning, or only allowed for Admins?! - , CourseSchoolId =. cfSchool res - , CourseCapacity =. cfCapacity res - , CourseRegisterFrom =. cfRegFrom res - , CourseRegisterTo =. cfRegTo res - , CourseChangedBy =. aid - , CourseChanged =. actTime - ] - return upokay - let cti = toPathPiece $ cfTerm res - if updateokay - then do - addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |] - redirect $ CourseListTermR $ cfTerm res - else do - addMessage "danger" [shamlet| Kurs #{cti}/#{cfShort res} konnte nicht geändert werden. - \ Es gibt bereits einen anderen Kurs mit diesem Kürzel in diesem Semester.|] - | fAct == formActionSave - , Nothing <- cfCourseId res -> do - actTime <- liftIO getCurrentTime - insertOkay <- runDB $ insertUnique $ Course - { courseName = cfName res - , courseDescription = cfDesc res - , courseLinkExternal = cfLink res - , courseShorthand = cfShort res - , courseTermId = cfTerm res - , courseSchoolId = cfSchool res - , courseCapacity = cfCapacity res - , courseHasRegistration = cfHasReg res - , courseRegisterFrom = cfRegFrom res - , courseRegisterTo = cfRegTo res - , courseCreated = actTime - , courseChanged = actTime - , courseCreatedBy = aid - , courseChangedBy = aid - } - case insertOkay of - (Just cid) -> do - runDB $ insert_ $ Lecturer aid cid - let cti = toPathPiece $ cfTerm res - addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|] - redirect $ CourseListTermR $ cfTerm res - Nothing -> do - let cti = toPathPiece $ cfTerm res - addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|] - (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren." - _other -> return () +-} + +courseEditHandler :: Maybe (Entity Course) -> Handler Html +courseEditHandler course = do + aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! + ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course + case result of + (FormSuccess res@( + CourseForm { cfCourseId = Nothing + , cfShort = csh + , cfTerm = tid + })) -> do -- create new course + let tident = unTermKey tid + now <- liftIO getCurrentTime + insertOkay <- runDB $ insertUnique $ Course + { courseName = cfName res + , courseDescription = cfDesc res + , courseLinkExternal = cfLink res + , courseShorthand = cfShort res + , courseTermId = cfTerm res + , courseSchoolId = cfSchool res + , courseCapacity = cfCapacity res + , courseHasRegistration = cfHasReg res + , courseRegisterFrom = cfRegFrom res + , courseRegisterTo = cfRegTo res + } + case insertOkay of + (Just cid) -> do + runDB $ do + insert_ $ CourseEdit aid now cid + insert_ $ Lecturer aid cid + addMessageI "info" $ MsgCourseNewOk tident csh + redirect $ CourseListTermR tid + Nothing -> + addMessageI "danger" $ MsgCourseNewDupShort tident csh + + (FormSuccess res@( + CourseForm { cfCourseId = Just cid + , cfShort = csh + , cfTerm = tid + })) -> do -- edit existing course + let tident = unTermKey tid + now <- liftIO getCurrentTime + -- addMessage "debug" [shamlet| #{show res}|] + runDB $ do + old <- get cid + case old of + Nothing -> addMessageI "error" $ MsgInvalidInput + (Just oldCourse) -> do + -- existing <- getBy $ CourseTermShort tid csh + -- if ((entityKey <$> existing) /= Just cid) + -- then addMessageI "danger" $ MsgCourseEditDupShort tident csh + -- else do + -- addMessage "debug" $ fromMaybe [shamlet|No description given.|] $ cfDesc res +-- update cid +-- [ CourseName =. cfName res +-- , CourseDescription =. cfDesc res +-- , CourseLinkExternal =. cfLink res +-- , CourseShorthand =. cfShort res -- TODO: change here should generate a warning, or only allowed for Admins?! +-- , CourseTermId =. tid -- TODO: change here should generate a warning, or only allowed for Admins?! +-- , CourseSchoolId =. cfSchool res +-- , CourseCapacity =. cfCapacity res +-- , CourseRegisterFrom =. cfRegFrom res +-- , CourseRegisterTo =. cfRegTo res +-- , CourseChangedBy =. aid +-- , CourseChanged =. now +-- ] + _updOkay <- replace cid ( -- TODO replaceUnique requires Eq?! + Course { courseName = cfName res + , courseDescription = cfDesc res + , courseLinkExternal = cfLink res + , courseShorthand = cfShort res + , courseTermId = cfTerm res + , courseSchoolId = cfSchool res + , courseCapacity = cfCapacity res + , courseHasRegistration = cfHasReg res + , courseRegisterFrom = cfRegFrom res + , courseRegisterTo = cfRegTo res + } + ) + insert_ $ CourseEdit aid now cid +-- if (isNothing updOkay) +-- then do + addMessageI "info" $ MsgCourseEditOk tident csh + -- redirect $ CourseListTermR tid +-- else addMessageI "danger" $ MsgCourseEditDupShort tident csh + + (FormFailure _) -> addMessageI "warning" MsgInvalidInput + other -> addMessage "error" $ [shamlet| Error: #{show other}|] let formTitle = "Kurs editieren/anlegen" :: Text - let actionUrl = CourseEditR - let formActions = defaultFormActions + actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute defaultLayout $ do setTitle [shamlet| #{formTitle} |] $(widgetFile "formPage") - - -data CourseForm = CourseForm + + +data CourseForm = CourseForm { cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse - , cfName :: Text + , cfName :: Text , cfDesc :: Maybe Html - , cfLink :: Maybe Text - , cfShort :: Text + , cfLink :: Maybe Text + , cfShort :: Text , cfTerm :: TermId , cfSchool :: SchoolId - , cfCapacity :: Maybe Int + , cfCapacity :: Maybe Int , cfHasReg :: Bool - , cfRegFrom :: Maybe UTCTime - , cfRegTo :: Maybe UTCTime - } + , cfRegFrom :: Maybe UTCTime + , cfRegTo :: Maybe UTCTime + } instance Show CourseForm where show cf = T.unpack (cfShort cf) ++ ' ':(show $ cfCourseId cf) - + courseToForm :: Entity Course -> CourseForm -courseToForm cEntity = CourseForm +courseToForm cEntity = CourseForm { cfCourseId = Just $ entityKey cEntity , cfName = courseName course , cfDesc = courseDescription course @@ -253,26 +289,26 @@ courseToForm cEntity = CourseForm , cfSchool = courseSchoolId course , cfCapacity = courseCapacity course , cfHasReg = courseHasRegistration course - , cfRegFrom = courseRegisterFrom course - , cfRegTo = courseRegisterTo course + , cfRegFrom = courseRegisterFrom course + , cfRegTo = courseRegisterTo course } where course = entityVal cEntity - + newCourseForm :: Maybe CourseForm -> Form CourseForm newCourseForm template = identForm FIDcourse $ \html -> do - -- mopt hiddenField + -- mopt hiddenField -- cidKey <- getsYesod appCryptoIDKey -- courseId <- runMaybeT $ do -- cid <- cfCourseId template - -- UUID.encrypt cidKey cid + -- UUID.encrypt cidKey cid (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? <$> aopt hiddenField "KursId" (cfCourseId <$> template) <*> areq textField (fsb "Name") (cfName <$> template) <*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template) <*> aopt urlField (fsb "Homepage") (cfLink <$> template) - <*> areq textField (fsb "Kürzel" + <*> areq textField (fsb "Kürzel" -- & addAttr "disabled" "disabled" & setTooltip "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template) @@ -282,9 +318,9 @@ newCourseForm template = identForm FIDcourse $ \html -> do <*> areq checkBoxField (fsb "Anmeldung") (cfHasReg <$> template) <*> aopt utcTimeField (fsb "Anmeldung von:") (cfRegFrom <$> template) <*> aopt utcTimeField (fsb "Anmeldung bis:") (cfRegTo <$> template) - -- <* bootstrapSubmit (bsSubmit (show cid)) - return $ case result of - FormSuccess courseResult + <* submitButton + return $ case result of + FormSuccess courseResult | errorMsgs <- validateCourse courseResult , not $ null errorMsgs -> (FormFailure errorMsgs, @@ -293,18 +329,18 @@ newCourseForm template = identForm FIDcourse $ \html -> do

Fehler: