chore(files): test roundtripping through minio & db

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

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"

src/Handler/Utils/Files.hs

@@ -2,7 +2,7 @@ module Handler.Utils.Files
   ( sourceFile, sourceFile'
   , sourceFiles, sourceFiles'
   , SourceFilesException(..)
-  , sourceFileDB
+  , sourceFileDB, sourceFileMinio
   , acceptFile
   ) where
 
@@ -50,24 +50,9 @@ sourceFileDB fileReference = do
   chunkHashes .| C.map E.unValue .| awaitForever (\chunkHash -> C.unfoldM (retrieveChunk chunkHash) $ Just (1 :: Int))
 
 
-sourceFiles :: Monad m => ConduitT FileReference DBFile m ()
+sourceFileMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
-sourceFiles = C.map sourceFile
+                => FileContentReference -> ConduitT () ByteString m ()
-
+sourceFileMinio fileReference = do
-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
-      if
-        | inDB -> sourceFileDB fileReference
-        | otherwise -> do
   chunkVar <- newEmptyTMVarIO
   minioAsync <- lift . allocateLinkedAsync $
     maybeT (throwM SourceFilesContentUnavailable) $ do
@@ -85,6 +70,24 @@ sourceFile FileReference{..} = File
           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'
 

src/Utils/Files.hs

@@ -3,7 +3,7 @@ module Utils.Files
   , sinkFile', sinkFiles'
   , FileUploads
   , replaceFileReferences, replaceFileReferences'
-  , sinkFileDB
+  , sinkFileDB, sinkFileMinio
   ) where
 
 import Import.NoFoundation
@@ -86,20 +86,11 @@ sinkFileDB doReplace fileContentContent = do
   where fileContentChunkContentBased = True
 
 
-sinkFiles :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT (File (SqlPersistT m)) FileReference (SqlPersistT m) ()
+sinkFileMinio :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
-sinkFiles = C.mapM sinkFile
+              => ConduitT () ByteString m ()
-
+              -> MaybeT m FileContentReference
-sinkFile :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => File (SqlPersistT m) -> SqlPersistT m FileReference
+-- ^ Cannot deal with zero length uploads
-sinkFile File{ fileContent = Nothing, .. } = return FileReference
+sinkFileMinio fileContentContent = do
-  { fileReferenceContent  = Nothing
-  , fileReferenceTitle    = fileTitle
-  , fileReferenceModified = fileModified
-  }
-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
@@ -110,7 +101,7 @@ sinkFile File{ fileContent = Just fileContentContent, .. } = do
           Just nextChunk'
             -> putMVar chunk (Just nextChunk') >> yield nextChunk' >> putChunks
   sinkAsync <- lift . allocateLinkedAsync . runConduit
-           $ fileContentContent'
+     $ fileContentContent
     .| putChunks
     .| Crypto.sinkHash
 
@@ -135,6 +126,22 @@ sinkFile File{ fileContent = Just fileContentContent, .. } = do
       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
+
+sinkFile :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => File (SqlPersistT m) -> SqlPersistT m FileReference
+sinkFile File{ fileContent = Nothing, .. } = return FileReference
+  { fileReferenceContent  = Nothing
+  , fileReferenceTitle    = fileTitle
+  , fileReferenceModified = fileModified
+  }
+sinkFile File{ fileContent = Just fileContentContent, .. } = do
+  (unsealConduitT -> fileContentContent', isEmpty) <- fileContentContent $$+ is _Nothing <$> C.peekE
+
+  fileContentHash <- if
+    | not isEmpty -> maybeT (sinkFileDB False fileContentContent') $ sinkFileMinio fileContentContent'
     | otherwise   -> return $$(liftTyped $ FileContentReference $$(emptyHash))
 
   return FileReference

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

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

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

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)