diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,17 @@ +## 0.2.0 + +* Added lots of test cases. +* Add support for compressed content stores. This requires lzma-conduit. +* Fix a file creation bug in fetchFile. If you attempted to fetch an object + that did not exist, the output file would still be created. This no longer + happens. +* Fix fetchByteString and fetchLazyByteString to return the entire object, + not just the first chunk of it. This was caused by improper use of headC. +* Fix a bug in fetchByteStringC and fetchLazyByteStringC that was causing + these functions to output objects as multiple ByteStrings. +* Remove duplicate MonadIO constraints. These were being duplicated by the + use of MonadResource constraints. + ## 0.1.1 * Relax overly strict aeson, monad-control, temporary, and text requirements. diff --git a/Data/ContentStore.hs b/Data/ContentStore.hs --- a/Data/ContentStore.hs +++ b/Data/ContentStore.hs @@ -44,7 +44,7 @@ import Conduit import Control.Conditional(ifM, unlessM, whenM) -import Control.Monad((>=>), forM, forM_, join, void) +import Control.Monad(forM, forM_, void) import Control.Monad.Base(MonadBase(..)) import Control.Monad.Except(ExceptT, MonadError, catchError, runExceptT, throwError) import Control.Monad.IO.Class(MonadIO, liftIO) @@ -52,6 +52,8 @@ import Control.Monad.Trans.Resource(MonadResource, MonadThrow, ResourceT, runResourceT) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS +import Data.Conduit.Binary(sinkFileCautious) +import Data.Conduit.Lzma(compress, decompress) import Data.Maybe(isNothing) import System.Directory(canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeFile, renameFile) import System.FilePath(()) @@ -206,8 +208,8 @@ closeFd fd -- This stores an object that is already (or can be) fully loaded into memory -doStore :: MonadIO m => ContentStore -> (a -> ObjectDigest) -> (Handle -> Consumer a IO ()) -> Conduit a m ObjectDigest -doStore cs hasher writer = awaitForever $ \object -> do +doStore :: MonadResource m => ContentStore -> (BS.ByteString -> ObjectDigest) -> Conduit BS.ByteString m ObjectDigest +doStore cs hasher = awaitForever $ \object -> do let digest = hasher object let (subdir, filename) = storedObjectDestination digest path = objectSubdirectoryPath cs subdir filename @@ -218,19 +220,19 @@ -- If it's already there, just return the digest. liftIO $ unlessM (doesFileExist path) $ do (tmpPath, handle) <- startStore cs - void $ runConduit $ yield object .| writer handle + void $ runConduitRes $ yield object .| maybeCompress cs .| sinkHandle handle finishStore cs (tmpPath, handle) digest yield digest -- Stream data into the content-store without loading all of it at once -doStoreSink :: MonadIO m => ContentStore -> (DigestContext -> a -> DigestContext) -> (Handle -> Sink a m ()) -> Sink a m ObjectDigest -doStoreSink cs hasher writer = do +doStoreSink :: MonadResource m => ContentStore -> (DigestContext -> BS.ByteString -> DigestContext) -> Sink BS.ByteString m ObjectDigest +doStoreSink cs hasher = do (tmpPath, handle) <- liftIO $ startStore cs let initctx = digestInit $ csHash cs -- One sink calculates the digest, the other writes the data to the tmp file - (_, digest) <- getZipConduit ((,) <$> ZipConduit (writer handle) + (_, digest) <- getZipConduit ((,) <$> ZipConduit (maybeCompress cs .| sinkHandle handle) <*> ZipConduit (digestSink initctx)) let (subdir, _) = storedObjectDestination digest @@ -280,6 +282,17 @@ fd <- openFd fullPath ReadOnly Nothing defaultFileFlags whenM (isNothing <$> getLock fd fullLock) $ removeFile fullPath +identityC :: Monad m => Conduit a m a +identityC = mapC id + +maybeCompress :: MonadResource m => ContentStore -> Conduit BS.ByteString m BS.ByteString +maybeCompress cs = + if confCompressed . csConfig $ cs then compress Nothing else identityC + +maybeDecompress :: MonadResource m => ContentStore -> Conduit BS.ByteString m BS.ByteString +maybeDecompress cs = + if confCompressed . csConfig $ cs then decompress Nothing else identityC + -- -- PUBLIC FUNCTIONS -- @@ -353,17 +366,6 @@ -- STRICT BYTE STRING INTERFACE -- --- Like headC, but throws a CsError if the stream is empty. You supply the error message. -headCError :: MonadError CsError m => String -> Consumer a m a -headCError s = - join $ maybe (throwError $ CsError s) return <$> headC - --- Like headC, but throws a CsErrorNoSuchObject if the stream is empty. You supply the --- digest of the object that's missing. -headCMissing :: MonadError CsError m => ObjectDigest -> Consumer a m a -headCMissing digest = - join $ maybe (throwError $ CsErrorNoSuchObject (show digest)) return <$> headC - -- | Lookup and return some previously stored object as a strict 'ByteString'. Note that -- you'll probably need to use 'fromByteString' to produce an 'ObjectDigest' from whatever -- text or binary representation you've got from the user/mddb/etc. @@ -372,38 +374,42 @@ -> ObjectDigest -- ^ The 'ObjectDigest' for some stored object. -> m BS.ByteString fetchByteString cs digest = - runConduitRes (yield digest .| fetchByteStringC cs .| headCMissing digest) + fmap BS.concat (runConduitRes (yield digest .| fetchByteStringC cs .| sinkList)) -- | Given an opened 'ContentStore' and a 'Conduit' of 'ObjectDigest's, load each one into -- a strict 'ByteString' and put it into the conduit. This is useful for stream many -- objects out of the content store at a time, like with exporting an RPM or other package -- format. -fetchByteStringC :: (MonadError CsError m, MonadIO m, MonadResource m) => ContentStore -> Conduit ObjectDigest m BS.ByteString -fetchByteStringC cs = awaitForever $ - findObject cs >=> sourceFile +fetchByteStringC :: (MonadError CsError m, MonadResource m) => ContentStore -> Conduit ObjectDigest m BS.ByteString +fetchByteStringC cs = awaitForever $ \digest -> do + f <- findObject cs digest + contents <- sourceFile f .| maybeDecompress cs .| sinkList + yield $ BS.concat contents -- | Store some object into the content store and return its 'ObjectDigest'. If an object -- with the same digest already exists in the content store, this is a duplicate. Simply -- return the digest of the already stored object and do nothing else. A 'CsErrorCollision' -- will NOT be thrown. -storeByteString :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m) => +storeByteString :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadThrow m) => ContentStore -- ^ An opened 'ContentStore'. -> BS.ByteString -- ^ An object to be stored, as a strict 'ByteString'. -> m ObjectDigest storeByteString cs bs = - runConduitRes (yield bs .| storeByteStringC cs .| headCError "Failed to store object") + runConduitRes (yield bs .| storeByteStringC cs .| headC) >>= \case + Nothing -> throwError $ CsError "Failed to store object" + Just d -> return d -- | Like 'storeByteString', but read strict 'ByteString's from a 'Conduit' and put their -- 'ObjectDigest's into the conduit. This is useful for storing many objects at a time, -- like with importing an RPM or other package format. -storeByteStringC :: (MonadError CsError m, MonadIO m) => ContentStore -> Conduit BS.ByteString m ObjectDigest -storeByteStringC cs = doStore cs (digestByteString $ csHash cs) sinkHandle +storeByteStringC :: (MonadError CsError m, MonadResource m) => ContentStore -> Conduit BS.ByteString m ObjectDigest +storeByteStringC cs = doStore cs (digestByteString $ csHash cs) -- | Read in a 'Conduit' of strict 'ByteString's, store the stream into an object in an -- already opened 'ContentStore', and return the final digest. This is useful for -- storing a stream of data as a single object. -storeByteStringSink :: MonadIO m => ContentStore -> Sink BS.ByteString m ObjectDigest -storeByteStringSink cs = doStoreSink cs digestUpdate sinkHandle +storeByteStringSink :: MonadResource m => ContentStore -> Sink BS.ByteString m ObjectDigest +storeByteStringSink cs = doStoreSink cs digestUpdate -- -- LAZY BYTE STRING INTERFACE @@ -415,28 +421,32 @@ -> ObjectDigest -> m LBS.ByteString fetchLazyByteString cs digest = - runConduitRes (yield digest .| fetchLazyByteStringC cs .| headCMissing digest) + fmap LBS.concat (runConduitRes (yield digest .| fetchLazyByteStringC cs .| sinkList)) -- | Like 'fetchByteStringC', but uses lazy 'Data.ByteString.Lazy.ByteString's instead. -fetchLazyByteStringC :: (MonadError CsError m, MonadIO m, MonadResource m) => ContentStore -> Conduit ObjectDigest m LBS.ByteString -fetchLazyByteStringC cs = awaitForever $ - findObject cs >=> \path -> sourceFile path .| sinkLazy +fetchLazyByteStringC :: (MonadError CsError m, MonadResource m) => ContentStore -> Conduit ObjectDigest m LBS.ByteString +fetchLazyByteStringC cs = awaitForever $ \digest -> do + f <- findObject cs digest + contents <- sourceFile f .| maybeDecompress cs .| sinkList + yield $ LBS.fromStrict $ BS.concat contents -- | Like 'storeByteString', but uses lazy 'Data.ByteString.Lazy.ByteString's instead. -storeLazyByteString :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m) => +storeLazyByteString :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadThrow m) => ContentStore -> LBS.ByteString -> m ObjectDigest storeLazyByteString cs bs = - runConduitRes (yield bs .| storeLazyByteStringC cs .| headCError "Failed to store object") + runConduitRes (yield bs .| storeLazyByteStringC cs .| headC) >>= \case + Nothing -> throwError $ CsError "Failed to store object" + Just d -> return d -- | Like 'storeByteStringC', but uses lazy 'Data.ByteString.Lazy.ByteString's instead. -storeLazyByteStringC :: (MonadError CsError m, MonadIO m) => ContentStore -> Conduit LBS.ByteString m ObjectDigest -storeLazyByteStringC cs = doStore cs (digestLazyByteString $ csHash cs) (\h -> mapC LBS.toStrict .| sinkHandle h) +storeLazyByteStringC :: (MonadError CsError m, MonadResource m) => ContentStore -> Conduit LBS.ByteString m ObjectDigest +storeLazyByteStringC cs = mapC LBS.toStrict .| doStore cs (digestByteString $ csHash cs) -- | Like 'storeByteStringSink', but uses lazy 'Data.ByteString.Lazy.ByteString's instead. -storeLazyByteStringSink :: MonadIO m => ContentStore -> Sink LBS.ByteString m ObjectDigest -storeLazyByteStringSink cs = doStoreSink cs (LBS.foldlChunks digestUpdate) (\h -> mapC LBS.toStrict .| sinkHandle h) +storeLazyByteStringSink :: MonadResource m => ContentStore -> Sink LBS.ByteString m ObjectDigest +storeLazyByteStringSink cs = mapC LBS.toStrict .| doStoreSink cs digestUpdate -- -- DIRECTORY INTERFACE @@ -446,7 +456,7 @@ -- of each. Note that directories will not be stored. The content store only contains things that -- have content. If you need to store directory information, that should be handled externally to -- this module. -storeDirectory :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadResource m) => +storeDirectory :: (MonadBaseControl IO m, MonadError CsError m, MonadResource m) => ContentStore -- ^ An opened 'ContentStore'. -> FilePath -- ^ A directory tree containing many objects. -> m [(FilePath, ObjectDigest)] @@ -463,17 +473,17 @@ -- | Find some object in the content store and write it to a destination. If the destination already -- exists, it will be overwritten. If the object does not already exist, a 'CsErrorNoSuchObject' will -- be thrown. -fetchFile :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadResource m) => +fetchFile :: (MonadBaseControl IO m, MonadError CsError m, MonadResource m) => ContentStore -- ^ An opened 'ContentStore'. -> ObjectDigest -- ^ The 'ObjectDigest' of some stored object. -> FilePath -- ^ The destination -> m () fetchFile cs digest dest = - runConduitRes $ yield digest .| fetchByteStringC cs .| sinkFile dest + runConduitRes $ yield digest .| fetchByteStringC cs .| sinkFileCautious dest -- | Store an already existing file in the content store, returning its 'ObjectDigest'. The original -- file will be left on disk. -storeFile :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadResource m) => +storeFile :: (MonadBaseControl IO m, MonadError CsError m, MonadResource m) => ContentStore -- ^ An opened 'ContentStore'. -> FilePath -- ^ The file to be stored. -> m ObjectDigest diff --git a/Data/ContentStore/Config.hs b/Data/ContentStore/Config.hs --- a/Data/ContentStore/Config.hs +++ b/Data/ContentStore/Config.hs @@ -34,10 +34,14 @@ import qualified Data.Text.IO as TIO import Text.Toml(parseTomlDoc) -{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} - -- | Configuration information needed by the content store. data Config = Config { + -- | Is the data in the content store compressed? If this option is missing + -- in a config file, we assume that the data is not compressed. This is to + -- keep backwards compatibility with previous versions of the content store + -- that did not support compression. New content stores are created supporting + -- compressed contents by default. + confCompressed :: Bool, -- | What 'DigestAlgorithm' is in use by this content store? While we do support -- several different algorithms, only one can ever be in use by a single content -- store. Note that the 'ContentStore' record also stores this piece of @@ -48,7 +52,8 @@ instance FromJSON Config where parseJSON = withObject "Config" $ \v -> - Config <$> v .:? "hash" .!= "BLAKE2b256" + Config <$> v .:? "compressed" .!= False + <*> v .:? "hash" .!= "BLAKE2b256" instance ToJSON Config where toJSON Config{..} = object [ "hash" .= toJSON confHash ] @@ -58,7 +63,8 @@ -- algorithm is defined. defaultConfig :: Config defaultConfig = - Config { confHash = "BLAKE2b256" } + Config { confCompressed = True, + confHash = "BLAKE2b256" } -- | Read a config file on disk, returning the 'Config' record on success and an error -- message on error. This function is typically not useful outside of content store @@ -78,4 +84,5 @@ writeConfig :: FilePath -> Config -> IO () writeConfig path Config{..} = TIO.writeFile path configText where - configText = T.concat ["hash = \"", confHash, "\"\n"] + configText = T.concat ["compressed = ", if confCompressed then "true" else "false", "\n", + "hash = \"", confHash, "\"\n"] diff --git a/content-store.cabal b/content-store.cabal --- a/content-store.cabal +++ b/content-store.cabal @@ -1,5 +1,5 @@ name: content-store -version: 0.1.1 +version: 0.2.0 synopsis: Store and retrieve data from an on-disk store description: This module provides a way to store and retrieve arbitrary data from an on-disk store, similar to how a source @@ -39,6 +39,7 @@ directory >= 1.3.0.0 && < 1.4.0.0, filepath >= 1.4.1.1 && < 1.5.0.0, htoml >= 1.0.0.0 && < 1.1.0.0, + lzma-conduit >= 1.1.0.0 && < 1.2.0.0, monad-control >= 1.0.1.0 && < 1.1.0.0, memory >= 0.14.3 && < 0.15.0, mtl >= 2.2.1 && < 2.3, @@ -58,8 +59,15 @@ hs-source-dirs: tests build-depends: base == 4.*, bytestring >= 0.10 && < 0.11, + conduit >= 1.0.11 && < 1.3, + conduit-combinators >= 1.1.0 && < 1.2, + directory >= 1.3.0.0 && < 1.4.0.0, + filepath >= 1.4.1.1 && < 1.5.0.0, hspec == 2.*, memory >= 0.14.3 && < 0.15.0, + mtl >= 2.2.1 && < 2.3, + resourcet >= 1.1.9 && < 1.2, + temporary >= 1.2.0.4 && < 1.3.0.0, content-store default-language: Haskell2010 diff --git a/tests/Data/ContentStore/DigestSpec.hs b/tests/Data/ContentStore/DigestSpec.hs --- a/tests/Data/ContentStore/DigestSpec.hs +++ b/tests/Data/ContentStore/DigestSpec.hs @@ -8,18 +8,164 @@ import qualified Data.ByteString as B import qualified Data.ByteArray as BA +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + testInput :: B.ByteString testInput = "The Dude abides." -testSHA256Digest :: B.ByteString -testSHA256Digest = "\xcd\x9c\xf3\x08\x62\x61\x24\xa7\x81\x81\xc0\x22\xfb\x9d\x0d\x51\x1a\xf1\xc1\x5d\x32\x20\x12\xf0\xa6\x9d\xfe\x86\x40\xc3\x40\xaa" +specBLAKE2 :: Spec +specBLAKE2 = + describe "Digest.DigestAlgorithm" $ do + it "knows about BLAKE2" $ + digestName <$> getDigestAlgorithm "BLAKE2" `shouldBe` Just "Blake2b_512" -testSHA256Hex :: String -testSHA256Hex = "cd9cf308626124a78181c022fb9d0d511af1c15d322012f0a69dfe8640c340aa" + let daBLAKE2 = fromJust $ getDigestAlgorithm "BLAKE2" + it "has the correct size for BLAKE2" $ + digestSize daBLAKE2 `shouldBe` 64 -spec :: Spec -spec = do + let od = digestByteString daBLAKE2 testInput + let hex = toHex od + + it "does BLAKE2 correctly" $ + BA.convert od `shouldBe` testDigest + + it "converts ObjectDigest to hex" $ + hex `shouldBe` testHex + where + testDigest :: B.ByteString + testDigest = "\x0e\x5e\xf4\x9c\x6b\x5d\xf5\x6f\xca\x89\x9f\xef\xde\x64\x8e\xc6\xc5\x42\x95\xe4\x40\x68\x9d\xe9\xd0\x2c\xaf\xc4\x87\xa6\xdb\xac\x7c\x79\x60\x1e\x2d\xa7\xb3\x13\xc8\x52\xa7\xba\xdd\x1d\x31\x97\x22\xa9\x6b\xd0\xd9\x1c\x06\x75\x97\x4b\x07\x69\xbe\x12\x45\x94" + + testHex :: String + testHex = "0e5ef49c6b5df56fca899fefde648ec6c54295e440689de9d02cafc487a6dbac7c79601e2da7b313c852a7badd1d319722a96bd0d91c0675974b0769be124594" + +specBLAKE2b :: Spec +specBLAKE2b = describe "Digest.DigestAlgorithm" $ do + it "knows about BLAKE2b" $ + digestName <$> getDigestAlgorithm "BLAKE2b" `shouldBe` Just "Blake2b_512" + + let daBLAKE2b = fromJust $ getDigestAlgorithm "BLAKE2b" + it "has the correct size for BLAKE2b" $ + digestSize daBLAKE2b `shouldBe` 64 + + let od = digestByteString daBLAKE2b testInput + let hex = toHex od + + it "does BLAKE2b correctly" $ + BA.convert od `shouldBe` testDigest + + it "converts ObjectDigest to hex" $ + hex `shouldBe` testHex + where + testDigest :: B.ByteString + testDigest = "\x0e\x5e\xf4\x9c\x6b\x5d\xf5\x6f\xca\x89\x9f\xef\xde\x64\x8e\xc6\xc5\x42\x95\xe4\x40\x68\x9d\xe9\xd0\x2c\xaf\xc4\x87\xa6\xdb\xac\x7c\x79\x60\x1e\x2d\xa7\xb3\x13\xc8\x52\xa7\xba\xdd\x1d\x31\x97\x22\xa9\x6b\xd0\xd9\x1c\x06\x75\x97\x4b\x07\x69\xbe\x12\x45\x94" + + testHex :: String + testHex = "0e5ef49c6b5df56fca899fefde648ec6c54295e440689de9d02cafc487a6dbac7c79601e2da7b313c852a7badd1d319722a96bd0d91c0675974b0769be124594" + +specBLAKE2b512 :: Spec +specBLAKE2b512 = + describe "Digest.DigestAlgorithm" $ do + it "knows about BLAKE2b512" $ + digestName <$> getDigestAlgorithm "BLAKE2b512" `shouldBe` Just "Blake2b_512" + + let daBLAKE2b512 = fromJust $ getDigestAlgorithm "BLAKE2b512" + it "has the correct size for BLAKE2b512" $ + digestSize daBLAKE2b512 `shouldBe` 64 + + let od = digestByteString daBLAKE2b512 testInput + let hex = toHex od + + it "does BLAKE2b512 correctly" $ + BA.convert od `shouldBe` testDigest + + it "converts ObjectDigest to hex" $ + hex `shouldBe` testHex + where + testDigest :: B.ByteString + testDigest = "\x0e\x5e\xf4\x9c\x6b\x5d\xf5\x6f\xca\x89\x9f\xef\xde\x64\x8e\xc6\xc5\x42\x95\xe4\x40\x68\x9d\xe9\xd0\x2c\xaf\xc4\x87\xa6\xdb\xac\x7c\x79\x60\x1e\x2d\xa7\xb3\x13\xc8\x52\xa7\xba\xdd\x1d\x31\x97\x22\xa9\x6b\xd0\xd9\x1c\x06\x75\x97\x4b\x07\x69\xbe\x12\x45\x94" + + testHex :: String + testHex = "0e5ef49c6b5df56fca899fefde648ec6c54295e440689de9d02cafc487a6dbac7c79601e2da7b313c852a7badd1d319722a96bd0d91c0675974b0769be124594" + +specBLAKE2b256 :: Spec +specBLAKE2b256 = + describe "Digest.DigestAlgorithm" $ do + it "knows about BLAKE2b256" $ + digestName <$> getDigestAlgorithm "BLAKE2b256" `shouldBe` Just "Blake2b_256" + + let daBLAKE2b256 = fromJust $ getDigestAlgorithm "BLAKE2b256" + it "has the correct size for BLAKE2b256" $ + digestSize daBLAKE2b256 `shouldBe` 32 + + let od = digestByteString daBLAKE2b256 testInput + let hex = toHex od + + it "does BLAKE2b256 correctly" $ + BA.convert od `shouldBe` testDigest + + it "converts ObjectDigest to hex" $ + hex `shouldBe` testHex + where + testDigest :: B.ByteString + testDigest = "\x82\xe4\x69\x8a\x1e\xbe\x82\xed\xae\xc8\xe8\xa6\xdc\xf1\x8d\x57\xbb\x5a\xc6\x71\x8b\x6b\xf2\xbb\xc3\x8a\x00\xda\x2e\x29\x34\xe6" + + testHex :: String + testHex = "82e4698a1ebe82edaec8e8a6dcf18d57bb5ac6718b6bf2bbc38a00da2e2934e6" + +specBLAKE2s :: Spec +specBLAKE2s = + describe "Digest.DigestAlgorithm" $ do + it "knows about BLAKE2s" $ + digestName <$> getDigestAlgorithm "BLAKE2s" `shouldBe` Just "Blake2s_256" + + let daBLAKE2s = fromJust $ getDigestAlgorithm "BLAKE2s" + it "has the correct size for BLAKE2s" $ + digestSize daBLAKE2s `shouldBe` 32 + + let od = digestByteString daBLAKE2s testInput + let hex = toHex od + + it "does BLAKE2s correctly" $ + BA.convert od `shouldBe` testDigest + + it "converts ObjectDigest to hex" $ + hex `shouldBe` testHex + where + testDigest :: B.ByteString + testDigest = "\xfe\x04\xd7\x14\x3e\x23\x1a\x36\xc7\xbd\x1f\x9b\xdb\x36\x04\x56\xdd\xe8\x1c\xb9\x22\x3a\xab\x25\x5f\x74\x9f\x80\xe9\x60\xd7\x9f" + + testHex :: String + testHex = "fe04d7143e231a36c7bd1f9bdb360456dde81cb9223aab255f749f80e960d79f" + +specBLAKE2s256 :: Spec +specBLAKE2s256 = + describe "Digest.DigestAlgorithm" $ do + it "knows about BLAKE2s256" $ + digestName <$> getDigestAlgorithm "BLAKE2s256" `shouldBe` Just "Blake2s_256" + + let daBLAKE2s256 = fromJust $ getDigestAlgorithm "BLAKE2s256" + it "has the correct size for BLAKE2s256" $ + digestSize daBLAKE2s256 `shouldBe` 32 + + let od = digestByteString daBLAKE2s256 testInput + let hex = toHex od + + it "does BLAKE2s256 correctly" $ + BA.convert od `shouldBe` testDigest + + it "converts ObjectDigest to hex" $ + hex `shouldBe` testHex + where + testDigest :: B.ByteString + testDigest = "\xfe\x04\xd7\x14\x3e\x23\x1a\x36\xc7\xbd\x1f\x9b\xdb\x36\x04\x56\xdd\xe8\x1c\xb9\x22\x3a\xab\x25\x5f\x74\x9f\x80\xe9\x60\xd7\x9f" + + testHex :: String + testHex = "fe04d7143e231a36c7bd1f9bdb360456dde81cb9223aab255f749f80e960d79f" + +specSHA256 :: Spec +specSHA256 = do + describe "Digest.DigestAlgorithm" $ do it "knows about SHA256" $ digestName <$> getDigestAlgorithm "SHA256" `shouldBe` Just "SHA256" @@ -31,22 +177,94 @@ let hex = toHex od it "does SHA256 correctly" $ - BA.convert od `shouldBe` testSHA256Digest + BA.convert od `shouldBe` testDigest it "converts ObjectDigest to hex" $ - hex `shouldBe` testSHA256Hex + hex `shouldBe` testHex describe "Digest.DigestContext" $ do let da = fromJust $ getDigestAlgorithm "SHA256" let ctx = digestInit da it "can do digests piece by piece" $ do let hex = toHex $ digestFinalize $ digestUpdate ctx testInput - hex `shouldBe` testSHA256Hex + hex `shouldBe` testHex describe "fromByteString" $ do let da = fromJust $ getDigestAlgorithm "SHA256" let od = digestByteString da testInput it "accepts a 32-byte ByteString" $ - fromByteString da testSHA256Digest `shouldBe` Just od + fromByteString da testDigest `shouldBe` Just od it "rejects wrong-sized ByteString" $ - fromByteString da (B.take 20 testSHA256Digest) `shouldBe` Nothing + fromByteString da (B.take 20 testDigest) `shouldBe` Nothing + where + testDigest :: B.ByteString + testDigest = "\xcd\x9c\xf3\x08\x62\x61\x24\xa7\x81\x81\xc0\x22\xfb\x9d\x0d\x51\x1a\xf1\xc1\x5d\x32\x20\x12\xf0\xa6\x9d\xfe\x86\x40\xc3\x40\xaa" + + testHex :: String + testHex = "cd9cf308626124a78181c022fb9d0d511af1c15d322012f0a69dfe8640c340aa" + +specSHA512 :: Spec +specSHA512 = do + describe "Digest.DigestAlgorithm" $ do + it "knows about SHA512" $ + digestName <$> getDigestAlgorithm "SHA512" `shouldBe` Just "SHA512" + + let daSHA512 = fromJust $ getDigestAlgorithm "SHA512" + it "has the correct size for SHA512" $ + digestSize daSHA512 `shouldBe` 64 + + let od = digestByteString daSHA512 testInput + let hex = toHex od + + it "does SHA512 correctly" $ + BA.convert od `shouldBe` testDigest + + it "converts ObjectDigest to hex" $ + hex `shouldBe` testHex + + describe "Digest.DigestContext" $ do + let da = fromJust $ getDigestAlgorithm "SHA512" + let ctx = digestInit da + it "can do digests piece by piece" $ do + let hex = toHex $ digestFinalize $ digestUpdate ctx testInput + hex `shouldBe` testHex + + describe "fromByteString" $ do + let da = fromJust $ getDigestAlgorithm "SHA512" + let od = digestByteString da testInput + it "accepts a 32-byte ByteString" $ + fromByteString da testDigest `shouldBe` Just od + it "rejects wrong-sized ByteString" $ + fromByteString da (B.take 20 testDigest) `shouldBe` Nothing + where + testDigest :: B.ByteString + testDigest = "\x05\x07\xdb\x94\x58\xc9\xfe\xce\x37\xd5\xfb\x54\xc4\xda\xf4\xe8\x21\x14\xda\xb1\x53\xdc\x0b\x0e\x15\x74\x49\x77\x54\x94\x35\xdc\x78\xc7\x0c\xef\x51\x3e\xb7\x3a\x4f\x80\x81\x2a\x6e\xd5\x73\x1e\xcf\xff\xb4\x95\x98\x56\xfa\x94\x40\x30\xec\x20\x78\x45\xae\x34" + + testHex :: String + testHex = "0507db9458c9fece37d5fb54c4daf4e82114dab153dc0b0e15744977549435dc78c70cef513eb73a4f80812a6ed5731ecfffb4959856fa944030ec207845ae34" + +spec :: Spec +spec = do + describe "SHA256" + specSHA256 + + describe "SHA512" + specSHA512 + + describe "BLAKE2" + specBLAKE2 + + describe "BLAKE2b" + specBLAKE2b + + describe "BLAKE2b512" + specBLAKE2b512 + + describe "BLAKE2b256" + specBLAKE2b256 + + describe "BLAKE2s" + specBLAKE2s + + describe "BLAKE2s256" + specBLAKE2s256 diff --git a/tests/Data/ContentStoreSpec.hs b/tests/Data/ContentStoreSpec.hs --- a/tests/Data/ContentStoreSpec.hs +++ b/tests/Data/ContentStoreSpec.hs @@ -1,10 +1,339 @@ -module Data.ContentStoreSpec(spec) where +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} -import Test.Hspec +module Data.ContentStoreSpec(spec) + where + +import Conduit((.|), ConduitM, runConduitRes, sinkList, yield, yieldMany) +import Control.Monad.Except(ExceptT, runExceptT) +import Control.Monad.Trans.Resource(ResourceT, runResourceT) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Either(isRight) +import Data.Maybe(fromJust) +import Data.Void(Void) +import System.Directory(createDirectory, doesFileExist, getTemporaryDirectory, removeFile) +import System.FilePath.Posix(()) +import System.IO(Handle, hClose) +import System.IO.Temp(openTempFile, withSystemTempDirectory) +import Test.Hspec + import Data.ContentStore +import Data.ContentStore.Digest +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +invalidChecksum :: BS.ByteString +invalidChecksum = "\x82\xe4\x69\x8a\x1e\xbe\x82\xed\xae\xc8\xe8\xa6\xdc\xf1\x8d\x57\xbb\x5a\xc6\x71\x8b\x6b\xf2\xbb\xc3\x8a\x00\xda\x2e\x29\x34\xe6" + +anyDigest :: Either CsError ObjectDigest -> Bool +anyDigest = isRight + +openSystemTempFile :: String -> IO (FilePath, Handle) +openSystemTempFile template = do + dir <- getTemporaryDirectory + openTempFile dir template + +runCs :: ResourceT (ExceptT CsError IO) a -> IO (Either CsError a) +runCs = runExceptT . runResourceT + +runCsConduit :: ConduitM () Void (ResourceT (ExceptT CsError IO)) a -> IO (Either CsError a) +runCsConduit = runExceptT . runConduitRes + +withContentStore :: ActionWith ContentStore -> IO () +withContentStore action = withTempDir $ \d -> + runExceptT (mkContentStore d) >>= either (expectationFailure . show) action + +withStoredFile :: FilePath -> ActionWith (ContentStore, ObjectDigest) -> IO () +withStoredFile f action = + withContentStore $ \cs -> + runCs (storeFile cs f) >>= \case + Left e -> expectationFailure $ show e + Right digest -> action (cs, digest) + +withTempDir :: ActionWith FilePath -> IO () +withTempDir action = + withSystemTempDirectory "cs.repo" action + +contentStoreValidSpec :: Spec +contentStoreValidSpec = + describe "contentStoreValid" $ do + it "raises CsErrorMissing when directory doesn't exist" $ + runExceptT (contentStoreValid "") >>= (`shouldBe` Left CsErrorMissing) + + around withTempDir $ + it "raises CsErrorInvalid when config file doesn't exist" $ \repo -> + runExceptT (contentStoreValid repo) >>= (`shouldBe` Left (CsErrorInvalid "config")) + + around withTempDir $ + it "raises CsErrorInvalid with objects subdir doesn't exist" $ \repo -> do + appendFile (repo "config") "" + runExceptT (contentStoreValid repo) >>= (`shouldBe` Left (CsErrorInvalid "objects")) + + around withTempDir $ + it "raises CsErrorInvalid with tmp subdir doesn't exist" $ \repo -> do + appendFile (repo "config") "" + createDirectory $ repo "objects" + runExceptT (contentStoreValid repo) >>= (`shouldBe` Left (CsErrorInvalid "tmp")) + + around withTempDir $ + it "raises CsErrorInvalid with lock subdir doesn't exist" $ \repo -> do + appendFile (repo "config") "" + createDirectory $ repo "objects" + createDirectory $ repo "tmp" + runExceptT (contentStoreValid repo) >>= (`shouldBe` Left (CsErrorInvalid "lock")) + + around withTempDir $ + it "repo should be valid" $ \repo -> do + appendFile (repo "config") "" + createDirectory $ repo "objects" + createDirectory $ repo "tmp" + createDirectory $ repo "lock" + runExceptT (contentStoreValid repo) >>= (`shouldBe` Right True) + +contentStoreDigestSpec :: Spec +contentStoreDigestSpec = + describe "contentStoreDigest" $ + around withContentStore $ + it "default digest is BLAKE2b256" $ \cs -> + -- The constructors of DigestAlgorithm are not exported, so we can only + -- compare names. + digestName (contentStoreDigest cs) `shouldBe` "Blake2b_256" + +fetchByteStringSpec :: Spec +fetchByteStringSpec = + describe "fetchByteString" $ do + around withContentStore $ + it "raises CsErrorNoSuchObject when the object doesn't exist" $ \cs -> do + let od = fromJust $ fromByteString (contentStoreDigest cs) invalidChecksum + + runCs (fetchByteString cs od) >>= (`shouldBe` Left (CsErrorNoSuchObject $ toHex od)) + + around (withStoredFile __FILE__) $ + it "stored file and fetched file are the same" $ \(cs, digest) -> + runCs (fetchByteString cs digest) >>= \case + Left e -> expectationFailure (show e) + Right bs2 -> do + bs1 <- BS.readFile __FILE__ + bs2 `shouldBe` bs1 + +fetchByteStringCSpec :: Spec +fetchByteStringCSpec = + describe "fetchByteStringC" $ do + around withContentStore $ + it "raises CsErrorNoSuchObject when the object doesn't exist" $ \cs -> do + let od = fromJust $ fromByteString (contentStoreDigest cs) invalidChecksum + + runCsConduit (yield od .| fetchByteStringC cs .| sinkList) >>= (`shouldBe` Left (CsErrorNoSuchObject $ toHex od)) + + around (withStoredFile __FILE__) $ + it "stored file and fetched file are the same" $ \(cs, digest) -> + runCsConduit (yield digest .| fetchByteStringC cs .| sinkList) >>= \case + Right [bs2] -> do + bs1 <- BS.readFile __FILE__ + bs2 `shouldBe` bs1 + Right l -> expectationFailure $ "fetchByteStringC returned " ++ show (length l) ++ " elements" + Left e -> expectationFailure (show e) + + around (withStoredFile __FILE__) $ + it "requesting two digests returns two files" $ \(cs, digest) -> + runCsConduit (yieldMany [digest, digest] .| fetchByteStringC cs .| sinkList) >>= \case + Left e -> expectationFailure (show e) + Right lst -> length lst `shouldBe` 2 + +storeByteStringSpec :: Spec +storeByteStringSpec = + describe "storeByteString" $ do + around withContentStore $ + it "storing a bytestring should return a digest" $ \cs -> + runCs (storeByteString cs "The spice must flow.") >>= (`shouldSatisfy` anyDigest) + + around withContentStore $ + it "duplicate stores do not raise an error" $ \cs -> do + first <- runCs $ storeByteString cs "blahblahblah" + second <- runCs $ storeByteString cs "blahblahblah" + + first `shouldSatisfy` anyDigest + first `shouldBe` second + +storeByteStringCSpec :: Spec +storeByteStringCSpec = + describe "storeByteStringC" $ do + around withContentStore $ + it "storing a bytestring should return a digest" $ \cs -> + runCsConduit (yield "The spice must flow." .| storeByteStringC cs .| sinkList) >>= \case + Left e -> expectationFailure (show e) + Right lst -> length lst `shouldBe` 1 + + around withContentStore $ + it "storing multiple bytestrings should return multiple digests" $ \cs -> do + let strs = ["I must not fear.", + "Fear is the mind-killer.", + "Fear is the little-death that brings total obliteration."] + runCsConduit (yieldMany strs .| storeByteStringC cs .| sinkList) >>= \case + Left e -> expectationFailure (show e) + Right lst -> length lst `shouldBe` 3 + +storeByteStringSinkSpec :: Spec +storeByteStringSinkSpec = + describe "storeByteStringSink" $ + around withContentStore $ + it "storing multiple bytestrings should return a single digest" $ \cs -> do + let strs = ["I must not fear.", + "Fear is the mind-killer.", + "Fear is the little-death that brings total obliteration."] + runCsConduit (yieldMany strs .| storeByteStringSink cs) >>= (`shouldSatisfy` anyDigest) + +fetchLazyByteStringSpec :: Spec +fetchLazyByteStringSpec = + describe "fetchLazyByteString" $ do + around withContentStore $ + it "raises CsErrorNoSuchObject when the object doesn't exist" $ \cs -> do + let od = fromJust $ fromByteString (contentStoreDigest cs) invalidChecksum + + runCs (fetchLazyByteString cs od) >>= (`shouldBe` Left (CsErrorNoSuchObject $ toHex od)) + + around (withStoredFile __FILE__) $ + it "stored file and fetched file are the same" $ \(cs, digest) -> + runCs (fetchLazyByteString cs digest) >>= \case + Left e -> expectationFailure (show e) + Right bs2 -> do + bs1 <- LBS.readFile __FILE__ + bs2 `shouldBe` bs1 + +fetchLazyByteStringCSpec :: Spec +fetchLazyByteStringCSpec = + describe "fetchLazyByteStringC" $ do + around withContentStore $ + it "raises CsErrorNoSuchObject when the object doesn't exist" $ \cs -> do + let od = fromJust $ fromByteString (contentStoreDigest cs) invalidChecksum + + runCsConduit (yield od .| fetchLazyByteStringC cs .| sinkList) >>= (`shouldBe` Left (CsErrorNoSuchObject $ toHex od)) + + around (withStoredFile __FILE__) $ + it "stored file and fetched file are the same" $ \(cs, digest) -> + runCsConduit (yield digest .| fetchLazyByteStringC cs .| sinkList) >>= \case + Right [bs2] -> do + bs1 <- LBS.readFile __FILE__ + bs2 `shouldBe` bs1 + Right _ -> expectationFailure "fetchByteStringC returned more than one element" + Left e -> expectationFailure (show e) + + around (withStoredFile __FILE__) $ + it "requesting two digests returns two files" $ \(cs, digest) -> + runCsConduit (yieldMany [digest, digest] .| fetchLazyByteStringC cs .| sinkList) >>= \case + Left e -> expectationFailure (show e) + Right lst -> length lst `shouldBe` 2 + +storeLazyByteStringSpec :: Spec +storeLazyByteStringSpec = + describe "storeLazyByteString" $ do + around withContentStore $ + it "storing a lazy bytestring should return a digest" $ \cs -> + runCs (storeLazyByteString cs "The spice must flow.") >>= (`shouldSatisfy` anyDigest) + + around withContentStore $ + it "duplicate stores do not raise an error" $ \cs -> do + first <- runCs $ storeLazyByteString cs "blahblahblah" + second <- runCs $ storeLazyByteString cs "blahblahblah" + + first `shouldSatisfy` anyDigest + first `shouldBe` second + +storeLazyByteStringCSpec :: Spec +storeLazyByteStringCSpec = + describe "storeLazyByteStringC" $ do + around withContentStore $ + it "storing a lazy bytestring should return a digest" $ \cs -> + runCsConduit (yield "The spice must flow." .| storeLazyByteStringC cs .| sinkList) >>= \case + Left e -> expectationFailure (show e) + Right lst -> length lst `shouldBe` 1 + + around withContentStore $ + it "storing multiple lazy bytestrings should return multiple digests" $ \cs -> do + let strs = ["I must not fear.", + "Fear is the mind-killer.", + "Fear is the little-death that brings total obliteration."] + runCsConduit (yieldMany strs .| storeLazyByteStringC cs .| sinkList) >>= \case + Left e -> expectationFailure (show e) + Right lst -> length lst `shouldBe` 3 + +storeLazyByteStringSinkSpec :: Spec +storeLazyByteStringSinkSpec = + describe "storeLazyByteStringSink" $ + around withContentStore $ + it "storing multiple bytestrings should return a single digest" $ \cs -> do + let strs = ["I must not fear.", + "Fear is the mind-killer.", + "Fear is the little-death that brings total obliteration."] + runCsConduit (yieldMany strs .| storeLazyByteStringSink cs) >>= (`shouldSatisfy` anyDigest) + +fetchFileSpec :: Spec +fetchFileSpec = + describe "fetchFile" $ do + around withContentStore $ + it "raises CsErrorNoSuchObject when the object doesn't exist" $ \cs -> do + let od = fromJust $ fromByteString (contentStoreDigest cs) invalidChecksum + dest = "yyyyyyyyyyyyyyy" + + runCs (fetchFile cs od dest) >>= (`shouldBe` Left (CsErrorNoSuchObject $ toHex od)) + -- Verify the destination file was not created by conduit. This can happen + -- if sinkFile is used instead of sinkFileCautious. + doesFileExist dest >>= (`shouldBe` False) + + around (withStoredFile __FILE__) $ + it "stored file and fetched file are the same" $ \(cs, digest) -> do + (dest, h) <- openSystemTempFile "dest" + hClose h + + -- Second, pull it back out of the store. + runCs (fetchFile cs digest dest) >>= \case + Left e -> removeFile dest >> expectationFailure (show e) + Right _ -> do + -- Third, compare the two files. They should be the same. + bs1 <- BS.readFile __FILE__ + bs2 <- BS.readFile dest + removeFile dest + bs2 `shouldBe` bs1 + +storeFileSpec :: Spec +storeFileSpec = do + describe "storeFile" $ + around withContentStore $ do + it "raises an IOException when trying to store a missing file" $ \cs -> + runCs (storeFile cs "xxxxxxxxxxxxxxx") `shouldThrow` anyIOException + + it "storing an existing file should return a digest" $ \cs -> + runCs (storeFile cs __FILE__) >>= (`shouldSatisfy` anyDigest) + + describe "storeFile duplicates" $ + around withContentStore $ + it "duplicate stores do not raise an error" $ \cs -> do + first <- runCs $ storeFile cs __FILE__ + second <- runCs $ storeFile cs __FILE__ + + first `shouldSatisfy` anyDigest + first `shouldBe` second + spec :: Spec spec = - describe "ContentStore" $ - it "has dummy test" $ - () `shouldBe` () + describe "ContentStore" $ do + contentStoreDigestSpec + contentStoreValidSpec + fetchByteStringSpec + fetchByteStringCSpec + fetchFileSpec + fetchLazyByteStringSpec + fetchLazyByteStringCSpec + -- mkContentStoreSpec + -- openContentStoreSpec + storeByteStringSpec + storeByteStringCSpec + storeByteStringSinkSpec + -- storeDirectorySpec + storeFileSpec + storeLazyByteStringSpec + storeLazyByteStringCSpec + storeLazyByteStringSinkSpec