From 5b28303539e28024b43addb413aedc4e5ee0e470 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 10 Nov 2020 17:23:15 +0100 Subject: [PATCH] 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 +
+
+