diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index 1d1425204..d37e3bac0 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -101,6 +101,7 @@ sourceFileDBChunks :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, Ba => ((Int, Int) -> ReaderT SqlReadBackend m (Maybe ByteString) -> ReaderT SqlReadBackend m (Maybe ByteString)) -> FileContentChunkReference -> ConduitT i (ByteString, (Int, Int)) (ReaderT backend m) () sourceFileDBChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlReadBackend) $ do dbChunksize <- getsYesod $ view _appFileUploadDBChunksize + -- mRunner <- getMinioRunner let retrieveChunk = \case Nothing -> return Nothing Just start -> do @@ -109,11 +110,12 @@ sourceFileDBChunks cont chunkHash = transPipe (withReaderT $ projectBackend @Sql return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) chunk <- fileChunkARC Nothing (chunkHash, (start, dbChunksize)) getChunkDB case chunk of - Nothing -> throwM SourceFilesContentUnavailable Just c -> do return . Just . ((c, (start, dbChunksize)), ) $ if | olength c >= dbChunksize -> Just $ start + dbChunksize | otherwise -> Nothing + -- Nothing | Just MinioRunner{..} <- mRunner -> do + Nothing -> throwM SourceFilesContentUnavailable C.unfoldM retrieveChunk $ Just (1 :: Int) diff --git a/src/Handler/Utils/Minio.hs b/src/Handler/Utils/Minio.hs index 92fdb0089..2e82fd799 100644 --- a/src/Handler/Utils/Minio.hs +++ b/src/Handler/Utils/Minio.hs @@ -1,5 +1,7 @@ module Handler.Utils.Minio - ( runAppMinio + ( MinioRunner(..) + , getMinioRunner + , runAppMinio , minioIsDoesNotExist ) where @@ -10,14 +12,24 @@ import Network.Minio (Minio) import qualified Network.Minio as Minio +newtype MinioRunner = MinioRunner + { runMinio :: forall m' a. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadThrow m') => Minio a -> m' a + } + +getMinioRunner :: (MonadHandler m, HandlerSite m ~ UniWorX) + => m (Maybe MinioRunner) +getMinioRunner = runMaybeT $ do + conn <- hoistMaybe =<< getsYesod appUploadCache + return MinioRunner{ runMinio = throwLeft <=< liftIO . Minio.runMinioWith conn } + runAppMinio :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m , MonadPlus m ) => Minio a -> m a runAppMinio act = do - conn <- hoistMaybe =<< getsYesod appUploadCache - throwLeft <=< liftIO $ Minio.runMinioWith conn act + MinioRunner{..} <- hoistMaybe =<< getMinioRunner + runMinio act minioIsDoesNotExist :: HttpException -> Bool minioIsDoesNotExist (HttpExceptionRequest _ (StatusCodeException resp _)) diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index 28c649dfd..b06396f86 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -6,7 +6,7 @@ module Model.Types.File , File(..), _fileTitle, _fileContent, _fileModified , PureFile, toPureFile, fromPureFile, pureFileToFileReference, _pureFileContent , transFile - , minioFileReference, etagFileReference + , minioFileChunkReference, minioFileReference, etagFileReference , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified , HasFileReference(..), IsFileReference(..), FileReferenceResidual(FileReferenceResidual, FileReferenceResidualEither, unFileReferenceResidualEither, FileReferenceResidualEntity, fileReferenceResidualEntityKey, fileReferenceResidualEntityResidual, unPureFileResidual) , FileReferenceTitleMap(..) @@ -39,6 +39,8 @@ import Text.Show import qualified Data.Aeson as JSON import qualified Data.Map as Map +import qualified Data.Text as Text + newtype FileContentChunkReference = FileContentChunkReference (Digest SHA3_512) @@ -55,6 +57,13 @@ instance PersistFieldSql FileContentChunkReference where makeWrapped ''FileContentChunkReference +minioFileChunkReference :: Prism' Minio.Object FileContentReference +minioFileChunkReference = prism' toObjectName fromObjectName + where toObjectName = (chunkPrefix <>) . decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert + fromObjectName = fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded . encodeUtf8 <=< Text.stripPrefix chunkPrefix + + chunkPrefix = "partial." + newtype FileContentReference = FileContentReference (Digest SHA3_512) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) deriving newtype ( PersistField diff --git a/test/Crypto/Hash/TestInstances.hs b/test/Crypto/Hash/TestInstances.hs new file mode 100644 index 000000000..e78510a1f --- /dev/null +++ b/test/Crypto/Hash/TestInstances.hs @@ -0,0 +1,15 @@ +module Crypto.Hash.TestInstances + () where + +import Crypto.Hash (Digest, HashAlgorithm) +import qualified Crypto.Hash as Crypto +import TestImport +import qualified Data.ByteArray as BA + + +instance HashAlgorithm a => Arbitrary (Digest a) where + arbitrary = Crypto.hash @ByteString @a <$> arbitrary +instance CoArbitrary (Digest a) where + coarbitrary = coarbitrary . BA.convert @_ @ByteString +instance HashAlgorithm a => Function (Digest a) where + function = functionShow diff --git a/test/Model/Types/FileSpec.hs b/test/Model/Types/FileSpec.hs index f6f3990e9..292bc047b 100644 --- a/test/Model/Types/FileSpec.hs +++ b/test/Model/Types/FileSpec.hs @@ -57,6 +57,13 @@ instance Arbitrary (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => arbitrary = genericArbitrary shrink = genericShrink +deriving newtype instance Arbitrary FileContentReference +instance CoArbitrary FileContentReference +instance Function FileContentReference +deriving newtype instance Arbitrary FileContentChunkReference +instance CoArbitrary FileContentChunkReference +instance Function FileContentChunkReference + spec :: Spec spec = do parallel $ do @@ -70,3 +77,10 @@ spec = do [ eqLaws, ordLaws, semigroupLaws, monoidLaws, semigroupMonoidLaws, idempotentSemigroupLaws ] lawsCheckHspec (Proxy @(FileField FileReference)) [ eqLaws, ordLaws, jsonLaws ] + lawsCheckHspec (Proxy @FileContentChunkReference) + [ eqLaws, ordLaws, showLaws, persistFieldLaws, pathPieceLaws, httpApiDataLaws, jsonLaws, hashableLaws, binaryLaws ] + lawsCheckHspec (Proxy @FileContentReference) + [ eqLaws, ordLaws, showLaws, persistFieldLaws, pathPieceLaws, httpApiDataLaws, jsonLaws, hashableLaws, binaryLaws ] + + describe "minioFileChunkReference" . it "is a prism" . property $ isPrism minioFileChunkReference + describe "minioFileReference" . it "is a prism" . property $ isPrism minioFileReference diff --git a/test/TestInstances.hs b/test/TestInstances.hs index 3e3416ca8..431110d65 100644 --- a/test/TestInstances.hs +++ b/test/TestInstances.hs @@ -5,3 +5,4 @@ module TestInstances import Text.Blaze.TestInstances as TestInstances () import Database.Persist.Sql.Types.TestInstances as TestInstances () import Data.NonNull.TestInstances as TestInstances () +import Crypto.Hash.TestInstances as TestInstances ()