Merge branch 'master' into 409-find-implement-alternative-for-datepicker
This commit is contained in:
Sarah Vaupel
commit
067d8d0a44
31
CHANGELOG.md
31
CHANGELOG.md
@ -2,6 +2,37 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
## [5.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.4.0...v5.5.0) (2019-08-27)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **changelog:** add date ([52a88f8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/52a88f8))
|
||||
* **course-applications-csv:** record rating time ([c2c6974](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2c6974))
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* optional ribbon ([c2e13cf](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2e13cf))
|
||||
|
||||
|
||||
|
||||
## [5.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.3.0...v5.4.0) (2019-08-27)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **course-edit:** only show allocation error message when relevant ([00a6ca8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/00a6ca8))
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **allocations:** serve archive of all application files by course ([5e393c5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5e393c5))
|
||||
* allow editing of course applications outside of allocation ([e816a30](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e816a30))
|
||||
* **course-applications:** csv transport ([cf0ec1a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cf0ec1a))
|
||||
|
||||
|
||||
|
||||
## [5.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.3...v5.3.0) (2019-08-22)
|
||||
|
||||
|
||||
|
||||
@ -122,3 +122,4 @@ user-defaults:
|
||||
warning-days: 1209600
|
||||
|
||||
instance-id: "_env:INSTANCE_ID:instance"
|
||||
ribbon: "_env:RIBBON:"
|
||||
|
||||
@ -1,6 +1,15 @@
|
||||
/* GENERAL STYLES FOR FORMS */
|
||||
|
||||
/* FORM GROUPS */
|
||||
.form-section-title {
|
||||
color: var(--color-fontsec);
|
||||
margin: 0;
|
||||
|
||||
+ .form-group {
|
||||
margin-top: 11px;
|
||||
}
|
||||
}
|
||||
|
||||
.form-group {
|
||||
position: relative;
|
||||
display: flex;
|
||||
@ -19,15 +28,22 @@
|
||||
}
|
||||
}
|
||||
|
||||
.form-section-title {
|
||||
color: var(--color-fontsec);
|
||||
}
|
||||
|
||||
.form-section-legend {
|
||||
color: var(--color-fontsec);
|
||||
margin: 7px 0;
|
||||
}
|
||||
|
||||
.form-section-title__hint {
|
||||
margin-top: 7px;
|
||||
color: var(--color-fontsec);
|
||||
font-size: 0.9rem;
|
||||
font-weight: 600;
|
||||
|
||||
+ .form-group {
|
||||
margin-top: 11px;
|
||||
}
|
||||
}
|
||||
|
||||
.form-group-label {
|
||||
font-weight: 600;
|
||||
padding-top: 6px;
|
||||
|
||||
@ -206,9 +206,12 @@ CourseLoginToApply: Um sich zum Kurz zu bewerben müssen Sie sich zunächst in U
|
||||
CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden
|
||||
|
||||
CourseApplicationArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand appId@CryptoFileNameCourseApplication displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase (toPathPiece appId)}-#{foldCase displayName}
|
||||
CourseAllApplicationsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen
|
||||
CourseApplicationsAllocatedDirectory: zentral
|
||||
CourseApplicationsNotAllocatedDirectory: direkt
|
||||
|
||||
CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
|
||||
AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden
|
||||
AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden. Ihre Änderungen wurden ignoriert.
|
||||
|
||||
|
||||
CourseFormSectionRegistration: Anmeldung zum Kurs
|
||||
@ -1027,6 +1030,7 @@ MenuExamUsers: Teilnehmer
|
||||
MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
|
||||
MenuLecturerInvite: Dozenten hinzufügen
|
||||
MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
|
||||
MenuCourseApplicationsFiles: Dateien aller Bewerbungen
|
||||
|
||||
AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
|
||||
AuthPredsActive: Aktive Authorisierungsprädikate
|
||||
@ -1407,6 +1411,18 @@ CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer
|
||||
CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können
|
||||
CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
|
||||
CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
|
||||
CsvColumnApplicationsAllocation: Zentralanmeldung über die die Bewerbung eingegangen ist
|
||||
CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien)
|
||||
CsvColumnApplicationsName: Voller Name des Bewerbers
|
||||
CsvColumnApplicationsMatriculation: Matrikelnummer des Bewerbers
|
||||
CsvColumnApplicationsField: Studienfach, mit dem der Bewerber seine Bewerbung assoziiert hat
|
||||
CsvColumnApplicationsDegree: Abschluss, den der Bewerber im assoziierten Studienfach anstrebt
|
||||
CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studienfach
|
||||
CsvColumnApplicationsText: Text-Bewerbung
|
||||
CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)?
|
||||
CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer
|
||||
CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0"
|
||||
CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber
|
||||
|
||||
Action: Aktion
|
||||
|
||||
@ -1429,6 +1445,15 @@ ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identi
|
||||
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
|
||||
ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
|
||||
|
||||
CourseApplicationsTableCsvSetField: Bewerbungs-assoziiertes Studienfach ändern
|
||||
CourseApplicationsTableCsvSetVeto: Veto setzen/entfernen
|
||||
CourseApplicationsTableCsvSetRating: Bewertung eintragen
|
||||
CourseApplicationsTableCsvSetComment: Bewertungskommentar eintragen
|
||||
|
||||
CourseApplicationsTableCsvExceptionNoMatchingUser: Bewerber konnte nicht eindeutig identifiziert werden
|
||||
CourseApplicationsTableCsvExceptionNoMatchingAllocation: Zentralanmeldung konnte nicht eindeutig identifiziert werden
|
||||
CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
|
||||
|
||||
TableHeadingFilter: Filter
|
||||
TableHeadingCsvImport: CSV-Import
|
||||
TableHeadingCsvExport: CSV-Export
|
||||
@ -1519,6 +1544,8 @@ ApplicationRatingPointsTip: Bewerber mit 5.0 werden garantiert nicht dem Kurs zu
|
||||
ApplicationRatingComment: Kommentar
|
||||
ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers
|
||||
ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter
|
||||
ApplicationRatingSection: Bewertung
|
||||
ApplicationRatingSectionSelfTip: Sie verfügen über hinreichende Authorisierung um sowohl die Bewerbung als auch ihre Bewertung zu editieren.
|
||||
|
||||
AllocationSchoolShort: Institut
|
||||
Allocation: Zentralanmeldung
|
||||
@ -1530,6 +1557,9 @@ CourseApplicationsListTitle: Bewerbungen
|
||||
CourseApplicationId: Bewerbungsnummer
|
||||
CourseApplicationRatingPoints: Bewertung
|
||||
CourseApplicationVeto: Veto
|
||||
CourseApplicationNoVeto: Kein Veto
|
||||
CourseApplicationNoRatingPoints: Keine Bewertung
|
||||
CourseApplicationNoRatingComment: Kein Kommentar
|
||||
|
||||
UserDisplayName: Voller Name
|
||||
UserMatriculation: Matrikelnummer
|
||||
@ -1,8 +1,8 @@
|
||||
Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students
|
||||
name AllocationName
|
||||
shorthand AllocationShorthand -- practical shorthand
|
||||
term TermId
|
||||
school SchoolId -- school that manages this central allocation, not necessarily school of courses
|
||||
shorthand AllocationShorthand -- practical shorthand
|
||||
name AllocationName
|
||||
description Html Maybe -- description for prospective students
|
||||
staffDescription Html Maybe -- description seen by prospective lecturers only
|
||||
staffRegisterFrom UTCTime Maybe -- lectureres may register courses
|
||||
@ -23,7 +23,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
-- overrideVisible not needed, since courses are always visible
|
||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
||||
deriving Show
|
||||
deriving Show Eq Ord Generic
|
||||
|
||||
AllocationCourse
|
||||
allocation AllocationId
|
||||
|
||||
@ -8,14 +8,14 @@
|
||||
-- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname
|
||||
--
|
||||
User json -- Each Uni2work user has a corresponding row in this table; created upon first login.
|
||||
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
|
||||
displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
||||
email (CI Text) -- Case-insensitive eMail address
|
||||
ident (CI Text) -- Case-insensitive user-identifier
|
||||
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
||||
lastAuthentication UTCTime Maybe -- last login date
|
||||
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
|
||||
matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
|
||||
email (CI Text) -- Case-insensitive eMail address
|
||||
displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
||||
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
|
||||
firstName Text -- For export in tables, pre-split firstName from displayName
|
||||
title Text Maybe -- For upcoming name customisation
|
||||
maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
|
||||
@ -29,7 +29,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
|
||||
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
|
||||
deriving Show Eq Ord 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
|
||||
school SchoolId
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "5.3.0",
|
||||
"version": "5.5.0",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "5.3.0",
|
||||
"version": "5.5.0",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 5.3.0
|
||||
version: 5.5.0
|
||||
|
||||
dependencies:
|
||||
# Due to a bug in GHC 8.0.1, we block its usage
|
||||
@ -194,7 +194,7 @@ ghc-options:
|
||||
- -fno-warn-unrecognised-pragmas
|
||||
- -fno-warn-partial-type-signatures
|
||||
- -fno-max-relevant-binds
|
||||
- -j3
|
||||
- -j
|
||||
|
||||
when:
|
||||
- condition: flag(pedantic)
|
||||
|
||||
5
routes
5
routes
@ -86,7 +86,6 @@
|
||||
/ AShowR GET !free
|
||||
/register ARegisterR POST !time
|
||||
/course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered
|
||||
/application/#CryptoFileNameCourseApplication AApplicationR GET POST !timeANDself !lecturerANDstaff-time !selfANDread
|
||||
|
||||
|
||||
-- For Pattern Synonyms see Foundation
|
||||
@ -163,8 +162,10 @@
|
||||
/users/invite EInviteR GET POST
|
||||
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
|
||||
/apps CApplicationsR GET POST
|
||||
!/apps/files CAppsFilesR GET
|
||||
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
|
||||
/files CAFilesR GET !self !lecturerANDtime
|
||||
/ CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread
|
||||
/files CAFilesR GET !self !lecturerANDstaff-time
|
||||
|
||||
/subs CorrectionsR GET POST !corrector !lecturer
|
||||
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
|
||||
28
src/Data/Bool/Instances.hs
Normal file
28
src/Data/Bool/Instances.hs
Normal file
@ -0,0 +1,28 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Bool.Instances
|
||||
() where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.CaseInsensitive.Instances ()
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
|
||||
instance Csv.ToField Bool where
|
||||
toField True = "t"
|
||||
toField False = "f"
|
||||
|
||||
instance Csv.FromField Bool where
|
||||
parseField f = do
|
||||
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
|
||||
(True <$ guard (isTrue t)) <|> (False <$ guard (isFalse t)) <|> fail "Could not decode Bool"
|
||||
where
|
||||
isTrue = flip elem
|
||||
[ "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
|
||||
isFalse = flip elem
|
||||
[ "no", "n", "nein", "falsch", "f", "false", "0" ]
|
||||
@ -16,6 +16,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
import Web.PathPieces
|
||||
import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..))
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
|
||||
instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
|
||||
toMarkup = toMarkup . CID.ciphertext
|
||||
@ -34,3 +36,12 @@ instance {-# OVERLAPS #-} (ToJSON s, ToJSONKey s) => ToJSONKey (CID.CryptoID c (
|
||||
instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where
|
||||
toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext
|
||||
fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece
|
||||
|
||||
instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where
|
||||
parseField = fmap CID.CryptoID . Csv.parseField
|
||||
|
||||
instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where
|
||||
toField = Csv.toField . CID.ciphertext
|
||||
|
||||
instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where
|
||||
toField = Csv.toField . CI.foldedCase . CID.ciphertext
|
||||
|
||||
@ -665,22 +665,6 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
||||
return Authorized
|
||||
AllocationR tid ssh ash (AApplicationR cID) -> $cachedHereBinary (mAuthId, tid, ssh, ash, cID) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedLecturer) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
isLecturer <- lift . E.selectExists . E.from $ \(courseApplication `E.InnerJoin` allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
||||
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
|
||||
E.&&. courseApplication E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
||||
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
||||
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
||||
E.&&. courseApplication E.^. CourseApplicationId E.==. E.val appId
|
||||
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
||||
return Authorized
|
||||
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
||||
@ -750,20 +734,6 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
|
||||
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
||||
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
|
||||
|
||||
case allocation of
|
||||
Nothing -> return ()
|
||||
Just Allocation{..} -> do
|
||||
cTime <- liftIO getCurrentTime
|
||||
guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
|
||||
guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo
|
||||
|
||||
return Authorized
|
||||
|
||||
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
|
||||
@ -872,6 +842,23 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
guard $ NTop (Just now) >= NTop deregUntil
|
||||
return Authorized
|
||||
_other -> unauthorizedI MsgUnauthorizedCourseTime
|
||||
|
||||
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
||||
Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
||||
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
|
||||
|
||||
case allocation of
|
||||
Nothing -> do
|
||||
cTime <- liftIO getCurrentTime
|
||||
guard $ maybe False (cTime >=) courseRegisterFrom
|
||||
guard $ maybe True (cTime <=) courseRegisterTo
|
||||
Just Allocation{..} -> do
|
||||
cTime <- liftIO getCurrentTime
|
||||
guard $ NTop allocationRegisterFrom <= NTop (Just cTime)
|
||||
guard $ NTop (Just cTime) <= NTop allocationRegisterTo
|
||||
|
||||
return Authorized
|
||||
|
||||
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
||||
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
||||
@ -891,6 +878,20 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
|
||||
r -> $unsupportedAuthPredicate AuthTime r
|
||||
tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of
|
||||
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
||||
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
|
||||
|
||||
case allocation of
|
||||
Nothing -> return ()
|
||||
Just Allocation{..} -> do
|
||||
cTime <- liftIO getCurrentTime
|
||||
guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
|
||||
guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo
|
||||
|
||||
return Authorized
|
||||
|
||||
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
||||
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
||||
now <- liftIO getCurrentTime
|
||||
@ -1203,10 +1204,6 @@ tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $
|
||||
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
|
||||
return $ Right courseApplicationUser
|
||||
AllocationR _ _ _ (AApplicationR cID) -> do
|
||||
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
|
||||
return $ Right courseApplicationUser
|
||||
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
|
||||
referencedUser <- case referencedUser' of
|
||||
Right uid -> return uid
|
||||
@ -1667,6 +1664,8 @@ siteLayout' headingOverride widget = do
|
||||
hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
|
||||
hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes
|
||||
hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes
|
||||
contentRibbon :: Maybe Widget
|
||||
contentRibbon = fmap toWidget appRibbon
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let
|
||||
@ -1757,7 +1756,6 @@ instance YesodBreadcrumbs UniWorX where
|
||||
mr <- getMessageRender
|
||||
Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ AllocationListR)
|
||||
breadcrumb (AllocationR tid ssh ash (AApplicationR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR)
|
||||
|
||||
breadcrumb CourseListR = return ("Kurse" , Nothing)
|
||||
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
|
||||
@ -1783,6 +1781,8 @@ instance YesodBreadcrumbs UniWorX where
|
||||
|
||||
breadcrumb (CourseR tid ssh csh CApplicationsR) = return ("Bewerbungen", Just $ CourseR tid ssh csh CShowR)
|
||||
|
||||
breadcrumb (CApplicationR tid ssh csh _ CAEditR) = return ("Bewerbung", Just $ CourseR tid ssh csh CApplicationsR)
|
||||
|
||||
breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
|
||||
breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
|
||||
breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
|
||||
@ -2708,6 +2708,28 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseR tid ssh csh CApplicationsR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuCourseApplicationsFiles
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAppsFilesR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback'
|
||||
= let appAccess (E.Value appId) = do
|
||||
cID <- encrypt appId
|
||||
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
|
||||
appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.where_ . E.exists . E.from $ \courseApplicationFile ->
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId
|
||||
return $ courseApplication E.^. CourseApplicationId
|
||||
in runDB . runConduit $ appSource .| anyMC appAccess
|
||||
}
|
||||
]
|
||||
pageActions (CorrectionsR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
|
||||
@ -4,9 +4,8 @@ module Handler.Allocation.Application
|
||||
, ApplicationForm(..)
|
||||
, ApplicationFormMode(..)
|
||||
, ApplicationFormException(..)
|
||||
, applicationForm
|
||||
, applicationForm, editApplicationR
|
||||
, postAApplyR
|
||||
, getAApplicationR, postAApplicationR
|
||||
) where
|
||||
|
||||
import Import hiding (hash)
|
||||
@ -71,20 +70,21 @@ data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Exception ApplicationFormException
|
||||
|
||||
applicationForm :: AllocationId
|
||||
applicationForm :: (Maybe AllocationId)
|
||||
-> CourseId
|
||||
-> UserId
|
||||
-> ApplicationFormMode -- ^ Which parts of the shared form to display
|
||||
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
|
||||
applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
||||
applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
|
||||
|
||||
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do
|
||||
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. Just aId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
||||
coursesNum <- fromIntegral <$> count [AllocationCourseAllocation ==. aId]
|
||||
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
||||
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
|
||||
course <- getJust cid
|
||||
[E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do
|
||||
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
|
||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
|
||||
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
|
||||
return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority
|
||||
return (mApplication, coursesNum, course, maxPrio)
|
||||
@ -110,18 +110,20 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
||||
}
|
||||
prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions
|
||||
|
||||
(prioRes, prioView) <- case (afmApplicant, afmApplicantEdit, mApp) of
|
||||
(True , True , Nothing)
|
||||
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
|
||||
(True , True , True , Nothing)
|
||||
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio)
|
||||
(True , True , Just _ )
|
||||
(True , True , True , Just _ )
|
||||
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
|
||||
(True , False, _ )
|
||||
(True , True , False, _ )
|
||||
-> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
|
||||
(False, _ , Just _ )
|
||||
(True , False, _ , Just _ )
|
||||
| is _Just oldPrio
|
||||
-> pure (FormSuccess oldPrio, Nothing)
|
||||
_other
|
||||
(True , _ , _ , _ )
|
||||
-> throwM ApplicationFormNoApplication
|
||||
(False, _ , _ , _ )
|
||||
-> pure (FormSuccess Nothing, Nothing)
|
||||
|
||||
(fieldRes, fieldView') <- if
|
||||
| afmApplicantEdit || afmLecturer
|
||||
@ -210,6 +212,15 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
||||
]
|
||||
(actionRes, buttonsView) <- buttonForm' buttons csrf
|
||||
|
||||
ratingSection <- if
|
||||
| afmLecturer
|
||||
, afmApplicantEdit
|
||||
-> Just . set _fvTooltip (Just . toHtml $ mr MsgApplicationRatingSectionSelfTip) . snd <$> formSection MsgApplicationRatingSection
|
||||
| afmLecturer
|
||||
-> Just . snd <$> formSection MsgApplicationRatingSection
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
|
||||
return ( ApplicationForm
|
||||
<$> prioRes
|
||||
<*> fieldRes
|
||||
@ -227,7 +238,8 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
||||
, filesLinkView
|
||||
, filesWarningView
|
||||
] ++ maybe [] (map Just) filesView ++
|
||||
[ vetoView
|
||||
[ ratingSection
|
||||
, vetoView
|
||||
, pointsView
|
||||
, commentView
|
||||
]
|
||||
@ -238,7 +250,7 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do
|
||||
|
||||
|
||||
|
||||
editApplicationR :: AllocationId
|
||||
editApplicationR :: Maybe AllocationId
|
||||
-> UserId
|
||||
-> CourseId
|
||||
-> Maybe CourseApplicationId
|
||||
@ -246,10 +258,10 @@ editApplicationR :: AllocationId
|
||||
-> (AllocationApplicationButton -> Bool)
|
||||
-> SomeRoute UniWorX
|
||||
-> Handler (ApplicationFormView, Enctype)
|
||||
editApplicationR aId uid cid mAppId afMode allowAction postAction = do
|
||||
editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
Course{..} <- runDB $ get404 cid
|
||||
|
||||
((appRes, appView), appEnc) <- runFormPost $ applicationForm aId cid uid afMode
|
||||
((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid uid afMode
|
||||
|
||||
formResult appRes $ \ApplicationForm{..} -> do
|
||||
if
|
||||
@ -258,7 +270,7 @@ editApplicationR aId uid cid mAppId afMode allowAction postAction = do
|
||||
-> runDB $ do
|
||||
haveOld <- exists [ CourseApplicationCourse ==. cid
|
||||
, CourseApplicationUser ==. uid
|
||||
, CourseApplicationAllocation ==. Just aId
|
||||
, CourseApplicationAllocation ==. maId
|
||||
]
|
||||
when haveOld $
|
||||
invalidArgsI [MsgCourseApplicationExists]
|
||||
@ -274,7 +286,7 @@ editApplicationR aId uid cid mAppId afMode allowAction postAction = do
|
||||
, courseApplicationRatingVeto = afRatingVeto
|
||||
, courseApplicationRatingPoints = afRatingPoints
|
||||
, courseApplicationRatingComment = afRatingComment
|
||||
, courseApplicationAllocation = Just aId
|
||||
, courseApplicationAllocation = maId
|
||||
, courseApplicationAllocationPriority = afPriority
|
||||
, courseApplicationTime = now
|
||||
, courseApplicationRatingTime = guardOn rated now
|
||||
@ -328,7 +340,7 @@ editApplicationR aId uid cid mAppId afMode allowAction postAction = do
|
||||
, courseApplicationRatingVeto = afRatingVeto
|
||||
, courseApplicationRatingPoints = afRatingPoints
|
||||
, courseApplicationRatingComment = afRatingComment
|
||||
, courseApplicationAllocation = Just aId
|
||||
, courseApplicationAllocation = maId
|
||||
, courseApplicationAllocationPriority = afPriority
|
||||
}
|
||||
|
||||
@ -393,50 +405,6 @@ postAApplyR tid ssh ash cID = do
|
||||
, afmLecturer
|
||||
}
|
||||
|
||||
void . editApplicationR aId uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID
|
||||
void . editApplicationR (Just aId) uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID
|
||||
|
||||
invalidArgs ["Application form required"]
|
||||
|
||||
|
||||
getAApplicationR, postAApplicationR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Html
|
||||
getAApplicationR = postAApplicationR
|
||||
postAApplicationR tid ssh ash cID = do
|
||||
uid <- requireAuthId
|
||||
appId <- decrypt cID
|
||||
(Entity aId Allocation{..}, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do
|
||||
alloc <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
app <- get404 appId
|
||||
Just course <- getEntity $ courseApplicationCourse app
|
||||
Just appUser <- get $ courseApplicationUser app
|
||||
isAdmin <- exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool]
|
||||
return (alloc, course, app, isAdmin, appUser)
|
||||
|
||||
afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||
afmApplicantEdit <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplicationR cID
|
||||
courseCID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||
|
||||
let afMode = ApplicationFormMode
|
||||
{ afmApplicant = uid == courseApplicationUser || isAdmin
|
||||
, afmApplicantEdit
|
||||
, afmLecturer
|
||||
}
|
||||
|
||||
(ApplicationFormView{..}, appEnc) <- editApplicationR aId uid cid (Just appId) afMode (/= BtnAllocationApply) $ if
|
||||
| uid == courseApplicationUser
|
||||
-> SomeRoute $ AllocationR tid ssh ash AShowR :#: courseCID
|
||||
| otherwise
|
||||
-> SomeRoute . AllocationR tid ssh ash $ AApplicationR cID
|
||||
|
||||
let title = MsgCourseApplicationTitle userDisplayName courseShorthand
|
||||
|
||||
siteLayoutMsg title $ do
|
||||
setTitleI title
|
||||
|
||||
wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute . AllocationR tid ssh ash $ AApplicationR cID
|
||||
, formEncoding = appEnc
|
||||
, formAttrs = []
|
||||
, formSubmit = FormNoSubmit
|
||||
, formAnchor = Nothing :: Maybe Text
|
||||
}
|
||||
|
||||
@ -71,15 +71,17 @@ getAShowR tid ssh ash = do
|
||||
cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
|
||||
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
|
||||
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||
mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm aId cid uid $ ApplicationFormMode True mayApply isLecturer
|
||||
subRoute <- fmap (fromMaybe $ AApplyR cID) . for mApp $ \(Entity appId _) -> AApplicationR <$> encrypt appId
|
||||
mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
|
||||
tRoute <- case mApp of
|
||||
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
|
||||
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
|
||||
let mApplyFormView' = view _1 <$> mApplyFormView
|
||||
overrideVisible = not mayApply && is _Just mApp
|
||||
case mApplyFormView of
|
||||
Just (_, appFormEnctype)
|
||||
-> wrapForm $(widgetFile "allocation/show/course") FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ AllocationR tid ssh ash subRoute
|
||||
, formAction = Just $ SomeRoute tRoute
|
||||
, formEncoding = appFormEnctype
|
||||
, formAttrs = [ ("class", "allocation-course")
|
||||
]
|
||||
|
||||
@ -1,230 +1,7 @@
|
||||
module Handler.Course.Application
|
||||
( getCAFilesR
|
||||
, getCApplicationsR, postCApplicationsR
|
||||
( module Handler.Course.Application
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Columns
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import System.FilePath (addExtension)
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
|
||||
getCAFilesR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler TypedContent
|
||||
getCAFilesR tid ssh csh cID = do
|
||||
appId <- decrypt cID
|
||||
User{..} <- runDB $ do
|
||||
CourseApplication{..} <- get404 appId
|
||||
Course{..} <- get404 courseApplicationCourse
|
||||
let matches = and
|
||||
[ tid == courseTerm
|
||||
, ssh == courseSchool
|
||||
, csh == courseShorthand
|
||||
]
|
||||
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
|
||||
get404 courseApplicationUser
|
||||
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName
|
||||
let
|
||||
fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
|
||||
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
||||
return file
|
||||
|
||||
serveSomeFiles archiveName $ fsSource .| C.map entityVal
|
||||
|
||||
|
||||
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
)
|
||||
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
||||
, Entity User
|
||||
, E.Value Bool -- hasFiles
|
||||
, Maybe (Entity Allocation)
|
||||
, Maybe (Entity StudyFeatures)
|
||||
, Maybe (Entity StudyTerms)
|
||||
, Maybe (Entity StudyDegree)
|
||||
)
|
||||
|
||||
courseApplicationsIdent :: Text
|
||||
courseApplicationsIdent = "applications"
|
||||
|
||||
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
|
||||
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
|
||||
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
||||
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
where
|
||||
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
|
||||
|
||||
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
|
||||
queryAllocation = to $(sqlLOJproj 3 2)
|
||||
|
||||
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
||||
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
||||
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
|
||||
|
||||
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
|
||||
resultCourseApplication = _dbrOutput . _1
|
||||
|
||||
resultUser :: Lens' CourseApplicationsTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultHasFiles :: Lens' CourseApplicationsTableData Bool
|
||||
resultHasFiles = _dbrOutput . _3 . _Value
|
||||
|
||||
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
|
||||
resultAllocation = _dbrOutput . _4 . _Just
|
||||
|
||||
resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures)
|
||||
resultStudyFeatures = _dbrOutput . _5 . _Just
|
||||
|
||||
resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms)
|
||||
resultStudyTerms = _dbrOutput . _6 . _Just
|
||||
|
||||
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _7 . _Just
|
||||
|
||||
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCApplicationsR = postCApplicationsR
|
||||
postCApplicationsR tid ssh csh = do
|
||||
table <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
let
|
||||
allocationLink :: Allocation -> SomeRoute UniWorX
|
||||
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
||||
|
||||
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
|
||||
participantLink uid = do
|
||||
cID <- encrypt uid
|
||||
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
|
||||
|
||||
dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
courseApplication <- view queryCourseApplication
|
||||
hasFiles <- view queryHasFiles
|
||||
user <- view queryUser
|
||||
allocation <- view queryAllocation
|
||||
studyFeatures <- view queryStudyFeatures
|
||||
studyTerms <- view queryStudyTerms
|
||||
studyDegree <- view queryStudyDegree
|
||||
|
||||
lift $ do
|
||||
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
|
||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
|
||||
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
||||
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||
|
||||
return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree)
|
||||
|
||||
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
|
||||
dbtProj = runReaderT $ do
|
||||
appId <- view $ resultCourseApplication . _entityKey
|
||||
cID <- encrypt appId
|
||||
|
||||
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR -- TODO: replace with CAShowR
|
||||
|
||||
view id
|
||||
|
||||
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat
|
||||
[ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
|
||||
, colApplicationId (resultCourseApplication . _entityKey)
|
||||
, anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||
, emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms
|
||||
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
|
||||
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
|
||||
, colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
|
||||
, lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusL 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
|
||||
, colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
|
||||
, colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
|
||||
, colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
|
||||
]
|
||||
|
||||
dbtSorting = mconcat
|
||||
[ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
|
||||
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
|
||||
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, sortStudyTerms queryStudyTerms
|
||||
, sortStudyDegree queryStudyDegree
|
||||
, sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, sortApplicationFiles queryHasFiles
|
||||
, sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
, sortApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||
, sortApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||
]
|
||||
|
||||
dbtFilter = mconcat
|
||||
[ fltrAllocation queryAllocation
|
||||
, fltrUserName' $ queryUser . to (E.^. UserDisplayName)
|
||||
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, fltrStudyTerms queryStudyTerms
|
||||
, fltrStudyDegree queryStudyDegree
|
||||
, fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, fltrApplicationFiles queryHasFiles
|
||||
, fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
, fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||
, fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ fltrAllocationUI
|
||||
, fltrUserNameUI'
|
||||
, fltrUserMatriculationUI
|
||||
, fltrStudyTermsUI
|
||||
, fltrStudyDegreeUI
|
||||
, fltrStudyFeaturesSemesterUI
|
||||
, fltrApplicationTextUI
|
||||
, fltrApplicationFilesUI
|
||||
, fltrApplicationVetoUI
|
||||
, fltrApplicationRatingPointsUI
|
||||
, fltrApplicationRatingCommentUI
|
||||
]
|
||||
|
||||
dbtStyle = def
|
||||
{ dbsFilterLayout = defaultDBSFilterLayout
|
||||
}
|
||||
dbtParams = def
|
||||
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
|
||||
dbtIdent = courseApplicationsIdent
|
||||
|
||||
psValidator :: PSValidator _ _
|
||||
psValidator = def
|
||||
|
||||
dbTableWidget' psValidator DBTable{..}
|
||||
|
||||
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
|
||||
|
||||
siteLayoutMsg title $ do
|
||||
setTitleI title
|
||||
table
|
||||
import Handler.Course.Application.List as Handler.Course.Application
|
||||
import Handler.Course.Application.Files as Handler.Course.Application
|
||||
import Handler.Course.Application.Edit as Handler.Course.Application
|
||||
|
||||
55
src/Handler/Course/Application/Edit.hs
Normal file
55
src/Handler/Course/Application/Edit.hs
Normal file
@ -0,0 +1,55 @@
|
||||
module Handler.Course.Application.Edit
|
||||
( getCAEditR, postCAEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Allocation.Application
|
||||
|
||||
|
||||
getCAEditR, postCAEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler Html
|
||||
getCAEditR = postCAEditR
|
||||
postCAEditR tid ssh csh cID = do
|
||||
uid <- requireAuthId
|
||||
appId <- decrypt cID
|
||||
(mAlloc, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do
|
||||
course <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
app <- get404 appId
|
||||
mAlloc <- traverse getEntity404 $ courseApplicationAllocation app
|
||||
appUser <- get404 $ courseApplicationUser app
|
||||
isAdmin <- case mAlloc of
|
||||
Just alloc -> exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool]
|
||||
Nothing -> exists [UserAdminUser ==. uid, UserAdminSchool ==. course ^. _entityVal . _courseSchool]
|
||||
return (mAlloc, course, app, isAdmin, appUser)
|
||||
|
||||
afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||
afmApplicantEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR
|
||||
courseCID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||
|
||||
let afMode = ApplicationFormMode
|
||||
{ afmApplicant = uid == courseApplicationUser || isAdmin
|
||||
, afmApplicantEdit
|
||||
, afmLecturer
|
||||
}
|
||||
|
||||
(ApplicationFormView{..}, appEnc) <- editApplicationR (entityKey <$> mAlloc) uid cid (Just appId) afMode (/= BtnAllocationApply) $ if
|
||||
| uid == courseApplicationUser
|
||||
, Just (Entity _ Allocation{..}) <- mAlloc
|
||||
-> SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: courseCID
|
||||
| otherwise
|
||||
-> SomeRoute $ CApplicationR tid ssh csh cID CAEditR
|
||||
|
||||
let title = MsgCourseApplicationTitle userDisplayName courseShorthand
|
||||
|
||||
siteLayoutMsg title $ do
|
||||
setTitleI title
|
||||
|
||||
wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ CApplicationR tid ssh csh cID CAEditR
|
||||
, formEncoding = appEnc
|
||||
, formAttrs = []
|
||||
, formSubmit = FormNoSubmit
|
||||
, formAnchor = Nothing :: Maybe Text
|
||||
}
|
||||
108
src/Handler/Course/Application/Files.hs
Normal file
108
src/Handler/Course/Application/Files.hs
Normal file
@ -0,0 +1,108 @@
|
||||
module Handler.Course.Application.Files
|
||||
( getCAFilesR
|
||||
, getCAppsFilesR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
import System.FilePath (addExtension, (</>))
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
getCAFilesR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler TypedContent
|
||||
getCAFilesR tid ssh csh cID = do
|
||||
appId <- decrypt cID
|
||||
User{..} <- runDB $ do
|
||||
CourseApplication{..} <- get404 appId
|
||||
Course{..} <- get404 courseApplicationCourse
|
||||
let matches = and
|
||||
[ tid == courseTerm
|
||||
, ssh == courseSchool
|
||||
, csh == courseShorthand
|
||||
]
|
||||
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
|
||||
get404 courseApplicationUser
|
||||
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName
|
||||
let
|
||||
fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
|
||||
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
||||
return file
|
||||
|
||||
serveSomeFiles archiveName $ fsSource .| C.map entityVal
|
||||
|
||||
|
||||
getCAppsFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
||||
getCAppsFilesR tid ssh csh = do
|
||||
runDB . existsBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
|
||||
|
||||
let
|
||||
fsSource :: Source DB File
|
||||
fsSource = do
|
||||
apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do
|
||||
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
|
||||
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
||||
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (allocation, user, courseApplication)
|
||||
apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do
|
||||
cID <- cachedByBinary appId $ encrypt appId
|
||||
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
|
||||
let
|
||||
applicationAllocs = setOf (folded . _1) apps'
|
||||
|
||||
allocations = applicationAllocs ^.. folded . _Just . _entityVal . $(multifocusG 3) _allocationTerm _allocationSchool _allocationShorthand
|
||||
|
||||
allEqualOn :: Eq x => Getter _ x -> Bool
|
||||
allEqualOn l = maybe True (\x -> allOf (folded . l) (== x) allocations) (allocations ^? _head . l)
|
||||
|
||||
mkAllocationDir mbAlloc
|
||||
| not $ allEqualOn _1
|
||||
, Just Allocation{..} <- mbAlloc
|
||||
= (</>) $ unpack [st|#{CI.foldCase (termToText (unTermKey allocationTerm))}-#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|]
|
||||
| not $ allEqualOn _2
|
||||
, Just Allocation{..} <- mbAlloc
|
||||
= (</>) $ unpack [st|#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|]
|
||||
| not $ allEqualOn _3
|
||||
, Just Allocation{..} <- mbAlloc
|
||||
= (</>) . unpack $ CI.foldedCase allocationShorthand
|
||||
| Just Allocation{} <- mbAlloc
|
||||
, not $ all (is _Just) applicationAllocs
|
||||
= (</>) . unpack $ mr MsgCourseApplicationsAllocatedDirectory
|
||||
| Nothing <- mbAlloc
|
||||
, any (is _Just) applicationAllocs
|
||||
= (</>) . unpack $ mr MsgCourseApplicationsNotAllocatedDirectory
|
||||
| otherwise
|
||||
= id
|
||||
|
||||
forM_ apps' $ \(mbAlloc, Entity _ User{..}, Entity appId CourseApplication{..}) -> do
|
||||
cID <- cachedByBinary appId $ encrypt appId :: _ CryptoFileNameCourseApplication
|
||||
let mkAppDir = mkAllocationDir (entityVal <$> mbAlloc) . (</>) (unpack [st|#{CI.foldedCase $ ciphertext cID}-#{CI.foldCase userSurname}|])
|
||||
dirFiles = C.map $ over _fileTitle mkAppDir . entityVal
|
||||
fileEntitySource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
|
||||
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
||||
return file
|
||||
|
||||
yield File
|
||||
{ fileModified = courseApplicationTime
|
||||
, fileTitle = mkAppDir ""
|
||||
, fileContent = Nothing
|
||||
}
|
||||
|
||||
fileEntitySource .| dirFiles
|
||||
|
||||
|
||||
serveSomeFiles archiveName fsSource
|
||||
535
src/Handler/Course/Application/List.hs
Normal file
535
src/Handler/Course/Application/List.hs
Normal file
@ -0,0 +1,535 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Handler.Course.Application.List
|
||||
( getCApplicationsR, postCApplicationsR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Columns
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lens as Text
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
|
||||
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
)
|
||||
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
||||
, Entity User
|
||||
, E.Value Bool -- hasFiles
|
||||
, Maybe (Entity Allocation)
|
||||
, Maybe (Entity StudyFeatures)
|
||||
, Maybe (Entity StudyTerms)
|
||||
, Maybe (Entity StudyDegree)
|
||||
)
|
||||
|
||||
courseApplicationsIdent :: Text
|
||||
courseApplicationsIdent = "applications"
|
||||
|
||||
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
|
||||
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
|
||||
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
||||
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
where
|
||||
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
|
||||
|
||||
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
|
||||
queryAllocation = to $(sqlLOJproj 3 2)
|
||||
|
||||
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
||||
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
||||
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
|
||||
|
||||
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
|
||||
resultCourseApplication = _dbrOutput . _1
|
||||
|
||||
resultUser :: Lens' CourseApplicationsTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultHasFiles :: Lens' CourseApplicationsTableData Bool
|
||||
resultHasFiles = _dbrOutput . _3 . _Value
|
||||
|
||||
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
|
||||
resultAllocation = _dbrOutput . _4 . _Just
|
||||
|
||||
resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures)
|
||||
resultStudyFeatures = _dbrOutput . _5 . _Just
|
||||
|
||||
resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms)
|
||||
resultStudyTerms = _dbrOutput . _6 . _Just
|
||||
|
||||
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _7 . _Just
|
||||
|
||||
|
||||
newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (Enum, Bounded)
|
||||
makePrisms ''CourseApplicationsTableVeto
|
||||
|
||||
instance Csv.ToField CourseApplicationsTableVeto where
|
||||
toField (CourseApplicationsTableVeto True) = "veto"
|
||||
toField (CourseApplicationsTableVeto False) = ""
|
||||
|
||||
instance Csv.FromField CourseApplicationsTableVeto where
|
||||
parseField f = do
|
||||
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
|
||||
return . CourseApplicationsTableVeto $ any (== t)
|
||||
[ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
|
||||
|
||||
data CourseApplicationsTableCsv = CourseApplicationsTableCsv
|
||||
{ csvCAAllocation :: Maybe AllocationShorthand
|
||||
, csvCAApplication :: Maybe CryptoFileNameCourseApplication
|
||||
, csvCAName :: Maybe Text
|
||||
, csvCAMatriculation :: Maybe Text
|
||||
, csvCAField :: Maybe Text
|
||||
, csvCADegree :: Maybe Text
|
||||
, csvCASemester :: Maybe Int
|
||||
, csvCAText :: Maybe Text
|
||||
, csvCAHasFiles :: Maybe Bool
|
||||
, csvCAVeto :: Maybe CourseApplicationsTableVeto
|
||||
, csvCARating :: Maybe ExamGrade
|
||||
, csvCAComment :: Maybe Text
|
||||
} deriving (Generic)
|
||||
makeLenses_ ''CourseApplicationsTableCsv
|
||||
|
||||
courseApplicationsTableCsvOptions :: Csv.Options
|
||||
courseApplicationsTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 }
|
||||
|
||||
instance Csv.ToNamedRecord CourseApplicationsTableCsv where
|
||||
toNamedRecord = Csv.genericToNamedRecord courseApplicationsTableCsvOptions
|
||||
|
||||
instance Csv.FromNamedRecord CourseApplicationsTableCsv where
|
||||
parseNamedRecord csv
|
||||
= CourseApplicationsTableCsv
|
||||
<$> csv .:?? "allocation"
|
||||
<*> csv .:?? "application"
|
||||
<*> csv .:?? "name"
|
||||
<*> csv .:?? "matriculation"
|
||||
<*> csv .:?? "field"
|
||||
<*> csv .:?? "degree"
|
||||
<*> csv .:?? "semester"
|
||||
<*> csv .:?? "text"
|
||||
<*> csv .:?? "has-files"
|
||||
<*> csv .:?? "veto"
|
||||
<*> csv .:?? "rating"
|
||||
<*> csv .:?? "comment"
|
||||
|
||||
instance Csv.DefaultOrdered CourseApplicationsTableCsv where
|
||||
headerOrder = Csv.genericHeaderOrder courseApplicationsTableCsvOptions
|
||||
|
||||
instance CsvColumnsExplained CourseApplicationsTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations courseApplicationsTableCsvOptions $ Map.fromList
|
||||
[ ('csvCAAllocation , MsgCsvColumnApplicationsAllocation )
|
||||
, ('csvCAApplication , MsgCsvColumnApplicationsApplication )
|
||||
, ('csvCAName , MsgCsvColumnApplicationsName )
|
||||
, ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation)
|
||||
, ('csvCAField , MsgCsvColumnApplicationsField )
|
||||
, ('csvCADegree , MsgCsvColumnApplicationsDegree )
|
||||
, ('csvCASemester , MsgCsvColumnApplicationsSemester )
|
||||
, ('csvCAText , MsgCsvColumnApplicationsText )
|
||||
, ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles )
|
||||
, ('csvCAVeto , MsgCsvColumnApplicationsVeto )
|
||||
, ('csvCARating , MsgCsvColumnApplicationsRating )
|
||||
, ('csvCAComment , MsgCsvColumnApplicationsComment )
|
||||
]
|
||||
|
||||
data CourseApplicationsTableCsvActionClass
|
||||
= CourseApplicationsTableCsvSetField
|
||||
| CourseApplicationsTableCsvSetVeto
|
||||
| CourseApplicationsTableCsvSetRating
|
||||
| CourseApplicationsTableCsvSetComment
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id
|
||||
|
||||
data CourseApplicationsTableCsvAction
|
||||
= CourseApplicationsTableCsvSetFieldData
|
||||
{ caCsvActApplication :: CourseApplicationId
|
||||
, caCsvActField :: Maybe StudyFeaturesId
|
||||
}
|
||||
| CourseApplicationsTableCsvSetVetoData
|
||||
{ caCsvActApplication :: CourseApplicationId
|
||||
, caCsvActVeto :: Bool
|
||||
}
|
||||
| CourseApplicationsTableCsvSetRatingData
|
||||
{ caCsvActApplication :: CourseApplicationId
|
||||
, caCsvActRating :: Maybe ExamGrade
|
||||
}
|
||||
| CourseApplicationsTableCsvSetCommentData
|
||||
{ caCsvActApplication :: CourseApplicationId
|
||||
, caCsvActComment :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 4 . dropEnd 1 . splitCamel
|
||||
, fieldLabelModifier = camelToPathPiece' 3
|
||||
, sumEncoding = TaggedObject "action" "data"
|
||||
} ''CourseApplicationsTableCsvAction
|
||||
|
||||
data CourseApplicationsTableCsvException
|
||||
= CourseApplicationsTableCsvExceptionNoMatchingUser
|
||||
| CourseApplicationsTableCsvExceptionNoMatchingAllocation
|
||||
| CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
|
||||
deriving (Show, Generic, Typeable)
|
||||
|
||||
instance Exception CourseApplicationsTableCsvException
|
||||
|
||||
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id
|
||||
|
||||
|
||||
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCApplicationsR = postCApplicationsR
|
||||
postCApplicationsR tid ssh csh = do
|
||||
table <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
let
|
||||
allocationLink :: Allocation -> SomeRoute UniWorX
|
||||
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
||||
|
||||
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
|
||||
participantLink uid = do
|
||||
cID <- encrypt uid
|
||||
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
|
||||
|
||||
dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
courseApplication <- view queryCourseApplication
|
||||
hasFiles <- view queryHasFiles
|
||||
user <- view queryUser
|
||||
allocation <- view queryAllocation
|
||||
studyFeatures <- view queryStudyFeatures
|
||||
studyTerms <- view queryStudyTerms
|
||||
studyDegree <- view queryStudyDegree
|
||||
|
||||
lift $ do
|
||||
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
|
||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
|
||||
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
||||
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||
|
||||
return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree)
|
||||
|
||||
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
|
||||
dbtProj = runReaderT $ do
|
||||
appId <- view $ resultCourseApplication . _entityKey
|
||||
cID <- encrypt appId
|
||||
|
||||
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
|
||||
|
||||
view id
|
||||
|
||||
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat
|
||||
[ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
|
||||
, colApplicationId (resultCourseApplication . _entityKey)
|
||||
, anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||
, emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms
|
||||
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
|
||||
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
|
||||
, colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
|
||||
, lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusL 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
|
||||
, colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
|
||||
, colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
|
||||
, colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
|
||||
]
|
||||
|
||||
dbtSorting = mconcat
|
||||
[ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
|
||||
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
|
||||
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, sortStudyTerms queryStudyTerms
|
||||
, sortStudyDegree queryStudyDegree
|
||||
, sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, sortApplicationFiles queryHasFiles
|
||||
, sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
, sortApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||
, sortApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||
]
|
||||
|
||||
dbtFilter = mconcat
|
||||
[ fltrAllocation queryAllocation
|
||||
, fltrUserName' $ queryUser . to (E.^. UserDisplayName)
|
||||
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, fltrStudyTerms queryStudyTerms
|
||||
, fltrStudyDegree queryStudyDegree
|
||||
, fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, fltrApplicationFiles queryHasFiles
|
||||
, fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
, fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||
, fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ fltrAllocationUI
|
||||
, fltrUserNameUI'
|
||||
, fltrUserMatriculationUI
|
||||
, fltrStudyTermsUI
|
||||
, fltrStudyDegreeUI
|
||||
, fltrStudyFeaturesSemesterUI
|
||||
, fltrApplicationTextUI
|
||||
, fltrApplicationFilesUI
|
||||
, fltrApplicationVetoUI
|
||||
, fltrApplicationRatingPointsUI
|
||||
, fltrApplicationRatingCommentUI
|
||||
]
|
||||
|
||||
dbtStyle = def
|
||||
{ dbsFilterLayout = defaultDBSFilterLayout
|
||||
}
|
||||
dbtParams = def
|
||||
|
||||
dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv
|
||||
dbtCsvEncode = DictJust . C.mapM . runReaderT $ CourseApplicationsTableCsv
|
||||
<$> preview (resultAllocation . _entityVal . _allocationShorthand)
|
||||
<*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt)
|
||||
<*> preview (resultUser . _entityVal . _userDisplayName)
|
||||
<*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just)
|
||||
<*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey)))
|
||||
<*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey)))
|
||||
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
||||
<*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just)
|
||||
<*> preview resultHasFiles
|
||||
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto)
|
||||
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingPoints . _Just)
|
||||
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingComment . _Just)
|
||||
dbtCsvDecode = Just DBTCsvDecode
|
||||
{ dbtCsvRowKey = \csv -> do
|
||||
appRes <- lift $ guessUser csv
|
||||
case appRes of
|
||||
Right appId -> return $ E.Value appId
|
||||
Left uid -> do
|
||||
alloc <- lift $ guessAllocation csv
|
||||
[appId] <- lift $ selectKeysList [CourseApplicationUser ==. uid, CourseApplicationAllocation ==. alloc] [LimitTo 2]
|
||||
return $ E.Value appId
|
||||
, dbtCsvComputeActions = \case
|
||||
DBCsvDiffMissing{}
|
||||
-> return () -- no deletion
|
||||
DBCsvDiffNew{}
|
||||
-> return () -- no addition
|
||||
DBCsvDiffExisting{..} -> do
|
||||
let appId = dbCsvOld ^. resultCourseApplication . _entityKey
|
||||
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
|
||||
yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures
|
||||
|
||||
let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
|
||||
whenIsJust mVeto $ \veto ->
|
||||
when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
|
||||
yield $ CourseApplicationsTableCsvSetVetoData appId veto
|
||||
|
||||
when (dbCsvNew ^. _csvCARating /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingPoints) $
|
||||
yield $ CourseApplicationsTableCsvSetRatingData appId (dbCsvNew ^. _csvCARating)
|
||||
|
||||
when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $
|
||||
yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment)
|
||||
, dbtCsvClassifyAction = \case
|
||||
CourseApplicationsTableCsvSetFieldData{} -> CourseApplicationsTableCsvSetField
|
||||
CourseApplicationsTableCsvSetVetoData{} -> CourseApplicationsTableCsvSetVeto
|
||||
CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating
|
||||
CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
|
||||
, dbtCsvCoarsenActionClass = const DBCsvActionExisting
|
||||
, dbtCsvExecuteActions = do
|
||||
now <- liftIO getCurrentTime
|
||||
C.mapM_ $ \case
|
||||
CourseApplicationsTableCsvSetFieldData{..} -> do
|
||||
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField
|
||||
, CourseApplicationTime =. now
|
||||
]
|
||||
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||
CourseApplicationsTableCsvSetVetoData{..} -> do
|
||||
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto
|
||||
, CourseApplicationRatingTime =. Just now
|
||||
]
|
||||
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||
CourseApplicationsTableCsvSetRatingData{..} -> do
|
||||
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating
|
||||
, CourseApplicationRatingTime =. Just now
|
||||
]
|
||||
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||
CourseApplicationsTableCsvSetCommentData{..} -> do
|
||||
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment
|
||||
, CourseApplicationRatingTime =. Just now
|
||||
]
|
||||
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||
return $ CourseR tid ssh csh CApplicationsR
|
||||
, dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case
|
||||
CourseApplicationsTableCsvSetFieldData{..} ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{existingApplicantName' caCsvActApplication}
|
||||
$maybe features <- caCsvActField
|
||||
, ^{studyFeaturesWidget features}
|
||||
$nothing
|
||||
, _{MsgCourseStudyFeatureNone}
|
||||
|]
|
||||
CourseApplicationsTableCsvSetVetoData{..} ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{existingApplicantName' caCsvActApplication}
|
||||
$if caCsvActVeto
|
||||
, _{MsgCourseApplicationVeto}
|
||||
$else
|
||||
, _{MsgCourseApplicationNoVeto}
|
||||
|]
|
||||
CourseApplicationsTableCsvSetRatingData{..} ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{existingApplicantName' caCsvActApplication}
|
||||
$maybe newResult <- caCsvActRating
|
||||
, _{newResult}
|
||||
$nothing
|
||||
, _{MsgCourseApplicationNoRatingPoints}
|
||||
|]
|
||||
CourseApplicationsTableCsvSetCommentData{..} ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{existingApplicantName' caCsvActApplication}
|
||||
$if is _Nothing caCsvActComment
|
||||
, _{MsgCourseApplicationNoRatingComment}
|
||||
|]
|
||||
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
||||
, dbtCsvRenderException = ap getMessageRender . pure :: CourseApplicationsTableCsvException -> DB Text
|
||||
}
|
||||
where
|
||||
guessUser :: CourseApplicationsTableCsv -> DB (Either UserId CourseApplicationId)
|
||||
guessUser csv = do
|
||||
mApp <- runMaybeT $ do
|
||||
appId <- squash . catchIfMaybeT (const True :: CryptoIDError -> Bool) . MaybeT . traverse decrypt $ csv ^? _csvCAApplication . _Just
|
||||
CourseApplication{..} <- MaybeT $ get appId
|
||||
guard $ courseApplicationCourse == cid
|
||||
return appId
|
||||
|
||||
maybe (Left <$> guessUser' csv) (return . Right) mApp
|
||||
where
|
||||
guessUser' :: CourseApplicationsTableCsv -> DB UserId
|
||||
guessUser' CourseApplicationsTableCsv{..} = $cachedHereBinary (csvCAMatriculation, csvCAName) $ do
|
||||
users <- E.select . E.from $ \user -> do
|
||||
E.where_ . E.and $ catMaybes
|
||||
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvCAMatriculation
|
||||
, (user E.^. UserDisplayName E.==.) . E.val <$> csvCAName
|
||||
]
|
||||
return $ user E.^. UserId
|
||||
case users of
|
||||
[E.Value uid]
|
||||
-> return uid
|
||||
_other
|
||||
-> throwM CourseApplicationsTableCsvExceptionNoMatchingUser
|
||||
|
||||
guessAllocation :: CourseApplicationsTableCsv -> DB (Maybe AllocationId)
|
||||
guessAllocation CourseApplicationsTableCsv{..} = $cachedHereBinary csvCAAllocation . for csvCAAllocation $ \ash -> do
|
||||
mAlloc <- traverse (getJustEntity . allocationCourseAllocation . entityVal) <=< getBy $ UniqueAllocationCourse cid
|
||||
case mAlloc of
|
||||
Just (Entity allocId Allocation{..})
|
||||
| allocationShorthand == ash
|
||||
-> return allocId
|
||||
_other
|
||||
-> throwM CourseApplicationsTableCsvExceptionNoMatchingAllocation
|
||||
|
||||
existingApplicantName :: Map (E.Value CourseApplicationId) CourseApplicationsTableData -> CourseApplicationId -> Widget
|
||||
existingApplicantName existing (E.Value -> appId) = nameWidget userDisplayName userSurname
|
||||
where
|
||||
Entity _ User{..} = existing ^. singular (ix appId . resultUser)
|
||||
|
||||
lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId)
|
||||
lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do
|
||||
appRes <- guessUser csv
|
||||
(uid, oldFeatures) <- case appRes of
|
||||
Left uid -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] []
|
||||
Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId
|
||||
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
|
||||
E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
|
||||
, E.asc (studyFeatures E.^. StudyFeaturesDegree)
|
||||
, E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
|
||||
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
||||
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
||||
E.where_ . E.and $ catMaybes
|
||||
[ do
|
||||
field <- csvCAField
|
||||
return . E.or $ catMaybes
|
||||
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
|
||||
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
|
||||
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
|
||||
]
|
||||
, do
|
||||
degree <- csvCADegree
|
||||
return . E.or $ catMaybes
|
||||
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
|
||||
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
|
||||
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
|
||||
]
|
||||
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvCASemester
|
||||
]
|
||||
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
||||
let isActiveOrPrevious = E.or
|
||||
$ (studyFeatures E.^. StudyFeaturesValid)
|
||||
: [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId
|
||||
| Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures
|
||||
]
|
||||
E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
|
||||
E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
|
||||
return $ studyFeatures E.^. StudyFeaturesId
|
||||
case studyFeatures of
|
||||
[E.Value fid] -> return $ Just fid
|
||||
_other
|
||||
| is _Nothing csvCAField
|
||||
, is _Nothing csvCADegree
|
||||
, is _Nothing csvCASemester
|
||||
-> return Nothing
|
||||
_other
|
||||
| [Entity _ CourseApplication{..}] <- oldFeatures
|
||||
, Just sfid <- courseApplicationField
|
||||
, E.Value sfid `elem` studyFeatures
|
||||
-> return $ Just sfid
|
||||
_other -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
|
||||
|
||||
|
||||
dbtIdent = courseApplicationsIdent
|
||||
|
||||
psValidator :: PSValidator _ _
|
||||
psValidator = def
|
||||
|
||||
dbTableWidget' psValidator DBTable{..}
|
||||
|
||||
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
|
||||
|
||||
siteLayoutMsg title $ do
|
||||
setTitleI title
|
||||
table
|
||||
@ -541,7 +541,15 @@ upsertAllocationCourse cid cfAllocation = do
|
||||
-> return True
|
||||
| Just Allocation{allocationStaffRegisterTo} <- prevAllocation
|
||||
, NTop allocationStaffRegisterTo <= NTop (Just now)
|
||||
-> False <$ addMessageI Error MsgAllocationStaffRegisterToExpired
|
||||
-> let anyChanges
|
||||
| Just AllocationCourseForm{..} <- cfAllocation
|
||||
, Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
|
||||
= or [ acfAllocation /= allocationCourseAllocation
|
||||
, acfMinCapacity /= allocationCourseMinCapacity
|
||||
]
|
||||
| otherwise
|
||||
= True
|
||||
in False <$ when anyChanges (addMessageI Error MsgAllocationStaffRegisterToExpired)
|
||||
| otherwise
|
||||
-> return True
|
||||
|
||||
|
||||
@ -30,7 +30,6 @@ import qualified Data.Conduit.List as C
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Numeric.Lens (integral)
|
||||
import Control.Arrow (Kleisli(..))
|
||||
|
||||
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
||||
|
||||
@ -123,23 +122,20 @@ instance ToNamedRecord ExamUserTableCsv where
|
||||
instance FromNamedRecord ExamUserTableCsv where
|
||||
parseNamedRecord csv -- Manually defined awaiting issue #427
|
||||
= ExamUserTableCsv
|
||||
<$> csv .:? "surname"
|
||||
<*> csv .:? "first-name"
|
||||
<*> csv .:? "name"
|
||||
<*> csv .:? "matriculation"
|
||||
<*> csv .:? "field"
|
||||
<*> csv .:? "degree"
|
||||
<*> csv .:? "semester"
|
||||
<*> csv .:? "occurrence"
|
||||
<*> csv .:? "exercise-points"
|
||||
<*> csv .:? "exercise-num-passes"
|
||||
<*> csv .:? "exercise-points-max"
|
||||
<*> csv .:? "exercise-num-passes-max"
|
||||
<*> csv .:? "exam-result"
|
||||
<*> csv .:? "course-note"
|
||||
where
|
||||
(.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a)
|
||||
m .:? name = Csv.lookup m name <|> return Nothing
|
||||
<$> csv .:?? "surname"
|
||||
<*> csv .:?? "first-name"
|
||||
<*> csv .:?? "name"
|
||||
<*> csv .:?? "matriculation"
|
||||
<*> csv .:?? "field"
|
||||
<*> csv .:?? "degree"
|
||||
<*> csv .:?? "semester"
|
||||
<*> csv .:?? "occurrence"
|
||||
<*> csv .:?? "exercise-points"
|
||||
<*> csv .:?? "exercise-num-passes"
|
||||
<*> csv .:?? "exercise-points-max"
|
||||
<*> csv .:?? "exercise-num-passes-max"
|
||||
<*> csv .:?? "exam-result"
|
||||
<*> csv .:?? "course-note"
|
||||
|
||||
instance DefaultOrdered ExamUserTableCsv where
|
||||
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
|
||||
@ -567,14 +563,6 @@ postEUsersR tid ssh csh examn = do
|
||||
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
|
||||
}
|
||||
where
|
||||
studyFeaturesWidget :: StudyFeaturesId -> Widget
|
||||
studyFeaturesWidget featId = do
|
||||
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
|
||||
[whamlet|
|
||||
$newline never
|
||||
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|
||||
|]
|
||||
|
||||
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
|
||||
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
|
||||
where
|
||||
@ -644,7 +632,6 @@ postEUsersR tid ssh csh examn = do
|
||||
_ -> isActive
|
||||
E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
|
||||
E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
|
||||
E.limit 2 -- we just need to know whether there is a unique one, none, or more than one
|
||||
return $ studyFeatures E.^. StudyFeaturesId
|
||||
case studyFeatures of
|
||||
[E.Value fid] -> return $ Just fid
|
||||
@ -657,7 +644,7 @@ postEUsersR tid ssh csh examn = do
|
||||
| Just (Entity _ CourseParticipant{..}) <- oldFeatures
|
||||
, Just sfid <- courseParticipantField
|
||||
, E.Value sfid `elem` studyFeatures
|
||||
-> return Nothing
|
||||
-> return $ Just sfid
|
||||
_other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
|
||||
|
||||
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
|
||||
|
||||
@ -225,3 +225,11 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
|
||||
f <- messageLoggerSource app <$> readTVarIO loggerTVar
|
||||
f loc src lvl str
|
||||
|
||||
studyFeaturesWidget :: StudyFeaturesId -> Widget
|
||||
studyFeaturesWidget featId = do
|
||||
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
|
||||
[whamlet|
|
||||
$newline never
|
||||
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|
||||
|]
|
||||
|
||||
|
||||
@ -14,6 +14,7 @@ import ClassyPrelude.Yesod as Import
|
||||
, static
|
||||
, boolField, identifyForm
|
||||
, HasHttpManager(..)
|
||||
, embed
|
||||
)
|
||||
|
||||
import Model.Types.TH.JSON as Import
|
||||
@ -71,7 +72,7 @@ import Ldap.Client.Pool as Import
|
||||
import System.Random as Import (Random(..))
|
||||
import Control.Monad.Random.Class as Import (MonadRandom(..))
|
||||
|
||||
import Control.Monad.Morph as Import (MFunctor(..))
|
||||
import Control.Monad.Morph as Import
|
||||
import Control.Monad.Trans.Resource as Import (ReleaseKey)
|
||||
|
||||
import Jose.Jwt as Import (Jwt)
|
||||
@ -128,6 +129,7 @@ import Net.IP.Instances as Import ()
|
||||
import Data.Void.Instances as Import ()
|
||||
import Crypto.Hash.Instances as Import ()
|
||||
import Colonnade.Instances as Import ()
|
||||
import Data.Bool.Instances as Import ()
|
||||
|
||||
import Control.Lens as Import
|
||||
hiding ( (<.>)
|
||||
@ -138,6 +140,8 @@ import Control.Lens as Import
|
||||
import Control.Lens.Extras as Import (is)
|
||||
import Data.Set.Lens as Import
|
||||
|
||||
import Control.Arrow as Import (Kleisli(..))
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
|
||||
@ -40,14 +40,6 @@ deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial
|
||||
deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial
|
||||
deriving instance Eq (Unique Exam)
|
||||
|
||||
instance Ord User where
|
||||
compare User{userSurname=surnameA, userDisplayName=displayNameA, userEmail=emailA}
|
||||
User{userSurname=surnameB, userDisplayName=displayNameB, userEmail=emailB}
|
||||
= compare surnameA surnameB
|
||||
<> compare displayNameA displayNameB
|
||||
<> compare emailA emailB -- userEmail is unique, so this suffices
|
||||
|
||||
|
||||
|
||||
submissionRatingDone :: Submission -> Bool
|
||||
submissionRatingDone Submission{..} = isJust submissionRatingTime
|
||||
|
||||
@ -138,6 +138,7 @@ data AppSettings = AppSettings
|
||||
, appAuthPWHash :: PWHashConf
|
||||
|
||||
, appInitialInstanceID :: Maybe (Either FilePath UUID)
|
||||
, appRibbon :: Maybe Text
|
||||
} deriving (Show)
|
||||
|
||||
data LogSettings = LogSettings
|
||||
@ -419,6 +420,8 @@ instance FromJSON AppSettings where
|
||||
_ -> return ()
|
||||
return val'
|
||||
|
||||
appRibbon <- assertM (not . Text.null) . fmap Text.strip <$> o.:? "ribbon"
|
||||
|
||||
return AppSettings {..}
|
||||
|
||||
makeClassy_ ''AppSettings
|
||||
|
||||
@ -42,6 +42,8 @@ import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.List as List
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Control.Lens
|
||||
import Control.Lens as Utils (none)
|
||||
|
||||
@ -676,6 +678,10 @@ peekN n = do
|
||||
peeked <- catMaybes <$> replicateM (fromIntegral n) await
|
||||
mapM_ leftover peeked
|
||||
return peeked
|
||||
|
||||
anyMC, allMC :: Monad m => (a -> m Bool) -> Consumer a m Bool
|
||||
anyMC f = C.mapM f .| orC
|
||||
allMC f = C.mapM f .| andC
|
||||
|
||||
-----------------
|
||||
-- Alternative --
|
||||
|
||||
@ -1,8 +1,9 @@
|
||||
module Utils.Csv
|
||||
( pathPieceCsv
|
||||
, (.:??)
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import ClassyPrelude hiding (lookup)
|
||||
import Data.Csv hiding (Name)
|
||||
|
||||
import Language.Haskell.TH (Name)
|
||||
@ -17,3 +18,7 @@ pathPieceCsv (conT -> t) =
|
||||
instance FromField $(t) where
|
||||
parseField = maybe (fail "Could not unmarshal from PathPiece") return . fromPathPiece <=< parseField
|
||||
|]
|
||||
|
||||
|
||||
(.:??) :: FromField (Maybe a) => NamedRecord -> ByteString -> Parser (Maybe a)
|
||||
m .:?? name = lookup m name <|> return Nothing
|
||||
|
||||
@ -40,10 +40,18 @@ getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity
|
||||
=> Unique record -> ReaderT backend m (Key record)
|
||||
getKeyBy404 u = getKeyBy u >>= maybe notFound return
|
||||
|
||||
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m)
|
||||
=> Key val -> ReaderT backend m (Entity val)
|
||||
getEntity404 k = Entity <$> pure k <*> get404 k
|
||||
|
||||
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m Bool
|
||||
existsBy = fmap (is _Just) . getKeyBy
|
||||
|
||||
existsBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
|
||||
=> Unique record -> ReaderT backend m ()
|
||||
existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
|
||||
|
||||
existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
|
||||
=> Key record -> ReaderT backend m Bool
|
||||
existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
|
||||
@ -52,6 +60,10 @@ exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity reco
|
||||
=> [Filter record] -> ReaderT backend m Bool
|
||||
exists = fmap (not . null) . flip selectKeysList [LimitTo 1]
|
||||
|
||||
exists404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
|
||||
=> [Filter record] -> ReaderT backend m ()
|
||||
exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
|
||||
|
||||
updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
|
||||
=> Unique record -> [Update record] -> ReaderT backend m ()
|
||||
updateBy uniq updates = do
|
||||
|
||||
@ -165,6 +165,8 @@ makeLenses_ ''CourseApplication
|
||||
|
||||
makeLenses_ ''Allocation
|
||||
|
||||
makeLenses_ ''File
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
1
start.sh
1
start.sh
@ -10,6 +10,7 @@ export LOG_ALL=${LOG_ALL:-false}
|
||||
export LOGLEVEL=${LOGLEVEL:-info}
|
||||
export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
|
||||
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
|
||||
export RIBBON=${RIBBON:-Localhost}
|
||||
|
||||
move-back() {
|
||||
mv -v .stack-work .stack-work-run
|
||||
|
||||
@ -5,6 +5,10 @@ $if not isModal
|
||||
<!-- navigation -->
|
||||
^{navbar}
|
||||
|
||||
$maybe ribbon <- contentRibbon
|
||||
<div .ribbon>
|
||||
^{ribbon}
|
||||
|
||||
<div .main>
|
||||
|
||||
<div .main__content uw-poc>
|
||||
|
||||
@ -694,3 +694,30 @@ section {
|
||||
.form--inline {
|
||||
display: inline-block;
|
||||
}
|
||||
|
||||
|
||||
.ribbon {
|
||||
position: fixed;
|
||||
top: calc(40px + var(--header-height));
|
||||
transition: all .2s cubic-bezier(0.03, 0.43, 0.58, 1);
|
||||
right: -63px;
|
||||
transform: rotate(45deg);
|
||||
width: 250px;
|
||||
background: var(--color-error);
|
||||
text-align: center;
|
||||
color: var(--color-lightwhite);
|
||||
font-weight: 600;
|
||||
font-size: 1.25rem;
|
||||
line-height: 2em;
|
||||
box-shadow: 0 0 3px rgba(0, 0, 0, 0.4);
|
||||
z-index: 19;
|
||||
pointer-events: none;
|
||||
}
|
||||
|
||||
@media (max-width: 768px) {
|
||||
.ribbon {
|
||||
top: calc(20px + var(--header-height-collapsed));
|
||||
right: -83px;
|
||||
transform: rotate(45deg) scale(0.6);
|
||||
}
|
||||
}
|
||||
|
||||
@ -1,5 +1,10 @@
|
||||
$newline never
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>27.08.2019
|
||||
<dd .deflist__dd>
|
||||
<ul>
|
||||
<li>Bewertung von Kurs-Bewerbungen via CSV
|
||||
|
||||
<dt .deflist__dt>19.08.2019
|
||||
<dd .deflist__dd>
|
||||
<ul>
|
||||
|
||||
@ -11,6 +11,9 @@ $case formLayout
|
||||
$if fvId view == idFormSectionNoinput
|
||||
<h3 .form-section-title>
|
||||
^{fvLabel view}
|
||||
$maybe hint <- fvTooltip view
|
||||
<div .form-section-title__hint>
|
||||
^{hint}
|
||||
$elseif fvId view == idFormMessageNoinput
|
||||
<div .form-section-notification>
|
||||
^{fvInput view}
|
||||
|
||||
@ -10,6 +10,7 @@
|
||||
width: 20px;
|
||||
z-index: 50;
|
||||
background-image: linear-gradient(to left, rgba(0, 0, 0, 0.4), transparent);
|
||||
transition: height .2s cubic-bezier(0.03, 0.43, 0.58, 1);
|
||||
}
|
||||
|
||||
@media (min-width: 768px) {
|
||||
|
||||
Loading…
Reference in New Issue
Block a user