277 lines
12 KiB
Haskell
277 lines
12 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Utils.Download
|
|
( sendThisFile
|
|
, sendByteStringAsFile
|
|
, sendFileReference
|
|
, serveOneFile
|
|
, serveSomeFiles
|
|
, serveSomeFiles'
|
|
, serveZipArchive
|
|
, serveZipArchive'
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Foundation.Type
|
|
import Foundation.Authorization
|
|
|
|
import qualified Data.HashSet as HashSet
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import Handler.Utils.Zip
|
|
import Handler.Utils.ContentDisposition
|
|
import Handler.Utils.Files
|
|
|
|
import qualified Network.Wai as W
|
|
|
|
|
|
data DownloadTokenRestriction
|
|
= DownloadRestrictSingle { downloadRestrictReference :: FileContentReference }
|
|
| DownloadRestrictMultiple
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece' 2
|
|
, fieldLabelModifier = camelToPathPiece' 2
|
|
} ''DownloadTokenRestriction
|
|
|
|
withFileDownloadTokenMaybe' :: forall url m.
|
|
( HasRoute UniWorX url
|
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
|
, MonadSite UniWorX m
|
|
, MonadCrypto m
|
|
, MonadCryptoKey m ~ CryptoIDKey
|
|
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
|
)
|
|
=> Maybe (ConduitT () (Either FileReference DBFile) m ())
|
|
-> url
|
|
-> m (SomeRoute UniWorX)
|
|
withFileDownloadTokenMaybe' mSource route = maybeT (return $ SomeRoute route) $ do
|
|
let rApproot = authoritiveApproot $ urlRoute route
|
|
case rApproot of
|
|
ApprootDefault -> mzero
|
|
_other -> return ()
|
|
guardM . getsYesod $ \app -> views _appRoot (is _Just . ($ rApproot)) app
|
|
&& views _appRoot ($ ApprootDefault) app /= views _appRoot ($ rApproot) app
|
|
|
|
uid <- MaybeT maybeAuthId
|
|
now <- liftIO getCurrentTime
|
|
expireOffset <- getsYesod $ view _appDownloadTokenExpire
|
|
restr <- case mSource of
|
|
Just source -> do
|
|
results <- lift . runConduit $ source .| C.take 2 .| C.foldMap (pure . either Just (const Nothing))
|
|
return $ case results of
|
|
[Just FileReference{ fileReferenceContent = Just ref }] -> DownloadRestrictSingle ref
|
|
_other -> DownloadRestrictMultiple
|
|
Nothing -> return DownloadRestrictMultiple
|
|
bearer <- lift $ bearerRestrict (urlRoute route) restr <$> bearerToken
|
|
(HashSet.singleton $ Right uid)
|
|
(Just uid)
|
|
(HashMap.singleton BearerTokenRouteAccess . HashSet.singleton $ urlRoute route)
|
|
Nothing
|
|
(Just . Just $ addUTCTime expireOffset now)
|
|
Nothing
|
|
encodedBearer <- lift $ encodeBearer bearer
|
|
|
|
lift . setDownload $ SomeRoute @UniWorX route
|
|
& over (urlRouteParams $ Proxy @UniWorX) (((toPathPiece GetBearer, toPathPiece encodedBearer) :) . filter (views _1 (maybe False (/= GetBearer) . fromPathPiece)))
|
|
|
|
where
|
|
setDownload :: SomeRoute UniWorX -> m (SomeRoute UniWorX)
|
|
setDownload route' = do
|
|
wantsDownload <- downloadFiles
|
|
defWantsDownload <- getsYesod $ views _appUserDefaults userDefaultDownloadFiles
|
|
let
|
|
addDownload params
|
|
| anyOf (folded . _1) (== toPathPiece GetDownload) params = params
|
|
| otherwise = (toPathPiece GetDownload, toPathPiece wantsDownload) : params
|
|
return $ route'
|
|
& over (urlRouteParams $ Proxy @UniWorX) (bool id addDownload $ wantsDownload /= defWantsDownload)
|
|
|
|
-- withFileDownloadToken' :: forall file url m.
|
|
-- ( HasFileReference file
|
|
-- , HasRoute UniWorX url
|
|
-- , MonadHandler m, HandlerSite m ~ UniWorX
|
|
-- , MonadCrypto m
|
|
-- , MonadCryptoKey m ~ CryptoIDKey
|
|
-- , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
|
-- )
|
|
-- => ConduitT () (Either file DBFile) m ()
|
|
-- -> url
|
|
-- -> m (SomeRoute UniWorX)
|
|
-- withFileDownloadToken' = withFileDownloadTokenMaybe' . Just . (.| C.map (first . view $ _FileReference . _1))
|
|
|
|
|
|
-- withFileDownloadToken :: forall file url m.
|
|
-- ( HasFileReference file
|
|
-- , HasRoute UniWorX url
|
|
-- , MonadHandler m, HandlerSite m ~ UniWorX
|
|
-- , MonadCrypto m
|
|
-- , MonadCryptoKey m ~ CryptoIDKey
|
|
-- , BearerAuthSite UniWorX
|
|
-- )
|
|
-- => ConduitT () file m ()
|
|
-- -> url
|
|
-- -> m (SomeRoute UniWorX)
|
|
-- withFileDownloadToken = withFileDownloadToken' . (.| C.map Left)
|
|
|
|
ensureApprootUserGeneratedMaybe'
|
|
:: forall m.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, MonadSite UniWorX m
|
|
, MonadCrypto m
|
|
, MonadCryptoKey m ~ CryptoIDKey
|
|
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
|
)
|
|
=> Maybe (ConduitT () (Either FileReference DBFile) m ())
|
|
-> m ()
|
|
ensureApprootUserGeneratedMaybe' source = maybeT_ $ do
|
|
route <- (,) <$> MaybeT getCurrentRoute <*> fmap reqGetParams getRequest
|
|
$logDebugS "ensureApproot" $ tshow route
|
|
rApproot <- hoistMaybe <=< lift . runMaybeT $ do
|
|
reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
|
|
let rApproot = authoritiveApproot $ urlRoute route
|
|
guard $ rApproot == ApprootUserGenerated
|
|
approotHost <- MaybeT . getsYesod $ approotScopeHost rApproot
|
|
guard $ approotHost /= reqHost
|
|
return rApproot
|
|
$logDebugS "ensureApproot" $ tshow rApproot
|
|
route' <- lift $ withFileDownloadTokenMaybe' source route
|
|
url <- approotRender rApproot route'
|
|
$logDebugS "ensureApprootUserGenerated" url
|
|
redirect url
|
|
|
|
|
|
-- | Simply send a `File`-Value
|
|
sendThisFile :: ( YesodAuthPersist UniWorX
|
|
, AuthEntity UniWorX ~ User
|
|
, AuthId UniWorX ~ UserId
|
|
, YesodPersistRunner UniWorX
|
|
, MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey
|
|
) => DBFile -> HandlerFor UniWorX TypedContent
|
|
sendThisFile File{..} = do
|
|
ensureApprootUserGeneratedMaybe' Nothing
|
|
if
|
|
| Just fileContent' <- fileContent -> do
|
|
setCSPSandbox
|
|
setContentDisposition' . Just $ takeFileName fileTitle
|
|
let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
|
|
respondSourceDB cType $
|
|
fileContent' .| C.map toFlushBuilder
|
|
| otherwise -> sendResponseStatus noContent204 ()
|
|
|
|
sendByteStringAsFile :: ( YesodAuthPersist UniWorX
|
|
, AuthEntity UniWorX ~ User
|
|
, AuthId UniWorX ~ UserId
|
|
, YesodPersistRunner UniWorX
|
|
, MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey
|
|
) => FilePath -> ByteString -> UTCTime -> HandlerFor UniWorX TypedContent
|
|
sendByteStringAsFile fileTitle content fileModified =
|
|
sendThisFile File{..}
|
|
where
|
|
fileContent
|
|
| null content = Nothing
|
|
| otherwise = Just $ yield content
|
|
|
|
sendFileReference :: forall file a.
|
|
( HasFileReference file
|
|
, BearerAuthSite UniWorX
|
|
, YesodPersistBackend UniWorX ~ SqlBackend
|
|
, YesodPersistRunner UniWorX
|
|
)
|
|
=> file -> HandlerFor UniWorX a
|
|
sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do
|
|
ensureApprootUserGeneratedMaybe' . Just . yield $ Left fRef
|
|
whenIsJust fileReferenceContent $ \fRef' -> do
|
|
dlRestr <- maybeCurrentBearerRestrictions
|
|
case dlRestr of
|
|
Just (DownloadRestrictSingle restrRef) | restrRef == fRef' -> return ()
|
|
_other -> setCSPSandbox
|
|
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
|
|
, BearerAuthSite UniWorX
|
|
, YesodPersistBackend UniWorX ~ SqlBackend
|
|
, YesodPersistRunner UniWorX
|
|
) => ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
|
serveOneFile source = do
|
|
results <- runDB . runConduit $ source .| C.take 2 .| C.foldMap pure -- We don't need more than two files to make a decision below
|
|
ensureApprootUserGeneratedMaybe' . Just . yieldMany $ map (views (_FileReference . _1) Left) results
|
|
case results of
|
|
[file] -> sendFileReference file
|
|
[] -> notFound
|
|
_other -> do
|
|
$logErrorS "SFileR" "Multiple matching files found."
|
|
error "Multiple matching files found."
|
|
|
|
-- | Serve one file directly or a zip-archive of files, identified through a given DB query
|
|
--
|
|
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
|
|
serveSomeFiles :: forall file.
|
|
( HasFileReference file
|
|
, BearerAuthSite UniWorX
|
|
, YesodPersistBackend UniWorX ~ SqlBackend
|
|
, YesodPersistRunner UniWorX
|
|
) => FilePath -> ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
|
serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left
|
|
|
|
serveSomeFiles' :: forall file.
|
|
( HasFileReference file
|
|
, BearerAuthSite UniWorX
|
|
, YesodPersistBackend UniWorX ~ SqlBackend
|
|
, YesodPersistRunner UniWorX
|
|
) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
|
serveSomeFiles' archiveName source = do
|
|
(source', results) <- runDB $ runPeekN 2 source
|
|
ensureApprootUserGeneratedMaybe' . Just . yieldMany $ over (traverse . _Left) (view $ _FileReference . _1) results
|
|
|
|
$logDebugS "serveSomeFiles" . tshow $ length results
|
|
|
|
case results of
|
|
[] -> notFound
|
|
[file] -> either sendFileReference sendThisFile file
|
|
_moreFiles -> do
|
|
setCSPSandbox
|
|
setContentDisposition' $ Just archiveName
|
|
respondSourceDB typeZip $ do
|
|
let zipComment = encodeUtf8 $ pack archiveName
|
|
source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| C.map toFlushBuilder
|
|
|
|
-- | Serve any number of files as a zip-archive of files, identified through a given DB query
|
|
--
|
|
-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
|
|
serveZipArchive :: forall file.
|
|
( HasFileReference file
|
|
, BearerAuthSite UniWorX
|
|
, YesodPersistBackend UniWorX ~ SqlBackend
|
|
, YesodPersistRunner UniWorX
|
|
) => FilePath -> ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
|
serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left
|
|
|
|
serveZipArchive' :: forall file.
|
|
( HasFileReference file
|
|
, BearerAuthSite UniWorX
|
|
, YesodPersistBackend UniWorX ~ SqlBackend
|
|
, YesodPersistRunner UniWorX
|
|
) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
|
serveZipArchive' archiveName source = do
|
|
(source', results) <- runDB $ runPeekN 1 source
|
|
|
|
$logDebugS "serveZipArchive" . tshow $ length results
|
|
|
|
case results of
|
|
[] -> notFound
|
|
_moreFiles -> do
|
|
setCSPSandbox
|
|
setContentDisposition' $ Just archiveName
|
|
respondSourceDB typeZip $ do
|
|
let zipComment = encodeUtf8 $ pack archiveName
|
|
source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| C.map toFlushBuilder
|