diff --git a/CHANGELOG.md b/CHANGELOG.md index 40171cfc0..6b2b815ec 100644 --- a/CHANGELOG.md +++ b/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) diff --git a/config/settings.yml b/config/settings.yml index 9d787ed7f..ca2520708 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -122,3 +122,4 @@ user-defaults: warning-days: 1209600 instance-id: "_env:INSTANCE_ID:instance" +ribbon: "_env:RIBBON:" diff --git a/frontend/src/utils/inputs/inputs.scss b/frontend/src/utils/inputs/inputs.scss index ae81b82d4..c4cb63373 100644 --- a/frontend/src/utils/inputs/inputs.scss +++ b/frontend/src/utils/inputs/inputs.scss @@ -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; diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 256f2a000..8568ce0e3 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 \ No newline at end of file diff --git a/models/allocations b/models/allocations index 0fac2cfee..9ddbd59bd 100644 --- a/models/allocations +++ b/models/allocations @@ -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 diff --git a/models/users b/models/users index 155970f60..f66651dd5 100644 --- a/models/users +++ b/models/users @@ -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 diff --git a/package-lock.json b/package-lock.json index c62b42252..c04eb68b8 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.3.0", + "version": "5.5.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index dce6f8e17..d7929fa2c 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.3.0", + "version": "5.5.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index ac24edf65..cdeca6c8f 100644 --- a/package.yaml +++ b/package.yaml @@ -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) diff --git a/routes b/routes index 88099df1a..b8c14a9e7 100644 --- a/routes +++ b/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 diff --git a/src/Data/Bool/Instances.hs b/src/Data/Bool/Instances.hs new file mode 100644 index 000000000..d5eb7a2e0 --- /dev/null +++ b/src/Data/Bool/Instances.hs @@ -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" ] diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index bc66cb874..0867f60b5 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/src/Data/CryptoID/Instances.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 9748f0b47..1852150ac 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 2cf732df8..bc19f3dc2 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -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 - } diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 0cc4d455b..b31ae9273 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -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") ] diff --git a/src/Handler/Course/Application.hs b/src/Handler/Course/Application.hs index 998ff9670..d22c299cc 100644 --- a/src/Handler/Course/Application.hs +++ b/src/Handler/Course/Application.hs @@ -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 diff --git a/src/Handler/Course/Application/Edit.hs b/src/Handler/Course/Application/Edit.hs new file mode 100644 index 000000000..281a21826 --- /dev/null +++ b/src/Handler/Course/Application/Edit.hs @@ -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 + } diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs new file mode 100644 index 000000000..31ec53e47 --- /dev/null +++ b/src/Handler/Course/Application/Files.hs @@ -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 diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs new file mode 100644 index 000000000..a3faa9a89 --- /dev/null +++ b/src/Handler/Course/Application/List.hs @@ -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 diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index ce9d0e422..248c17571 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -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 diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 6bd06b1b5..692a69c3c 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -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"] diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 21f140921..0d181cbbd 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -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} + |] + diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index ea3a99691..598c8479b 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -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) diff --git a/src/Model.hs b/src/Model.hs index b63b39a19..d798d98bf 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -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 diff --git a/src/Settings.hs b/src/Settings.hs index 7bec37cb8..7e99cae3a 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 91a53cdb9..7bea6fcd0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 -- diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index 0205eab4f..e864f9e04 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 326cef129..412e2527f 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 8f1cc1357..d72fdac3e 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -165,6 +165,8 @@ makeLenses_ ''CourseApplication makeLenses_ ''Allocation +makeLenses_ ''File + -- makeClassy_ ''Load diff --git a/start.sh b/start.sh index a9ef7cb8d..ffe083bea 100755 --- a/start.sh +++ b/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 diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 21ac81042..cdcffaad5 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -5,6 +5,10 @@ $if not isModal ^{navbar} + $maybe ribbon <- contentRibbon +
+ ^{ribbon} +
diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index b3b493fd5..44baa25d9 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -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); + } +} diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index d2c436d00..5031e21ef 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -1,5 +1,10 @@ $newline never
+
27.08.2019 +
+
    +
  • Bewertung von Kurs-Bewerbungen via CSV +
    19.08.2019
      diff --git a/templates/widgets/aform/aform.hamlet b/templates/widgets/aform/aform.hamlet index 844821fa2..c492b61d7 100644 --- a/templates/widgets/aform/aform.hamlet +++ b/templates/widgets/aform/aform.hamlet @@ -11,6 +11,9 @@ $case formLayout $if fvId view == idFormSectionNoinput

      ^{fvLabel view} + $maybe hint <- fvTooltip view +
      + ^{hint} $elseif fvId view == idFormMessageNoinput
      ^{fvInput view} diff --git a/templates/widgets/navbar/navbar.lucius b/templates/widgets/navbar/navbar.lucius index ce25a3588..c3885f975 100644 --- a/templates/widgets/navbar/navbar.lucius +++ b/templates/widgets/navbar/navbar.lucius @@ -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) {