230 lines
12 KiB
Haskell
230 lines
12 KiB
Haskell
module Handler.Utils.Files
|
|
( sourceFile, sourceFile'
|
|
, sourceFiles, sourceFiles'
|
|
, SourceFilesException(..)
|
|
, sourceFileDB, sourceFileMinio
|
|
, acceptFile
|
|
, respondFileConditional
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Foundation.Type
|
|
import Utils.Metrics
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
import qualified Data.Conduit.List as C (unfoldM)
|
|
|
|
import Handler.Utils.Minio
|
|
import qualified Network.Minio as Minio
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import System.FilePath (normalise, makeValid)
|
|
import Data.List (dropWhileEnd)
|
|
|
|
|
|
data SourceFilesException
|
|
= SourceFilesMismatchedHashes
|
|
| SourceFilesContentUnavailable
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
|
|
sourceFileDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX)
|
|
=> FileContentReference -> ConduitT () ByteString (SqlPersistT m) ()
|
|
sourceFileDB fileReference = do
|
|
dbChunksize <- getsYesod $ view _appFileUploadDBChunksize
|
|
let retrieveChunk chunkHash = \case
|
|
Nothing -> return Nothing
|
|
Just start -> do
|
|
chunk <- E.selectMaybe . E.from $ \fileContentChunk -> do
|
|
E.where_ $ fileContentChunk E.^. FileContentChunkId E.==. E.val chunkHash
|
|
return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize)
|
|
case chunk of
|
|
Nothing -> throwM SourceFilesContentUnavailable
|
|
Just (E.Value c) -> do
|
|
observeSourcedChunk StorageDB $ olength c
|
|
return . Just . (c, ) $ if
|
|
| olength c >= dbChunksize -> Just $ start + dbChunksize
|
|
| otherwise -> Nothing
|
|
chunkHashes = E.selectSource . E.from $ \fileContentEntry -> do
|
|
E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference
|
|
E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryIx ]
|
|
return $ fileContentEntry E.^. FileContentEntryChunkHash
|
|
chunkHashes .| C.map E.unValue .| awaitForever (\chunkHash -> C.unfoldM (retrieveChunk chunkHash) $ Just (1 :: Int))
|
|
|
|
|
|
sourceFileMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
|
|
=> FileContentReference -> ConduitT () ByteString m ()
|
|
sourceFileMinio fileReference = do
|
|
chunkVar <- newEmptyTMVarIO
|
|
minioAsync <- lift . allocateLinkedAsync $
|
|
maybeT (throwM SourceFilesContentUnavailable) $ do
|
|
let uploadName = minioFileReference # fileReference
|
|
uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
|
|
hoistMaybe <=< runAppMinio . runMaybeT $ do
|
|
objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions
|
|
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
|
|
|
|
|
|
sourceFiles :: (Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT FileReference DBFile m ()
|
|
sourceFiles = C.map sourceFile
|
|
|
|
sourceFile :: YesodPersistBackend UniWorX ~ SqlBackend
|
|
=> FileReference -> DBFile
|
|
sourceFile FileReference{..} = File
|
|
{ fileTitle = fileReferenceTitle
|
|
, fileModified = fileReferenceModified
|
|
, fileContent = toFileContent <$> fileReferenceContent
|
|
}
|
|
where
|
|
toFileContent fileReference
|
|
| fileReference == $$(liftTyped $ FileContentReference $$(emptyHash))
|
|
= return ()
|
|
toFileContent fileReference = do
|
|
inDB <- lift . E.selectExists . E.from $ \fileContentEntry -> E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference
|
|
bool sourceFileMinio sourceFileDB inDB fileReference
|
|
|
|
sourceFiles' :: forall file m. (HasFileReference file, Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT file DBFile m ()
|
|
sourceFiles' = C.map sourceFile'
|
|
|
|
sourceFile' :: forall file. (HasFileReference file, YesodPersistBackend UniWorX ~ SqlBackend) => file -> DBFile
|
|
sourceFile' = sourceFile . view (_FileReference . _1)
|
|
|
|
respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX)
|
|
=> Maybe UTCTime -> MimeType
|
|
-> FileReference
|
|
-> SqlPersistT m (HandlerFor UniWorX 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
|
|
let fileTitle = "." <//> unpack (fileName fInfo)
|
|
& normalise
|
|
& makeValid
|
|
& dropWhile isPathSeparator
|
|
& dropWhileEnd isPathSeparator
|
|
& normalise
|
|
& makeValid
|
|
fileContent = Just $ fileSource fInfo
|
|
fileModified <- liftIO getCurrentTime
|
|
return File{..}
|