Merge branch 'master' into 'live'
Fancier Breadcrumbs, Sheet-UploadMode, Overhauled Authentication Closes #190, #189, #188, #150, #148, #147, #86, #186, #183, and #181 See merge request !77
This commit is contained in:
Gregor Kleen
commit
8b05f1eb05
@ -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
|
||||
|
||||
|
||||
@ -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"
|
||||
|
||||
27
db.hs
27
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
|
||||
}
|
||||
|
||||
1
messages/dummy/de.msg
Normal file
1
messages/dummy/de.msg
Normal file
@ -0,0 +1 @@
|
||||
DummyIdent: Nutzer-Kennung
|
||||
2
messages/pw-hash/de.msg
Normal file
2
messages/pw-hash/de.msg
Normal file
@ -0,0 +1,2 @@
|
||||
PWHashIdent: Identifikation
|
||||
PWHashPassword: Passwort
|
||||
@ -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
|
||||
|
||||
22
models
22
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
|
||||
|
||||
11
routes
11
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
|
||||
|
||||
@ -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{..}
|
||||
|
||||
63
src/Auth/Dummy.hs
Normal file
63
src/Auth/Dummy.hs
Normal file
@ -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")
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
105
src/Auth/PWHash.hs
Normal file
105
src/Auth/PWHash.hs
Normal file
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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|
|
||||
<h1>TODO
|
||||
<h2>Admin Page for User #{display userDisplayName}
|
||||
<h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
|
||||
|]
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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|<span style="float:right"> ^{modalStatic descr} |]
|
||||
[whamlet|
|
||||
$newline never
|
||||
<span style="float:right">
|
||||
^{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|
|
||||
<h1>TODO
|
||||
<h2>Lecturer's Page for User ^{nameWidget userDisplayName userSurname}
|
||||
|]
|
||||
|
||||
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCHiWisR tid ssh csh = undefined -- TODO
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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|
|
||||
<form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
|
||||
<h2>
|
||||
Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
|
||||
<div .container>
|
||||
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.
|
||||
<div .container>
|
||||
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.
|
||||
<div .container>
|
||||
<em>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.)
|
||||
<div .container>
|
||||
<em>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.
|
||||
<div .container>
|
||||
^{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 {..}
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -12,6 +12,8 @@ module Handler.Utils
|
||||
import Import
|
||||
|
||||
import qualified Data.Text as T
|
||||
-- import qualified Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils.DateTime as Handler.Utils
|
||||
import Handler.Utils.Form as Handler.Utils
|
||||
@ -34,6 +36,11 @@ downloadFiles = do
|
||||
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
|
||||
return userDefaultDownloadFiles
|
||||
|
||||
tidFromText :: Text -> Maybe TermId
|
||||
tidFromText = (fmap TermKey) . maybeRight . termFromText
|
||||
|
||||
simpleLink :: Widget -> Route UniWorX -> Widget
|
||||
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
|
||||
|
||||
nameWidget :: Text -> Text -> Widget
|
||||
nameWidget displayName surname
|
||||
@ -52,3 +59,17 @@ nameWidget displayName surname
|
||||
|]
|
||||
[] -> error "Data.Text.splitOn returned empty list in violation of specification."
|
||||
|
||||
|
||||
warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
|
||||
warnTermDays tid times = do
|
||||
Term{..} <- get404 tid
|
||||
let alldays = Set.map utctDay $ Set.fromList $ catMaybes times
|
||||
warnholidays = Set.intersection alldays $ Set.fromList termHolidays
|
||||
outoftermdays = Set.filter (\d -> d < termStart || d > termEnd ) alldays
|
||||
outoflecture = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
|
||||
`Set.difference` outoftermdays -- out of term implies out of lecture-time
|
||||
warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid dt
|
||||
forM_ warnholidays $ warnI MsgDayIsAHoliday
|
||||
forM_ outoflecture $ warnI MsgDayIsOutOfLecture
|
||||
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
|
||||
|
||||
|
||||
@ -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| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
|
||||
-- [whamlet|
|
||||
-- <form method=post action=@{url}>
|
||||
@ -120,10 +121,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
|
||||
-- |]
|
||||
-- <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
|
||||
|
||||
simpleLink :: Widget -> Route UniWorX -> Widget
|
||||
simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]
|
||||
|
||||
|
||||
{-
|
||||
combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
|
||||
combinedButtonField btns inner csrf = do
|
||||
@ -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{..}
|
||||
|
||||
@ -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) $
|
||||
|
||||
@ -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| <span style="float:right"> ^{modalStatic descr} |]
|
||||
(Just descr) -> cell [whamlet|
|
||||
$newline never
|
||||
<span style="float:right">
|
||||
^{modal "Beschreibung" (Right $ toWidget descr)}
|
||||
|]
|
||||
|
||||
sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
|
||||
sheetCell crse shn =
|
||||
|
||||
@ -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'
|
||||
|
||||
@ -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|<div .tooltip__handle ##{uniqueId}>?|] -- 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|<a .btn ##{triggerId} href=@{route}>^{modalTrigger}|]
|
||||
Right content -> [whamlet|<div .btn ##{triggerId}>^{modalTrigger}|]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"';
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
32
src/Utils.hs
32
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 --
|
||||
---------------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
<datalist ##{listId}>
|
||||
$forall value <- values
|
||||
<option value=#{value}>
|
||||
|]
|
||||
}
|
||||
|
||||
------------------------------------------------
|
||||
-- Unique Form Identifiers to avoid accidents --
|
||||
------------------------------------------------
|
||||
@ -178,7 +195,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
|
||||
fieldParse [] _ = return $ Right Nothing
|
||||
fieldParse [str] _
|
||||
| str == toPathPiece btn = return $ Right $ Just btn
|
||||
| otherwise = return $ Left "Wrong button value"
|
||||
| otherwise = return $ Left "Wrong button value" -- SJ: Right Nothing?!
|
||||
fieldParse _ _ = return $ Left "Multiple button values"
|
||||
|
||||
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
|
||||
@ -188,3 +205,14 @@ combinedButtonField btns = traverse b2f btns
|
||||
|
||||
submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
|
||||
submitButton = void $ combinedButtonField [BtnSubmit]
|
||||
|
||||
-------------------
|
||||
-- Custom Fields --
|
||||
-------------------
|
||||
|
||||
ciField :: ( Textual t
|
||||
, CI.FoldCase t
|
||||
, Monad m
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
) => Field m (CI t)
|
||||
ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField
|
||||
|
||||
35
src/Utils/Message.hs
Normal file
35
src/Utils/Message.hs
Normal file
@ -0,0 +1,35 @@
|
||||
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module Utils.Message
|
||||
( MessageClass(..)
|
||||
, addMessage, addMessageI
|
||||
) where
|
||||
|
||||
|
||||
import Data.Text as Text (toLower)
|
||||
import Data.Universe
|
||||
import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
|
||||
|
||||
import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
|
||||
import ClassyPrelude.Yesod (PathPiece(..),MonadHandler,HandlerSite,RenderMessage,Html)
|
||||
|
||||
|
||||
data MessageClass = Error | Warning | Info | Success
|
||||
deriving (Eq,Ord,Enum,Bounded,Show,Read)
|
||||
|
||||
instance Universe MessageClass
|
||||
instance Finite MessageClass
|
||||
|
||||
$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
|
||||
|
||||
instance PathPiece MessageClass where
|
||||
toPathPiece = $(nullaryToPathPiece ''MessageClass [Text.toLower])
|
||||
fromPathPiece = finiteFromPathPiece
|
||||
|
||||
addMessage :: MonadHandler m => MessageClass-> Html -> m ()
|
||||
addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc)
|
||||
|
||||
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
|
||||
addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
|
||||
@ -35,15 +35,17 @@ nullaryToPathPiece nullaryType manglers = do
|
||||
where
|
||||
mangle = appEndo (foldMap Endo manglers) . Text.pack
|
||||
|
||||
splitCamel :: Text -> [Text]
|
||||
splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack
|
||||
splitCamel :: Textual t => t -> [t]
|
||||
splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList
|
||||
where
|
||||
helper _hadChange items thisWord [] = reverse thisWord : items
|
||||
helper _hadChange items [] (c:cs) = helper True items [c] cs
|
||||
helper hadChange items ws@(w:ws') (c:cs)
|
||||
| sameCategory w c
|
||||
, null ws' = helper False items (c:ws) cs
|
||||
, null ws' = helper (Char.isLower w) items (c:ws) cs
|
||||
| sameCategory w c = helper hadChange items (c:ws) cs
|
||||
| Char.isLower w
|
||||
, Char.isUpper c = helper True (reverse ws :items) [c] cs
|
||||
| null ws' = helper True items (c:ws) cs
|
||||
| not hadChange = helper True (reverse ws':items) [c,w] cs
|
||||
| otherwise = helper True (reverse ws :items) [c] cs
|
||||
|
||||
@ -19,6 +19,9 @@ Utils.Form
|
||||
Utils.PathPiece
|
||||
: (Template-Haskell)-Hilfsfunktionen für Formulierung von PathPiece-Instanzen
|
||||
|
||||
Utils.Message
|
||||
: redefines addMessage, addMessageI, defines MessageClass
|
||||
|
||||
Utils.Lens
|
||||
: Automatisch erzeugt Linsen für eigene und Yesod-Typen, `Control.Lens`-Export
|
||||
|
||||
|
||||
@ -22,7 +22,6 @@
|
||||
<li .list-group-item>
|
||||
<a href=@{CourseNewR}>Kurse anlegen
|
||||
|
||||
<hr>
|
||||
<div .container>
|
||||
<h2>Funktionen zum Testen
|
||||
|
||||
@ -33,9 +32,5 @@
|
||||
^{btnWdgt}
|
||||
<li><br>
|
||||
Modals:
|
||||
^{modal ".toggler1" Nothing}
|
||||
<a href="/" .btn.toggler1>Klick mich für Ajax-Test
|
||||
<noscript>(Für Modals bitte JS aktivieren)</noscript>
|
||||
^{modal ".toggler2" (Just "Test Inhalt für Modal")}
|
||||
<div .btn.toggler2>Klick mich für Content-Test
|
||||
<noscript>(Für Modals bitte JS aktivieren)</noscript>
|
||||
^{modal "Klick mich für Ajax-Test" (Left UsersR)}
|
||||
^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
|
||||
|
||||
@ -7,38 +7,11 @@ $newline never
|
||||
<html class="no-js" lang="en"> <!--<![endif]-->
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
|
||||
<title>#{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>
|
||||
|
||||
@ -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 {
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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>
|
||||
|
||||
@ -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'));
|
||||
});
|
||||
|
||||
@ -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';
|
||||
}
|
||||
}
|
||||
|
||||
@ -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"] {
|
||||
|
||||
@ -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() {
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
@ -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 {
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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{..})
|
||||
|
||||
2
templates/widgets/dummy-login-form.hamlet
Normal file
2
templates/widgets/dummy-login-form.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<form method=POST action=@{toMaster $ PluginR "dummy" []} enctype=#{loginEnctype}>
|
||||
^{login}
|
||||
@ -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}
|
||||
|
||||
2
templates/widgets/hash-login-form.hamlet
Normal file
2
templates/widgets/hash-login-form.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<form method=POST action=@{toMaster $ PluginR "PWHash" []} enctype=#{loginEnctype}>
|
||||
^{login}
|
||||
@ -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 _
|
||||
|
||||
@ -1,2 +0,0 @@
|
||||
<div .modal.js-modal #modal-#{modalId} data-trigger=#{modalTrigger} data-closeable=true>
|
||||
#{modalContent}
|
||||
@ -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);
|
||||
|
||||
@ -6,6 +6,7 @@
|
||||
|
||||
.pagenav__list {
|
||||
display: block;
|
||||
margin-left: 0;
|
||||
}
|
||||
|
||||
.pagenav__list-item {
|
||||
|
||||
Loading…
Reference in New Issue
Block a user