From 78c5bc5258c9305deafac18b010dc6a41e5ea864 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Nov 2020 12:12:39 +0100 Subject: [PATCH 01/22] fix(course): better explanation for material access --- messages/uniworx/de-de-formal.msg | 7 ++++++- messages/uniworx/en-eu.msg | 9 +++++++-- src/Handler/Course/Show.hs | 17 +++++++++++++++-- templates/course.hamlet | 25 +++++++++++++++++++++---- 4 files changed, 49 insertions(+), 9 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index f0b4133c7..5a3b9d136 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2513,7 +2513,12 @@ CourseNewsActionDelete: Löschen CourseNewsActionCreate: Neue Nachricht CourseMaterial: Material CourseMaterialFree: Das Kursmaterial ist ohne Anmeldung frei zugänglich -CourseMaterialNotFree: Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial +CourseMaterialNotFree: Das Kursmaterial ist nur für Mitglieder des Kurses einsehbar, also z.B. für Teilnehmer, Tutoren, Korrektoren und Verwalter. + +CourseSheetsFoundHere: Die Übungsblatter zum Kurs finden Sie hier +CourseSheetsNoneVisible: Aktuell gibt es zu diesem Kurs keine Übungsblätter, oder nur Übungsblätter auf die Sie keinen Zugriff haben (z.B. aufgrund von Fristen bzgl. der Sichtbarkeit). +CourseMaterialsFoundHere: Material zum Kurs finden Sie hier +CourseMaterialsNoneVisible: Aktuell gibt es zu diesem Kurs kein Material, oder nur Material auf das Sie keinen Zugriff haben (z.B. aufgrund von Fristen bzgl. der Sichtbarkeit). CourseNewsVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Teilnehmer verwirren könnte. CourseNewsVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für noch unfertige Nachrichten diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 1a621874c..22c76a2df 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2512,8 +2512,13 @@ CourseNewsActionEdit: Edit CourseNewsActionDelete: Delete CourseNewsActionCreate: Create new item CourseMaterial: Material -CourseMaterialFree: Course material is publicly accessable -CourseMaterialNotFree: Only course participants may access course material +CourseMaterialFree: Course material is publicly accessible +CourseMaterialNotFree: Course material is only accessible to members of the course, e.g. for participants, tutors, correctors or administratiors. + +CourseSheetsFoundHere: Exercise sheets for this course are available here +CourseSheetsNoneVisible: Currently there are no exercise sheets for this course or only exercise sheets to which you don't have access (e.g. because of visibility settings) +CourseMaterialsFoundHere: Material for this course is available here +CourseMaterialsNoneVisible: Currently there is no material for this course or only material to which you don't have access (e.g. because of visibility settings) CourseNewsVisibleFromEditWarning: This item of course news has already been published and should no longer be changed sind this might confuse participants. CourseNewsVisibleFromTip: If left empty this item is never visible. Leave empty for unfinished items diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index f34d5048f..67fe5e06a 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -28,7 +28,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -90,6 +90,7 @@ getCShowR tid ssh csh = do lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR + return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete) events' <- fmap (sortOn $ courseEventTime . entityVal) . lift $ selectList [ CourseEventCourse ==. cid ] [] @@ -108,7 +109,19 @@ getCShowR tid ssh csh = do mayReRegister <- lift . courseMayReRegister $ Entity cid course - return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) + mayViewSheets <- hasReadAccessTo $ CourseR tid ssh csh SheetListR + sheets <- lift . E.select . E.from $ \sheet -> do + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return $ sheet E.^. SheetName + mayViewAnySheet <- anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR + + mayViewMaterials <- hasReadAccessTo $ CourseR tid ssh csh MaterialListR + materials <- lift . E.select . E.from $ \material -> do + E.where_ $ material E.^. MaterialCourse E.==. E.val cid + return $ material E.^. MaterialName + mayViewAnyMaterial <- anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR + + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' diff --git a/templates/course.hamlet b/templates/course.hamlet index 4492a29e2..c01b249d4 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -232,10 +232,27 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
_{MsgCourseMaterial}
- $if courseMaterialFree course - _{MsgCourseMaterialFree} - $else - _{MsgCourseMaterialNotFree} + $if mayViewSheets +

+ $if mayViewAnySheet + _{MsgCourseSheetsFoundHere}: # + + _{MsgMenuSheetList} + $else + _{MsgCourseSheetsNoneVisible} + $if mayViewMaterials +

+ $if mayViewAnyMaterial + _{MsgCourseMaterialsFoundHere}: # + + _{MsgMenuMaterialList} + $else + _{MsgCourseMaterialsNoneVisible} +

+ $if courseMaterialFree course + _{MsgCourseMaterialFree} + $else + _{MsgCourseMaterialNotFree} $if hasExams

_{MsgCourseExams} From 549b95882dc6bd7abf088487ede894d292641190 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Nov 2020 12:14:17 +0100 Subject: [PATCH 02/22] chore(release): 21.1.1 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c5836333f..63252d33a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +### [21.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.0...v21.1.1) (2020-11-06) + + +### Bug Fixes + +* **course:** better explanation for material access ([78c5bc5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/78c5bc5258c9305deafac18b010dc6a41e5ea864)) + ## [21.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.3...v21.1.0) (2020-11-05) diff --git a/package-lock.json b/package-lock.json index a6f372d0a..02c7a612b 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "21.1.0", + "version": "21.1.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index ee0548eda..f3591e5ee 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "21.1.0", + "version": "21.1.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index b888e1340..90c13841a 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 21.1.0 +version: 21.1.1 dependencies: - base From e25e8a2f4ca65afc29acc8a3884df9acf77d4398 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Nov 2020 20:39:43 +0100 Subject: [PATCH 03/22] fix(html-field): introduce stored-markup BREAKING CHANGE: StoredMarkup --- models/allocations.model | 4 +- models/courses.model | 8 +- models/courses/materials.model | 2 +- models/courses/news.model | 4 +- models/exams.model | 4 +- models/sheets.model | 4 +- models/system-messages.model | 8 +- src/Database/Esqueleto/Utils.hs | 8 +- src/Foundation/SiteLayout.hs | 2 +- src/Handler/Course/Edit.hs | 4 +- src/Handler/Course/Events/Form.hs | 2 +- src/Handler/Course/List.hs | 13 +- src/Handler/Course/News/Form.hs | 4 +- src/Handler/Course/User.hs | 3 +- src/Handler/Course/Users.hs | 2 +- src/Handler/Exam/Form.hs | 12 +- src/Handler/Exam/Users.hs | 4 +- src/Handler/Help.hs | 2 +- src/Handler/Material.hs | 2 +- src/Handler/Sheet/Form.hs | 4 +- src/Handler/Utils/Communication.hs | 2 +- src/Handler/Utils/Form.hs | 8 +- src/Handler/Utils/Pandoc.hs | 33 ++++- src/Model/Migration.hs | 21 +++ src/Model/Types.hs | 1 + src/Model/Types/Changelog.hs | 1 + src/Model/Types/Exam.hs | 9 +- src/Model/Types/Markup.hs | 133 ++++++++++++++++++ .../stored-markup.de-de-formal.hamlet | 2 + .../i18n/changelog/stored-markup.en-eu.hamlet | 2 + test/Database/Fill.hs | 2 +- test/Model/TypesSpec.hs | 25 +++- 32 files changed, 277 insertions(+), 58 deletions(-) create mode 100644 src/Model/Types/Markup.hs create mode 100644 templates/i18n/changelog/stored-markup.de-de-formal.hamlet create mode 100644 templates/i18n/changelog/stored-markup.en-eu.hamlet diff --git a/models/allocations.model b/models/allocations.model index 0bbebbea5..e4e96f6b2 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -3,8 +3,8 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis 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 + description StoredMarkup Maybe -- description for prospective students + staffDescription StoredMarkup Maybe -- description seen by prospective lecturers only staffRegisterFrom UTCTime Maybe -- lectureres may register courses staffRegisterTo UTCTime Maybe -- course registration stops -- staffDeregisterUntil not needed: staff may make arbitrary changes until staffRegisterTo, always frozen afterwards diff --git a/models/courses.model b/models/courses.model index 6033ff0a9..f9b4a0526 100644 --- a/models/courses.model +++ b/models/courses.model @@ -5,7 +5,7 @@ DegreeCourse json -- for which degree programmes this course is appropriate fo UniqueDegreeCourse course degree terms Course -- Information about a single course; contained info is always visible to all users name (CI Text) - description Html Maybe -- user-defined large Html, ought to contain module description + description StoredMarkup Maybe -- user-defined large Html, ought to contain module description linkExternal Text Maybe -- arbitrary user-defined url for external course page shorthand (CI Text) -- practical shorthand of course name, used for identification term TermId -- semester this course is taught @@ -21,7 +21,7 @@ Course -- Information about a single course; contained info is always visible registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase materialFree Bool -- False: only enrolled users may see course materials not stored in this table applicationsRequired Bool default=false - applicationsInstructions Html Maybe + applicationsInstructions StoredMarkup Maybe applicationsText Bool default=false applicationsFiles UploadMode "default='{\"mode\": \"no-upload\"}'::jsonb" applicationsRatingsVisible Bool default=false @@ -33,7 +33,7 @@ CourseEvent course CourseId room Text time Occurrences - note Html Maybe + note StoredMarkup Maybe lastChanged UTCTime default=now() CourseAppInstructionFile @@ -72,7 +72,7 @@ CourseParticipant -- course enrolement CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student course CourseId user UserId - note Html -- arbitrary user-defined text; visible only to lecturer of this course + note StoredMarkup -- arbitrary user-defined text; visible only to lecturer of this course UniqueCourseUserNote user course CourseUserNoteEdit -- who edited a participants course note when user UserId diff --git a/models/courses/materials.model b/models/courses/materials.model index fd1d19fb7..3a4767ec5 100644 --- a/models/courses/materials.model +++ b/models/courses/materials.model @@ -2,7 +2,7 @@ Material -- course material for disemination to course participants course CourseId name (CI Text) type (CI Text) Maybe - description Html Maybe + description StoredMarkup Maybe visibleFrom UTCTime Maybe -- Invisible to enrolled participants before lastEdit UTCTime UniqueMaterial course name diff --git a/models/courses/news.model b/models/courses/news.model index fdd2c0254..c31312d2e 100644 --- a/models/courses/news.model +++ b/models/courses/news.model @@ -3,8 +3,8 @@ CourseNews visibleFrom UTCTime Maybe participantsOnly Bool title Text Maybe - content Html - summary Html Maybe + content StoredMarkup + summary StoredMarkup Maybe lastEdit UTCTime CourseNewsFile news CourseNewsId diff --git a/models/exams.model b/models/exams.model index 4963e4075..295f2e768 100644 --- a/models/exams.model +++ b/models/exams.model @@ -16,7 +16,7 @@ Exam closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification) publicStatistics Bool gradingMode ExamGradingMode - description Html Maybe + description StoredMarkup Maybe examMode ExamMode staff Text Maybe UniqueExam course name @@ -35,7 +35,7 @@ ExamOccurrence capacity Natural start UTCTime end UTCTime Maybe - description Html Maybe + description StoredMarkup Maybe UniqueExamOccurrence exam name ExamRegistration exam ExamId diff --git a/models/sheets.model b/models/sheets.model index f54426040..6f0bb6176 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -1,10 +1,10 @@ Sheet -- exercise sheet for a given course course CourseId name (CI Text) - description Html Maybe + description StoredMarkup Maybe type SheetType -- Does it count towards overall course grade? grouping SheetGroup -- May participants submit in groups of certain sizes? - markingText Html Maybe -- Instructons for correctors, included in marking templates + markingText StoredMarkup Maybe -- Instructons for correctors, included in marking templates visibleFrom UTCTime Maybe -- Invisible to enrolled participants before activeFrom UTCTime Maybe -- Download of questions and submission is permitted afterwards activeTo UTCTime Maybe -- Submission is only permitted before diff --git a/models/system-messages.model b/models/system-messages.model index 0d5cd5611..e8dfbd9ad 100644 --- a/models/system-messages.model +++ b/models/system-messages.model @@ -11,14 +11,14 @@ SystemMessage lastChanged UTCTime default=now() lastUnhide UTCTime default=now() defaultLanguage Lang -- Language of @content@ and @summary@ - content Html -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified - summary Html Maybe + content StoredMarkup -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified + summary StoredMarkup Maybe SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers message SystemMessageId language Lang - content Html - summary Html Maybe + content StoredMarkup + summary StoredMarkup Maybe UniqueSystemMessageTranslation message language SystemMessageHidden diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 66061ec3e..396f497f6 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -25,7 +25,7 @@ module Database.Esqueleto.Utils , max, min , abs , SqlProject(..) - , (->.) + , (->.), (#>>.) , fromSqlKey , selectCountRows , selectMaybe @@ -367,6 +367,12 @@ infixl 8 ->. (->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b) (->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t +infixl 8 #>>. + +(#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text)) +(#>>.) expr t = E.unsafeSqlBinOp "#>>" expr $ E.val t + + fromSqlKey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value Int64) fromSqlKey = E.veryUnsafeCoerceSqlExprValue diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 8ca6c3b29..9f151bca7 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -454,7 +454,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) case summary of Just s -> addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID) - Nothing -> addMessage systemMessageSeverity content + Nothing -> addMessage systemMessageSeverity $ toHtml content tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $ HashMap.singleton cID mempty{ userSystemMessageShown = Just now } diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index d1a340740..54590756e 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -34,14 +34,14 @@ data CourseForm = CourseForm , cfShort :: CourseShorthand , cfSchool :: SchoolId , cfTerm :: TermId - , cfDesc :: Maybe Html + , cfDesc :: Maybe StoredMarkup , cfLink :: Maybe Text , cfVisFrom :: Maybe UTCTime , cfVisTo :: Maybe UTCTime , cfMatFree :: Bool , cfAllocation :: Maybe AllocationCourseForm , cfAppRequired :: Bool - , cfAppInstructions :: Maybe Html + , cfAppInstructions :: Maybe StoredMarkup , cfAppInstructionFiles :: Maybe FileUploads , cfAppText :: Bool , cfAppFiles :: UploadMode diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs index ecc01b8e9..be55771dd 100644 --- a/src/Handler/Course/Events/Form.hs +++ b/src/Handler/Course/Events/Form.hs @@ -15,7 +15,7 @@ data CourseEventForm = CourseEventForm { cefType :: CI Text , cefRoom :: Text , cefTime :: Occurrences - , cefNote :: Maybe Html + , cefNote :: Maybe StoredMarkup } courseEventForm :: Maybe CourseEventForm -> Form CourseEventForm diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index a996fc3e5..2ab517fce 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -81,7 +81,12 @@ makeCourseTable whereClause colChoices psValidator = do return (course, participants, registered, school) lecturerQuery cid (user `E.InnerJoin` lecturer) = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser - E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer + E.where_ $ cid E.==. lecturer E.^. LecturerCourse + E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer + return user + isCourseAdminQuery cid (user `E.InnerJoin` lecturer) = do + E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + E.where_ $ cid E.==. lecturer E.^. LecturerCourse return user isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course E.&&. E.just (user E.^. UserId) E.==. E.val muid @@ -135,8 +140,8 @@ makeCourseTable whereClause colChoices psValidator = do , ( "lecturer", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> E.exists $ E.from $ \t -> do - user <- lecturerQuery (course E.^. CourseId) t - E.where_ $ E.any (E.hasInfix (user E.^. UserSurname) . E.val) (criterias :: Set.Set Text) + user <- isCourseAdminQuery (course E.^. CourseId) t + E.where_ $ E.any (E.hasInfix (user E.^. UserDisplayName) . E.val) (criterias :: Set.Set Text) ) , ( "openregistration", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Bool) of Nothing -> E.val True @@ -167,7 +172,7 @@ makeCourseTable whereClause colChoices psValidator = do Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) - E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + E.||. (E.maybe (E.val mempty) (E.castString . esqueletoMarkupOutput) (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs index 5d5aeb599..33e9a1938 100644 --- a/src/Handler/Course/News/Form.hs +++ b/src/Handler/Course/News/Form.hs @@ -12,8 +12,8 @@ import qualified Data.Conduit.List as C data CourseNewsForm = CourseNewsForm { cnfTitle :: Maybe Text - , cnfSummary :: Maybe Html - , cnfContent :: Html + , cnfSummary :: Maybe StoredMarkup + , cnfContent :: StoredMarkup , cnfParticipantsOnly :: Bool , cnfVisibleFrom :: Maybe UTCTime , cnfFiles :: Maybe FileUploads diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index de8747fc4..f8147faf4 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -29,6 +29,7 @@ import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.Combinators as C +import qualified Data.Text.Lazy as LT data ExamAction = ExamDeregister @@ -226,7 +227,7 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote) deleteBy thisUniqueNote addMessageI Info MsgCourseUserNoteDeleted - _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes + _ | ((==) `on` fmap (LT.strip . renderHtml . markupOutput)) mbNote noteText -> return () -- no changes (Just note) -> do dozentId <- requireAuthId (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note] diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index f6c31ef4e..9775952b4 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -174,7 +174,7 @@ data UserTableCsv = UserTableCsv , csvUserStudyFeatures :: UserTableStudyFeatures , csvUserSubmissionGroup :: Maybe SubmissionGroupName , csvUserRegistration :: UTCTime - , csvUserNote :: Maybe Html + , csvUserNote :: Maybe StoredMarkup , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName)) , csvUserExams :: [ExamName] , csvUserSheets :: Map SheetName (SheetType, Maybe Points) diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 2a19dfa4f..cc8d0c273 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -22,12 +22,14 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Control.Monad.State.Class as State -import Text.Blaze.Html.Renderer.String (renderHtml) +import Text.Blaze.Html.Renderer.Text (renderHtml) + +import qualified Data.Text.Lazy as LT data ExamForm = ExamForm { efName :: ExamName - , efDescription :: Maybe Html + , efDescription :: Maybe StoredMarkup , efStart :: Maybe UTCTime , efEnd :: Maybe UTCTime , efVisibleFrom :: Maybe UTCTime @@ -56,7 +58,7 @@ data ExamOccurrenceForm = ExamOccurrenceForm , eofCapacity :: Natural , eofStart :: UTCTime , eofEnd :: Maybe UTCTime - , eofDescription :: Maybe Html + , eofDescription :: Maybe StoredMarkup } deriving (Read, Show, Eq, Generic, Typeable) instance Ord ExamOccurrenceForm where @@ -231,7 +233,7 @@ examOccurrenceForm prev = wFormToAForm $ do <*> eofCapacityRes <*> eofStartRes <*> eofEndRes - <*> (assertM (not . null . renderHtml) <$> eofDescRes) + <*> eofDescRes , $(widgetFile "widgets/massinput/examRooms/form") ) @@ -430,7 +432,7 @@ validateExam cId oldExam = do [ (/=) `on` eofRoom , (/=) `on` eofStart , (/=) `on` eofEnd - , (/=) `on` fmap renderHtml . eofDescription + , (/=) `on` fmap (LT.strip . renderHtml . markupOutput) . eofDescription ] guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 6e76ed20b..eb3f4aba1 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -181,7 +181,7 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserBonus :: Maybe (Maybe Points) , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints) , csvEUserExamResult :: Maybe ExamResultPassedGrade - , csvEUserCourseNote :: Maybe Html + , csvEUserCourseNote :: Maybe StoredMarkup } deriving (Generic) makeLenses_ ''ExamUserTableCsv @@ -345,7 +345,7 @@ data ExamUserCsvAction } | ExamUserCsvSetCourseNoteData { examUserCsvActUser :: UserId - , examUserCsvActCourseNote :: Maybe Html + , examUserCsvActCourseNote :: Maybe StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index 4c2bd4f0b..f6070369e 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -67,7 +67,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do <$> hfReferer' <*> hfUserId' <*> hfSubject' - <*> hfRequest' + <*> (fmap markupOutput <$> hfRequest') <*> hfError' validateHelpForm :: FormValidator HelpForm Handler () diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index c0679cd31..37367fa70 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -19,7 +19,7 @@ import Handler.Utils.Delete data MaterialForm = MaterialForm { mfName :: MaterialName , mfType :: Maybe (CI Text) - , mfDescription :: Maybe Html + , mfDescription :: Maybe StoredMarkup , mfVisibleFrom :: Maybe UTCTime , mfFiles :: Maybe FileUploads } diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 56c0943a3..73c65cdcb 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -26,7 +26,7 @@ type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector) data SheetForm = SheetForm { sfName :: SheetName - , sfDescription :: Maybe Html + , sfDescription :: Maybe StoredMarkup , sfRequireExamRegistration :: Maybe ExamId , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads , sfPersonalF :: Maybe SheetPersonalisedFilesForm @@ -39,7 +39,7 @@ data SheetForm = SheetForm , sfGrouping :: SheetGroup , sfType :: SheetType , sfAutoDistribute :: Bool - , sfMarkingText :: Maybe Html + , sfMarkingText :: Maybe StoredMarkup , sfAnonymousCorrection :: Bool , sfCorrectors :: Loads -- Keine SheetId im Formular! diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 153ba69ea..5a3a5486d 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -210,7 +210,7 @@ commR CommunicationRoute{..} = do <$> recipientAForm <* aformMessage recipientsListMsg <*> aopt textField (fslI MsgCommSubject) Nothing - <*> areq htmlField (fslI MsgCommBody) Nothing + <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 2c3ee4dcd..4a7f6ec8b 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -2124,25 +2124,25 @@ examModeForm mPrev = examMode where examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..} - examAidsEither :: Iso' ExamAids (Either Html ExamAidsPreset) + examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset) examAidsEither = iso examAidsToEither examAidsFromEither where examAidsToEither (ExamAidsPreset p) = Right p examAidsToEither (ExamAidsCustom c) = Left c examAidsFromEither (Right p) = ExamAidsPreset p examAidsFromEither (Left c) = ExamAidsCustom c - examOnlineEither :: Iso' ExamOnline (Either Html ExamOnlinePreset) + examOnlineEither :: Iso' ExamOnline (Either StoredMarkup ExamOnlinePreset) examOnlineEither = iso examOnlineToEither examOnlineFromEither where examOnlineToEither (ExamOnlinePreset p) = Right p examOnlineToEither (ExamOnlineCustom c) = Left c examOnlineFromEither (Right p) = ExamOnlinePreset p examOnlineFromEither (Left c) = ExamOnlineCustom c - examSynchronicityEither :: Iso' ExamSynchronicity (Either Html ExamSynchronicityPreset) + examSynchronicityEither :: Iso' ExamSynchronicity (Either StoredMarkup ExamSynchronicityPreset) examSynchronicityEither = iso examSynchronicityToEither examSynchronicityFromEither where examSynchronicityToEither (ExamSynchronicityPreset p) = Right p examSynchronicityToEither (ExamSynchronicityCustom c) = Left c examSynchronicityFromEither (Right p) = ExamSynchronicityPreset p examSynchronicityFromEither (Left c) = ExamSynchronicityCustom c - examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either Html ExamRequiredEquipmentPreset) + examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either StoredMarkup ExamRequiredEquipmentPreset) examRequiredEquipmentEither = iso examRequiredEquipmentToEither examRequiredEquipmentFromEither where examRequiredEquipmentToEither (ExamRequiredEquipmentPreset p) = Right p examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left c diff --git a/src/Handler/Utils/Pandoc.hs b/src/Handler/Utils/Pandoc.hs index e4f3d49e1..50dc3dc5a 100644 --- a/src/Handler/Utils/Pandoc.hs +++ b/src/Handler/Utils/Pandoc.hs @@ -9,6 +9,9 @@ import Import.NoFoundation import Handler.Utils.I18n import qualified Data.Text as Text +import qualified Data.Text.Lazy as LT + +import Control.Monad.Error.Class (liftEither) import qualified Text.Pandoc as P @@ -24,27 +27,39 @@ data HtmlFieldKind instance Universe HtmlFieldKind instance Finite HtmlFieldKind -htmlField, htmlFieldSmall :: MonadLogger m => Field m Html +htmlField, htmlFieldSmall :: MonadLogger m => Field m StoredMarkup htmlField = htmlField' HtmlFieldNormal htmlFieldSmall = htmlField' HtmlFieldSmall -htmlField' :: MonadLogger m => HtmlFieldKind -> Field m Html +htmlField' :: MonadLogger m => HtmlFieldKind -> Field m StoredMarkup htmlField' fieldKind = Field{..} where fieldEnctype = UrlEncoded - fieldParse (t : _) _ - = return . fmap (assertM' $ not . null . renderHtml) . parseMarkdown $ Text.strip t + fieldParse ((Text.strip -> t) : _) _ = runExceptT . runMaybeT $ do + html <- assertM' (not . null . LT.strip . renderHtml) =<< liftEither (parseMarkdown t) + return StoredMarkup + { markupInputFormat = MarkupMarkdown + , markupInput = fromStrict t + , markupOutput = html + } fieldParse [] _ = return $ Right Nothing fieldView theId name attrs val isReq = do - val' <- either return (maybeT (return mempty) . renderMarkdown) val + val' + <- let toMarkdown StoredMarkup{..} = case markupInputFormat of + MarkupMarkdown -> return $ toStrict markupInput + MarkupHtml -> renderMarkdown markupOutput + MarkupPlaintext -> plaintextToMarkdown $ toStrict markupInput + in either return (maybeT (return mempty) . toMarkdown) val + let markdownExplanation = $(i18nWidgetFile "markdown-explanation") $(widgetFile "widgets/html-field") parseMarkdown = parseMarkdownWith markdownReaderOptions htmlWriterOptions renderMarkdown = renderMarkdownWith htmlReaderOptions markdownWriterOptions + plaintextToMarkdown = plaintextToMarkdownWith markdownWriterOptions parseMarkdownWith :: P.ReaderOptions -> P.WriterOptions -> Text -> Either (SomeMessage site) Html parseMarkdownWith readerOptions writerOptions text = @@ -60,6 +75,14 @@ renderMarkdownWith readerOptions writerOptions html = where logPandocError = $logErrorS "renderMarkdown" . tshow +plaintextToMarkdownWith :: (MonadLogger m, MonadPlus m) => P.WriterOptions -> Text -> m Text +plaintextToMarkdownWith writerOptions text = + either (\e -> logPandocError e >> mzero) return . P.runPure $ + P.writeMarkdown writerOptions pandoc + where + logPandocError = $logErrorS "renderMarkdown" . tshow + pandoc = P.Pandoc mempty [P.Plain [P.Str text]] + htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions htmlReaderOptions = markdownReaderOptions diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 1e2864dfd..c85065220 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -990,6 +990,27 @@ customMigrations = Map.fromListWith (>>) , ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|] , return () -- Unused; used to create and fill `ChangelogItemFirstSeen` ) + , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|44.0.0|] + , [executeQQ| + ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationDescription} TYPE jsonb USING (CASE WHEN @{AllocationDescription} IS NOT NULL THEN to_json(@{AllocationDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationStaffDescription} TYPE jsonb USING (CASE WHEN @{AllocationStaffDescription} IS NOT NULL THEN to_json(@{AllocationStaffDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseApplicationsInstructions} TYPE jsonb USING (CASE WHEN @{CourseApplicationsInstructions} IS NOT NULL THEN to_json(@{CourseApplicationsInstructions}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{CourseEvent} ALTER COLUMN @{CourseEventNote} TYPE jsonb USING (CASE WHEN @{CourseEventNote} IS NOT NULL THEN to_json(@{CourseEventNote}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{CourseUserNote} ALTER COLUMN @{CourseUserNoteNote} TYPE jsonb USING (CASE WHEN @{CourseUserNoteNote} IS NOT NULL THEN to_json(@{CourseUserNoteNote}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Material} ALTER COLUMN @{MaterialDescription} TYPE jsonb USING (CASE WHEN @{MaterialDescription} IS NOT NULL THEN to_json(@{MaterialDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsContent} TYPE jsonb USING (CASE WHEN @{CourseNewsContent} IS NOT NULL THEN to_json(@{CourseNewsContent}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsSummary} TYPE jsonb USING (CASE WHEN @{CourseNewsSummary} IS NOT NULL THEN to_json(@{CourseNewsSummary}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Exam} ALTER COLUMN @{ExamDescription} TYPE jsonb USING (CASE WHEN @{ExamDescription} IS NOT NULL THEN to_json(@{ExamDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{ExamOccurrence} ALTER COLUMN @{ExamOccurrenceDescription} TYPE jsonb USING (CASE WHEN @{ExamOccurrenceDescription} IS NOT NULL THEN to_json(@{ExamOccurrenceDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetDescription} TYPE jsonb USING (CASE WHEN @{SheetDescription} IS NOT NULL THEN to_json(@{SheetDescription}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetMarkingText} TYPE jsonb USING (CASE WHEN @{SheetMarkingText} IS NOT NULL THEN to_json(@{SheetMarkingText}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageContent} TYPE jsonb USING (CASE WHEN @{SystemMessageContent} IS NOT NULL THEN to_json(@{SystemMessageContent}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END); + ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END); + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index a8e437f17..5c140edbd 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -18,3 +18,4 @@ import Model.Types.Languages as Types import Model.Types.File as Types import Model.Types.User as Types import Model.Types.Changelog as Types +import Model.Types.Markup as Types diff --git a/src/Model/Types/Changelog.hs b/src/Model/Types/Changelog.hs index f0b64a502..e0d855ba8 100644 --- a/src/Model/Types/Changelog.hs +++ b/src/Model/Types/Changelog.hs @@ -38,6 +38,7 @@ classifyChangelogItem = \case ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix ChangelogFormsTimesReset -> ChangelogItemBugfix ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix + ChangelogStoredMarkup -> ChangelogItemBugfix _other -> ChangelogItemFeature changelogItemDays :: Map ChangelogItem Day diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 6938ef227..98835feb3 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -43,6 +43,7 @@ module Model.Types.Exam import Import.NoModel import Model.Types.Common import Model.Types.TH.PathPiece +import Model.Types.Markup import qualified Data.Text as Text import qualified Data.Map as Map @@ -439,7 +440,7 @@ instance Enum ExamPartNumber where data ExamAids = ExamAidsPreset { examAidsPreset :: ExamAidsPreset } - | ExamAidsCustom { examAidsCustom :: Html } + | ExamAidsCustom { examAidsCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) data ExamAidsPreset @@ -460,7 +461,7 @@ pathPieceJSON ''ExamAidsPreset data ExamOnline = ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset } - | ExamOnlineCustom { examOnlineCustom :: Html } + | ExamOnlineCustom { examOnlineCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) data ExamOnlinePreset @@ -481,7 +482,7 @@ pathPieceJSON ''ExamOnlinePreset data ExamSynchronicity = ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset } - | ExamSynchronicityCustom { examSynchronicityCustom :: Html } + | ExamSynchronicityCustom { examSynchronicityCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) data ExamSynchronicityPreset @@ -502,7 +503,7 @@ pathPieceJSON ''ExamSynchronicityPreset data ExamRequiredEquipment = ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset } - | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: Html } + | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) data ExamRequiredEquipmentPreset diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs new file mode 100644 index 000000000..d4b0a1035 --- /dev/null +++ b/src/Model/Types/Markup.hs @@ -0,0 +1,133 @@ +module Model.Types.Markup + ( MarkupFormat(..) + , StoredMarkup(..) + , htmlToStoredMarkup, plaintextToStoredMarkup, preEscapedToStoredMarkup + , esqueletoMarkupOutput + ) where + +import Import.NoModel + +import Text.Blaze (ToMarkup(..)) +import Text.Blaze.Html.Renderer.Text (renderHtml) + +import qualified Data.Text.Lazy as LT +import qualified Data.ByteString.Lazy as LBS +import Data.Text.Encoding (decodeUtf8') + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import qualified Data.Csv as Csv + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Internal.Internal as E +import Database.Persist.Sql + + +data MarkupFormat + = MarkupMarkdown + | MarkupHtml + | MarkupPlaintext + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) +nullaryPathPiece ''MarkupFormat $ camelToPathPiece' 1 +pathPieceJSON ''MarkupFormat + +data StoredMarkup = StoredMarkup + { markupInputFormat :: MarkupFormat + , markupInput :: LT.Text + , markupOutput :: Html + } deriving (Read, Show, Generic, Typeable) + +htmlToStoredMarkup :: Html -> StoredMarkup +htmlToStoredMarkup html = StoredMarkup + { markupInputFormat = MarkupHtml + , markupInput = renderHtml html + , markupOutput = html + } +plaintextToStoredMarkup :: Textual t => t -> StoredMarkup +plaintextToStoredMarkup (repack -> t) = StoredMarkup + { markupInputFormat = MarkupPlaintext + , markupInput = t + , markupOutput = toMarkup t + } +preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup +preEscapedToStoredMarkup (repack -> t) = StoredMarkup + { markupInputFormat = MarkupHtml + , markupInput = fromStrict t + , markupOutput = preEscapedToMarkup t + } + +esqueletoMarkupOutput :: E.SqlExpr (E.Value StoredMarkup) -> E.SqlExpr (E.Value Html) +esqueletoMarkupOutput sMarkup = E.maybe (E.val mempty) E.veryUnsafeCoerceSqlExprValue $ E.maybe (sMarkup E.#>>. "{}") E.just (sMarkup E.#>>. "{\"markup-output\"}") + +instance Eq StoredMarkup where + (==) = (==) `on` LT.strip . renderHtml . markupOutput +instance Ord StoredMarkup where + compare = comparing $ LT.strip . renderHtml . markupOutput + +instance ToJSON StoredMarkup where + toJSON StoredMarkup{..} + | markupInputFormat == MarkupHtml + , renderHtml markupOutput == markupInput + = Aeson.String $ toStrict markupInput + | otherwise + = Aeson.object + [ "input-format" Aeson..= markupInputFormat + , "markup-input" Aeson..= markupInput + , "markup-output" Aeson..= markupOutput + ] +instance FromJSON StoredMarkup where + parseJSON v = case v of + Aeson.String t -> return $ preEscapedToStoredMarkup t + Aeson.Object o -> do + markupInputFormat <- o Aeson..: "input-format" + markupInput <- o Aeson..: "markup-input" + markupOutput <- o Aeson..: "markup-output" + return StoredMarkup{..} + other -> Aeson.typeMismatch "StoredMarkup" other + +instance IsString StoredMarkup where + fromString = preEscapedToStoredMarkup +instance ToMarkup StoredMarkup where + toMarkup = markupOutput +instance ToWidget site StoredMarkup where + toWidget = toWidget . toMarkup + +instance Semigroup StoredMarkup where + a <> b + | markupInputFormat a == markupInputFormat b + = StoredMarkup + { markupInputFormat = markupInputFormat a + , markupInput = ((<>) `on` markupInput) a b -- this seems optimistic... + , markupOutput = ((<>) `on` markupOutput) a b + } + | null $ markupInput a + = b + | null $ markupInput b + = a + | otherwise + = StoredMarkup + { markupInputFormat = MarkupHtml + , markupInput = renderHtml $ ((<>) `on` markupOutput) a b + , markupOutput = ((<>) `on` markupOutput) a b + } +instance Monoid StoredMarkup where + mempty = fromString mempty + +instance Csv.ToField StoredMarkup where + toField = Csv.toField . markupOutput +instance Csv.FromField StoredMarkup where + parseField = fmap htmlToStoredMarkup . Csv.parseField + +instance PersistField StoredMarkup where + fromPersistValue (PersistDbSpecific bs) = first pack $ Aeson.eitherDecodeStrict' bs + fromPersistValue (PersistByteString bs) = first pack $ Aeson.eitherDecodeStrict' bs + <|> bimap show preEscapedToStoredMarkup (decodeUtf8' bs) + fromPersistValue (PersistText t) = first pack $ Aeson.eitherDecodeStrict' (encodeUtf8 t) + <|> return (preEscapedToStoredMarkup t) + fromPersistValue _ = Left "StoredMarkup values must be converted from PersistDbSpecific, PersistText, or PersistByteString" + toPersistValue = PersistDbSpecific . LBS.toStrict . Aeson.encode +instance PersistFieldSql StoredMarkup where + sqlType _ = SqlOther "jsonb" diff --git a/templates/i18n/changelog/stored-markup.de-de-formal.hamlet b/templates/i18n/changelog/stored-markup.de-de-formal.hamlet new file mode 100644 index 000000000..486abbabb --- /dev/null +++ b/templates/i18n/changelog/stored-markup.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Html-Felder speichern nun den genauen Markdown-Eingabetext, sodass erneutes Editieren nicht mehr zu verändertem oder invaliden Markup führen sollte. diff --git a/templates/i18n/changelog/stored-markup.en-eu.hamlet b/templates/i18n/changelog/stored-markup.en-eu.hamlet new file mode 100644 index 000000000..35e529249 --- /dev/null +++ b/templates/i18n/changelog/stored-markup.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Html fields now store the exact markdown input. Therefore repeated editing should no longer result in changed or invalid markup. diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8139235f4..29cdb615b 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -556,7 +556,7 @@ fillDb = do nbrs = [1,2,3,27,7,1] ffp <- insert' Course { courseName = "Fortgeschrittene Funktionale Programmierung" - , courseDescription = Just [shamlet| + , courseDescription = Just $ htmlToStoredMarkup [shamlet|

It is fun!

Come to where the functional is!

diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 2836b9149..917079d8d 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -18,7 +18,7 @@ import Yesod.Auth.Util.PasswordStore import Database.Persist.Sql (SqlBackend, fromSqlKey, toSqlKey) import Text.Blaze.Html -import Text.Blaze.Renderer.Text +import Text.Blaze.Html.Renderer.Text (renderHtml) import qualified Data.Set as Set @@ -215,7 +215,13 @@ instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key r instance Arbitrary Html where arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary - shrink = map preEscapedToHtml . shrink . renderMarkup + shrink = map preEscapedToHtml . shrink . renderHtml + +instance Arbitrary StoredMarkup where + arbitrary = oneof + [ htmlToStoredMarkup <$> arbitrary + , (plaintextToStoredMarkup :: Text -> StoredMarkup) <$> arbitrary + ] instance Arbitrary OccurrenceSchedule where arbitrary = genericArbitrary @@ -389,6 +395,8 @@ spec = do [ persistFieldLaws, jsonLaws, binaryLaws ] lawsCheckHspec (Proxy @ExamPartNumber) [ persistFieldLaws, jsonLaws, pathPieceLaws, csvFieldLaws, eqLaws, ordLaws ] + lawsCheckHspec (Proxy @StoredMarkup) + [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws, csvFieldLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ @@ -448,6 +456,19 @@ spec = do t "{\"user\": {\"mode\": \"upload-specific\", \"specific-files\": [{\"name\": \"abgabe6.pdf\", \"label\": \"Abgabe 6\", \"required\": true}]}, \"corrector\": false}" t "{\"user\": {\"mode\": \"upload-specific\", \"specific-files\": [{\"name\": \"abgabe10.pdf\", \"label\": \"Abgabe 10\", \"required\": true}, {\"name\": \"deckblatt10.pdf\", \"label\": \"Deckblatt 10\", \"required\": true}]}, \"corrector\": false}" t "{\"user\": {\"mode\": \"no-upload\"}, \"corrector\": false}" + describe "StoredMarkup" $ do + it "decodes from Html via json" . property $ + \html -> case Aeson.eitherDecode (Aeson.encode html) of + Left _ -> False + Right StoredMarkup{..} -> ((==) `on` renderHtml) markupOutput html + && markupInputFormat == MarkupHtml + && renderHtml html == markupInput + it "decodes from Html via persistent" . property $ + \html -> case fromPersistValue (toPersistValue html) of + Left _ -> False + Right StoredMarkup{..} -> ((==) `on` renderHtml) markupOutput html + && markupInputFormat == MarkupHtml + && renderHtml html == markupInput termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do From d20d8a1505f297ffb4d0866511ed49d46166374c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Nov 2020 21:11:26 +0100 Subject: [PATCH 04/22] chore: fix arbitrary instance for storable markup --- test/Model/TypesSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 917079d8d..1934aa03a 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -220,7 +220,7 @@ instance Arbitrary Html where instance Arbitrary StoredMarkup where arbitrary = oneof [ htmlToStoredMarkup <$> arbitrary - , (plaintextToStoredMarkup :: Text -> StoredMarkup) <$> arbitrary + , plaintextToStoredMarkup . getPrintableString <$> arbitrary ] instance Arbitrary OccurrenceSchedule where From 6185138a39c1d274e4f0392cdad305cebe8500e2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Nov 2020 21:17:00 +0100 Subject: [PATCH 05/22] chore(release): 22.0.0 --- CHANGELOG.md | 11 +++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 14 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 63252d33a..b25b8de72 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,17 @@ 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. +## [22.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.1...v22.0.0) (2020-11-06) + + +### ⚠ BREAKING CHANGES + +* **html-field:** StoredMarkup + +### Bug Fixes + +* **html-field:** introduce stored-markup ([e25e8a2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e25e8a2f4ca65afc29acc8a3884df9acf77d4398)) + ### [21.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.0...v21.1.1) (2020-11-06) diff --git a/package-lock.json b/package-lock.json index 02c7a612b..0edfcdc36 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "21.1.1", + "version": "22.0.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index f3591e5ee..9e4a74a00 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "21.1.1", + "version": "22.0.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 90c13841a..7d992178d 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 21.1.1 +version: 22.0.0 dependencies: - base From 6008cb040dea268e0a096f6c2fafa87f321d115f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 9 Nov 2020 17:07:17 +0100 Subject: [PATCH 06/22] fix(personalised-sheet-files): don't delete files when "keep" --- src/Handler/Sheet/PersonalisedFiles.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index 91da0bcc2..53f3b41f0 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -153,9 +153,10 @@ sinkPersonalisedSheetFiles cid sid keep openSinks <- State.get lift . lift . mapM_ closeResumableSink $ openSinks ^.. folded . folded let (nub -> sinkSheets, nub -> sinkUsers) = unzip $ Map.keys openSinks - lift . lift $ deleteWhere [ PersonalisedSheetFileSheet <-. sinkSheets - , PersonalisedSheetFileUser /<-. sinkUsers - ] + unless keep $ + lift . lift $ deleteWhere [ PersonalisedSheetFileSheet <-. sinkSheets + , PersonalisedSheetFileUser /<-. sinkUsers + ] msgUnreferenced ((), unreferenced) = unless (null collated && null uncollated) $ addMessageModal msgStatus msgTrigger $ Right msgWidget From 5b28303539e28024b43addb413aedc4e5ee0e470 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 10 Nov 2020 17:23:15 +0100 Subject: [PATCH 07/22] feat: partial/conditional downloads & video streaming --- config/settings.yml | 2 +- config/video-types | 31 ++ frontend/src/app.sass | 14 + messages/uniworx/de-de-formal.msg | 6 +- messages/uniworx/en-eu.msg | 4 + package.yaml | 1 + routes | 1 + src/CryptoID.hs | 1 + src/Foundation/Navigation.hs | 1 + src/Foundation/Yesod/Middleware.hs | 10 + src/Handler/Material.hs | 49 ++- src/Handler/Submission/List.hs | 3 +- src/Handler/Utils.hs | 11 +- src/Handler/Utils/Files.hs | 112 ++++++ src/Model/Types/File.hs | 9 +- src/Settings/Mime.hs | 5 +- src/Utils.hs | 10 +- src/Utils/HttpConditional.hs | 375 ++++++++++++++++++++ src/Utils/Icon.hs | 2 + src/Utils/Lang.hs | 2 +- src/Web/ServerSession/Frontend/Yesod/Jwt.hs | 3 +- 21 files changed, 632 insertions(+), 20 deletions(-) create mode 100644 config/video-types create mode 100644 src/Utils/HttpConditional.hs diff --git a/config/settings.yml b/config/settings.yml index 4ded0132e..9c4060e61 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -35,7 +35,7 @@ notification-expiration: 259200 session-timeout: 7200 bearer-expiration: 604800 bearer-encoding: HS256 -maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728" +maximum-content-length: "_env:MAX_UPLOAD_SIZE:805306368" session-files-expire: 3600 prune-unreferenced-files-within: 57600 prune-unreferenced-files-interval: 3600 diff --git a/config/video-types b/config/video-types new file mode 100644 index 000000000..361fd28ef --- /dev/null +++ b/config/video-types @@ -0,0 +1,31 @@ +# Simple list of mime-types corresponding to video-formats +# +# Comments are empty lines and any line for which the first non-whitespace symbol is ‘#’ +# +# Format is a single mime-type per line (may not contain whitespace) +# +# Largely copied from https://en.wikipedia.org/wiki/Video_file_format + +video/webm +video/x-matroska +video/x-flv +video/x-f4v +video/ogg +video/x-mng +video/x-msvideo +model/vnd.mts +video/quicktime +video/x-ms-wmv +application/vnd.rn-realmedia +application/vnd.rn-realmedia-vbr +video/vnd.vivo +video/x-ms-asf +video/mp4 +video/mpeg +video/x-m4v +video/3gpp +video/3gpp2 +application/mxf +video/h261 +video/h263 +video/h264 \ No newline at end of file diff --git a/frontend/src/app.sass b/frontend/src/app.sass index dc26f1b5f..c2da111cb 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1398,3 +1398,17 @@ a.breadcrumbs__home .multi-user-invitation-field__wrapper max-width: 25rem + +video + max-width: 100% + max-height: calc(90vh - var(--current-header-height)) + background: black + +.video-container + display: flex + justify-content: center + width: 100% + + & > video + object-fit: contain + flex-grow: 1 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 5a3b9d136..4a0156841 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -435,7 +435,7 @@ MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist MaterialVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Benutzer verwirren könnte. MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar! MaterialFiles: Dateien -MaterialHeading materialName@MaterialName: Material "#{materialName}" +MaterialHeading materialName@MaterialName: #{materialName} MaterialListHeading: Materialien MaterialNewHeading: Neues Material veröffentlichen MaterialNewTitle: Neues Material @@ -448,6 +448,9 @@ MaterialDelHasFiles count@Int64: inklusive #{count} #{pluralDE count "Datei" "Da MaterialIsVisible: Achtung, dieses Material wurde bereits veröffentlicht. MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht MaterialArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName} +MaterialVideo materialName@MaterialName: #{materialName} - Video +MaterialVideoUnsupported: Ihr Browser scheint keine eingebetten Videos zu unterstützen +MaterialVideoDownload: Herunterladen Unauthorized: Sie haben hierfür keine explizite Berechtigung. @@ -1442,6 +1445,7 @@ BreadcrumbAllocationInfo: Ablauf einer Zentralanmeldung BreadcrumbCourseParticipantInvitation: Einladung zum Kursteilnehmer BreadcrumbMaterialArchive: Archiv BreadcrumbMaterialFile: Datei +BreadcrumbMaterialVideo: Video BreadcrumbSheetArchive: Dateien BreadcrumbSheetIsCorrector: Korrektor-Überprüfung BreadcrumbSheetPseudonym: Pseudonym diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 22c76a2df..17e8672ed 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -446,6 +446,9 @@ MaterialDelHasFiles count: including #{count} #{pluralEN count "file" "files"} MaterialIsVisible: Caution, this course material has already been published. MaterialDeleted materialName: Successfully deleted course material “#{materialName}” MaterialArchiveName tid ssh csh materialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName} +MaterialVideo materialName: #{materialName} - Video +MaterialVideoUnsupported: Your browser does not seem to support embedded video +MaterialVideoDownload: Download Unauthorized: You do not have explicit authorisation. UnauthorizedAnd l r: (#{l} AND #{r}) @@ -1442,6 +1445,7 @@ BreadcrumbAllocationInfo: On central allocations BreadcrumbCourseParticipantInvitation: Invitation to be a course participant BreadcrumbMaterialArchive: Archive BreadcrumbMaterialFile: File +BreadcrumbMaterialVideo: Video BreadcrumbSheetArchive: Files BreadcrumbSheetIsCorrector: Corrector-check BreadcrumbSheetPseudonym: Pseudonym diff --git a/package.yaml b/package.yaml index 7d992178d..be738cbff 100644 --- a/package.yaml +++ b/package.yaml @@ -8,6 +8,7 @@ dependencies: - yesod-auth - yesod-static - yesod-form + - yesod-persistent - classy-prelude - classy-prelude-yesod - bytestring diff --git a/routes b/routes index 7658aa6ce..cc55afab4 100644 --- a/routes +++ b/routes @@ -179,6 +179,7 @@ /show MShowR GET !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor !/download MArchiveR GET !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor !/download/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor + /video/#CryptoUUIDMaterialFile MVideoR GET !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor /tuts CTutorialListR GET !tutor -- THIS route is used to check for overall course tutor access! /tuts/new CTutorialNewR GET POST /tuts/#TutorialName TutorialR: diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 8884fba25..2c6462321 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -73,6 +73,7 @@ decCryptoIDs [ ''SubmissionId , ''CourseEventId , ''TutorialId , ''ExternalExamId + , ''MaterialFileId ] decCryptoIDKeySize diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 99fc523e8..c3313490f 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -291,6 +291,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR + MVideoR _ -> i18nCrumb MsgBreadcrumbMaterialVideo . Just $ CMaterialR tid ssh csh mnm MShowR breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 4c6206205..cf4b98db0 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -155,6 +155,7 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . , verifySubmission , verifyCourseApplication , verifyCourseNews + , verifyMaterialVideo ] where normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX) @@ -253,3 +254,12 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr tell . Any $ route /= newRoute return newRoute + verifyMaterialVideo = maybeOrig $ \route -> do + CMaterialR _tid _ssh _csh _mnm (MVideoR cID) <- return route + mfId <- decrypt cID + MaterialFile{materialFileMaterial} <- lift . lift $ get404 mfId + Material{materialName, materialCourse} <- lift . lift $ get404 materialFileMaterial + Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 materialCourse + let newRoute = CMaterialR courseTerm courseSchool courseShorthand materialName (MVideoR cID) + tell . Any $ route /= newRoute + return newRoute diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 37367fa70..fa6a8db39 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -170,12 +170,33 @@ getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal -- return file entity return matFile +getMVideoR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> CryptoUUIDMaterialFile -> Handler Html +getMVideoR tid ssh csh mnm cID = do + mfId <- decrypt cID + MaterialFile{..} <- runDB $ get404 mfId + let mimeType = mimeLookup $ pack materialFileTitle + mfile = CMaterialR tid ssh csh mnm $ MFileR materialFileTitle + unless (mimeType `Set.member` videoTypes) $ + redirectWith movedPermanently301 mfile + siteLayout' Nothing $ do + setTitleI . prependCourseTitle tid ssh csh $ MsgMaterialVideo mnm + [whamlet| + $newline never +
+
+
+ + ^{iconFileDownload} # + _{MsgMaterialVideoDownload} + |] + + getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMShowR tid ssh csh mnm = do - let matLink :: FilePath -> Route UniWorX - matLink = CourseR tid ssh csh . MaterialR mnm . MFileR - - zipLink :: Route UniWorX + let zipLink :: Route UniWorX zipLink = CMaterialR tid ssh csh mnm MArchiveR seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility @@ -192,11 +213,25 @@ getMShowR tid ssh csh mnm = do { dbtSQLQuery = \matFile -> do E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) E.&&. E.not_ (E.isNothing $ matFile E.^. MaterialFileContent) -- don't show directories - return (matFile E.^. MaterialFileTitle, matFile E.^. MaterialFileModified) + return (matFile E.^. MaterialFileId, matFile E.^. MaterialFileTitle, matFile E.^. MaterialFileModified) , dbtRowKey = (E.^. MaterialFileId) , dbtColonnade = widgetColonnade $ mconcat - [ (<> indicatorCell) <$> colFilePathSimple (view $ _dbrOutput . _1) matLink - , materialModDateCol (view $ _dbrOutput . _2) + [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \DBRow{..} + -> let matLink = CourseR tid ssh csh . MaterialR mnm <$> if + | isVideo + -> MVideoR <$> encrypt (dbrOutput ^. _1 . _Value) + | otherwise -> return $ MFileR fileTitle + wgt = [whamlet| + $newline never + + #{fileTitle} + $if isVideo + \ ^{iconVideo} + |] + isVideo = mimeLookup (pack fileTitle) `Set.member` videoTypes + fileTitle = unpack $ dbrOutput ^. _2 . _Value + in anchorCellM matLink wgt + , materialModDateCol (view $ _dbrOutput . _3) ] , dbtProj = return , dbtStyle = def diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 27dff4edb..61bdc1532 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -472,7 +472,8 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do formResult actionRes $ \case (CorrDownloadData nonAnonymous, subs) -> do ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable - addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|] + MsgRenderer mr <- getMsgRenderer + setContentDisposition' $ Just ((addExtension `on` unpack) (mr MsgSubmissionArchiveName) extensionZip) sendResponse =<< submissionMultiArchive nonAnonymous ids (CorrSetCorrectorData (Just uid), subs') -> do subs <- mapM decrypt $ Set.toList subs' diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index c4ddd7db3..ed54753c0 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -43,12 +43,19 @@ sendThisFile File{..} fileContent' .| Conduit.map toFlushBuilder | otherwise = sendResponseStatus noContent204 () +sendFileReference :: forall file a. HasFileReference file => file -> Handler a +sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do + when (is _Just fileReferenceContent) $ + setContentDisposition' . Just $ takeFileName fileReferenceTitle + let cType = simpleContentType (mimeLookup $ pack fileReferenceTitle) <> "; charset=utf-8" + join . runDB $ respondFileConditional Nothing cType fRef + -- | Serve a single file, identified through a given DB query serveOneFile :: forall file. HasFileReference file => ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent serveOneFile source = do results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below case results of - [file] -> sendThisFile $ sourceFile' file + [file] -> sendFileReference file [] -> notFound _other -> do $logErrorS "SFileR" "Multiple matching files found." @@ -68,7 +75,7 @@ serveSomeFiles' archiveName source = do case results of [] -> notFound - [file] -> sendThisFile $ either sourceFile' id file + [file] -> either sendFileReference sendThisFile file _moreFiles -> do setContentDisposition' $ Just archiveName respondSourceDB typeZip $ do diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index 8d8ca5dd8..91aeb8198 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -4,6 +4,7 @@ module Handler.Utils.Files , SourceFilesException(..) , sourceFileDB, sourceFileMinio , acceptFile + , respondFileConditional ) where import Import @@ -99,6 +100,117 @@ sourceFiles' = C.map sourceFile' sourceFile' :: forall file. HasFileReference file => file -> DBFile sourceFile' = sourceFile . view (_FileReference . _1) +respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) + => Maybe UTCTime -> MimeType + -> FileReference + -> SqlPersistT m (Handler a) +respondFileConditional representationLastModified cType FileReference{..} = do + if + | Just fileContent <- fileReferenceContent + , fileContent == $$(liftTyped $ FileContentReference $$(emptyHash)) + -> return . respondSourceConditional @ByteRangesSpecifier condInfo cType . Left $ (return () :: ConduitT () ByteString _ ()) + | Just fileContent <- fileReferenceContent -> do + dbManifest <- fmap fromNullable . E.select . E.from $ \(fileContentEntry `E.LeftOuterJoin` fileContentChunk) -> do + E.on $ E.just (fileContentEntry E.^. FileContentEntryChunkHash) E.==. fileContentChunk E.?. FileContentChunkId + E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileContent + E.orderBy [E.asc $ fileContentEntry E.^. FileContentEntryIx ] + return ( fileContentChunk E.?. FileContentChunkHash + , E.maybe E.nothing (E.just . E.length_) $ fileContentChunk E.?. FileContentChunkContent + ) + case dbManifest of + Nothing -> do + uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket + let uploadName = minioFileReference # fileContent + statRes <- maybeT (throwM SourceFilesContentUnavailable) . (hoistMaybe <=< runAppMinio) . runMaybeT $ do + catchIfMaybeT minioIsDoesNotExist $ Minio.statObject uploadBucket uploadName Minio.defaultGetObjectOptions + let iLength = fromIntegral $ Minio.oiSize statRes + respondSourceConditional condInfo cType . Right $ \byteRange -> + let byteRange' = case byteRange of + ByteRangeSpecification f Nothing -> ByteRangeFrom (fromIntegral $ min (pred iLength) f) + ByteRangeSpecification f (Just t) -> ByteRangeFromTo (fromIntegral $ min iLength f) (fromIntegral $ min (pred iLength) t) + ByteRangeSuffixSpecification s -> ByteRangeSuffix (fromIntegral $ min iLength s) + respRange = case byteRange of + ByteRangeSpecification f Nothing -> ByteRangeResponseSpecification (min (pred iLength) f) (pred iLength) + ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t) + ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - (min (pred iLength) s)) (pred iLength) + in ( do + chunkVar <- newEmptyTMVarIO + minioAsync <- lift . allocateLinkedAsync $ + maybeT (throwM SourceFilesContentUnavailable) . (hoistMaybe <=< runAppMinio) . runMaybeT $ do + objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions{ Minio.gooRange = Just byteRange' } + lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar) + let go = do + mChunk <- atomically $ Right <$> takeTMVar chunkVar + <|> Left <$> waitCatchSTM minioAsync + case mChunk of + Right chunk -> do + observeSourcedChunk StorageMinio $ olength chunk + yield chunk + go + Left (Right ()) -> return () + Left (Left exc) -> throwM exc + in go + , ByteContentRangeSpecification (Just respRange) (Just iLength) + ) + Just (toNullable -> dbManifest') + | Just dbManifest'' <- forM dbManifest' $ \(E.Value chunkHash, E.Value chunkLength) -> (,) <$> chunkHash <*> chunkLength + -> do + let iLength = sumOf (folded . _2) dbManifest'' + respondSourceDBConditional condInfo cType . Right $ \byteRange -> + let (byteFrom, byteTo) = case byteRange of + ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength) + ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t) + ByteRangeSuffixSpecification s -> (iLength - (min (pred iLength) s), pred iLength) + relevantChunks = view _2 $ foldl' go (0, []) dbManifest'' + where go :: (Natural, [(FileContentChunkReference, Natural, Natural)]) + -> (FileContentChunkReference, Natural) + -> (Natural, [(FileContentChunkReference, Natural, Natural)]) + go (lengthBefore, acc) (cChunk, cLength) + = ( lengthBefore + cLength + , if + | byteFrom < lengthBefore + cLength, byteTo >= lengthBefore + -> let cChunk' = ( cChunk + , bool 0 (byteFrom - lengthBefore) $ byteFrom >= lengthBefore + , bool cLength (cLength - pred (lengthBefore + cLength - byteTo)) $ byteTo < lengthBefore + cLength + ) + in acc ++ pure cChunk' + | otherwise + -> acc + ) + in ( do + dbChunksize <- getsYesod $ views _appFileUploadDBChunksize fromIntegral + forM_ relevantChunks $ \(chunkHash, offset, cLength) + -> let retrieveChunk = \case + Just (start, cLength') | cLength' > 0 -> do + chunk <- E.selectMaybe . E.from $ \fileContentChunk -> do + E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash + return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) + case chunk of + Nothing -> throwM SourceFilesContentUnavailable + Just (E.Value c) -> do + observeSourcedChunk StorageDB $ olength c + return . Just . (c, ) $ if + | fromIntegral (olength c) >= min cLength' dbChunksize + -> Just (start + dbChunksize, cLength' - fromIntegral (olength c)) + | otherwise + -> Nothing + _other -> return Nothing + in C.unfoldM retrieveChunk . Just $ (succ offset, cLength) + , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength) + ) + | otherwise -> throwM SourceFilesContentUnavailable + + | otherwise + -> return $ sendResponseStatus noContent204 () + where + condInfo = RepresentationConditionalInformation + { representationETag = review etagFileReference <$> fileReferenceContent + , representationLastModified + , representationExists = True + , requestedActionAlreadySucceeded = Nothing + } + + acceptFile :: (MonadResource m, MonadResource m') => FileInfo -> m (File m') acceptFile fInfo = do diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index 5da04921b..0e7539825 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -3,7 +3,7 @@ module Model.Types.File , File(..), _fileTitle, _fileContent, _fileModified , PureFile, toPureFile, fromPureFile, pureFileToFileReference, _pureFileContent , transFile - , minioFileReference + , minioFileReference, etagFileReference , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified , HasFileReference(..), IsFileReference(..), FileReferenceResidual(FileReferenceResidual, FileReferenceResidualEither, unFileReferenceResidualEither, FileReferenceResidualEntity, fileReferenceResidualEntityKey, fileReferenceResidualEntityResidual, unPureFileResidual) ) where @@ -53,6 +53,13 @@ minioFileReference :: Prism' Minio.Object FileContentReference minioFileReference = prism' toObjectName fromObjectName where toObjectName = decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert fromObjectName = fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded . encodeUtf8 + +etagFileReference :: Prism' ETag FileContentReference +etagFileReference = prism' toETag fromETag + where toETag = StrongETag . decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert + fromETag = \case + StrongETag t -> fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded $ encodeUtf8 t + _other -> Nothing data File m = File diff --git a/src/Settings/Mime.hs b/src/Settings/Mime.hs index afa03594b..bd5f4290a 100644 --- a/src/Settings/Mime.hs +++ b/src/Settings/Mime.hs @@ -2,7 +2,7 @@ module Settings.Mime ( mimeMap , mimeLookup , mimeExtensions - , archiveTypes + , archiveTypes, videoTypes , module Network.Mime ) where @@ -27,5 +27,6 @@ mimeLookup = mimeByExt mimeMap defaultMimeType mimeExtensions :: MimeType -> Set Extension mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ] -archiveTypes :: Set MimeType +archiveTypes, videoTypes :: Set MimeType archiveTypes = $(mimeSetFile "config/archive-types") +videoTypes = $(mimeSetFile "config/video-types") diff --git a/src/Utils.hs b/src/Utils.hs index 72c1a0a6e..9b6b03e4c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -32,6 +32,7 @@ import Utils.Cookies.Registered as Utils import Utils.Session as Utils import Utils.Csv as Utils import Utils.NTop as Utils +import Utils.HttpConditional as Utils import Text.Blaze (Markup, ToMarkup) @@ -98,6 +99,7 @@ import Data.Binary (Binary) import qualified Data.Binary as Binary import Network.Wai (requestMethod) +import Network.HTTP.Types.Header import Data.Time.Clock @@ -1002,7 +1004,7 @@ setContentDisposition :: MonadHandler m => ContentDisposition -> Maybe FilePath -- ^ Set a @Content-Disposition@-header using `replaceOrAddHeader` -- -- Takes care of correct formatting and encoding of non-ascii filenames -setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader "Content-Disposition" headerVal +setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader (decodeUtf8 $ CI.original hContentDisposition) headerVal where headerVal | Just fName <- mFName @@ -1141,6 +1143,8 @@ cachedHereBinary = do loc <- location [e| \k -> cachedByBinary (loc, k) |] +-- TODO: replace with Utils.HttpConditional + hashToText :: Hashable a => a -> Text hashToText = Text.dropWhileEnd (== '=') . decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash @@ -1153,12 +1157,12 @@ setLastModified lastModified = do rMethod <- requestMethod <$> waiRequest when (rMethod `elem` safeMethods) $ do - ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader "If-Modified-Since" + ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader hIfModifiedSince $logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince) when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince) notModified - addHeader "Last-Modified" $ formatRFC1123 lastModified + addHeader (decodeUtf8 $ CI.original hLastModified) $ formatRFC1123 lastModified where precision :: NominalDiffTime precision = 1 diff --git a/src/Utils/HttpConditional.hs b/src/Utils/HttpConditional.hs new file mode 100644 index 000000000..eb4c2b928 --- /dev/null +++ b/src/Utils/HttpConditional.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE UndecidableInstances #-} + +{-| +Description: Support for partial and conditional http requests (Range, ETag, If-Match, ...) +-} + +module Utils.HttpConditional + ( ByteRangesSpecifier(..), ByteRangeSpecification(..) + , ByteContentRangeSpecification(..), ByteRangeResponseSpecification(..) + , IsRangeUnit(..) + , ETag(..) + , RepresentationConditionalInformation(..) + , mkResponseConditional + , respondSourceConditional, respondSourceDBConditional + ) where + +import ClassyPrelude hiding (Builder) +import Yesod.Core +import Yesod.Persist.Core +import Data.Conduit +import qualified Data.Conduit.Combinators as C +import Data.Binary.Builder (Builder) + +import Web.HttpApiData + +import qualified Data.Attoparsec.Text as A + +import Data.Char (chr, ord) +import Numeric.Natural + +import qualified Data.Set as Set +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import Data.Time + +import Network.HTTP.Types +import Network.HTTP.Types.Header + +import Control.Lens +import Control.Lens.Extras + +import Data.Kind (Type) +import Data.Coerce +import Data.Proxy + +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Fail (MonadFail(..)) +import Control.Monad.Trans.Resource (ResourceT) + +import Network.Wai + +import Control.Monad.Random.Class + +import qualified Data.ByteString.Base64.URL as Base64 +import qualified Data.ByteString as BS + +import Data.List.NonEmpty (NonEmpty(..)) + + +ows :: A.Parser () +ows = A.skipMany $ A.satisfy (`elem` [chr 0x20, chr 0x09]) + +httpList :: A.Parser a -> A.Parser [a] +httpList itemParser = do + let sep = A.many1 $ ows *> A.char ',' <* ows + A.skipMany sep + xs <- itemParser `A.sepBy1` sep + A.skipMany sep + return xs + +parseUrlPiece' :: A.Parser a -> (Text -> Either Text a) +parseUrlPiece' p = first pack . A.parseOnly (p <* A.endOfInput) + + +newtype ByteRangesSpecifier = ByteRangesSpecifier (NonNull (Set ByteRangeSpecification)) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +data ByteRangeSpecification + = ByteRangeSpecification + { byteRangeSpecFirstPosition :: Natural + , byteRangeSpecLastPosition :: Maybe Natural + } + | ByteRangeSuffixSpecification + { byteRangeSpecSuffixLength :: Natural + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance FromHttpApiData ByteRangesSpecifier where + parseUrlPiece = parseUrlPiece' parser + where parser :: A.Parser ByteRangesSpecifier + parser = do + ranges <- httpList brSpecParser + ByteRangesSpecifier <$> maybe (fail "Parser definition error: empty list of ByteRangeSpecifications") return (fromNullable $ Set.fromList ranges) + brSpecParser :: A.Parser ByteRangeSpecification + brSpecParser = brSpecParser' <|> brSuffixParser + where brSpecParser' = do + byteRangeSpecFirstPosition <- A.decimal + void $ A.char '-' + byteRangeSpecLastPosition <- optional A.decimal + return ByteRangeSpecification{..} + brSuffixParser = do + void $ A.char '-' + byteRangeSpecSuffixLength <- A.decimal + return ByteRangeSuffixSpecification{..} + +data ByteContentRangeSpecification + = ByteContentRangeSpecification + { byteRangeResponse :: Maybe ByteRangeResponseSpecification + , byteRangeInstanceLength :: Maybe Natural + } deriving (Eq, Ord, Read, Show, Generic, Typeable) +data ByteRangeResponseSpecification + = ByteRangeResponseSpecification + { byteRangeResponseSpecFirstPosition + , byteRangeResponseSpecLastPosition :: Natural + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance ToHttpApiData ByteContentRangeSpecification where + toUrlPiece ByteContentRangeSpecification{..} = maybe "*" encByteRangeResponse byteRangeResponse <> "/" <> maybe "*" encByteRangeInstanceLength byteRangeInstanceLength + where + encByteRangeInstanceLength = toUrlPiece + encByteRangeResponse ByteRangeResponseSpecification{..} = toUrlPiece byteRangeResponseSpecFirstPosition <> "-" <> toUrlPiece byteRangeResponseSpecLastPosition + + +class (FromHttpApiData req, ToHttpApiData resp, Ord (SingularRangeSpecification req), Show resp) => IsRangeUnit req resp | req -> resp, resp -> req where + type SingularRangeSpecification req :: Type + rangeUnit :: forall p1 p2. p1 req -> p2 resp -> Text + rangeRequestAll :: forall p. p req -> SingularRangeSpecification req + _RangeSpecifications :: Iso' req (NonNull (Set (SingularRangeSpecification req))) + default _RangeSpecifications :: Coercible req (NonNull (Set (SingularRangeSpecification req))) + => Iso' req (NonNull (Set (SingularRangeSpecification req))) + _RangeSpecifications = coerced + rangeInstanceLength :: resp -> Maybe Natural + rangeInstanceLength _ = Nothing + +instance IsRangeUnit ByteRangesSpecifier ByteContentRangeSpecification where + type SingularRangeSpecification ByteRangesSpecifier = ByteRangeSpecification + rangeUnit _ _ = "bytes" + rangeRequestAll _ = ByteRangeSpecification 0 Nothing + rangeInstanceLength = byteRangeInstanceLength + + +data ETag = WeakETag { unETag :: Text } | StrongETag { unETag :: Text } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +parseETag :: A.Parser ETag +parseETag = do + isWeak <- is _Just <$> optional (A.string "W/") + void $ A.char '"' + tag <- pack <$> many (A.satisfy isETagChar) + void $ A.char '"' + return $ bool StrongETag WeakETag isWeak tag + where + isETagChar c = c == '!' + || (0x23 <= ord c && ord c <= 0x7e) + || (0x80 <= ord c && ord c <= 0xff) + +instance FromHttpApiData ETag where + parseUrlPiece = parseUrlPiece' parseETag +instance ToHttpApiData ETag where + toUrlPiece (WeakETag t) = "W/\"" <> t <> "\"" + toUrlPiece (StrongETag t) = "\"" <> t <> "\"" + +strongETagEq, weakETagEq :: ETag -> ETag -> Bool +strongETagEq (StrongETag a) (StrongETag b) = a == b +strongETagEq _ _ = False +weakETagEq = (==) `on` unETag + +data RepresentationConditionalInformation = RepresentationConditionalInformation + { representationETag :: Maybe ETag + , representationLastModified :: Maybe UTCTime + , representationExists :: Bool + , requestedActionAlreadySucceeded :: Maybe Status + } deriving (Eq, Ord, Show, Generic, Typeable) + +newtype ETagMatch = ETagMatch (Set ETag) + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Semigroup, Monoid) + +instance FromHttpApiData ETagMatch where + parseUrlPiece = parseUrlPiece' parseIfMatch + where parseIfMatch :: A.Parser ETagMatch + parseIfMatch = parseEmptyIfMatch <|> parseNonEmptyIfMatch + parseEmptyIfMatch = mempty <* A.char '*' + parseNonEmptyIfMatch = ETagMatch . Set.fromList <$> httpList parseETag + +parseHTTPTime :: A.Parser UTCTime +parseHTTPTime = do + inpT <- A.takeText + maybe (fail "Could not parse time specification") return . parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" $ unpack inpT + +newtype ModifiedMatch = ModifiedMatch UTCTime + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance FromHttpApiData ModifiedMatch where + parseUrlPiece = parseUrlPiece' $ ModifiedMatch <$> parseHTTPTime + +data IfRange = IfRangeETag ETag | IfRangeModified UTCTime + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance FromHttpApiData IfRange where + parseUrlPiece = parseUrlPiece' parseIfRange + where parseIfRange = parseIfRangeETag <|> parseIfRangeModified + parseIfRangeETag = IfRangeETag <$> parseETag + parseIfRangeModified = IfRangeModified <$> parseHTTPTime + +newtype RangeRequest req = RangeRequest { unRangeRequest :: req } + deriving (Generic, Typeable) + deriving newtype (Eq, Ord, Read, Show) + +instance IsRangeUnit req resp => FromHttpApiData (RangeRequest req) where + parseUrlPiece = parseUrlPiece' parseRangeRequest + where parseRangeRequest :: A.Parser (RangeRequest req) + parseRangeRequest = do + void . A.string $ rangeUnit (Proxy @req) (Proxy @resp) + void $ A.char '=' + t <- A.takeText + either (fail . unpack) return . fmap RangeRequest $ parseUrlPiece t + +newtype RangeResponse resp = RangeResponse resp + deriving (Generic, Typeable) + deriving newtype (Eq, Ord, Read, Show) + +instance IsRangeUnit req resp => ToHttpApiData (RangeResponse resp) where + toUrlPiece (RangeResponse r) = rangeUnit (Proxy @req) (Proxy @resp) <> " " <> toUrlPiece r + +newtype MultipartBoundary = MultipartBoundary ByteString + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance ToHttpApiData MultipartBoundary where + toUrlPiece (MultipartBoundary bs) = decodeUtf8 $ Base64.encodeUnpadded bs + +mkResponseConditional :: forall rangeReq rangeResp builder m m'. + ( MonadHandler m, Monad m' + , IsRangeUnit rangeReq rangeResp + , ToFlushBuilder builder + ) + => RepresentationConditionalInformation + -> ContentType + -> Either (ConduitT () builder m' ()) (SingularRangeSpecification rangeReq -> (ConduitT () builder m' (), rangeResp)) + -> m (Status, ContentType, ConduitT () (Flush Builder) m' ()) +-- ^ Implementes https://tools.ietf.org/html/rfc7232#section-6 +-- +-- Assumes we are the origin server +mkResponseConditional RepresentationConditionalInformation{..} cType cont = liftHandler $ do + isSafeMethod <- (`elem` safeMethods) . requestMethod <$> waiRequest + + for_ representationETag $ \etag -> + replaceOrAddHeader (decodeUtf8 $ CI.original hETag) . decodeUtf8 $ toHeader etag + for_ representationLastModified $ \lModified -> + replaceOrAddHeader (decodeUtf8 $ CI.original hLastModified) $ formatRFC1123 lModified + + ifMatch <- lookupHeader' hIfMatch + for_ ifMatch $ \(ETagMatch ps) -> if + | null ps, representationExists -> return () + | Just etag <- representationETag + , any (`strongETagEq` etag) ps -> return () + | Just retCode <- requestedActionAlreadySucceeded -> sendResponseStatus retCode () + | otherwise -> preconditionFailed + + ifUnmodifiedSince <- lookupHeader' hIfUnmodifiedSince + for_ (guard (is _Nothing ifMatch) *> ifUnmodifiedSince) $ \(ModifiedMatch ts) -> if + | Just lModified <- representationLastModified + , lModified < addUTCTime (-precision) ts -> return () + | Just retCode <- requestedActionAlreadySucceeded -> sendResponseStatus retCode () + | otherwise -> preconditionFailed + + ifNoneMatch <- lookupHeader' hIfNoneMatch + for_ ifNoneMatch $ \(ETagMatch ps) -> if + | null ps, representationExists -> bool preconditionFailed notModified isSafeMethod + | Just etag <- representationETag + , any (`weakETagEq` etag) ps -> bool preconditionFailed notModified isSafeMethod + | otherwise -> return () + + ifModifiedSince <- lookupHeader' hIfModifiedSince + for_ (guard (isSafeMethod && is _Nothing ifNoneMatch) *> ifModifiedSince) $ \(ModifiedMatch ts) -> if + | Just lModified <- representationLastModified + , lModified <= addUTCTime precision ts -> notModified + | otherwise -> return () + + case cont of + Left evalNoRanges -> do + replaceOrAddHeader (decodeUtf8 $ CI.original hAcceptRanges) "none" + return (ok200, cType, evalNoRanges .| C.map toFlushBuilder) + Right evalRange -> do + replaceOrAddHeader (decodeUtf8 $ CI.original hAcceptRanges) $ rangeUnit (Proxy @rangeReq) (Proxy @rangeResp) + + mRanges <- do + ifRange <- lookupHeader' hIfRange + range <- lookupHeader' @(RangeRequest rangeReq) hRange + case ifRange of + Just (IfRangeETag p) + | Just etag <- representationETag + , p `strongETagEq` etag -> return range + Just (IfRangeModified ts) + | Just lModified <- representationLastModified + , lModified < addUTCTime (-precision) ts -> return range + Just _ -> return Nothing + Nothing -> return range + + let ranges = maybe (rangeRequestAll (Proxy @rangeReq) :| []) (toNonEmpty . view _RangeSpecifications . unRangeRequest) mRanges + + when (length ranges > 5) $ do + invalidArgs ["Too many ranges"] + + case ranges of + r :| [] -> do + let (respSrc, rResp) = evalRange r + when (is _Just mRanges) $ + replaceOrAddHeader (decodeUtf8 $ CI.original hContentRange) . decodeUtf8 . toHeader $ RangeResponse rResp + return (bool partialContent206 ok200 $ r == rangeRequestAll (Proxy @rangeReq), cType, respSrc .| C.map toFlushBuilder) + (toList -> rs) -> do + boundary <- liftIO $ MultipartBoundary . BS.pack <$> replicateM 12 getRandom + let cType' = "multipart/byteranges; boundary=" <> toHeader boundary + bodySrc = do + forM_ rs $ \r -> do + let (respSrc, rResp) = evalRange r + sendChunkBS $ "--" <> toHeader boundary <> "\r\n" + sendChunkBS $ CI.original hContentType <> ": " <> cType <> "\r\n" + sendChunkBS $ CI.original hContentRange <> ": " <> toHeader (RangeResponse rResp) <> "\r\n" + sendChunkBS "\r\n" + respSrc .| C.map toFlushBuilder + sendChunkBS "\r\n" + sendFlush + sendChunkBS $ "--" <> toHeader boundary <> "--\r\n" + return (partialContent206, cType', bodySrc) + + where + lookupHeader' :: forall hdr n. (MonadHandler n, FromHttpApiData hdr) => CI ByteString -> n (Maybe hdr) + lookupHeader' hdrName = liftHandler . runMaybeT $ do + hdrBS <- MaybeT $ lookupHeader hdrName + case parseHeader hdrBS of + Left errMsg -> do + $logInfoS "lookupHeader'" $ "Could not parse value for request header “" <> decodeUtf8 (CI.original hdrName) <> "”, “" <> tshow hdrBS <> "”: " <> errMsg + mzero + Right val -> return val + + precision :: NominalDiffTime + precision = 1 + + safeMethods = [ methodGet, methodHead, methodOptions ] + + preconditionFailed = sendResponseStatus preconditionFailed412 () + +respondSourceConditional :: forall rangeReq rangeResp builder m a. + ( MonadHandler m + , IsRangeUnit rangeReq rangeResp + , ToFlushBuilder builder + ) + => RepresentationConditionalInformation + -> ContentType + -> Either (ConduitT () builder (HandlerFor (HandlerSite m)) ()) (SingularRangeSpecification rangeReq -> (ConduitT () builder (HandlerFor (HandlerSite m)) (), rangeResp)) + -> m a +respondSourceConditional cInfo cType cont = liftHandler $ do + (rStatus, cType', cont') <- mkResponseConditional cInfo cType cont + UnliftIO{..} <- askUnliftIO + sendResponseStatus rStatus ( cType' + , toContent $ + transPipe (lift @ResourceT . unliftIO) cont' + ) + +respondSourceDBConditional :: forall rangeReq rangeResp builder m a. + ( MonadHandler m, YesodPersistRunner (HandlerSite m) + , IsRangeUnit rangeReq rangeResp + , ToFlushBuilder builder + ) + => RepresentationConditionalInformation + -> ContentType + -> Either (ConduitT () builder (YesodDB (HandlerSite m)) ()) (SingularRangeSpecification rangeReq -> (ConduitT () builder (YesodDB (HandlerSite m)) (), rangeResp)) + -> m a +respondSourceDBConditional cInfo cType cont = liftHandler $ do + (rStatus, cType', cont') <- mkResponseConditional cInfo cType cont + UnliftIO{..} <- askUnliftIO + sendResponseStatus rStatus ( cType' + , toContent . transPipe (lift @ResourceT . unliftIO) $ runDBSource cont' + ) diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 75d228abf..c77fb8c47 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -90,6 +90,7 @@ data Icon | IconAllocationRegister | IconAllocationRegistrationEdit | IconAllocationApplicationEdit | IconPersonalIdentification + | IconVideo deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) iconText :: Icon -> Text @@ -160,6 +161,7 @@ iconText = \case IconAllocationRegistrationEdit -> "pencil-alt" IconAllocationApplicationEdit -> "pencil-alt" IconPersonalIdentification -> "id-card" + IconVideo -> "video" instance Universe Icon instance Finite Icon diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs index 7b1f069b5..09a076fdb 100644 --- a/src/Utils/Lang.hs +++ b/src/Utils/Lang.hs @@ -63,7 +63,7 @@ highPrioRequestedLangs = fmap (concatMap $ fromMaybe []) . mapM runMaybeT $ , lookupRegisteredCookies pure CookieLang , fmap pure . MaybeT $ lookupSessionKey SessionLang ] -lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader "Accept-Language" +lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader hAcceptLanguage languagesMiddleware :: forall site a. NonEmpty Lang -> HandlerFor site a -> HandlerFor site a languagesMiddleware avL act = do diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs index 341fb2291..27aa2bc13 100644 --- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs +++ b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs @@ -92,7 +92,8 @@ findSession :: State sto -> Maybe Jwt findSession state req = do [raw] <- return $ do - ("Cookie", header) <- Wai.requestHeaders req + (hdrName, header) <- Wai.requestHeaders req + guard $ hdrName == hCookie (k, v) <- parseCookies header guard $ k == encodeUtf8 (getCookieName state) return v From 8d49e66eedf059795b58d4668e3730a01a6c91ff Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 10 Nov 2020 17:36:52 +0100 Subject: [PATCH 08/22] style: use full course name in exam office notifications --- messages/uniworx/de-de-formal.msg | 4 ++-- messages/uniworx/en-eu.msg | 4 ++-- src/Jobs/Handler/SendNotification/ExamOffice.hs | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 4a0156841..6f54a2e5e 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1017,10 +1017,10 @@ MailCourseRegisteredIntroOther displayName@Text courseName@Text termDesc@Text: # MailSubjectExamResult csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden herausgegeben MailExamResultIntro courseName@Text termDesc@Text examn@ExamName: Sie können nun Ihr Ergebnis für #{examn} im Kurs #{courseName} (#{termDesc}) einsehen. -MailSubjectExamOfficeExamResults csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} sind fertiggestellt +MailSubjectExamOfficeExamResults coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} sind fertiggestellt MailExamOfficeExamResultsIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter hat die Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) freigegeben. -MailSubjectExamOfficeExamResultsChanged csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden verändert +MailSubjectExamOfficeExamResultsChanged coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} wurden verändert MailExamOfficeExamResultsChangedIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter hat Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) verändert. MailSubjectExamOfficeExternalExamResults coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 17e8672ed..75b828737 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1017,10 +1017,10 @@ MailCourseRegisteredIntroOther displayName courseName termDesc: #{displayName} w MailSubjectExamResult csh examn: Results for #{examn} in #{csh} are now available MailExamResultIntro courseName termDesc examn: You may now view your result for #{examn} of the course #{courseName} (#{termDesc}). -MailSubjectExamOfficeExamResults csh examn: Results for #{examn} of #{csh} are now available +MailSubjectExamOfficeExamResults coursen examn: Results for #{examn} of #{coursen} are now available MailExamOfficeExamResultsIntro courseName termDesc examn: A course administrator has made the results for #{examn} of the course #{courseName} (#{termDesc}) available. -MailSubjectExamOfficeExamResultsChanged csh examn: Results for #{examn} of #{csh} were changed +MailSubjectExamOfficeExamResultsChanged coursen examn: Results for #{examn} of #{coursen} were changed MailExamOfficeExamResultsChangedIntro courseName termDesc examn: A course administrator has changed exam results for #{examn} of the course #{courseName} (#{termDesc}). MailSubjectExamOfficeExternalExamResults coursen@CourseName examn@ExamName: Results for #{examn} in #{coursen} diff --git a/src/Jobs/Handler/SendNotification/ExamOffice.hs b/src/Jobs/Handler/SendNotification/ExamOffice.hs index c7a6d1c37..62992478a 100644 --- a/src/Jobs/Handler/SendNotification/ExamOffice.hs +++ b/src/Jobs/Handler/SendNotification/ExamOffice.hs @@ -24,7 +24,7 @@ dispatchNotificationExamOfficeExamResults nExam jRecipient = userMailT jRecipien course <- belongsToJust examCourse exam return (course, exam) replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectExamOfficeExamResults courseShorthand examName + setSubjectI $ MsgMailSubjectExamOfficeExamResults courseName examName MsgRenderer mr <- getMailMsgRenderer let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm @@ -48,7 +48,7 @@ dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient = do course <- belongsToJust examCourse exam return (course, exam) replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectExamOfficeExamResultsChanged courseShorthand examName + setSubjectI $ MsgMailSubjectExamOfficeExamResultsChanged courseName examName MsgRenderer mr <- getMailMsgRenderer let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm From 80960f42c578c201f78e226653431e9dd965cfce Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 10 Nov 2020 19:33:11 +0100 Subject: [PATCH 09/22] fix: translation --- messages/uniworx/en-eu.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 75b828737..a9c9159a5 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -433,7 +433,7 @@ MaterialVisibleFromTip: Never visible to participants if left empty; leaving the MaterialVisibleFromEditWarning: This course material has already been published and should not be edited. Doing so might confuse the participants. MaterialInvisible: This course material is currently invisible to participants! MaterialFiles: Files -MaterialHeading materialName: Course material “#{materialName}” +MaterialHeading materialName: #{materialName} MaterialListHeading: Course materials MaterialNewHeading: Publish new course material MaterialNewTitle: New course material From 4ea54d8b821f274c49dbeb25eb7021ffa965b2e6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 10 Nov 2020 19:46:22 +0100 Subject: [PATCH 10/22] refactor: hlint --- src/Handler/Utils/Files.hs | 4 ++-- src/Utils/HttpConditional.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index 91aeb8198..c058a3ffa 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -132,7 +132,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do respRange = case byteRange of ByteRangeSpecification f Nothing -> ByteRangeResponseSpecification (min (pred iLength) f) (pred iLength) ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t) - ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - (min (pred iLength) s)) (pred iLength) + ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength) in ( do chunkVar <- newEmptyTMVarIO minioAsync <- lift . allocateLinkedAsync $ @@ -160,7 +160,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do let (byteFrom, byteTo) = case byteRange of ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength) ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t) - ByteRangeSuffixSpecification s -> (iLength - (min (pred iLength) s), pred iLength) + ByteRangeSuffixSpecification s -> (iLength - min (pred iLength) s, pred iLength) relevantChunks = view _2 $ foldl' go (0, []) dbManifest'' where go :: (Natural, [(FileContentChunkReference, Natural, Natural)]) -> (FileContentChunkReference, Natural) diff --git a/src/Utils/HttpConditional.hs b/src/Utils/HttpConditional.hs index eb4c2b928..e295dbbe1 100644 --- a/src/Utils/HttpConditional.hs +++ b/src/Utils/HttpConditional.hs @@ -214,7 +214,7 @@ instance IsRangeUnit req resp => FromHttpApiData (RangeRequest req) where void . A.string $ rangeUnit (Proxy @req) (Proxy @resp) void $ A.char '=' t <- A.takeText - either (fail . unpack) return . fmap RangeRequest $ parseUrlPiece t + either (fail . unpack) (return . RangeRequest) $ parseUrlPiece t newtype RangeResponse resp = RangeResponse resp deriving (Generic, Typeable) From 779abecfbd4710d619e3924688a247abbb3b806d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 10 Nov 2020 19:47:07 +0100 Subject: [PATCH 11/22] chore(release): 22.1.0 --- CHANGELOG.md | 13 +++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 16 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b25b8de72..c4a0f40ff 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,19 @@ 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. +## [22.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v22.0.0...v22.1.0) (2020-11-10) + + +### Features + +* partial/conditional downloads & video streaming ([5b28303](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b28303539e28024b43addb413aedc4e5ee0e470)) + + +### Bug Fixes + +* translation ([80960f4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/80960f42c578c201f78e226653431e9dd965cfce)) +* **personalised-sheet-files:** don't delete files when "keep" ([6008cb0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6008cb040dea268e0a096f6c2fafa87f321d115f)) + ## [22.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.1...v22.0.0) (2020-11-06) diff --git a/package-lock.json b/package-lock.json index 0edfcdc36..36b02a12e 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "22.0.0", + "version": "22.1.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 9e4a74a00..8ae5fcf63 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "22.0.0", + "version": "22.1.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index be738cbff..72ffbece2 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 22.0.0 +version: 22.1.0 dependencies: - base From eb3495acff006f93415abebff3ef70436e35814e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 11 Nov 2020 10:12:51 +0100 Subject: [PATCH 12/22] chore(changelog): materials-video-streaming --- .../changelog/materials-video-streaming.de-de-formal.hamlet | 2 ++ templates/i18n/changelog/materials-video-streaming.en-eu.hamlet | 2 ++ 2 files changed, 4 insertions(+) create mode 100644 templates/i18n/changelog/materials-video-streaming.de-de-formal.hamlet create mode 100644 templates/i18n/changelog/materials-video-streaming.en-eu.hamlet diff --git a/templates/i18n/changelog/materials-video-streaming.de-de-formal.hamlet b/templates/i18n/changelog/materials-video-streaming.de-de-formal.hamlet new file mode 100644 index 000000000..6d6428fe1 --- /dev/null +++ b/templates/i18n/changelog/materials-video-streaming.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Als Kursmaterial hochgeladene Videos können jetzt direkt in Uni2work gestreamt, statt nur komplett heruntergeladen, werden. diff --git a/templates/i18n/changelog/materials-video-streaming.en-eu.hamlet b/templates/i18n/changelog/materials-video-streaming.en-eu.hamlet new file mode 100644 index 000000000..c1a63cbef --- /dev/null +++ b/templates/i18n/changelog/materials-video-streaming.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Videos uploaded as course material can now be streamed directly in Uni2work. Previously they could only be downloaded completely. From 34cd393e615d36b2d7ecb221618a55c276f00e70 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 14 Nov 2020 12:29:07 +0100 Subject: [PATCH 13/22] style(file-input): improve file-input__list --- frontend/src/utils/inputs/inputs.sass | 7 +++- templates/widgets/genericFileField.hamlet | 41 ++++++++++++----------- 2 files changed, 27 insertions(+), 21 deletions(-) diff --git a/frontend/src/utils/inputs/inputs.sass b/frontend/src/utils/inputs/inputs.sass index 022efa71d..c40e74d6e 100644 --- a/frontend/src/utils/inputs/inputs.sass +++ b/frontend/src/utils/inputs/inputs.sass @@ -225,11 +225,15 @@ option margin: 10px 0 color: var(--color-fontsec) +.file-input__list-wrapper + overflow: auto + max-height: 75vh + max-width: 30vw + .file-input__list margin-left: 40px margin-top: 10px font-weight: 600 - max-width: 25vw tr:last-child td padding-bottom: 0 @@ -237,6 +241,7 @@ option .file-input__list-item font-family: var(--font-monospace) font-size: 15px + word-break: break-all // PREVIOUSLY UPLOADED FILES diff --git a/templates/widgets/genericFileField.hamlet b/templates/widgets/genericFileField.hamlet index 4b3f853b8..5736ea80a 100644 --- a/templates/widgets/genericFileField.hamlet +++ b/templates/widgets/genericFileField.hamlet @@ -4,27 +4,28 @@ $maybe ident <- identSecret $if not (null fileInfos) - - - - - - - - +
+
- - _{MsgPreviouslyUploadedInfo} - $forall FileUploadInfo{..} <- fileInfos -
+ + + + + - + $forall FileUploadInfo{..} <- fileInfos + + - $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}) <- events + $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}, showRoom) <- events toPathPiece cID}> - $forall (occurrence, registered, rCount) <- occurrences + $forall (occurrence, registered, rCount, showRoom) <- occurrences $with Entity _occId ExamOccurrence{examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription} <- occurrence $with registerWdgt <- registerWidget (Just occurrence) $if occurrenceNamesShown
- - - $if fuiSession - ^{messageTooltip uploadOnlySessionMessage} - - + + _{MsgPreviouslyUploadedInfo} +
+ + + $if fuiSession + ^{messageTooltip uploadOnlySessionMessage} + +
@@ -291,8 +291,15 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
^{occurrencesWidget courseEventTime}
-
- #{courseEventRoom} + $if showRoom +
+ $maybe room <- courseEventRoom + ^{roomReferenceWidget room} + $nothing + _{MsgCourseEventRoomIsUnset} + $else +
+ _{MsgCourseEventRoomIsHidden}
#{courseEventNote} diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 8438a1835..4c99a4a83 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -81,7 +81,7 @@ $maybe desc <- examDescription ^{notificationPersonalIdentification} $maybe room <- examRoom
_{MsgExamRoom} -
#{room} +
^{roomReferenceWidget room} $if examTimes
_{MsgExamTime}
@@ -204,14 +204,22 @@ $if not (null occurrences) \ ^{isVisible False}
_{MsgExamRoomDescription}
#{examOccurrenceName} $if is _Nothing examRoom - #{examOccurrenceRoom} + $if showRoom + + $maybe room <- examOccurrenceRoom + ^{roomReferenceWidget room} + $nothing + _{MsgExamOccurrenceRoomIsUnset} + $else + + _{MsgExamOccurrenceRoomIsHidden} $if not examTimes ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd} diff --git a/templates/widgets/aform/aform.hamlet b/templates/widgets/aform/aform.hamlet index ad026d02c..cffc289a0 100644 --- a/templates/widgets/aform/aform.hamlet +++ b/templates/widgets/aform/aform.hamlet @@ -9,16 +9,16 @@ $case formLayout $of _ $forall view <- fieldViews $if fvId view == idFormSectionNoinput -

+

^{fvLabel view} $maybe hint <- fvTooltip view -
+
^{hint} $elseif fvId view == idFormMessageNoinput -
+
^{fvInput view} $else -
+
$if not (Blaze.null $ fvLabel view)

- #{examOccurrenceRoom} + $maybe room <- examOccurrenceRoom + ^{roomReferenceWidget room} + $nothing + _{MsgExamOccurrenceRoomIsUnset} ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd} diff --git a/templates/widgets/massinput/examRooms/form.hamlet b/templates/widgets/massinput/examRooms/form.hamlet index 363566059..bddd282aa 100644 --- a/templates/widgets/massinput/examRooms/form.hamlet +++ b/templates/widgets/massinput/examRooms/form.hamlet @@ -1,7 +1,7 @@ $newline never -#{csrf}^{fvInput eofIdView}^{fvWidget eofNameView} -^{fvWidget eofRoomView} -^{fvWidget eofCapacityView} -^{fvWidget eofStartView} -^{fvWidget eofEndView} -^{fvWidget eofDescView} +#{csrf}^{fvInput eofIdView}^{fvWidget eofNameView} +^{eofRoomView} +^{fvWidget eofCapacityView} +^{fvWidget eofStartView} +^{fvWidget eofEndView} +^{fvWidget eofDescView} diff --git a/templates/widgets/massinput/examRooms/layout.hamlet b/templates/widgets/massinput/examRooms/layout.hamlet index bb7cbf94e..54e97b2a8 100644 --- a/templates/widgets/massinput/examRooms/layout.hamlet +++ b/templates/widgets/massinput/examRooms/layout.hamlet @@ -6,8 +6,7 @@ $newline never _{MsgExamRoomName} # - _{MsgExamRoom} # - + _{MsgExamRoom} _{MsgExamRoomCapacity} # diff --git a/templates/widgets/room-reference/link-instructions-modal.hamlet b/templates/widgets/room-reference/link-instructions-modal.hamlet new file mode 100644 index 000000000..1fd7aae88 --- /dev/null +++ b/templates/widgets/room-reference/link-instructions-modal.hamlet @@ -0,0 +1,11 @@ +$newline never +
+
+ _{MsgRoomReferenceLinkLink} +
+ + #{linkText} +
+ _{MsgRoomReferenceLinkInstructions} +
+ #{roomRefInstructions} diff --git a/templates/widgets/room-reference/link.hamlet b/templates/widgets/room-reference/link.hamlet new file mode 100644 index 000000000..1eb2da00f --- /dev/null +++ b/templates/widgets/room-reference/link.hamlet @@ -0,0 +1,5 @@ +$newline never + + _{MsgRoomReferenceLinkLink} +$if is _Just roomRefInstructions + , ^{instrModal} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index ec51b7952..b41ebc09e 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -909,6 +909,7 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = Just "Hilbert-Raum" + , tutorialRoomHidden = True , tutorialTime = Occurrences { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) , occurrencesExceptions = Set.empty @@ -928,6 +929,7 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = Just "Hilbert-Raum" + , tutorialRoomHidden = True , tutorialTime = Occurrences { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) , occurrencesExceptions = Set.empty diff --git a/test/Handler/Exam/FormSpec.hs b/test/Handler/Exam/FormSpec.hs index d49dbac6c..100f16aa2 100644 --- a/test/Handler/Exam/FormSpec.hs +++ b/test/Handler/Exam/FormSpec.hs @@ -16,6 +16,7 @@ instance Arbitrary ExamOccurrenceForm where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary instance Arbitrary ExamPartForm where arbitrary = ExamPartForm @@ -30,6 +31,6 @@ spec :: Spec spec = do parallel $ do lawsCheckHspec (Proxy @ExamOccurrenceForm) - [ eqLaws, ordLaws, showReadLaws ] + [ eqLaws, ordLaws ] lawsCheckHspec (Proxy @ExamPartForm) [ eqLaws, ordLaws ] diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 5c2113656..21c63893d 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -39,6 +39,8 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.CaseInsensitive as CI +import qualified Data.Text.Lazy as LT + instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable @@ -218,7 +220,7 @@ instance Arbitrary Html where shrink = map preEscapedToHtml . shrink . renderHtml instance Arbitrary StoredMarkup where - arbitrary = oneof + arbitrary = (`suchThat` (not . null . LT.strip . renderHtml . markupOutput)) $ oneof [ htmlToStoredMarkup <$> arbitrary , plaintextToStoredMarkup . getPrintableString <$> arbitrary ] @@ -305,6 +307,17 @@ instance Arbitrary ExamCloseMode where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary RoomReference where + arbitrary = oneof + [ RoomReferenceSimple . pack <$> suchThat (getPrintableString <$> arbitrary) (not . null) + , RoomReferenceLink + <$> arbitrary + <*> arbitrary + ] + +instance Arbitrary RoomReference' where + arbitrary = genericArbitrary + spec :: Spec spec = do @@ -403,6 +416,10 @@ spec = do [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws, csvFieldLaws ] lawsCheckHspec (Proxy @ExamCloseMode) [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, pathPieceLaws, jsonKeyLaws, finiteLaws, httpApiDataLaws, binaryLaws ] + lawsCheckHspec (Proxy @RoomReference) + [ persistFieldLaws, jsonLaws, eqLaws, ordLaws ] + lawsCheckHspec (Proxy @RoomReference') + [ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index b4e9c911b..dce83ba01 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -84,7 +84,8 @@ instance Arbitrary Tutorial where <*> arbitrary <*> (CI.mk . pack . getPrintableString <$> arbitrary) <*> (fmap getPositive <$> arbitrary) - <*> (assertM' (not . null) . pack . getPrintableString <$> arbitrary) + <*> arbitrary + <*> arbitrary <*> arbitrary <*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary) <*> arbitrary diff --git a/test/TestImport.hs b/test/TestImport.hs index 7896ac296..27212218f 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -42,6 +42,7 @@ import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn) import Jobs (handleJobs) import Numeric.Natural as X +import Network.URI.Arbitrary as X () import Control.Lens as X hiding ((<.), elements) From 771532c666a51833a62d934993985aa2f9aca098 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 20 Nov 2020 11:31:10 +0100 Subject: [PATCH 21/22] style(exams): larger occurrence description fields --- src/Handler/Exam/Form.hs | 2 +- templates/widgets/massinput/examRooms/add.hamlet | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index ffa654531..b179a9a43 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -231,7 +231,7 @@ examOccurrenceForm prev = wFormToAForm $ do (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) (fslI MsgExamRoomCapacity & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField (fslI MsgExamRoomStart & addName (nudge "start")) (eofStart <$> mPrev) (eofEndRes, eofEndView) <- mopt utcTimeField (fslI MsgExamRoomEnd & addName (nudge "end")) (eofEnd <$> mPrev) - (eofDescRes, eofDescView) <- mopt htmlFieldSmall (fslI MsgExamRoomDescription & addName (nudge "description")) (eofDescription <$> mPrev) + (eofDescRes, eofDescView) <- mopt htmlField (fslI MsgExamRoomDescription & addName (nudge "description")) (eofDescription <$> mPrev) return ( ExamOccurrenceForm <$> eofIdRes diff --git a/templates/widgets/massinput/examRooms/add.hamlet b/templates/widgets/massinput/examRooms/add.hamlet index 31c175949..e48c07407 100644 --- a/templates/widgets/massinput/examRooms/add.hamlet +++ b/templates/widgets/massinput/examRooms/add.hamlet @@ -1,4 +1,4 @@ $newline never ^{formWidget} -
 + ^{fvWidget submitView} From 44da2714b3587b8e6eb8138585627ddac7eecb39 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 24 Nov 2020 10:27:59 +0100 Subject: [PATCH 22/22] chore: typo --- messages/uniworx/de-de-formal.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 086d37695..f78a63be9 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1701,7 +1701,7 @@ TutorialRoomIsHidden: Raum wird nur Teilnehmern angezeigt TutorialTime: Zeit TutorialRegistered: Angemeldet TutorialRegGroup: Registrierungs-Gruppe -TutorialRegisterFrom: Anmeldungen a +TutorialRegisterFrom: Anmeldungen ab TutorialRegisterTo: Anmeldungen bis TutorialDeregisterUntil: Abmeldungen bis TutorialsHeading: Tutorien