content-store 0.1.1 → 0.2.0

raw patch · 6 files changed

+650/−64 lines, 6 filesdep +lzma-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: lzma-conduit

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• Data/ContentStore.hs +52/−42
• Data/ContentStore/Config.hs +12/−5
• content-store.cabal +9/−1
• tests/Data/ContentStore/DigestSpec.hs +229/−11
• tests/Data/ContentStoreSpec.hs +334/−5

@@ -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.

@@ -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

@@ -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"]

@@ -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

@@ -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

@@ -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