feat: partial/conditional downloads & video streaming

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

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 

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

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

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

package.yaml

@@ -8,6 +8,7 @@ dependencies:
   - yesod-auth
   - yesod-static
   - yesod-form
+  - yesod-persistent
   - classy-prelude
   - classy-prelude-yesod
   - bytestring

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:

src/CryptoID.hs

@@ -73,6 +73,7 @@ decCryptoIDs [ ''SubmissionId
              , ''CourseEventId
              , ''TutorialId
              , ''ExternalExamId
+             , ''MaterialFileId
              ]
 
 decCryptoIDKeySize

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
 

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

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
+      <section>
+        <div .video-container>
+          <video controls autoplay preload=auto>
+            <source src=@{mfile} type=#{decodeUtf8 mimeType}>
+            _{MsgMaterialVideoUnsupported}
+      <section>
+        <a .btn href=@{mfile} download target=_blank>
+          ^{iconFileDownload} #
+          _{MsgMaterialVideoDownload}
+    |]
+    
+
 getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
 getMShowR tid ssh csh mnm = do
-  let matLink :: FilePath -> Route UniWorX
+  let zipLink :: Route UniWorX
-      matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
-
-      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
+            [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \DBRow{..}
-            , materialModDateCol  (view $ _dbrOutput . _2)
+                -> let matLink = CourseR tid ssh csh . MaterialR mnm <$> if
+                         | isVideo
+                           -> MVideoR <$> encrypt (dbrOutput ^. _1 . _Value)
+                         | otherwise -> return $ MFileR fileTitle
+                       wgt = [whamlet|
+                               $newline never
+                               <span .file-path>
+                                 #{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

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'

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

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

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

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")

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

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'
+                             )

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

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

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