diff --git a/config/test-settings.yml b/config/test-settings.yml index ab9bd7f5a..905639ac1 100644 --- a/config/test-settings.yml +++ b/config/test-settings.yml @@ -1,5 +1,6 @@ database: database: "_env:PGDATABASE_TEST:uniworx_test" +upload-cache-bucket: "uni2work-test-uploads" log-settings: detailed: true diff --git a/package.yaml b/package.yaml index b49ed607c..d378fd445 100644 --- a/package.yaml +++ b/package.yaml @@ -311,6 +311,7 @@ tests: - generic-arbitrary - http-types - yesod-persistent + - quickcheck-io ghc-options: - -fno-warn-orphans - -threaded -rtsopts "-with-rtsopts=-N -T" diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index 33e1518e9..aa0d280bc 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -2,7 +2,7 @@ module Handler.Utils.Files ( sourceFile, sourceFile' , sourceFiles, sourceFiles' , SourceFilesException(..) - , sourceFileDB + , sourceFileDB, sourceFileMinio , acceptFile ) where @@ -50,6 +50,27 @@ sourceFileDB fileReference = do 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 -> yield chunk >> go + Left (Right ()) -> return () + Left (Left exc) -> throwM exc + in go + + sourceFiles :: Monad m => ConduitT FileReference DBFile m () sourceFiles = C.map sourceFile @@ -65,25 +86,7 @@ sourceFile FileReference{..} = File = return () toFileContent fileReference = do inDB <- lift . E.selectExists . E.from $ \fileContentEntry -> E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference - if - | inDB -> sourceFileDB fileReference - | otherwise -> 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 -> yield chunk >> go - Left (Right ()) -> return () - Left (Left exc) -> throwM exc - in go + bool sourceFileMinio sourceFileDB inDB fileReference sourceFiles' :: forall file m. (HasFileReference file, Monad m) => ConduitT file DBFile m () sourceFiles' = C.map sourceFile' diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 4749f46c5..3119313da 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -3,7 +3,7 @@ module Utils.Files , sinkFile', sinkFiles' , FileUploads , replaceFileReferences, replaceFileReferences' - , sinkFileDB + , sinkFileDB, sinkFileMinio ) where import Import.NoFoundation @@ -85,6 +85,48 @@ sinkFileDB doReplace fileContentContent = do return fileContentHash where fileContentChunkContentBased = True + +sinkFileMinio :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) + => ConduitT () ByteString m () + -> MaybeT m FileContentReference +-- ^ Cannot deal with zero length uploads +sinkFileMinio fileContentContent = do + uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket + chunk <- liftIO newEmptyMVar + let putChunks = do + nextChunk <- await + case nextChunk of + Nothing + -> putMVar chunk Nothing + Just nextChunk' + -> putMVar chunk (Just nextChunk') >> yield nextChunk' >> putChunks + sinkAsync <- lift . allocateLinkedAsync . runConduit + $ fileContentContent + .| putChunks + .| Crypto.sinkHash + + runAppMinio $ do + tmpUUID <- liftIO UUID.nextRandom + let uploadName = ".tmp." <> toPathPiece tmpUUID + pooOptions = Minio.defaultPutObjectOptions + { Minio.pooCacheControl = Just "immutable" + } + Minio.putObject uploadBucket uploadName (C.unfoldM (\x -> fmap (, x) <$> takeMVar chunk) ()) Nothing pooOptions + fileContentHash <- review _Wrapped <$> waitAsync sinkAsync + let dstName = minioFileReference # fileContentHash + copySrc = Minio.defaultSourceInfo + { Minio.srcBucket = uploadBucket, Minio.srcObject = uploadName + } + copyDst = Minio.defaultDestinationInfo + { Minio.dstBucket = uploadBucket + , Minio.dstObject = dstName + } + uploadExists <- handleIf minioIsDoesNotExist (const $ return False) $ True <$ Minio.statObject uploadBucket dstName Minio.defaultGetObjectOptions + unless uploadExists $ + Minio.copyObject copyDst copySrc + Minio.removeObject uploadBucket uploadName + return fileContentHash + sinkFiles :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT (File (SqlPersistT m)) FileReference (SqlPersistT m) () sinkFiles = C.mapM sinkFile @@ -99,43 +141,8 @@ sinkFile File{ fileContent = Just fileContentContent, .. } = do (unsealConduitT -> fileContentContent', isEmpty) <- fileContentContent $$+ is _Nothing <$> C.peekE fileContentHash <- if - | not isEmpty -> maybeT (sinkFileDB False fileContentContent') $ do - uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket - chunk <- liftIO newEmptyMVar - let putChunks = do - nextChunk <- await - case nextChunk of - Nothing - -> putMVar chunk Nothing - Just nextChunk' - -> putMVar chunk (Just nextChunk') >> yield nextChunk' >> putChunks - sinkAsync <- lift . allocateLinkedAsync . runConduit - $ fileContentContent' - .| putChunks - .| Crypto.sinkHash - - runAppMinio $ do - tmpUUID <- liftIO UUID.nextRandom - let uploadName = ".tmp." <> toPathPiece tmpUUID - pooOptions = Minio.defaultPutObjectOptions - { Minio.pooCacheControl = Just "immutable" - } - Minio.putObject uploadBucket uploadName (C.unfoldM (\x -> fmap (, x) <$> takeMVar chunk) ()) Nothing pooOptions - fileContentHash <- review _Wrapped <$> waitAsync sinkAsync - let dstName = minioFileReference # fileContentHash - copySrc = Minio.defaultSourceInfo - { Minio.srcBucket = uploadBucket, Minio.srcObject = uploadName - } - copyDst = Minio.defaultDestinationInfo - { Minio.dstBucket = uploadBucket - , Minio.dstObject = dstName - } - uploadExists <- handleIf minioIsDoesNotExist (const $ return False) $ True <$ Minio.statObject uploadBucket dstName Minio.defaultGetObjectOptions - unless uploadExists $ - Minio.copyObject copyDst copySrc - Minio.removeObject uploadBucket uploadName - return fileContentHash - | otherwise -> return $$(liftTyped $ FileContentReference $$(emptyHash)) + | not isEmpty -> maybeT (sinkFileDB False fileContentContent') $ sinkFileMinio fileContentContent' + | otherwise -> return $$(liftTyped $ FileContentReference $$(emptyHash)) return FileReference { fileReferenceContent = Just fileContentHash diff --git a/test/Handler/Utils/FilesSpec.hs b/test/Handler/Utils/FilesSpec.hs new file mode 100644 index 000000000..be8b2b3a3 --- /dev/null +++ b/test/Handler/Utils/FilesSpec.hs @@ -0,0 +1,69 @@ +module Handler.Utils.FilesSpec where + +import TestImport hiding (runDB) +import Yesod.Core.Handler (getsYesod) +import Yesod.Persist.Core (YesodPersist(runDB)) + +import ModelSpec () + +import Handler.Utils.Files +import Utils.Files + +import Control.Lens.Extras (is) + +import Data.Conduit +import qualified Data.Conduit.Combinators as C + +import Control.Monad.Fail (MonadFail(..)) +import Control.Monad.Trans.Maybe (runMaybeT) + +import Utils.Sql (setSerializable) + + +spec :: Spec +spec = withApp . describe "File handling" $ do + describe "Minio" $ do + modifyMaxSuccess (`div` 10) . it "roundtrips" $ \(tSite, _) -> property $ do + fileContentContent <- arbitrary + `suchThat` (\fc -> not . null . runIdentity . runConduit $ fc .| C.sinkLazy) -- Minio (and by extension `sinkFileMinio`) cannot deal with zero length uploads; this is handled seperately by `sinkFile` + file' <- arbitrary :: Gen PureFile + let file = file' { fileContent = Just fileContentContent } + return . propertyIO . unsafeHandler tSite $ do + haveUploadCache <- getsYesod $ is _Just . appUploadCache + unless haveUploadCache . liftIO $ + pendingWith "No upload cache (minio) configured" + + let fRef = file ^. _FileReference . _1 . _fileReferenceContent + fRef' <- runMaybeT . sinkFileMinio $ transPipe generalize fileContentContent + + liftIO $ fRef' `shouldBe` fRef + + fileReferenceContentContent <- liftIO . maybe (fail "Produced no file reference") return $ fRef' + + suppliedContent <- runConduit $ transPipe generalize fileContentContent + .| C.sinkLazy + readContent <- runConduit $ sourceFileMinio fileReferenceContentContent + .| C.takeE (succ $ olength suppliedContent) + .| C.sinkLazy + + liftIO $ readContent `shouldBe` suppliedContent + describe "DB" $ do + modifyMaxSuccess (`div` 10) . it "roundtrips" $ \(tSite, _) -> property $ do + fileContentContent <- arbitrary + `suchThat` (\fc -> not . null . runIdentity . runConduit $ fc .| C.sinkLazy) -- Minio (and by extension `sinkFileMinio`) cannot deal with zero length uploads; this is handled seperately by `sinkFile` + file' <- arbitrary :: Gen PureFile + let file = file' { fileContent = Just fileContentContent } + return . propertyIO . unsafeHandler tSite $ do + let fRef = file ^. _FileReference . _1 . _fileReferenceContent + fRef' <- runDB . setSerializable . sinkFileDB True $ transPipe generalize fileContentContent + + liftIO $ Just fRef' `shouldBe` fRef + + suppliedContent <- runConduit $ transPipe generalize fileContentContent + .| C.sinkLazy + readContent <- runDB . runConduit + $ sourceFileDB fRef' + .| C.takeE (succ $ olength suppliedContent) + .| C.sinkLazy + + liftIO $ readContent `shouldBe` suppliedContent diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index 7c33dea28..85030cc81 100644 --- a/test/Handler/Utils/ZipSpec.hs +++ b/test/Handler/Utils/ZipSpec.hs @@ -36,8 +36,7 @@ spec = describe "Zip file handling" $ do describe "has compatible encoding to, and decoding from zip files" . forM_ universeF $ \strategy -> modifyMaxSuccess (bool id (37 *) $ strategy == (ZipProduceInterleaved, ZipConsumeInterleaved)) . it (show strategy) . property $ do zipFiles <- listOf arbitrary :: Gen [PureFile] - return . property $ do - + return . propertyIO $ do let zipProduceBuffered = evaluate . force <=< runConduitRes $ zipProduceInterleaved .| C.sinkLazy zipProduceInterleaved diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 1e7dd6a8a..043786e83 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -34,6 +34,7 @@ import Control.Monad.Catch.Pure (Catch, runCatch) import System.IO.Unsafe (unsafePerformIO) +import Data.Conduit import qualified Data.Conduit.Combinators as C import Data.Ratio ((%)) @@ -141,6 +142,9 @@ instance Arbitrary User where return User{..} shrink = genericShrink +instance (LazySequence lazy strict, Arbitrary lazy, Monad m) => Arbitrary (ConduitT () strict m ()) where + arbitrary = C.sourceLazy <$> arbitrary + scaleRatio :: Rational -> Int -> Int scaleRatio r = ceiling . (* r) . fromIntegral @@ -151,7 +155,7 @@ instance Monad m => Arbitrary (File m) where fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange fileContent <- oneof [ pure Nothing - , Just . C.sourceLazy <$> scale (scaleRatio $ 7 % 8) arbitrary + , Just <$> scale (scaleRatio $ 7 % 8) arbitrary ] return File{..} where diff --git a/test/TestImport.hs b/test/TestImport.hs index 510b1e9c0..7896ac296 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -36,6 +36,7 @@ import Test.QuickCheck.Classes.HttpApiData as X import Test.QuickCheck.Classes.Universe as X import Test.QuickCheck.Classes.Binary as X import Test.QuickCheck.Classes.Csv as X +import Test.QuickCheck.IO as X import Data.Proxy as X import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn)