chore: minio-runner

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)
 
 

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 _))

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

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

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

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 ()