115 lines
4.5 KiB
Haskell
115 lines
4.5 KiB
Haskell
module Handler.Utils.Files
|
|
( sourceFile, sourceFile'
|
|
, sourceFiles, sourceFiles'
|
|
, SourceFilesException(..)
|
|
, sourceFileDB, sourceFileMinio
|
|
, acceptFile
|
|
) where
|
|
|
|
import Import
|
|
|
|
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 => ConduitT FileReference DBFile m ()
|
|
sourceFiles = C.map sourceFile
|
|
|
|
sourceFile :: 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) => ConduitT file DBFile m ()
|
|
sourceFiles' = C.map sourceFile'
|
|
|
|
sourceFile' :: forall file. HasFileReference file => file -> DBFile
|
|
sourceFile' = sourceFile . view (_FileReference . _1)
|
|
|
|
|
|
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{..}
|