119 lines
5.7 KiB
Haskell
119 lines
5.7 KiB
Haskell
module Utils.Files
|
|
( sinkFile, sinkFiles
|
|
, sinkFile', sinkFiles'
|
|
, FileUploads
|
|
, replaceFileReferences
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Foundation.Type
|
|
import Handler.Utils.Minio
|
|
import qualified Network.Minio as Minio
|
|
|
|
import qualified Crypto.Hash as Crypto (hash)
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import qualified Data.ByteString.Base64.URL as Base64
|
|
import qualified Data.ByteArray as ByteArray
|
|
|
|
import qualified Data.Map.Lazy as Map
|
|
import qualified Data.Set as Set
|
|
import Control.Monad.Trans.State.Lazy (execStateT)
|
|
import Control.Monad.State.Class (modify)
|
|
|
|
import Database.Persist.Sql (deleteWhereCount)
|
|
|
|
import Control.Monad.Trans.Resource (allocate)
|
|
|
|
|
|
sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT File FileReference (SqlPersistT m) ()
|
|
sinkFiles = C.mapM sinkFile
|
|
|
|
sinkFile :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => File -> SqlPersistT m FileReference
|
|
sinkFile File{ fileContent = Nothing, .. } = return FileReference
|
|
{ fileReferenceContent = Nothing
|
|
, fileReferenceTitle = fileTitle
|
|
, fileReferenceModified = fileModified
|
|
}
|
|
sinkFile File{ fileContent = Just fileContentContent, .. } = do
|
|
void . withUnliftIO $ \UnliftIO{..} ->
|
|
let takeLock = do
|
|
fileLockTime <- liftIO getCurrentTime
|
|
fileLockInstance <- getsYesod appInstanceID
|
|
insert FileLock{ fileLockContent = fileContentHash, .. }
|
|
releaseLock lId = liftHandler . runDB $ (withReaderT projectBackend $ setSerializable (delete lId :: SqlPersistT (HandlerFor UniWorX) ()) :: YesodDB UniWorX ())
|
|
in unliftIO $ allocate (unliftIO takeLock) (unliftIO . releaseLock)
|
|
|
|
inDB <- exists [ FileContentHash ==. fileContentHash ]
|
|
|
|
let sinkFileDB = unless inDB $ repsert (FileContentKey fileContentHash) FileContent{..}
|
|
maybeT sinkFileDB $ do
|
|
let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
|
|
uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
|
|
unless inDB . runAppMinio $ do
|
|
uploadExists <- handleIf minioIsDoesNotExist (const $ return False) $ True <$ Minio.statObject uploadBucket uploadName Minio.defaultGetObjectOptions
|
|
unless uploadExists $ do
|
|
let
|
|
pooOptions = Minio.defaultPutObjectOptions
|
|
{ Minio.pooCacheControl = Just "immutable"
|
|
}
|
|
Minio.putObject uploadBucket uploadName (C.sourceLazy $ fromStrict fileContentContent) (Just . fromIntegral $ olength fileContentContent) pooOptions
|
|
-- Note that MinIO does not accept length zero uploads without an explicit length specification (not `Nothing` in the line above for the api we use)
|
|
|
|
return FileReference
|
|
{ fileReferenceContent = Just fileContentHash
|
|
, fileReferenceTitle = fileTitle
|
|
, fileReferenceModified = fileModified
|
|
}
|
|
where
|
|
fileContentHash = Crypto.hash fileContentContent
|
|
|
|
|
|
sinkFiles' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) ()
|
|
sinkFiles' = C.mapM $ uncurry sinkFile'
|
|
|
|
sinkFile' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record
|
|
sinkFile' file residual = do
|
|
reference <- sinkFile file
|
|
return $ _FileReference # (reference, residual)
|
|
|
|
|
|
type FileUploads = ConduitT () FileReference (HandlerFor UniWorX) ()
|
|
|
|
replaceFileReferences :: ( MonadHandler m, MonadThrow m
|
|
, HandlerSite m ~ UniWorX
|
|
, HasFileReference record
|
|
, PersistEntityBackend record ~ SqlBackend
|
|
)
|
|
=> (FileReferenceResidual record -> [Filter record])
|
|
-> FileReferenceResidual record
|
|
-> FileUploads
|
|
-> SqlPersistT m (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@
|
|
replaceFileReferences mkFilter residual fs = do
|
|
let resFilter = mkFilter residual
|
|
|
|
oldFiles <- Map.fromListWith Set.union . map (\(Entity k v) -> (v ^. _FileReference . _1, Set.singleton k)) <$> selectList resFilter []
|
|
let oldFiles' = setOf (folded . folded) oldFiles
|
|
|
|
let
|
|
finsert fRef
|
|
| Just sfIds <- fRef `Map.lookup` oldFiles
|
|
= modify $ Map.mapMaybe (assertM' (not . Set.null) . (\\ sfIds))
|
|
| otherwise = do
|
|
let fRef' = _FileReference # (fRef, residual)
|
|
forM_ (persistUniqueKeys fRef') $ \u -> maybeT (return ()) $ do
|
|
Entity cKey cVal <- MaybeT . lift $ getBy u
|
|
deleted <- lift . lift . deleteWhereCount $ resFilter <> [ persistIdField ==. cKey ]
|
|
unless (deleted == 1) $
|
|
throwM . userError $ "replaceFileReferences tried to delete outside of filter/database inconsistency: deleted=" <> show deleted
|
|
lift . modify $ Map.alter (Just . maybe (Set.singleton cKey) (Set.insert cKey)) (cVal ^. _FileReference . _1)
|
|
fId <- lift $ insert fRef'
|
|
modify $ Map.alter (Just . maybe (Set.singleton fId) (Set.insert fId)) fRef
|
|
|
|
changes <- fmap (setOf $ folded . folded) . flip execStateT oldFiles . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert
|
|
|
|
deleteWhere $ resFilter <> [ persistIdField <-. Set.toList (oldFiles' `Set.intersection` changes) ]
|
|
|
|
return (oldFiles', changes)
|