fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into 284-massinput

Browse Source
This commit is contained in:
Steffen Jost 2019-03-20 15:57:43 +01:00
commit 5f67c3ac00
52 changed files with 1596 additions and 356 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.hlint.yaml
View File

@ -1,5 +1,5 @@
# HLint configuration file # HLint configuration file
# https://github.com/ndmitchell/hlint # https://github.com/ndmitchell/hlint
########################## ##########################
- ignore: { name: "Parse error" } - ignore: { name: "Parse error" }
@ -7,6 +7,7 @@
- ignore: { name: "Use ||" } - ignore: { name: "Use ||" }
- ignore: { name: "Use &&" } - ignore: { name: "Use &&" }
- ignore: { name: "Use ++" } - ignore: { name: "Use ++" }
- ignore: { name: "Use ***" }
- arguments: - arguments:
- -XQuasiQuotes - -XQuasiQuotes

4
ChangeLog.md
View File

@ -1,3 +1,7 @@
* Version 20.03.2019
Kursanmeldung benötigen assoziertes Hauptfach (für Studierende mit mehreren Hauptfächern)
* Version 30.01.2019 * Version 30.01.2019
Designänderungen Designänderungen

53
RoleDescriptions.txt Normal file
View File

@ -0,0 +1,53 @@
Most roles are school dependent, i.e. a lecturer for the Math-department can only create new lectures that have Math-department in their school field.
Administrator for a school
- top-level rights, can access everything other roles can within the same school
- restrictions only apply to routes containing a different school; then no special rights are given
- may appoint further administrators and lecturers for his school
- all school-independent routes, such as help-requests and user-list are accessible
- can impersonate any other user with lesser rights, i.e. lecturers within same school, all students, etc.
- a user can be administrator for more than one school
Lecturer for a school
- can create courses for their school for all active terms
- can view participants of his courses and record notes for participants
- can create sheets for their courses
- can view homework submissions for his courses, including marks and plain user-names
- can mark homework
- may appoint correctors for sheets belonging to his courses
- may assign submitted homework to correctors
- a user can be lecturer for more than one school
- all rights correctors for his courses have
Corrector for a sheet
- may download their assigned anonymous homework submissions (submissions are identify through crypto-ids, no user-names)
- may upload corrected and marked homework submissions for their assignments
- may always download solution and sheet description files for their sheet, ignoring deadline constraints
- may create homework submissions in the name of students (which identify themselves to the corrector by pseudonym; no association with real identity needed) for homework assignments which have their submission-mode set to "Submission external with pseudonym" by a lecturer
Tutor for a tutorial of a course
- yet unimplemented, likely similar to corrector; ie. can access sheets and solutions earlier than participants
User (logged-in)
- all logged-in users may use this role
- no special school restrictions
- may enroll in courses from any school; enrollment is associated with a field of study the user had at the time
- may submit homework for marking in enrolled courses
- all rights that not logged-in users have
User (not logged-in)
- can view course descriptions
- can download course materials from courses that allow this for all un-enrolled users
- can requests help from administrators
- can log in with their campus-id creating a new user record in the process and elevating rights to "logged-in"
Terminology:
- participants: a logged-in users that is enrolled in a specific course

1
build.sh
View File

@ -1,3 +1,4 @@
#!/usr/bin/env bash #!/usr/bin/env bash
exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev
echo Build task completed.

4
db.sh
View File

@ -1,4 +1,4 @@
#!/usr/bin/env -S bash -xe #!/usr/bin/env bash
# Options: see /test/Database.hs (Main)
stack build --fast --flag uniworx:library-only --flag uniworx:dev stack build --fast --flag uniworx:library-only --flag uniworx:dev
stack exec uniworxdb -- $@ stack exec uniworxdb -- $@

29
messages/uniworx/de.msg
View File

@ -53,6 +53,8 @@ CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
CourseRegisterOk: Sie wurden angemeldet CourseRegisterOk: Sie wurden angemeldet
CourseDeregisterOk: Sie wurden abgemeldet CourseDeregisterOk: Sie wurden abgemeldet
CourseStudyFeature: Assoziiertes Hauptfach
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
CourseSecretWrong: Falsches Kennwort CourseSecretWrong: Falsches Kennwort
CourseSecret: Zugangspasswort CourseSecret: Zugangspasswort
CourseNewOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt. CourseNewOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.
@ -69,8 +71,8 @@ CourseNewHeading: Neuen Kurs anlegen
CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
CourseEditTitle: Kurs editieren/anlegen CourseEditTitle: Kurs editieren/anlegen
CourseMembers: Teilnehmer CourseMembers: Teilnehmer
CourseMembersCount num@Int64: #{display num} CourseMembersCount n@Int: #{display n}
CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} CourseMembersCountLimited n@Int max@Int: #{display n}/#{display max}
CourseName: Name CourseName: Name
CourseDescription: Beschreibung CourseDescription: Beschreibung
CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet
@ -253,8 +255,10 @@ Theme: Oberflächen Design
Favoriten: Anzahl gespeicherter Favoriten Favoriten: Anzahl gespeicherter Favoriten
Plugin: Plugin Plugin: Plugin
Ident: Identifikation Ident: Identifikation
LastLogin: Letzter Login
Settings: Individuelle Benutzereinstellungen Settings: Individuelle Benutzereinstellungen
SettingsUpdate: Einstellungen wurden gespeichert. SettingsUpdate: Einstellungen wurden gespeichert.
Never: Nie
MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
@ -341,6 +345,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget
NoTableContent: Kein Tabelleninhalt NoTableContent: Kein Tabelleninhalt
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
AdminHeading: Administration
AdminUserHeading: Benutzeradministration AdminUserHeading: Benutzeradministration
AccessRightsFor: Berechtigungen für AccessRightsFor: Berechtigungen für
AdminFor: Administrator AdminFor: Administrator
@ -402,8 +407,28 @@ SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahr
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
AdminFeaturesHeading: Studiengänge
StudyFeatureInference: Studiengangschlüssel-Inferenz
StudyFeatureAge: Fachsemester
StudyFeatureDegree: Abschluss
FieldPrimary: Hauptfach FieldPrimary: Hauptfach
FieldSecondary: Nebenfach FieldSecondary: Nebenfach
NoPrimaryStudyField: (kein Hauptfach registriert)
DegreeKey: Schlüssel Abschluss
DegreeName: Abschluss
DegreeShort: Abschlusskürzel
StudyTermsKey: Schlüssel Studiengang
StudyTermsName: Studiengang
StudyTermsShort: Studiengangkürzel
StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert
StudyDegreeChangeSuccess: Zuordnung Studiengänge aktualisiert
StudyCandidateIncidence: Anmeldevorgang
AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt
RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt
CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
StudyTermIsNew: Neu
MailTestFormEmail: Email-Addresse MailTestFormEmail: Email-Addresse
MailTestFormLanguages: Spracheinstellungen MailTestFormLanguages: Spracheinstellungen

6
models/config
View File

@ -1,4 +1,6 @@
-- Configuration settings shared among all uni2work-instances for interoperability (Users can seamlessly switch between uni2work-instances (load-balancing need not attach users to an instance persistently))
-- Mostly cryptographic keys
ClusterConfig ClusterConfig
setting ClusterSettingsKey setting ClusterSettingsKey -- I.e. Symmetric key for encrypting database-ids for use in URLs, Symmetric key for encrypting user-sessions so they can be saved directly as a browser-cookie, Symmetric key for encrypting error messages which might contain secret information, ...
value Value value Value -- JSON-encoded value
Primary setting Primary setting

51
models/courses
View File

@ -1,50 +1,51 @@
DegreeCourse json DegreeCourse json -- for which degree programmes this course is appropriate for
course CourseId course CourseId
degree StudyDegreeId degree StudyDegreeId
terms StudyTermsId terms StudyTermsId
UniqueDegreeCourse course degree terms UniqueDegreeCourse course degree terms
Course Course -- Information about a single course; contained info is always visible to all users
name (CI Text) name (CI Text)
description Html Maybe description Html Maybe -- user-defined large Html, ought to contain module description
linkExternal Text Maybe linkExternal Text Maybe -- arbitrary user-defined url for external course page
shorthand (CI Text) shorthand (CI Text) -- practical shorthand of course name, used for identification
term TermId term TermId -- semester this course is taught
school SchoolId school SchoolId
capacity Int64 Maybe capacity Int Maybe -- number of allowed enrolements, if restricted
-- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
registerFrom UTCTime Maybe registerFrom UTCTime Maybe -- enrolement allowed from a given day onwwards or prohibited
registerTo UTCTime Maybe registerTo UTCTime Maybe -- enrolement may be prohibited from a given date onwards
deregisterUntil UTCTime Maybe deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase
materialFree Bool materialFree Bool -- False: only enrolled users may see course materials not stored in this table
TermSchoolCourseShort term school shorthand TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester
TermSchoolCourseName term school name TermSchoolCourseName term school name -- name must be unique within school and semester
deriving Generic deriving Generic
CourseEdit CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables)
user UserId user UserId
time UTCTime time UTCTime
course CourseId course CourseId
CourseFavourite CourseFavourite -- which user accessed which course when, only displayed to user for convenience;
user UserId user UserId -- max number of rows kept per user is user-defined by column 'maxFavourites' in table "User"
time UTCTime time UTCTime -- oldest is removed first
course CourseId course CourseId
UniqueCourseFavourite user course UniqueCourseFavourite user course
deriving Show deriving Show
Lecturer Lecturer -- course ownership
user UserId user UserId
course CourseId course CourseId
UniqueLecturer user course UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
CourseParticipant CourseParticipant -- course enrolement
course CourseId course CourseId
user UserId user UserId
registration UTCTime registration UTCTime -- time of last enrolement for this course
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
UniqueParticipant user course UniqueParticipant user course
CourseUserNote CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student
course CourseId course CourseId
user UserId user UserId
note Text note Text -- arbitrary user-defined text; visible only to lecturer of this course
UniqueCourseUserNotes user course UniqueCourseUserNotes user course
CourseUserNoteEdit CourseUserNoteEdit -- who edited a participants course note whenl
user UserId user UserId
time UTCTime time UTCTime
note CourseUserNoteId note CourseUserNoteId

6
models/exams
View File

@ -1,4 +1,4 @@
-- EXAMS ARE TODO: -- EXAMS ARE TODO; THIS IS JUST AN UNUSED STUB
Exam Exam
course CourseId course CourseId
name Text name Text
@ -8,8 +8,8 @@ Exam
registrationBegin UTCTime registrationBegin UTCTime
registrationEnd UTCTime registrationEnd UTCTime
deregistrationEnd UTCTime deregistrationEnd UTCTime
ratingVisible Bool ratingVisible Bool -- may participants see their own rating yet
statisticsVisible Bool statisticsVisible Bool -- may participants view statistics over all participants (should not be allowed for 'small' courses)
--ExamEdit --ExamEdit
-- user UserId -- user UserId
-- time UTCTime -- time UTCTime

3
models/files
View File

@ -1,3 +1,6 @@
-- Table storing all kinds of larges files as 8bit-byte vectors (regardless of encoding)
-- PostgreSQL is intelligent enough to handle this in a sensible manner;
-- helps to ensure consistency of database snapshots, no data is stored outside database
File File
title FilePath title FilePath
content ByteString Maybe -- Nothing iff this is a directory content ByteString Maybe -- Nothing iff this is a directory

19
models/jobs
View File

@ -1,12 +1,17 @@
-- Jobs to be executed as soon as possible in the background (so not to delay HTTP-responses, or triggered by cron-system without associated HTTP-Request)
QueuedJob QueuedJob
content Value content Value -- JSON-encoded description of the work to be done (send an email to "test@example.org", find all recipients for a certain notifications and queue one new job each, distribute all submissions for a sheet to correctors, ...)
creationInstance InstanceId creationInstance InstanceId -- multiple uni2work-instances access the same database, record which instance created this job for debugging purposes
creationTime UTCTime creationTime UTCTime
lockInstance InstanceId Maybe lockInstance InstanceId Maybe -- instance that has started to execute this job
lockTime UTCTime Maybe lockTime UTCTime Maybe -- time when execution had begun
deriving Eq Read Show Generic Typeable deriving Eq Read Show Generic Typeable
-- Jobs are deleted from @QueuedJob@ after they are executed successfully and recorded in @CronLastExec@
-- There is a Cron-system that, at set intervals, queries the database for work to be done in the background (i.e. if a lecturer has set a sheet's submissions to be automatically distributed and the submission deadline passed since the last check, then queue a new job to actually do the distribution)
-- For the cron-system to determine whether a job needs to be done it needs to know if and when it was last (or ever) executed (i.e. a sheet's submissions should not be distributed twice)
CronLastExec CronLastExec
job Value job Value -- JSON-encoded description of work done
time UTCTime time UTCTime -- When was the job executed
instance InstanceId instance InstanceId -- Which uni2work-instance did the work
UniqueCronLastExec job UniqueCronLastExec job

8
models/rooms
View File

@ -1,3 +1,8 @@
-- ROOMS ARE TODO; THIS IS JUST AN UNUSED STUB
-- Idea is to create a selection of rooms that may be
-- associated with exercise classes and exams
-- offering links to the LMU Roomfinder
-- and allow the creation of neat timetables for users
Booking Booking
term TermId term TermId
begin UTCTime begin UTCTime
@ -13,7 +18,8 @@ BookingEdit
Room Room
name Text name Text
capacity Int Maybe capacity Int Maybe
building Text Maybe building Text Maybe -- name of building
roomfinder Text Maybe -- external url for LMU Roomfinder
-- BookingRoom -- BookingRoom
-- subject RoomForId -- subject RoomForId
-- room RoomId -- room RoomId

2
models/schools
View File

@ -1,3 +1,5 @@
-- Description of all primary schools managed by uni2work
-- Each school must have a unique human-readable shorthand which is used as database row key
School json School json
name (CI Text) name (CI Text)
shorthand (CI Text) -- SchoolKey :: SchoolShorthand -> SchoolId shorthand (CI Text) -- SchoolKey :: SchoolShorthand -> SchoolId

42
models/sheets
View File

@ -1,39 +1,43 @@
Sheet Sheet -- exercise sheet for a given course
course CourseId course CourseId
name (CI Text) name (CI Text)
description Html Maybe description Html Maybe
type SheetType type SheetType -- Does it count towards overall course grade?
grouping SheetGroup grouping SheetGroup -- May participants submit in groups of certain sizes?
markingText Html Maybe markingText Html Maybe -- Instructions for correctors, included in marking templates
visibleFrom UTCTime Maybe visibleFrom UTCTime Maybe -- Invisible to enrolled participants before
activeFrom UTCTime activeFrom UTCTime -- Download of questions and submission is permitted afterwards
activeTo UTCTime activeTo UTCTime -- Submission is only permitted before
hintFrom UTCTime Maybe hintFrom UTCTime Maybe -- Additional files are made available
solutionFrom UTCTime Maybe solutionFrom UTCTime Maybe -- Solution is made available
uploadMode UploadMode uploadMode UploadMode -- Take apart Zip-Archives or not?
submissionMode SheetSubmissionMode default='UserSubmissions' submissionMode SheetSubmissionMode default='UserSubmissions' -- Submission upload by students or through tutors only?
autoDistribute Bool default=false autoDistribute Bool default=false -- Should correctors be assigned submissions automagically?
CourseSheet course name CourseSheet course name
deriving Generic deriving Generic
SheetEdit SheetEdit -- who edited when a row in table "Course", kept indefinitely
user UserId user UserId
time UTCTime time UTCTime
sheet SheetId sheet SheetId
-- For anonoymous external submissions (i.e. paper submission tracked in uni2work)
-- Map pseudonyms to users injectively in the context of a single sheet; for the next sheet all-new pseudonyms need to be created
-- Chosen uniformly at random when the submitting user presses a button on the view of a sheet
SheetPseudonym SheetPseudonym
sheet SheetId sheet SheetId
pseudonym Pseudonym pseudonym Pseudonym -- 24-bit number that should be attached to external submission (i.e. written on the submitted paper); encoded as two english words akin to PGP-Wordlist
user UserId user UserId
UniqueSheetPseudonym sheet pseudonym UniqueSheetPseudonym sheet pseudonym
UniqueSheetPseudonymUser sheet user UniqueSheetPseudonymUser sheet user
SheetCorrector SheetCorrector -- grant corrector role to user for a sheet
user UserId user UserId
sheet SheetId sheet SheetId
load Load load Load -- portion of work that will be assigned to this corrector
state CorrectorState default='CorrectorNormal' state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness)
UniqueSheetCorrector user sheet UniqueSheetCorrector user sheet
deriving Show Eq Ord deriving Show Eq Ord
SheetFile SheetFile -- a file that is part of an exercise sheet
sheet SheetId sheet SheetId
file FileId file FileId
type SheetFileType type SheetFileType -- excercise, marking, hint or solution
UniqueSheetFile file sheet type UniqueSheetFile file sheet type

30
models/submissions
View File

@ -1,34 +1,34 @@
Submission Submission -- submission for marking by a CourseParticipant
sheet SheetId sheet SheetId
ratingPoints Points Maybe -- "Just" does not mean done ratingPoints Points Maybe -- "Just" does not mean done; not yet visible to participant
ratingComment Text Maybe -- "Just" does not mean done ratingComment Text Maybe -- "Just" does not mean done; not yet visible to participant
ratingBy UserId Maybe -- assigned corrector ratingBy UserId Maybe -- assigned corrector
ratingAssigned UTCTime Maybe -- time assigned corrector ratingAssigned UTCTime Maybe -- time when corrector was assigned
ratingTime UTCTime Maybe -- "Just" here indicates done! ratingTime UTCTime Maybe -- "Just" here indicates done; marking is made visible to participant
deriving Show Generic deriving Show Generic
SubmissionEdit SubmissionEdit -- user uploads new version of their submission
user UserId user UserId -- track id, important for group submissions
time UTCTime time UTCTime
submission SubmissionId submission SubmissionId
SubmissionFile SubmissionFile -- files that are part of a submission
submission SubmissionId submission SubmissionId
file FileId file FileId
isUpdate Bool -- is this the file updated by a corrector (original will always be retained) isUpdate Bool -- is this the file updated by a corrector (original will always be retained)
isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector
UniqueSubmissionFile file submission isUpdate UniqueSubmissionFile file submission isUpdate
deriving Show deriving Show
SubmissionUser -- Actual submission participant SubmissionUser -- which submission belongs to whom
user UserId user UserId
submission SubmissionId submission SubmissionId
UniqueSubmissionUser user submission UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups
SubmissionGroup SubmissionGroup -- pre-defined submission groups; some courses only allow pre-defined submission groups
course CourseId course CourseId
name Text Maybe name Text Maybe
SubmissionGroupEdit SubmissionGroupEdit -- who edited a submissionGroup when?
user UserId user UserId
time UTCTime time UTCTime
submissionGroup SubmissionGroupId submissionGroup SubmissionGroupId
SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser SubmissionGroupUser -- Registered submission groups, just for checking upon submission, but independent of actual SubmissionUser
submissionGroup SubmissionGroupId submissionGroup SubmissionGroupId
user UserId user UserId
UniqueSubmissionGroupUser submissionGroup user UniqueSubmissionGroupUser submissionGroup user

16
models/system-messages
View File

@ -1,12 +1,14 @@
-- Messages shown to all users as soon as they visit the site/log in (i.e.: "System is going down for maintenance next sunday")
-- Only administrators (of any school) should be able to create these via a web-interface
SystemMessage SystemMessage
from UTCTime Maybe from UTCTime Maybe -- Message is not shown before this date has passed (never shown, if null)
to UTCTime Maybe to UTCTime Maybe -- Message is shown until this date has passed (shown forever, if null)
authenticatedOnly Bool authenticatedOnly Bool -- Show message to all users upon visiting the site or only upon login?
severity MessageStatus severity MessageStatus -- Success, Warning, Error, Info, ...
defaultLanguage Lang defaultLanguage Lang -- Language of @content@ and @summary@
content Html content Html -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified
summary Html Maybe summary Html Maybe
SystemMessageTranslation SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers
message SystemMessageId message SystemMessageId
language Lang language Lang
content Html content Html

11
models/terms
View File

@ -1,10 +1,13 @@
-- Describes each term time.
-- TermIdentifier is either W for Winterterm or S for Summerterm,
-- followed by a two-digit year
Term json Term json
name TermIdentifier -- unTermKey :: TermId -> TermIdentifier name TermIdentifier -- unTermKey :: TermId -> TermIdentifier
start Day -- TermKey :: TermIdentifier -> TermId start Day -- TermKey :: TermIdentifier -> TermId
end Day end Day
holidays [Day] holidays [Day] -- LMU holidays, for display in timetables
lectureStart Day lectureStart Day -- lectures usually start/end later/earlier than the actual term,
lectureEnd Day lectureEnd Day -- used to generate warnings for lecturers creating unusual courses
active Bool active Bool -- may lecturers add courses to this term?
Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier } Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
deriving Show Eq Generic -- type TermId = Key Term deriving Show Eq Generic -- type TermId = Key Term

3
models/tutorials
View File

@ -1,7 +1,10 @@
-- TUTORIALS ARE TODO; THIS IS JUST AN UNUSED STUB
-- Idea: management of exercise classes, offering sub-enrolement to distribute all students among all exercise classs
Tutorial json Tutorial json
name Text name Text
tutor UserId tutor UserId
course CourseId course CourseId
capacity Int Maybe -- limit for enrolement in this tutorial
TutorialUser TutorialUser
user UserId user UserId
tutorial TutorialId tutorial TutorialId

96
models/users
View File

@ -1,44 +1,68 @@
-- Some comments needes -- The files in /models determine the database scheme.
User json -- The organisational split into several files has no operational effects.
ident (CI Text) -- White-space and case matters: Each SQL table is named in 1st column of this file
authentication AuthenticationMode -- Indendent lower-case lines describe the SQL-columns of the table with name, type and options
matrikelnummer Text Maybe -- Nullable columns have "Maybe" written after their type
email (CI Text) -- Option "default=xyz" is only used for database migrations due to changes in the SQL-schema, also see Model.Migration
displayName Text -- Indendent upper-case lines usually impose Uniqueness constraints for rows by some columns.
surname Text -- always use: nameWidget displayName surname -- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname
maxFavourites Int default=12 --
theme Theme default='Default' User json -- Each Uni2work user has a corresponding row in this table; created upon first login.
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" ident (CI Text) -- Case-insensitive user-identifier
dateFormat DateTimeFormat "default='%d.%m.%Y'" authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
timeFormat DateTimeFormat "default='%R'" lastAuthentication UTCTime Maybe -- last login date
downloadFiles Bool default=false matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
mailLanguages MailLanguages default='[]' email (CI Text) -- Case-insensitive eMail address
notificationSettings NotificationSettings displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
UniqueAuthentication ident surname Text -- Display user names always through 'nameWidget displayName surname'
UniqueEmail email maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
deriving Show Eq Generic theme Theme default='Default' -- Color-theme of the frontend; user-defined
UserAdmin dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined
timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined
downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
mailLanguages MailLanguages default='[]' -- Preferred language for eMail; i18n not yet implemented; user-defined
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
UniqueEmail email -- Column 'email' can be used as a row-key in this table
deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory
UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user
user UserId user UserId
school SchoolId school SchoolId
UniqueUserAdmin user school UniqueUserAdmin user school -- combination of user+school must be unique, i.e. no duplicate rows
UserLecturer UserLecturer -- Each row in this table grants school-specific lecturer-rights to a specific user
user UserId user UserId
school SchoolId school SchoolId
UniqueSchoolLecturer user school UniqueSchoolLecturer user school -- combination of user+school must be unique, i.e. no duplicate rows
StudyFeatures -- Abschluss, Studiengang, Haupt/Nebenfachh und Fachsemester StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login
user UserId user UserId
degree StudyDegreeId degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc.
field StudyTermsId field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc.
type StudyFieldType type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach
semester Int semester Int
-- UniqueUserSubject user degree field -- There exists a counterexample updated UTCTime default='NOW()' -- last update from LDAP
valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets)
UniqueStudyFeatures user degree field type semester
-- UniqueUserSubject ubuser degree field -- There exists a counterexample
StudyDegree -- Studienabschluss StudyDegree -- Studienabschluss
key Int key Int -- LMU-internal key
shorthand Text Maybe shorthand Text Maybe -- admin determined shorthand
name Text Maybe name Text Maybe -- description given by LDAP
Primary key Primary key -- column key is used as actual DB row key
-- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int }
deriving Show
StudyTerms -- Studiengang StudyTerms -- Studiengang
key Int key Int -- LMU-internal key
shorthand Text Maybe shorthand Text Maybe -- admin determined shorthand
name Text Maybe name Text Maybe -- description given by LDAP
Primary key Primary key -- column key is used as actual DB row key
-- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int }
deriving Show
StudyTermCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
-- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence.
-- This table helps us to infer which key belongs to which plain text by recording possible combinations at login.
-- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations
incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs
key Int -- a possible key for the studyTermName
name Text -- studyTermName as plain text from LDAP
deriving Show Eq Ord

1
package.yaml
View File

@ -171,6 +171,7 @@ default-extensions:
ghc-options: ghc-options:
- -Wall - -Wall
- -fno-warn-type-defaults - -fno-warn-type-defaults
- -fno-warn-unrecognised-pragmas
- -fno-warn-partial-type-signatures - -fno-warn-partial-type-signatures
when: when:

2
routes
View File

@ -38,6 +38,8 @@
/users UsersR GET -- no tags, i.e. admins only /users UsersR GET -- no tags, i.e. admins only
/users/#CryptoUUIDUser AdminUserR GET POST !development /users/#CryptoUUIDUser AdminUserR GET POST !development
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
/admin AdminR GET
/admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST /admin/test AdminTestR GET POST
/admin/errMsg AdminErrMsgR GET POST /admin/errMsg AdminErrMsgR GET POST

1
src/CryptoID.hs
View File

@ -36,6 +36,7 @@ decCryptoIDs [ ''SubmissionId
, ''SheetId , ''SheetId
, ''SystemMessageId , ''SystemMessageId
, ''SystemMessageTranslationId , ''SystemMessageTranslationId
, ''StudyFeaturesId
] ]
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

66
src/Database/Esqueleto/Utils.hs
View File

@ -1,8 +1,19 @@
module Database.Esqueleto.Utils where {-# OPTIONS_GHC -fno-warn-orphans #-}
import ClassyPrelude.Yesod hiding (isInfixOf, (||.)) module Database.Esqueleto.Utils
import Data.Foldable as F ( true, false
import Database.Esqueleto as E , isInfixOf, hasInfix
, any, all
, SqlIn(..)
, mkExactFilter, mkContainsFilter
, anyFilter
) where
import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
import qualified Data.Set as Set
import qualified Data.Foldable as F
import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils.TH
-- --
@ -33,13 +44,52 @@ hasInfix = flip isInfixOf
-- | Given a test and a set of values, check whether anyone succeeds the test -- | Given a test and a set of values, check whether anyone succeeds the test
-- WARNING: SQL leaves it explicitely unspecified whether || is short curcuited (i.e. lazily evaluated) -- WARNING: SQL leaves it explicitely unspecified whether || is short curcuited (i.e. lazily evaluated)
any :: Foldable f => any :: Foldable f =>
(a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool) (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
any test = F.foldr (\needle acc -> acc ||. test needle) false any test = F.foldr (\needle acc -> acc E.||. test needle) false
-- | Given a test and a set of values, check whether all succeeds the test -- | Given a test and a set of values, check whether all succeeds the test
-- WARNING: SQL leaves it explicitely unspecified whether && is short curcuited (i.e. lazily evaluated) -- WARNING: SQL leaves it explicitely unspecified whether && is short curcuited (i.e. lazily evaluated)
all :: Foldable f => all :: Foldable f =>
(a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool) (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
all test = F.foldr (\needle acc -> acc &&. test needle) true all test = F.foldr (\needle acc -> acc E.&&. test needle) true
-- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
$(sqlInTuples [2..16])
-- | Example for usage of sqlIJproj
-- queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
-- queryFeaturesDegree = $(sqlIJproj 3 2)
-- | generic filter creation for dbTable
-- Given a lens-like function, make filter for exact matches in a collection
-- (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere)
mkExactFilter :: (PersistField a)
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
-> t -- ^ query row
-> Set.Set a -- ^ needle collection
-> E.SqlExpr (E.Value Bool)
mkExactFilter lenslike row criterias
| Set.null criterias = true
| otherwise = lenslike row `E.in_` E.valList (Set.toList criterias)
-- | generic filter creation for dbTable
-- Given a lens-like function, make filter searching for needles in String-like elements
-- (Keep Set here to ensure that there are no duplicates)
mkContainsFilter :: (E.SqlString a)
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
-> t -- ^ query row
-> Set.Set Text -- ^ needle collection
-> E.SqlExpr (E.Value Bool)
mkContainsFilter lenslike row criterias
| Set.null criterias = true
| otherwise = any (hasInfix $ lenslike row) criterias
anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
-> t -> Set.Set Text-> E.SqlExpr (E.Value Bool)
anyFilter fltrs needle criterias = F.foldr aux false fltrs
where
aux fltr acc = fltr needle criterias E.||. acc

58
src/Database/Esqueleto/Utils/TH.hs Normal file
View File

@ -0,0 +1,58 @@
module Database.Esqueleto.Utils.TH
( SqlIn(..)
, sqlInTuple, sqlInTuples
, sqlIJproj, sqlLOJproj
) where
import ClassyPrelude
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
import Database.Persist (PersistField)
import Language.Haskell.TH
import Data.List (foldr1, foldl)
import Utils.TH
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
sqlInTuples :: [Int] -> DecsQ
sqlInTuples = mapM sqlInTuple
sqlInTuple :: Int -> DecQ
sqlInTuple arity = do
tyVars <- replicateM arity $ newName "t"
vVs <- replicateM arity $ newName "v"
xVs <- replicateM arity $ newName "x"
xsV <- newName "xs"
let
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
[ funD 'sqlIn
[ clause [tupP $ map varP xVs, varP xsV]
( guardedB
[ normalGE [e|null $(varE xsV)|] [e|E.val False|]
, normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
]
) []
]
]
-- | Generic projections for InnerJoin-tuples
-- gives I-th element of N-tuple of left-associative InnerJoin-pairs,
-- i.e. @$(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
sqlIJproj :: Int -> Int -> ExpQ
sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
sqlLOJproj :: Int -> Int -> ExpQ
sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin

130
src/Foundation.hs
View File

@ -42,6 +42,8 @@ import qualified Data.Set as Set
import Data.Map (Map, (!?)) import Data.Map (Map, (!?))
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.List (nubBy)
import Data.Monoid (Any(..)) import Data.Monoid (Any(..))
import Data.Pool import Data.Pool
@ -1077,9 +1079,12 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .|
instance YesodBreadcrumbs UniWorX where instance YesodBreadcrumbs UniWorX where
breadcrumb (AuthR _) = return ("Login" , Just HomeR) breadcrumb (AuthR _) = return ("Login" , Just HomeR)
breadcrumb HomeR = return ("Uni2work" , Nothing) breadcrumb HomeR = return ("Uni2work" , Nothing)
breadcrumb UsersR = return ("Benutzer" , Just HomeR) breadcrumb UsersR = return ("Benutzer" , Just AdminR)
breadcrumb AdminTestR = return ("Test" , Just HomeR)
breadcrumb (AdminUserR _) = return ("Users" , Just UsersR) breadcrumb (AdminUserR _) = return ("Users" , Just UsersR)
breadcrumb AdminR = return ("Administration", Nothing)
breadcrumb AdminFeaturesR = return ("Test" , Just AdminR)
breadcrumb AdminTestR = return ("Test" , Just AdminR)
breadcrumb AdminErrMsgR = return ("Test" , Just AdminR)
breadcrumb InfoR = return ("Information" , Nothing) breadcrumb InfoR = return ("Information" , Nothing)
breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR) breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR)
@ -1107,10 +1112,12 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
-- (CourseR tid ssh csh CRegisterR) -- is POST only -- (CourseR tid ssh csh CRegisterR) -- is POST only
breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CUsersR) = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR) breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR)
@ -1132,7 +1139,7 @@ instance YesodBreadcrumbs UniWorX where
return $ if return $ if
| mayList -> ("Statusmeldung", Just MessageListR) | mayList -> ("Statusmeldung", Just MessageListR)
| otherwise -> ("Statusmeldung", Just HomeR) | otherwise -> ("Statusmeldung", Just HomeR)
breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR) breadcrumb (MessageListR) = return ("Statusmeldungen", Just AdminR)
breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId] submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
@ -1251,6 +1258,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
} }
, return MenuItem
{ menuItemType = NavbarAside
, menuItemLabel = MsgAdminHeading
, menuItemIcon = Just "screwdriver"
, menuItemRoute = SomeRoute AdminR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
] ]
@ -1272,33 +1287,75 @@ pageActions (HomeR) =
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuAdminTest , menuItemLabel = MsgAdminHeading
, menuItemIcon = Just "screwdriver" , menuItemIcon = Just "screwdriver"
, menuItemRoute = SomeRoute AdminTestR , menuItemRoute = SomeRoute AdminR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgAdminFeaturesHeading
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminFeaturesR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuMessageList , menuItemLabel = MsgMenuMessageList
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute MessageListR , menuItemRoute = SomeRoute MessageListR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuAdminErrMsg , menuItemLabel = MsgMenuAdminErrMsg
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminErrMsgR , menuItemRoute = SomeRoute AdminErrMsgR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (AdminR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgAdminFeaturesHeading
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminFeaturesR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgErrMsgHeading
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminErrMsgR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuUsers
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute UsersR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuAdminTest
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminTestR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (InfoR) = [ pageActions (InfoR) = [
MenuItem MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgInfoLecturerTitle , menuItemLabel = MsgInfoLecturerTitle
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute InfoLecturerR , menuItemRoute = SomeRoute InfoLecturerR
@ -1919,6 +1976,8 @@ instance YesodAuth UniWorX where
$(widgetFile "login") $(widgetFile "login")
authenticate Creds{..} = runDB $ do authenticate Creds{..} = runDB $ do
now <- liftIO getCurrentTime
let let
userIdent = CI.mk credsIdent userIdent = CI.mk credsIdent
uAuth = UniqueAuthentication userIdent uAuth = UniqueAuthentication userIdent
@ -1946,7 +2005,12 @@ instance YesodAuth UniWorX where
return $ ServerError "LDAP lookup failed" return $ ServerError "LDAP lookup failed"
] ]
acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth acceptExisting = do
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
case res of
Authenticated uid
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
_other -> return res
$logDebugS "auth" $ tshow Creds{..} $logDebugS "auth" $ tshow Creds{..}
UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
@ -1965,6 +2029,7 @@ instance YesodAuth UniWorX where
userAuthentication userAuthentication
| isPWHash = error "PWHash should only work for users that are already known" | isPWHash = error "PWHash should only work for users that are already known"
| otherwise = AuthLDAP | otherwise = AuthLDAP
userLastAuthentication = now <$ guard (not isDummy)
userEmail <- if userEmail <- if
| Just [bs] <- userEmail' | Just [bs] <- userEmail'
@ -2005,16 +2070,18 @@ instance YesodAuth UniWorX where
, userMailLanguages = def , userMailLanguages = def
, .. , ..
} }
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
, UserDisplayName =. userDisplayName , UserDisplayName =. userDisplayName
, UserSurname =. userSurname , UserSurname =. userSurname
, UserEmail =. userEmail , UserEmail =. userEmail
] ] ++
[ UserLastAuthentication =. Just now | not isDummy ]
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
studyTermCandidateIncidence <- liftIO getRandom
let let
userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
userStudyFeatures' = do userStudyFeatures' = do
(k, v) <- ldapData (k, v) <- ldapData
guard $ k == Attr "dfnEduPersonFeaturesOfStudy" guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
@ -2022,15 +2089,28 @@ instance YesodAuth UniWorX where
Right str <- return $ Text.decodeUtf8' v' Right str <- return $ Text.decodeUtf8' v'
return str return str
termNames = nubBy ((==) `on` CI.mk) $ do
(k, v) <- ldapData
guard $ k == Attr "dfnEduPersonFieldOfStudyString"
v' <- v
Right str <- return $ Text.decodeUtf8' v'
return str
fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
lift $ deleteWhere [StudyFeaturesUser ==. userId] let
studyTermCandidates = do
studyTermCandidateName <- termNames
StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs
return StudyTermCandidate{..}
lift $ insertMany_ studyTermCandidates
forM_ fs $ \StudyFeatures{..} -> do lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
forM_ fs $ \f@StudyFeatures{..} -> do
lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
lift $ insertMany_ fs
return $ Authenticated userId return $ Authenticated userId
Nothing -> acceptExisting Nothing -> acceptExisting

192
src/Handler/Admin.hs
View File

@ -4,30 +4,43 @@ import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Form.MassInput import Handler.Utils.Form.MassInput
import Jobs import Jobs
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer (mapWriterT)
import Utils.Lens
-- import Data.Time -- import Data.Time
-- import qualified Data.Text as T import Data.Char (isDigit)
import qualified Data.Text as Text
-- import Data.Function ((&)) -- import Data.Function ((&))
-- import Yesod.Form.Bootstrap3 -- import Yesod.Form.Bootstrap3
import Database.Persist.Sql (fromSqlKey)
import qualified Data.Text as Text
import Data.Char (isDigit)
import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map
import Database.Persist.Sql (fromSqlKey)
import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils as E
import Handler.Utils.Table.Cells
import qualified Handler.Utils.TermCandidates as Candidates
-- import Colonnade hiding (fromMaybe) -- import Colonnade hiding (fromMaybe)
-- import Yesod.Colonnade -- import Yesod.Colonnade
-- import qualified Data.UUID.Cryptographic as UUID -- import qualified Data.UUID.Cryptographic as UUID
import Control.Monad.Trans.Writer (mapWriterT)
getAdminR :: Handler Html
getAdminR = -- do
siteLayoutMsg MsgAdminHeading $ do
setTitleI MsgAdminHeading
[whamlet|
This shall become the Administrators' overview page.
Its current purpose is to provide links to some important admin functions
|]
-- BEGIN - Buttons needed only here -- BEGIN - Buttons needed only here
data ButtonCreate = CreateMath | CreateInf -- Dummy for Example data ButtonCreate = CreateMath | CreateInf -- Dummy for Example
@ -43,7 +56,7 @@ instance Button UniWorX ButtonCreate where
btnClasses CreateMath = [BCIsButton, BCInfo] btnClasses CreateMath = [BCIsButton, BCInfo]
btnClasses CreateInf = [BCIsButton, BCPrimary] btnClasses CreateInf = [BCIsButton, BCPrimary]
-- END Button needed here -- END Button needed only here
emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
emailTestForm = (,) emailTestForm = (,)
@ -167,7 +180,7 @@ postAdminTestR = do
deleteCell l pos deleteCell l pos
| l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
| otherwise = return Map.empty | otherwise = return Map.empty
((miResult, (fvInput -> miForm)), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell) "" True Nothing ((miResult, (fvInput -> miForm)), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell) "" True Nothing
@ -216,3 +229,160 @@ postAdminErrMsgR = do
<form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}> <form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
^{ctView} ^{ctView}
|] |]
-- BEGIN - Buttons needed only for StudyTermCandidateManagement
data ButtonInferStudyTerms = ButtonInferStudyTerms
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonInferStudyTerms
instance Finite ButtonInferStudyTerms
nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece
instance Button UniWorX ButtonInferStudyTerms where
btnLabel ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen"
btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary]
-- END Button needed only here
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
getAdminFeaturesR = postAdminFeaturesR
postAdminFeaturesR = do
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonInferStudyTerms)
(infConflicts,infAccepted) <- case btnResult of
(FormSuccess ButtonInferStudyTerms) -> do
(infConflicts,infAmbiguous,infRedundant,infAccepted) <- Candidates.inferHandler
unless (null infAmbiguous) $ addMessageI Info $ MsgAmbiguousCandidatesRemoved $ length infAmbiguous
unless (null infRedundant) $ addMessageI Info $ MsgRedundantCandidatesRemoved $ length infRedundant
if null infAccepted
then addMessageI Info MsgNoCandidatesInferred
else addMessageI Success $ MsgCandidatesInferred $ length infAccepted
return (infConflicts,infAccepted)
_other -> (,[]) <$> runDB Candidates.conflicts
unless (null infConflicts) $ addMessage Warning "KONFLIKTE vorhanden" --TODO i18n
( (degreeResult,degreeTable)
, (studyTermsResult,studytermsTable)
, ((),candidateTable)) <- runDB $ (,,)
<$> mkDegreeTable
<*> mkStudytermsTable (Set.fromList $ map (StudyTermsKey' . fst) infAccepted)
<*> mkCandidateTable
let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
degreeResult' = degreeResult <&> getDBFormResult
(\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
, row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
))
updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
formResult degreeResult' $ \res -> do
void . runDB $ Map.traverseWithKey updateDegree res
addMessageI Success MsgStudyDegreeChangeSuccess
let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text))
studyTermsResult' = studyTermsResult <&> getDBFormResult
(\row -> ( row ^. _dbrOutput . _entityVal . _studyTermsName
, row ^. _dbrOutput . _entityVal . _studyTermsShorthand
))
updateStudyTerms studyTermsKey (name,short) = update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
formResult studyTermsResult' $ \res -> do
void . runDB $ Map.traverseWithKey updateStudyTerms res
addMessageI Success MsgStudyTermsChangeSuccess
siteLayoutMsg MsgAdminFeaturesHeading $ do
setTitleI MsgAdminFeaturesHeading
$(widgetFile "adminFeatures")
where
textInputCell lensRes lensDefault = formCell id (return . view (_dbrOutput . _entityKey))
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
<$> mopt textField "" (Just $ row ^. lensDefault)
)
mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
mkDegreeTable =
let dbtIdent = "admin-studydegrees" :: Text
dbtStyle = def
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery ( E.SqlExpr (Entity StudyDegree))
dbtSQLQuery = return
dbtRowKey = (E.^. StudyDegreeKey)
dbtProj = return
dbtColonnade = formColonnade $ mconcat
[ sortable (Just "key") (i18nCell MsgDegreeKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName))
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
, dbRow
]
dbtSorting = Map.fromList
[ ("key" , SortColumn (E.^. StudyDegreeKey))
, ("name" , SortColumn (E.^. StudyDegreeName))
, ("short", SortColumn (E.^. StudyDegreeShorthand))
]
dbtFilter = mempty
dbtFilterUI = mempty
dbtParams = def { dbParamsFormAddSubmit = True
, dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
}
psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
in dbTable psValidator DBTable{..}
mkStudytermsTable :: Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
mkStudytermsTable newKeys =
let dbtIdent = "admin-studyterms" :: Text
dbtStyle = def
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
dbtSQLQuery = return
dbtRowKey = (E.^. StudyTermsKey)
dbtProj = return
dbtColonnade = formColonnade $ mconcat
[ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
, sortable (Just "isnew") (i18nCell MsgStudyTermIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
, dbRow
]
dbtSorting = Map.fromList
[ ("key" , SortColumn (E.^. StudyTermsKey))
, ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList newKeys)))
, ("name" , SortColumn (E.^. StudyTermsName))
, ("short" , SortColumn (E.^. StudyTermsShorthand))
]
dbtFilter = mempty
dbtFilterUI = mempty
dbtParams = def { dbParamsFormAddSubmit = True
, dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
}
psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
in dbTable psValidator DBTable{..}
mkCandidateTable =
let dbtIdent = "admin-termcandidate" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery :: E.SqlExpr (Entity StudyTermCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermCandidate))
dbtSQLQuery = return
dbtRowKey = (E.^. StudyTermCandidateId)
dbtProj = return
dbtColonnade = dbColonnade $ mconcat
[ dbRow
, sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermCandidateKey))
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermCandidateName))
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermCandidateIncidence))
]
dbtSorting = Map.fromList
[ ("key" , SortColumn (E.^. StudyTermCandidateKey))
, ("name" , SortColumn (E.^. StudyTermCandidateName))
, ("incidence", SortColumn (E.^. StudyTermCandidateIncidence))
]
dbtFilter = Map.fromList
[ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermCandidateKey))
, ("name", FilterColumn $ mkContainsFilter (E.^. StudyTermCandidateName))
, ("incidence", FilterColumn $ mkExactFilter (E.^. StudyTermCandidateIncidence)) -- contains filter desired, but impossible here
]
dbtFilterUI mPrev = mconcat
-- [ prismAForm (singletonFilter "key") mPrev $ aopt intField (fslI MsgStudyTermsKey) -- Typing problem exactFilter suffices here
[ prismAForm (singletonFilter "key") mPrev $ aopt (searchField False) (fslI MsgStudyTermsKey)
, prismAForm (singletonFilter "name") mPrev $ aopt (searchField False) (fslI MsgStudyTermsName)
, prismAForm (singletonFilter "incidence") mPrev $ aopt (searchField False) (fslI MsgStudyCandidateIncidence)
]
dbtParams = def
psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
in dbTable psValidator DBTable{..}

4
src/Handler/Corrections.hs
View File

@ -223,7 +223,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
E.orderBy [E.asc $ user E.^. UserDisplayName] E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
return (user, pseudonym E.?. SheetPseudonymPseudonym) return (user, pseudonym E.?. SheetPseudonymPseudonym)
let let
submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
@ -266,7 +266,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.orderBy [E.asc $ user E.^. UserSurname] E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
E.limit 1 E.limit 1
return (user E.^. UserSurname) return (user E.^. UserSurname)
) )

248
src/Handler/Course.hs
View File

@ -5,11 +5,16 @@ module Handler.Course where
import Import import Import
import Utils.Lens import Utils.Lens
import Utils.Form
-- import Utils.DB -- import Utils.DB
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells
import Handler.Utils.Course import Handler.Utils.Course
import Handler.Utils.Delete import Handler.Utils.Delete
import Handler.Utils.Database
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Database.Esqueleto.Utils
import Database.Esqueleto.Utils.TH
-- import Data.Time -- import Data.Time
-- import qualified Data.Text as T -- import qualified Data.Text as T
@ -26,7 +31,7 @@ import qualified Database.Esqueleto as E
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School) type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
@ -103,10 +108,10 @@ colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int64) course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int))
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
@ -263,8 +268,8 @@ getTermCourseListR tid = do
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do (course,schoolName,participants,registration,defSFid,lecturers) <- runDB . maybeT notFound $ do
[(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)] [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
<- lift . E.select . E.from $ <- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
@ -273,57 +278,82 @@ getCShowR tid ssh csh = do
E.where_ $ course E.^. CourseTerm E.==. E.val tid E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
let numParticipants = E.sub_select . E.from $ \part -> do let numParticipants = E.sub_select . E.from $ \part -> do
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
return ( E.countRows :: E.SqlExpr (E.Value Int64)) return ( E.countRows :: E.SqlExpr (E.Value Int))
return (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration) return (course,school E.^. SchoolName, numParticipants, participant)
defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion
lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
return (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail) return (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail)
return (course,schoolName,participants,registered,lecturers) return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers)
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) registered mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
(regWidget, regEnctype) <- generateFormPost $ identifyForm FIDCourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration defSFid $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
siteLayout (toWgt $ courseName course) $ do siteLayout (toWgt $ courseName course) $ do
setTitle [shamlet| #{toPathPiece tid} - #{csh}|] setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course") $(widgetFile "course")
-- | Registration button with maybe a userid if logged in
-- , maybe existing features if already registered
-- , maybe some default study features
-- , maybe a course secret
registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
-- unfinished WIP: must take study features if registred and show as mforced field
registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do
-- secret fields
(msecretRes', msecretView) <- case msecret of
(Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
_ -> return (Nothing,Nothing)
-- study features
(msfRes', msfView) <- case loggedin of
Nothing -> return (Nothing,Nothing)
Just _ -> bimap Just Just <$> case participant of
Just CourseParticipant{courseParticipantField=Just sfid}
-> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
_other -> mreq (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature
& setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid)
-- button de-/register
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing
registerForm :: Bool -> Maybe Text -> Form Bool let widget = $(widgetFile "widgets/register-form/register-form")
registerForm registered msecret extra = do let msecretRes | Just res <- msecretRes' = Just <$> res
(msecretRes', msecretView) <- case msecret of | otherwise = FormSuccess Nothing
(Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing let msfRes | Just res <- msfRes' = res
_ -> return (Nothing,Nothing) | otherwise = FormSuccess Nothing
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing -- checks that correct button was pressed, and ignores result of btnRes
let widget = $(widgetFile "widgets/register-form/register-form") let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes)
let msecretRes | Just res <- msecretRes' = Just <$> res return (formRes, widget)
| otherwise = FormSuccess Nothing where
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes isRegistered = isJust participant
postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do postCRegisterR tid ssh csh = do
aid <- requireAuthId aid <- requireAuthId
(cid, course, registered) <- runDB $ do (cid, course, registration) <- runDB $ do
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
registered <- isJust <$> getBy (UniqueParticipant aid cid) registration <- getBy (UniqueParticipant aid cid)
return (cid, course, registered) return (cid, course, entityVal <$> registration)
((regResult,_), _) <- runFormPost $ identifyForm FIDCourseRegister $ registerForm registered $ courseRegisterSecret course let isRegistered = isJust registration
case regResult of ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course
(FormSuccess codeOk) formResult regResult $ \(mbSfId,codeOk) -> if
| registered -> do | isRegistered -> do
runDB $ deleteBy $ UniqueParticipant aid cid runDB $ deleteBy $ UniqueParticipant aid cid
addMessageI Info MsgCourseDeregisterOk addMessageI Info MsgCourseDeregisterOk
| codeOk -> do | codeOk -> do
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
| otherwise -> addMessageI Warning MsgCourseSecretWrong | otherwise -> addMessageI Warning MsgCourseSecretWrong
_other -> return () -- TODO check this! -- addMessage Info $ toHtml $ show regResult -- For debugging only
redirect $ CourseR tid ssh csh CShowR redirect $ CourseR tid ssh csh CShowR
@ -502,7 +532,7 @@ data CourseForm = CourseForm
, cfShort :: CourseShorthand , cfShort :: CourseShorthand
, cfTerm :: TermId , cfTerm :: TermId
, cfSchool :: SchoolId , cfSchool :: SchoolId
, cfCapacity :: Maybe Int64 , cfCapacity :: Maybe Int
, cfSecret :: Maybe Text , cfSecret :: Maybe Text
, cfMatFree :: Bool , cfMatFree :: Bool
, cfRegFrom :: Maybe UTCTime , cfRegFrom :: Maybe UTCTime
@ -621,25 +651,53 @@ validateCourse CourseForm{..} =
] ] ] ]
-------------------- --------------------
-- CourseUserTable -- CourseUserTable
type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
type UserTableWhere = UserTableExpr -> E.SqlExpr (E.Value Bool) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId) `E.LeftOuterJoin`
(E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) -- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
forceUserTableType = id -- forceUserTableType = id
userTableQuery :: UserTableWhere -> UserTableExpr -- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
-> E.SqlQuery ( E.SqlExpr (Entity User) -- This ought to ease refactoring the query
, E.SqlExpr (E.Value UTCTime) queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
, E.SqlExpr (E.Value (Maybe CourseUserNoteId))) queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
userTableQuery whereClause t@((user `E.InnerJoin` participant) `E.LeftOuterJoin` note) = do
queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryUserNote = $(sqlLOJproj 3 2)
queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
, E.SqlExpr (E.Value UTCTime)
, E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
, StudyFeaturesDescription')
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
-- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
E.where_ $ whereClause t E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId) return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)
type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms))
instance HasEntity UserTableData User where instance HasEntity UserTableData User where
hasEntity = _dbrOutput . _1 hasEntity = _dbrOutput . _1
@ -654,44 +712,84 @@ _userTableRegistration = _dbrOutput . _2
_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3 _userTableNote = _dbrOutput . _3
-- default Where-Clause _userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
courseIs :: CourseId -> UserTableWhere _userTableFeatures = _dbrOutput . _4
courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid
_rowUserSemester :: Traversal' UserTableData Int
_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh = colUserComment tid ssh csh =
sortable (Just "course-user-note") (i18nCell MsgCourseUserNote) sortable (Just "note") (i18nCell MsgCourseUserNote)
$ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey) } -> $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
maybeEmpty mbNoteKey $ const $ maybeEmpty mbNoteKey $ const $
anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True) anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True)
where where
courseLink = CourseR tid ssh csh . CUserR courseLink = CourseR tid ssh csh . CUserR
-- makeCourseUserTable :: (ToSortable h, Functor h) => colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-- UserTableWhere colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
-- -> Colonnade foldMap numCell . preview _rowUserSemester
-- h
-- (DBRow
-- (Entity User, E.Value UTCTime,
-- E.Value (Maybe CourseUserNoteId)))
-- (DBCell (HandlerT UniWorX IO) ())
-- -> PSValidator (HandlerT UniWorX IO) ()
-- -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
makeCourseUserTable :: UserTableWhere -> _ -> _ -> DB Widget colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
makeCourseUserTable whereClause colChoices psValidator = colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
-- return [whamlet|TODO|] -- TODO foldMap htmlCell . view (_userTableFeatures . _3)
colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
foldMap (htmlCell . shortStudyTerms) . view (_userTableFeatures . _3)
colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
foldMap htmlCell . preview (_userTableFeatures . _2 . _Just)
colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
foldMap (htmlCell . shortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
makeCourseUserTable cid colChoices psValidator =
-- -- psValidator has default sorting and filtering -- -- psValidator has default sorting and filtering
let dbtIdent = "courseUsers" :: Text let dbtIdent = "courseUsers" :: Text
dbtStyle = def dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery = userTableQuery whereClause dbtSQLQuery = userTableQuery cid
dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note) = user E.^. UserId dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId) -> return (user, registrationTime, userNoteId) dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
dbtColonnade = colChoices dbtColonnade = colChoices
dbtSorting = Map.fromList [] -- TODO dbtSorting = Map.fromList
dbtFilter = Map.fromList [] -- TODO [ sortUserNameLink queryUser -- slower sorting through clicking name column header
dbtFilterUI = mempty -- TODO , sortUserSurname queryUser -- needed for initial sorting
, sortUserDisplayName queryUser -- needed for initial sorting
, sortUserEmail queryUser
, sortUserMatriclenr queryUser
, ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
, ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
, ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
, ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
, ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
E.sub_select . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime
)
]
dbtFilter = Map.fromList
[ fltrUserNameLink queryUser
, fltrUserEmail queryUser
, fltrUserMatriclenr queryUser
, fltrUserNameEmail queryUser
-- , ("course-user-degree", error "TODO") -- TODO
-- , ("course-user-field" , error "TODO") -- TODO
, ("course-user-semesternr", FilterColumn $ mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
-- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev
]
dbtParams = def dbtParams = def
in dbTableWidget' psValidator DBTable{..} in dbTableWidget' psValidator DBTable{..}
@ -700,19 +798,21 @@ getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR tid ssh csh = do getCUsersR tid ssh csh = do
Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
whereClause = courseIs cid
colChoices = mconcat colChoices = mconcat
[ colUserParticipantLink tid ssh csh [ colUserNameLink (CourseR tid ssh csh . CUserR)
, colUserEmail , colUserEmail
, colUserMatriclenr , colUserMatriclenr
, sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration) , colUserDegreeShort
, colUserField
, colUserSemester
, sortable (Just "course-registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
, colUserComment tid ssh csh , colUserComment tid ssh csh
] ]
psValidator = def psValidator = def & defaultSortingByName
tableWidget <- runDB $ makeCourseUserTable whereClause colChoices psValidator tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator
siteLayout heading $ do siteLayout heading $ do
setTitle [shamlet| #{toPathPiece tid} - #{csh}|] setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
-- TODO: creat hamlet wrapper -- TODO: create hamlet wrapper
tableWidget tableWidget

2
src/Handler/Profile.hs
View File

@ -248,6 +248,8 @@ getProfileDataR = do
let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication
-- Delete Button -- Delete Button
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete) (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
defaultLayout $ do defaultLayout $ do

32
src/Handler/Utils/Database.hs
View File

@ -1,6 +1,8 @@
module Handler.Utils.Database module Handler.Utils.Database
( getSchoolsOf ( getSchoolsOf
, makeSchoolDictionaryDB, makeSchoolDictionary , makeSchoolDictionaryDB, makeSchoolDictionary
, StudyFeaturesDescription'
, studyFeaturesQuery, studyFeaturesQuery'
) where ) where
import Import import Import
@ -29,3 +31,33 @@ getSchoolsOf uid uschool uuser = fmap (Import.map E.unValue) $ E.select $ E.from
E.where_ $ urights E.^. uuser E.==. E.val uid E.where_ $ urights E.^. uuser E.==. E.val uid
E.orderBy [E.asc $ school E.^.SchoolName] E.orderBy [E.asc $ school E.^.SchoolName]
return $ school E.^. SchoolName return $ school E.^. SchoolName
-- | Sub-Query to retrieve StudyFeatures with their human-readable names
studyFeaturesQuery :: E.Esqueleto query expr backend
=> expr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@
-> expr (Entity StudyFeatures) `E.InnerJoin` expr (Entity StudyDegree) `E.InnerJoin` expr (Entity StudyTerms)
-> query (expr (Entity StudyFeatures), expr (Entity StudyDegree), expr (Entity StudyTerms))
studyFeaturesQuery studyFeaturesId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do
E.on $ terms E.^. StudyTermsId E.==. features E.^. StudyFeaturesField
E.on $ degree E.^. StudyDegreeId E.==. features E.^. StudyFeaturesDegree
E.on $ features E.^. StudyFeaturesId E.==. studyFeaturesId
return (features, degree, terms)
type StudyFeaturesDescription' =
( E.SqlExpr (Maybe (Entity StudyFeatures))
, E.SqlExpr (Maybe (Entity StudyDegree))
, E.SqlExpr (Maybe (Entity StudyTerms))
)
-- | Variant of @studyFeaturesQuery@ to be used in outer joins
-- Sub-Query to retrieve StudyFeatures with their human-readable names
studyFeaturesQuery'
:: E.SqlExpr (E.Value (Maybe StudyFeaturesId)) -- ^ query is joined on this @Maybe StudyFeaturesId@
-> (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))
-> E.SqlQuery StudyFeaturesDescription'
studyFeaturesQuery' studyFeatureId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do
E.on $ terms E.?. StudyTermsId E.==. features E.?. StudyFeaturesField
E.on $ degree E.?. StudyDegreeId E.==. features E.?. StudyFeaturesDegree
E.on $ features E.?. StudyFeaturesId E.==. studyFeatureId
return (features, degree, terms)

41
src/Handler/Utils/Form.hs
View File

@ -214,6 +214,47 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
-- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user)
-- (too many special cases, hence not used in course registration anymore)
studyFeaturesPrimaryFieldFor :: [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
-- we need a join, so we cannot just use optionsPersistCryptoId
rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do
E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId
E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures)
E.||. isPrimaryActiveUserStudyFeature feature
return (feature E.^. StudyFeaturesId, degree, field)
mr <- getMessageRender
mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM procOptions rawOptions
where
isPrimaryActiveUserStudyFeature feature = case mbuid of
Nothing -> E.val False
(Just uid) -> feature E.^. StudyFeaturesUser E.==. E.val uid
E.&&. feature E.^. StudyFeaturesValid E.==. E.val True
E.&&. feature E.^. StudyFeaturesType E.==. E.val FieldPrimary
procOptions :: (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId))
procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do
let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName)
stname = fromMaybe (tshow stid) (studyTermsShorthand <|> studyTermsName )
cfid <- encrypt sfid
return Option
{ optionDisplay = stname <> " (" <> dgname <> ")"
, optionInternalValue = Just sfid
, optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId)
}
nonEmptyOptions :: Text -> [Option (Maybe StudyFeaturesId)] -> [Option (Maybe StudyFeaturesId)]
nonEmptyOptions emptyOpt opts
| null opts = [ Option
{ optionDisplay = emptyOpt
, optionInternalValue = Nothing
, optionExternalValue = "NoPrimaryStudyField"
} ]
| otherwise = opts
uploadModeField :: Field Handler UploadMode uploadModeField :: Field Handler UploadMode
uploadModeField = selectField optionsFinite uploadModeField = selectField optionsFinite

14
src/Handler/Utils/StudyFeatures.hs
View File

@ -8,12 +8,12 @@ import Text.Parsec
import Text.Parsec.Text import Text.Parsec.Text
parseStudyFeatures :: UserId -> Text -> Either Text [StudyFeatures] parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures]
parseStudyFeatures uId = first tshow . parse (pStudyFeatures uId <* eof) "" parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) ""
pStudyFeatures :: UserId -> Parser [StudyFeatures] pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
pStudyFeatures studyFeaturesUser = do pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
studyFeaturesDegree <- StudyDegreeKey' <$> pKey studyFeaturesDegree <- StudyDegreeKey' <$> pKey
void $ string "$$" void $ string "$$"
@ -28,11 +28,11 @@ pStudyFeatures studyFeaturesUser = do
studyFeaturesType <- pType studyFeaturesType <- pType
void $ char '!' void $ char '!'
studyFeaturesSemester <- decimal studyFeaturesSemester <- decimal
let studyFeaturesValid = True
return StudyFeatures{..} return StudyFeatures{..}
pStudyFeature `sepBy1` char '#' pStudyFeature `sepBy1` char '#'
pKey :: Parser Int pKey :: Parser Int
pKey = decimal pKey = decimal

47
src/Handler/Utils/Table/Cells.hs
View File

@ -9,6 +9,8 @@ import Data.Monoid (Any(..))
import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.Writer (WriterT) import Control.Monad.Trans.Writer (WriterT)
import Text.Blaze (ToMarkup(..))
import Utils.Lens import Utils.Lens
import Handler.Utils import Handler.Utils
@ -35,15 +37,31 @@ writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
writerCell act = mempty & cellContents %~ (<* act) writerCell act = mempty & cellContents %~ (<* act)
maybeCell :: (IsDBTable m a) => Maybe a -> (a -> DBCell m a) -> DBCell m a maybeCell :: (IsDBTable m a) => Maybe a -> (a -> DBCell m a) -> DBCell m a
maybeCell =flip foldMap maybeCell = flip foldMap
htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
htmlCell = cell . toWidget . toMarkup
pathPieceCell :: (IsDBTable m a, PathPiece p) => p -> DBCell m a
pathPieceCell = cell . toWidget . toPathPiece
-- | execute a DB action that return a widget for the cell contents
sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a
sqlCell act = mempty & cellContents .~ lift act
--------------------- ---------------------
-- Icon cells -- Icon cells
-- | Maybe display a tickmark/checkmark icon
tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
tickmarkCell = cell . toWidget . hasTickmark tickmarkCell = cell . toWidget . hasTickmark
-- | Maybe display a exclamation icon
isNewCell :: (IsDBTable m a) => Bool -> DBCell m a
isNewCell = cell . toWidget . isNew
-- | Maybe display comment icon linking a given URL or show nothing at all
commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
commentCell Nothing = mempty commentCell Nothing = mempty
commentCell (Just link) = anchorCell link icon commentCell (Just link) = anchorCell link icon
@ -167,30 +185,3 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
correctorLoadCell sc = correctorLoadCell sc =
i18nCell $ sheetCorrectorLoad sc i18nCell $ sheetCorrectorLoad sc
--------------------------------
-- Generic Columns
-- reuse encourages consistency
--
-- if it works out, turn into its own module
-- together with filters and sorters
-- | Does not work, since we have now show Instance for RenderMesage UniWorX msg
colUser :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c)
colUser msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
colUserParticipant :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMembers) cellHasUser
colUserParticipantLink :: (IsDBTable m c, HasEntity a User) => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable a (DBCell m c)
colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMembers) (cellHasUserLink courseLink)
where
-- courseLink :: CryptoUUIDUser -> Route UniWorX
courseLink = CourseR tid ssh csh . CUserR
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail

157
src/Handler/Utils/Table/Columns.hs Normal file
View File

@ -0,0 +1,157 @@
module Handler.Utils.Table.Columns where
import Import
-- import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI
-- import Data.Monoid (Any(..))
-- import Control.Monad.Writer.Class (MonadWriter(..))
-- import Control.Monad.Trans.Writer (WriterT)
-- import Text.Blaze (ToMarkup(..))
import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils as E
import Utils.Lens
import Handler.Utils
import Handler.Utils.Table.Cells
--------------------------------
-- Generic Columns
-- reuse encourages consistency
--
-- The constant string for sort/filter keys
-- should never be mentioned outside of this module
-- to ensure consistency!
--
-- Each section should have the following parts:
-- * colXYZ : column definitions plus variants
-- * sortXYZ : sorting definitions for these columns
-- * fltrXYZ : filter definitions for these columns
-- * additional helper, such as default sorting
---------------
-- User names
-- | Generic sort key from msg does not work, since we have no show Instance for RenderMesage UniWorX msg. Dangerous anyway!
colUserName' :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c)
colUserName' msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserName = sortable (Just "user-name") (i18nCell MsgCourseMembers) cellHasUser
colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
-- TOOD: We want to sort first by UserSurname and then by UserDisplayName, not supportet by dbTable
-- see also @defaultSortingName@
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
sortUserName queryUser = ("user-name", SortColumn $ toSortKey . queryUser)
where toSortKey user = (user E.^. UserSurname) E.++. (user E.^. UserDisplayName)
-- | Alias for sortUserName for consistency, since column comes in two variants
sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
sortUserNameLink = sortUserName
sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname))
sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>> (E.^. UserDisplayName))
defaultSortingByName :: PSValidator m x -> PSValidator m x
defaultSortingByName =
defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
-- defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
-- | Alias for sortUserName for consistency
fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t)
fltrUserNameLink = fltrUserName
fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t)
fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
where
queryName = queryUser >>> (E.^. UserDisplayName)
fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t)
fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
where
queryName = queryUser >>> (E.^. UserDisplayName)
fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t)
fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname))
fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t)
fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
-- | Searche all names, i.e. DisplayName, Surname, EMail
fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t)
fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
[ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
, mkContainsFilter $ queryUser >>> (E.^. UserSurname)
, mkContainsFilter $ queryUser >>> (E.^. UserEmail)
]
)
fltrUserNameLinkUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrUserNameLinkUI = fltrUserNameUI
fltrUserNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrUserNameUI mPrev =
prismAForm (singletonFilter "user-name") mPrev $ aopt (searchField True) (fslI MsgCourseMembers)
fltrUserNameEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrUserNameEmailUI mPrev =
prismAForm (singletonFilter "user-name-email") mPrev $ aopt (searchField True) (fslI MsgCourseMembers)
-------------------
-- Matriclenumber
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
fltrUserMatriclenr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t)
fltrUserMatriclenr queryUser = ( "user-matriclenumber", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserMatrikelnummer))
fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrUserMatriclenrUI mPrev =
prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt (searchField False) (fslI MsgMatrikelNr)
----------------
-- User E-Mail
colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserEmail = sortable (Just "user-email") (i18nCell MsgEMail) cellHasEMail
sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail))
fltrUserEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t)
fltrUserEmail queryUser = ( "user-email", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserEmail))
fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrUserEmailUI mPrev =
prismAForm (singletonFilter "user-email") mPrev $ aopt (searchField False) (fslI MsgEMail)

30
src/Handler/Utils/Table/Pagination.hs
View File

@ -39,6 +39,7 @@ import Utils.Lens.TH
import Import hiding (pi) import Import hiding (pi)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue) import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
import qualified Database.Esqueleto.Internal.Language as E (From) import qualified Database.Esqueleto.Internal.Language as E (From)
@ -53,7 +54,7 @@ import Control.Monad.Trans.Maybe
import Data.Foldable (Foldable(foldMap)) import Data.Foldable (Foldable(foldMap))
import Data.Map (Map, (!)) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
@ -89,9 +90,6 @@ import qualified Data.ByteString.Base64.URL as Base64 (encode)
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
$(sqlInTuples [2..16])
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
data SortDirection = SortAsc | SortDesc data SortDirection = SortAsc | SortDesc
@ -370,12 +368,12 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
data DBTable m x = forall a r r' h i t k k'. data DBTable m x = forall a r r' h i t k k'.
( ToSortable h, Functor h ( ToSortable h, Functor h
, E.SqlSelect a r, SqlIn k k', DBTableKey k' , E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
, PathPiece i, Eq i , PathPiece i, Eq i
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
) => DBTable ) => DBTable
{ dbtSQLQuery :: t -> E.SqlQuery a { dbtSQLQuery :: t -> E.SqlQuery a
, dbtRowKey :: t -> k , dbtRowKey :: t -> k -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
, dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r' , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
, dbtColonnade :: Colonnade h r' (DBCell m x) , dbtColonnade :: Colonnade h r' (DBCell m x)
, dbtSorting :: Map SortingKey (SortColumn t) , dbtSorting :: Map SortingKey (SortColumn t)
@ -652,7 +650,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
= (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing = (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
| otherwise | otherwise
= (, def) $ runPSValidator dbtable Nothing = (, def) $ runPSValidator dbtable Nothing
psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting psSorting' = map (\SortingSetting{..} -> (Map.findWithDefault (error $ "Invalid sorting key: " <> show sortKey) sortKey dbtSorting, sortDir)) psSorting
mapM_ (addMessageI Warning) errs mapM_ (addMessageI Warning) errs
@ -665,9 +663,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
-> do -> do
E.limit l E.limit l
E.offset (psPage * l) E.offset (psPage * l)
Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
_other -> return () _other -> return ()
Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v) let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
@ -869,11 +867,11 @@ instance Ord i => Monoid (DBFormResult i a r) where
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
formCell :: forall res r i a. (Ord i, Monoid res) formCell :: forall x r i a. (Ord i, Monoid x)
=> Lens' res (FormResult (DBFormResult i a (DBRow r))) => Lens' x (FormResult (DBFormResult i a (DBRow r))) -- ^ lens focussing on the form result within the larger DBResult; @id@ iff the form delivers the only result of the table
-> (DBRow r -> MForm (HandlerT UniWorX IO) i) -> (DBRow r -> MForm (HandlerT UniWorX IO) i) -- ^ generate row identfifiers for use in form result
-> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm` -> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) res) -> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) x)
formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
{ formCellAttrs = [] { formCellAttrs = []
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget) , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
@ -896,11 +894,11 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res) dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid x)
=> Lens' res (FormResult (DBFormResult i a (DBRow r))) => Lens' x (FormResult (DBFormResult i a (DBRow r)))
-> Setter' a Bool -> Setter' a Bool
-> (DBRow r -> MForm (HandlerT UniWorX IO) i) -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) res) -> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) x)
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
where where
genForm _ mkUnique = do genForm _ mkUnique = do

41
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -6,8 +6,6 @@ module Handler.Utils.Table.Pagination.Types
, sortable , sortable
, ToSortable(..) , ToSortable(..)
, SortableP(..) , SortableP(..)
, SqlIn(..)
, sqlInTuples
, DBTableInvalid(..) , DBTableInvalid(..)
) where ) where
@ -20,13 +18,6 @@ import Data.CaseInsensitive (CI)
import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey) import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
import Language.Haskell.TH
import Data.List (foldr1, foldl)
newtype FilterKey = FilterKey { _unFilterKey :: CI Text } newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
deriving (Show, Read, Generic) deriving (Show, Read, Generic)
@ -67,38 +58,6 @@ instance ToSortable Headless where
pSortable = Nothing pSortable = Nothing
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
sqlInTuples :: [Int] -> DecsQ
sqlInTuples = mapM sqlInTuple
sqlInTuple :: Int -> DecQ
sqlInTuple arity = do
tyVars <- replicateM arity $ newName "t"
vVs <- replicateM arity $ newName "v"
xVs <- replicateM arity $ newName "x"
xsV <- newName "xs"
let
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
[ funD 'sqlIn
[ clause [tupP $ map varP xVs, varP xsV]
( guardedB
[ normalGE [e|null $(varE xsV)|] [e|E.val False|]
, normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
]
) []
]
]
data DBTableInvalid = DBTIRowsMissing Int data DBTableInvalid = DBTIRowsMissing Int
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)

184
src/Handler/Utils/TermCandidates.hs Normal file
View File

@ -0,0 +1,184 @@
module Handler.Utils.TermCandidates where
import Import
-- import Handler.Utils
-- Import this module as Candidates
-- import Utils.Lens
-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
-- import Yesod.Form.Bootstrap3
-- import Colonnade hiding (fromMaybe)
-- import Yesod.Colonnade
-- import qualified Data.UUID.Cryptographic as UUID
-- import Control.Monad.Trans.Writer (mapWriterT)
-- import Database.Persist.Sql (fromSqlKey)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
-- import Database.Esqueleto.Utils as E
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
type STKey = Int -- for convenience, assmued identical to field StudyTermCandidateKey
data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms]
deriving (Typeable, Show)
instance Exception FailedCandidateInference
-- Default Instance
-- -- | Just an heuristik to fill in defaults
-- shortenStudyTerm :: Text -> Text
-- shortenStudyTerm = concatMap (take 4) . splitCamel
-- | Attempt to identify new StudyTerms based on observations, returning:
-- * list of ambiguous instances that were discarded outright (identical names for differents keys observed in single incidences)
-- * list of problems, ie. StudyTerms that contradict observed incidences
-- * list of redundants, i.e. redundant observed incidences
-- * list of accepted, i.e. newly accepted key/name pairs
inferHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermCandidate],[(STKey,Text)])
inferHandler = runDB $ inferAcc ([],[],[])
where
inferAcc (accAmbiguous, accRedundants, accAccepted) =
handle (\(FailedCandidateInference fails) -> (fails,accAmbiguous,accRedundants,accAccepted) <$ E.transactionUndo) $ do
(infAmbis, infReds,infAccs) <- inferStep
if null infAccs
then return ([], accAmbiguous, infReds ++ accRedundants, accAccepted)
else do
E.transactionSave -- commit transaction if there are no problems
inferAcc (infAmbis ++ accAmbiguous, infReds ++ accRedundants, infAccs ++ accAccepted)
inferStep = do
ambiguous <- removeAmbiguous
redundants <- removeRedundant
accepted <- acceptSingletons
problems <- conflicts
unless (null problems) $ throwM $ FailedCandidateInference problems
return (ambiguous, redundants, accepted)
{-
Candidate 1 11 "A"
Candidate 1 11 "B"
Candidate 1 12 "A"
Candidate 1 12 "B"
Candidate 2 12 "B"
Candidate 2 12 "C"
Candidate 2 13 "B"
Candidate 2 13 "C"
should readily yield 11/A, 12/B 13/C:
it can infer due to overlab that 12/B must be true, then eliminating B identifies A and C;
this rests on the assumption that the Names are unique, which is NOT TRUE;
as a fix we simply eliminate all observations that have the same name twice, see removeInconsistent
-}
-- | remove candidates with ambiguous observations,
-- ie. candidates that have duplicated term names with differing keys
-- which may happen in rare cases
removeAmbiguous :: DB [TermCandidateIncidence]
removeAmbiguous = do
ambiList <- E.select $ E.from $ \candidate -> do
E.groupBy ( candidate E.^. StudyTermCandidateIncidence
, candidate E.^. StudyTermCandidateKey
, candidate E.^. StudyTermCandidateName
)
E.having $ E.countRows E.!=. E.val (1 :: Int64)
return $ candidate E.^. StudyTermCandidateIncidence
let ambiSet = E.unValue <$> List.nub ambiList
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
deleteWhere [StudyTermCandidateIncidence <-. ambiSet]
return ambiSet
-- | remove known StudyTerm from candidates that have the _exact_ name,
-- ie. if a candidate contains a known key, we remove it and its associated fullname
-- only save if ambiguous candidates haven been removed
removeRedundant :: DB [Entity StudyTermCandidate]
removeRedundant = do
redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
E.on $ candidate E.^. StudyTermCandidateKey E.==. sterm E.^. StudyTermsKey
E.&&. E.just (candidate E.^. StudyTermCandidateName) E.==. sterm E.^. StudyTermsName
return candidate
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
forM_ redundants $ \Entity{entityVal=StudyTermCandidate{..}} ->
deleteWhere $ ( StudyTermCandidateIncidence ==. studyTermCandidateIncidence )
: ([ StudyTermCandidateKey ==. studyTermCandidateKey ]
||. [ StudyTermCandidateName ==. studyTermCandidateName ])
return redundants
-- | Search for single candidates and memorize them as StudyTerms.
-- Should be called after @removeRedundant@ to increase success chances and reduce cost; otherwise memory heavy!
-- Does not delete the used candidates, user @removeRedundant@ for this later on.
-- Esqueleto does not provide the INTERESECT operator, thus
-- we load the table into Haskell and operate there. Memory usage problem? StudyTermsCandidate may become huge.
acceptSingletons :: DB [(STKey,Text)]
acceptSingletons = do
knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
-- let knownKeysSet = Set.fromAscList knownKeys
-- In case of memory problems, change next lines to conduit proper:
incidences <- fmap entityVal <$> selectList [StudyTermCandidateKey /<-. knownKeys] [] -- LimitTo might be dangerous here, if we get a partial incidence. Possibly first select N incidences, then retrieving all those only.
-- incidences <- E.select $ E.from $ \candidate -> do
-- E.where_ $ candidate E.^. StudyTermCandidayeKey `E.notIn` E.valList knownKeys
-- return candidate
-- Possibly expensive pure computations follows. Break runDB to shorten transaction?
let groupedCandidates :: Map STKey (Map UUID (Set Text))
groupedCandidates = foldl' groupFun mempty incidences
-- given a key, map each incidence to set of possible names for this key
groupFun :: Map STKey (Map TermCandidateIncidence (Set Text)) -> StudyTermCandidate -> Map STKey (Map TermCandidateIncidence (Set Text))
groupFun m StudyTermCandidate{..} =
insertWith (Map.unionWith Set.union)
studyTermCandidateKey
(Map.singleton studyTermCandidateIncidence $ Set.singleton studyTermCandidateName)
m
-- pointwise intersection per incidence gives possible candidates per key
keyCandidates :: Map STKey (Set Text)
keyCandidates = Map.map (setIntersections . Map.elems) groupedCandidates
-- filter candidates having a unique possibility left
fixedKeys :: [(STKey,Text)]
fixedKeys = Map.foldlWithKey' combFixed [] keyCandidates
combFixed :: [(STKey,Text)] -> STKey -> Set Text -> [(STKey,Text)]
combFixed acc k s | Set.size s == 1 -- possibly redundant
, [n] <- Set.elems s = (k,n):acc
-- empty sets should not occur here , if LDAP is consistent. Maybe raise a warning?!
| otherwise = acc
-- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
registerFixed :: (STKey, Text) -> DB ()
registerFixed (key, name) = repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name)
-- register newly fixed candidates
forM_ fixedKeys registerFixed
return fixedKeys
-- | all existing StudyTerms that are contradiced by current observations
conflicts :: DB [Entity StudyTerms]
conflicts = E.select $ E.from $ \studyTerms -> do
E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
E.where_ $ E.exists $ E.from $ \candidateOne -> do
E.where_ $ candidateOne E.^. StudyTermCandidateKey E.==. studyTerms E.^. StudyTermsKey
E.where_ $ E.notExists . E.from $ \candidateTwo -> do
E.where_ $ candidateTwo E.^. StudyTermCandidateIncidence E.==. candidateOne E.^. StudyTermCandidateIncidence
E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
return studyTerms

2
src/Import/NoFoundation.hs
View File

@ -62,6 +62,8 @@ import Database.Persist.Sql.Instances as Import ()
import Database.Persist.Sql as Import (SqlReadT,SqlWriteT) import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
import Numeric.Natural.Instances as Import () import Numeric.Natural.Instances as Import ()
import System.Random as Import (Random)
import Control.Monad.Random.Class as Import (MonadRandom(..))
import Control.Monad.Trans.RWS (RWST) import Control.Monad.Trans.RWS (RWST)

19
src/Model.hs
View File

@ -19,7 +19,9 @@ import Data.Aeson (Value)
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Data.CaseInsensitive.Instances () import Data.CaseInsensitive.Instances ()
import Text.Blaze (ToMarkup, toMarkup, Markup)
import Utils.Message (MessageStatus) import Utils.Message (MessageStatus)
import Settings.Cluster (ClusterSettingsKey) import Settings.Cluster (ClusterSettingsKey)
import Data.Binary (Binary) import Data.Binary (Binary)
@ -41,3 +43,20 @@ deriving instance Binary (Key Term)
submissionRatingDone :: Submission -> Bool submissionRatingDone :: Submission -> Bool
submissionRatingDone Submission{..} = isJust submissionRatingTime submissionRatingDone Submission{..} = isJust submissionRatingTime
-- Do these instances belong here?
instance ToMarkup StudyDegree where
toMarkup StudyDegree{..} = toMarkup $
fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
shortStudyDegree :: StudyDegree -> Markup
shortStudyDegree StudyDegree{..} = toMarkup $
fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
instance ToMarkup StudyTerms where
toMarkup StudyTerms{..} = toMarkup $
fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
shortStudyTerms :: StudyTerms -> Markup
shortStudyTerms StudyTerms{..} = toMarkup $
fromMaybe (tshow studyTermsKey) studyTermsShorthand

16
src/Model/Migration.hs
View File

@ -207,6 +207,22 @@ customMigrations = Map.fromListWith (>>)
UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points', 'passing', 0)) WHERE ("type"->'grading'->'type') = '"pass-points"' AND jsonb_exists("type"->'grading', 'points'); UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points', 'passing', 0)) WHERE ("type"->'grading'->'type') = '"pass-points"' AND jsonb_exists("type"->'grading', 'points');
|] |]
) )
, ( AppliedMigrationKey [migrationVersion|8.0.0|] [version|9.0.0|]
, whenM ((\a b c -> a && b && not c) <$> tableExists "study_features" <*> tableExists "course_participant" <*> columnExists "course_participant" "field") $ do
[executeQQ|
ALTER TABLE "course_participant" ADD COLUMN "field" bigint DEFAULT null REFERENCES study_features(id);
ALTER TABLE "study_features" ADD COLUMN IF NOT EXISTS "valid" boolean NOT NULL DEFAULT true;
|]
users <- [sqlQQ| SELECT DISTINCT ON ("user"."id") "user"."id", "study_features"."id" FROM "user", "study_features" WHERE "study_features"."user" = "user"."id" AND "study_features"."valid" AND "study_features"."type" = 'FieldPrimary' ORDER BY "user"."id", random(); |]
forM_ users $ \(uid :: UserId, sfid :: StudyFeaturesId) -> [executeQQ| UPDATE "course_participant" SET "field" = #{sfid} WHERE "user" = #{uid} AND "field" IS NULL; |]
)
, ( AppliedMigrationKey [migrationVersion|9.0.0|] [version|10.0.0|]
, do
whenM (columnExists "study_degree" "shorthand") $ [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
whenM (columnExists "study_degree" "name") $ [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
)
] ]

2
src/Model/Types.hs
View File

@ -8,6 +8,7 @@ module Model.Types
, module Numeric.Natural , module Numeric.Natural
, module Mail , module Mail
, module Utils.DateTime , module Utils.DateTime
, module Data.UUID.Types
) where ) where
import ClassyPrelude import ClassyPrelude
@ -784,3 +785,4 @@ type UserEmail = CI Email
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
type InstanceId = UUID type InstanceId = UUID
type TermCandidateIncidence = UUID

36
src/Utils.hs
View File

@ -24,23 +24,24 @@ import Utils.DateTime as Utils
import Utils.PathPiece as Utils import Utils.PathPiece as Utils
import Utils.Message as Utils import Utils.Message as Utils
import Utils.Lang as Utils import Utils.Lang as Utils
import Control.Lens as Utils (none)
import Utils.Parameters as Utils import Utils.Parameters as Utils
import Text.Blaze (Markup, ToMarkup) import Text.Blaze (Markup, ToMarkup)
import Data.Char (isDigit, isSpace) import Data.Char (isDigit, isSpace)
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
import Numeric (showFFloat) import Numeric (showFFloat)
import Control.Lens
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
-- import qualified Data.List as List -- import qualified Data.List as List
import Control.Lens
import Control.Lens as Utils (none)
import Control.Arrow as Utils ((>>>))
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Except (MonadError(..)) import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Maybe (MaybeT(..))
@ -160,6 +161,11 @@ hasTickmark :: Bool -> Markup
hasTickmark True = [shamlet|<i .fas .fa-check>|] hasTickmark True = [shamlet|<i .fas .fa-check>|]
hasTickmark False = mempty hasTickmark False = mempty
isNew :: Bool -> Markup
isNew True = [shamlet|<i .fas .fa-exclamation>|]
isNew False = mempty
--------------------- ---------------------
-- Text and String -- -- Text and String --
--------------------- ---------------------
@ -321,6 +327,17 @@ mergeAttrs = mergeAttrs' `on` sort
----------
-- Sets --
----------
-- | Intersection of multiple sets. Returns empty set for empty input list
setIntersections :: Ord a => [Set a] -> Set a
setIntersections [] = Set.empty
setIntersections (h:t) = foldl' Set.intersection h t
---------- ----------
-- Maps -- -- Maps --
---------- ----------
@ -341,6 +358,17 @@ invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
invertMap = groupMap . map swap . Map.toList invertMap = groupMap . map swap . Map.toList
---------------
-- Functions --
---------------
-- curryN, uncurryN see Utils.TH
-- | Just @flip (.)@ for convenient formatting in some cases,
-- Deprecated in favor of Control.Arrow.(>>>)
compose :: (a -> b) -> (b -> c) -> (a -> c)
compose = flip (.)
----------- -----------
-- Maybe -- -- Maybe --
@ -474,8 +502,6 @@ throwExceptT :: ( Exception e, MonadThrow m )
=> ExceptT e m a -> m a => ExceptT e m a -> m a
throwExceptT = exceptT throwM return throwExceptT = exceptT throwM return
------------ ------------
-- Monads -- -- Monads --
------------ ------------

1
src/Utils/Form.hs
View File

@ -198,6 +198,7 @@ addAutosubmit = addAttr "data-autosubmit" ""
data FormIdentifier data FormIdentifier
= FIDcourse = FIDcourse
| FIDcourseRegister
| FIDsheet | FIDsheet
| FIDsubmission | FIDsubmission
| FIDsettings | FIDsettings

9
src/Utils/Lens.hs
View File

@ -82,6 +82,15 @@ makePrisms ''AuthResult
makePrisms ''FormResult makePrisms ''FormResult
makeLenses_ ''StudyFeatures
makeLenses_ ''StudyDegree
makeLenses_ ''StudyTerms
makeLenses_ ''StudyTermCandidate
-- makeClassy_ ''Load -- makeClassy_ ''Load

23
src/Utils/TH.hs
View File

@ -20,10 +20,25 @@ import Data.List ((!!), foldl)
-- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens -- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens
projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2) --ghci -fth projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2) --ghci -fth
-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n) -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
projNI n i = lamE [pat] rhs projNI n i = do
where pat = tupP (map varP xs) x <- newName "x"
rhs = varE (xs !! (i - 1)) let rhs = varE x
xs = [ mkName $ "x" ++ show j | j <- [1..n] ] let pat = tupP $ replicate (pred i) wildP ++ varP x : replicate (n-i) wildP
lamE [pat] rhs
-- | Generic projections N-tuples that are actually left-associative pairs
-- i.e. @$(leftAssociativePairProjection c n m :: (..(t1 `c` t2) `c` .. `c` tn) -> tm@ (for m<=n)
leftAssociativePairProjection :: Name -> Int -> Int -> ExpQ
leftAssociativePairProjection constructor n i = do
x <- newName "x"
lamE [pat x n] (varE x)
where
pat x 1 = varP x
pat x w
| w==i = conP constructor [wildP, varP x]
| otherwise = conP constructor [pat x (pred w), wildP]
--------------- ---------------
-- Functions -- -- Functions --

2
start.sh
View File

@ -2,7 +2,7 @@
unset HOST unset HOST
export DETAILED_LOGGING=true export DETAILED_LOGGING=true
export LOG_ALL=true export LOG_ALL=false
export LOGLEVEL=info export LOGLEVEL=info
export DUMMY_LOGIN=true export DUMMY_LOGIN=true
export ALLOW_DEPRECATED=true export ALLOW_DEPRECATED=true

19
templates/adminFeatures.hamlet Normal file
View File

@ -0,0 +1,19 @@
<section>
^{degreeTable}
<section>
^{studytermsTable}
<section>
<h2>_{MsgStudyFeatureInference}
<p>
$if null infConflicts
Kein Konflikte beobachtet.
$else
<h3>Studiengangseingträge mit beobachteten Konflikten:
<ul>
$forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts
<li> #{show ky} - #{foldMap id nm}
<form .form-inline method=post action=@{AdminFeaturesR} enctype=#{btnEnctype}>
^{btnWdgt}
<div .container>
^{candidateTable}

6
templates/profileData.hamlet
View File

@ -10,6 +10,12 @@
<dd .deflist__dd> #{display userEmail} <dd .deflist__dd> #{display userEmail}
<dt .deflist__dt> _{MsgIdent} <dt .deflist__dt> _{MsgIdent}
<dd .deflist__dd> #{display userIdent} <dd .deflist__dd> #{display userIdent}
<dt .deflist__dt> _{MsgLastLogin}
<dd .deflist__dd>
$maybe llogin <- lastLogin
#{llogin}
$nothing
_{MsgNever}
$if not $ null admin_rights $if not $ null admin_rights
<dt .deflist__dt> Administrator <dt .deflist__dt> Administrator
<dd .deflist__dd> <dd .deflist__dd>

6
templates/widgets/register-form/register-form.hamlet
View File

@ -2,6 +2,12 @@ $# extra protects us against CSRF
#{extra} #{extra}
$# Maybe display textField for passcode $# Maybe display textField for passcode
$maybe secretView <- msecretView $maybe secretView <- msecretView
^{fvLabel secretView}
^{fvInput secretView} ^{fvInput secretView}
$# Ask for associated primary field uf study, unless registered
$maybe sfView <- msfView
^{fvLabel sfView}
^{fvInput sfView}
$# Always display register/deregister button $# Always display register/deregister button
^{fvInput btnView} ^{fvInput btnView}

164
test/Database.hs
View File

@ -93,6 +93,7 @@ fillDb = do
gkleen <- insert User gkleen <- insert User
{ userIdent = "G.Kleen@campus.lmu.de" { userIdent = "G.Kleen@campus.lmu.de"
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
, userLastAuthentication = Just now
, userMatrikelnummer = Nothing , userMatrikelnummer = Nothing
, userEmail = "G.Kleen@campus.lmu.de" , userEmail = "G.Kleen@campus.lmu.de"
, userDisplayName = "Gregor Kleen" , userDisplayName = "Gregor Kleen"
@ -109,6 +110,7 @@ fillDb = do
fhamann <- insert User fhamann <- insert User
{ userIdent = "felix.hamann@campus.lmu.de" { userIdent = "felix.hamann@campus.lmu.de"
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userMatrikelnummer = Nothing , userMatrikelnummer = Nothing
, userEmail = "felix.hamann@campus.lmu.de" , userEmail = "felix.hamann@campus.lmu.de"
, userDisplayName = "Felix Hamann" , userDisplayName = "Felix Hamann"
@ -125,6 +127,7 @@ fillDb = do
jost <- insert User jost <- insert User
{ userIdent = "jost@tcs.ifi.lmu.de" { userIdent = "jost@tcs.ifi.lmu.de"
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userMatrikelnummer = Nothing , userMatrikelnummer = Nothing
, userEmail = "jost@tcs.ifi.lmu.de" , userEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost" , userDisplayName = "Steffen Jost"
@ -141,6 +144,7 @@ fillDb = do
maxMuster <- insert User maxMuster <- insert User
{ userIdent = "max@campus.lmu.de" { userIdent = "max@campus.lmu.de"
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
, userLastAuthentication = Just now
, userMatrikelnummer = Just "1299" , userMatrikelnummer = Just "1299"
, userEmail = "max@campus.lmu.de" , userEmail = "max@campus.lmu.de"
, userDisplayName = "Max Musterstudent" , userDisplayName = "Max Musterstudent"
@ -157,6 +161,7 @@ fillDb = do
tinaTester <- insert $ User tinaTester <- insert $ User
{ userIdent = "tester@campus.lmu.de" { userIdent = "tester@campus.lmu.de"
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userMatrikelnummer = Just "999" , userMatrikelnummer = Just "999"
, userEmail = "tester@campus.lmu.de" , userEmail = "tester@campus.lmu.de"
, userDisplayName = "Tina Tester" , userDisplayName = "Tina Tester"
@ -198,7 +203,7 @@ fillDb = do
, termActive = True , termActive = True
} }
ifi <- insert' $ School "Institut für Informatik" "IfI" ifi <- insert' $ School "Institut für Informatik" "IfI"
mi <- insert' $ School "Institut für Mathematik" "MI" mi <- insert' $ School "Institut für Mathematik" "MI"
void . insert' $ UserAdmin gkleen ifi void . insert' $ UserAdmin gkleen ifi
void . insert' $ UserAdmin gkleen mi void . insert' $ UserAdmin gkleen mi
void . insert' $ UserAdmin fhamann ifi void . insert' $ UserAdmin fhamann ifi
@ -210,13 +215,150 @@ fillDb = do
let let
sdBsc = StudyDegreeKey' 82 sdBsc = StudyDegreeKey' 82
sdMst = StudyDegreeKey' 88 sdMst = StudyDegreeKey' 88
sdLAR = StudyDegreeKey' 33
sdLAG = StudyDegreeKey' 35
repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" )
repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" ) repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" )
repsert sdLAR $ StudyDegree 33 (Just "LAR") Nothing -- intentionally left unknown
repsert sdLAG $ StudyDegree 35 Nothing Nothing -- intentionally left unknown
let let
sdInf = StudyTermsKey' 79 sdInf = StudyTermsKey' 79
sdMath = StudyTermsKey' 105 sdMath = StudyTermsKey' 105
repsert sdInf $ StudyTerms 79 (Just "IfI") (Just "Institut für Informatik") sdMedi = StudyTermsKey' 121
repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut") sdPhys = StudyTermsKey' 128
sdBioI1 = StudyTermsKey' 221
sdBioI2 = StudyTermsKey' 228
sdBiol = StudyTermsKey' 26
sdChem1 = StudyTermsKey' 61
sdChem2 = StudyTermsKey' 113
sdBWL = StudyTermsKey' 21
sdDeut = StudyTermsKey' 103
repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatikk")
repsert sdMath $ StudyTerms 105 (Just "Math" ) (Just "Mathematik")
repsert sdMedi $ StudyTerms 121 Nothing (Just "Fehler hier")
repsert sdPhys $ StudyTerms 128 Nothing Nothing -- intentionally left unknown
repsert sdBioI1 $ StudyTerms 221 Nothing Nothing -- intentionally left unknown
repsert sdBioI2 $ StudyTerms 228 Nothing Nothing -- intentionally left unknown
repsert sdBiol $ StudyTerms 26 Nothing Nothing -- intentionally left unknown
repsert sdChem1 $ StudyTerms 61 Nothing Nothing -- intentionally left unknown
repsert sdChem2 $ StudyTerms 113 Nothing Nothing -- intentionally left unknown
repsert sdBWL $ StudyTerms 21 Nothing Nothing -- intentionally left unknown
repsert sdDeut $ StudyTerms 103 Nothing Nothing -- intentionally left unknown
incidence1 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence1 221 "Bioinformatik"
void . insert $ StudyTermCandidate incidence1 221 "Mathematik"
void . insert $ StudyTermCandidate incidence1 105 "Bioinformatik"
void . insert $ StudyTermCandidate incidence1 105 "Mathematik"
incidence2 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence2 221 "Bioinformatik"
void . insert $ StudyTermCandidate incidence2 221 "Chemie"
void . insert $ StudyTermCandidate incidence2 61 "Bioinformatik"
void . insert $ StudyTermCandidate incidence2 61 "Chemie"
incidence3 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence3 113 "Chemie"
incidence4 <- liftIO getRandom -- ambiguous incidence
void . insert $ StudyTermCandidate incidence4 221 "Bioinformatik"
void . insert $ StudyTermCandidate incidence4 221 "Chemie"
void . insert $ StudyTermCandidate incidence4 221 "Biologie"
void . insert $ StudyTermCandidate incidence4 61 "Bioinformatik"
void . insert $ StudyTermCandidate incidence4 61 "Chemie"
void . insert $ StudyTermCandidate incidence4 61 "Biologie"
void . insert $ StudyTermCandidate incidence4 61 "Chemie"
void . insert $ StudyTermCandidate incidence4 26 "Bioinformatik"
void . insert $ StudyTermCandidate incidence4 26 "Chemie"
void . insert $ StudyTermCandidate incidence4 26 "Biologie"
incidence5 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence5 228 "Bioinformatik"
void . insert $ StudyTermCandidate incidence5 228 "Physik"
void . insert $ StudyTermCandidate incidence5 128 "Bioinformatik"
void . insert $ StudyTermCandidate incidence5 128 "Physik"
incidence6 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence6 228 "Bioinformatik"
void . insert $ StudyTermCandidate incidence6 228 "Physik"
void . insert $ StudyTermCandidate incidence6 128 "Bioinformatik"
void . insert $ StudyTermCandidate incidence6 128 "Physik"
incidence7 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence7 228 "Physik"
void . insert $ StudyTermCandidate incidence7 228 "Bioinformatik"
void . insert $ StudyTermCandidate incidence7 128 "Physik"
void . insert $ StudyTermCandidate incidence7 128 "Bioinformatik"
incidence8 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence8 128 "Physik"
void . insert $ StudyTermCandidate incidence8 128 "Medieninformatik"
void . insert $ StudyTermCandidate incidence8 121 "Physik"
void . insert $ StudyTermCandidate incidence8 121 "Medieninformatik"
incidence9 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence9 79 "Informatik"
incidence10 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence10 103 "Deutsch"
void . insert $ StudyTermCandidate incidence10 103 "Betriebswirtschaftslehre"
void . insert $ StudyTermCandidate incidence10 21 "Deutsch"
void . insert $ StudyTermCandidate incidence10 21 "Betriebswirtschaftslehre"
incidence11 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence11 221 "Bioinformatik"
void . insert $ StudyTermCandidate incidence11 221 "Chemie"
void . insert $ StudyTermCandidate incidence11 221 "Biologie"
void . insert $ StudyTermCandidate incidence11 61 "Bioinformatik"
void . insert $ StudyTermCandidate incidence11 61 "Chemie"
void . insert $ StudyTermCandidate incidence11 61 "Biologie"
void . insert $ StudyTermCandidate incidence11 26 "Bioinformatik"
void . insert $ StudyTermCandidate incidence11 26 "Chemie"
void . insert $ StudyTermCandidate incidence11 26 "Biologie"
incidence12 <- liftIO getRandom
void . insert $ StudyTermCandidate incidence12 103 "Deutsch"
void . insert $ StudyTermCandidate incidence12 103 "Betriebswirtschaftslehre"
void . insert $ StudyTermCandidate incidence12 21 "Deutsch"
void . insert $ StudyTermCandidate incidence12 21 "Betriebswirtschaftslehre"
sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here
maxMuster
sdBsc
sdInf
FieldPrimary
2
now
True
sfMMs <- insert $ StudyFeatures
maxMuster
sdBsc
sdMath
FieldSecondary
2
now
True
_sfTTa <- insert $ StudyFeatures
tinaTester
sdBsc
sdInf
FieldPrimary
4
now
False
sfTTb <- insert $ StudyFeatures
tinaTester
sdLAG
sdPhys
FieldPrimary
1
now
True
sfTTc <- insert $ StudyFeatures
tinaTester
sdLAR
sdMedi
FieldPrimary
7
now
True
_sfTTd <- insert $ StudyFeatures
tinaTester
sdMst
sdMath
FieldPrimary
3
now
True
-- FFP -- FFP
let nbrs :: [Int] let nbrs :: [Int]
nbrs = [1,2,3,27,7,1] nbrs = [1,2,3,27,7,1]
@ -256,6 +398,12 @@ fillDb = do
insert_ $ SheetEdit gkleen now feste insert_ $ SheetEdit gkleen now feste
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
insert_ $ SheetEdit gkleen now keine insert_ $ SheetEdit gkleen now keine
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf)
[(fhamann , Nothing)
,(maxMuster , Just sfMMs)
,(tinaTester, Just sfTTc)
]
-- EIP -- EIP
eip <- insert' Course eip <- insert' Course
{ courseName = "Einführung in die Programmierung" { courseName = "Einführung in die Programmierung"
@ -328,7 +476,11 @@ fillDb = do
insert_ $ CourseEdit jost now pmo insert_ $ CourseEdit jost now pmo
void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ DegreeCourse pmo sdBsc sdInf
void . insert $ Lecturer jost pmo void . insert $ Lecturer jost pmo
void . insertMany $ map (\u -> CourseParticipant pmo u now) [fhamann, maxMuster, tinaTester] void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf)
[(fhamann , Nothing)
,(maxMuster , Just sfMMp)
,(tinaTester, Just sfTTb)
]
sh1 <- insert Sheet sh1 <- insert Sheet
{ sheetCourse = pmo { sheetCourse = pmo
, sheetName = "Blatt 1" , sheetName = "Blatt 1"
@ -376,8 +528,8 @@ fillDb = do
, courseRegisterFrom = Nothing , courseRegisterFrom = Nothing
, courseRegisterTo = Nothing , courseRegisterTo = Nothing
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing , courseRegisterSecret = Just "dbs"
, courseMaterialFree = True , courseMaterialFree = False
} }
insert_ $ CourseEdit gkleen now dbs insert_ $ CourseEdit gkleen now dbs
void . insert' $ DegreeCourse dbs sdBsc sdInf void . insert' $ DegreeCourse dbs sdBsc sdInf

5
test/ModelSpec.hs
View File

@ -40,6 +40,7 @@ instance Arbitrary User where
, on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
] ]
userAuthentication <- arbitrary userAuthentication <- arbitrary
userLastAuthentication <- arbitrary
userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9']) userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
userEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary userEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary
@ -60,7 +61,7 @@ instance Arbitrary User where
userDownloadFiles <- arbitrary userDownloadFiles <- arbitrary
userMailLanguages <- arbitrary userMailLanguages <- arbitrary
userNotificationSettings <- arbitrary userNotificationSettings <- arbitrary
return User{..} return User{..}
shrink = genericShrink shrink = genericShrink
@ -71,7 +72,7 @@ instance Arbitrary File where
fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
fileContent <- arbitrary fileContent <- arbitrary
return File{..} return File{..}
where where
inZipRange :: UTCTime -> Bool inZipRange :: UTCTime -> Bool
inZipRange time inZipRange time
| time > UTCTime (fromGregorian 1980 1 1) 0 | time > UTCTime (fromGregorian 1980 1 1) 0

3
test/TestImport.hs
View File

@ -92,7 +92,7 @@ authenticateAs (Entity _ User{..}) = do
setMethod "GET" setMethod "GET"
addRequestHeader ("Accept-Language", "de") addRequestHeader ("Accept-Language", "de")
setUrl $ AuthR LoginR setUrl $ AuthR LoginR
request $ do request $ do
setMethod "POST" setMethod "POST"
addToken_ "#login--dummy" addToken_ "#login--dummy"
@ -107,6 +107,7 @@ createUser adjUser = do
let let
userMatrikelnummer = Nothing userMatrikelnummer = Nothing
userAuthentication = AuthLDAP userAuthentication = AuthLDAP
userLastAuthentication = Nothing
userIdent = "dummy@example.invalid" userIdent = "dummy@example.invalid"
userEmail = "dummy@example.invalid" userEmail = "dummy@example.invalid"
userDisplayName = "Dummy Example" userDisplayName = "Dummy Example"