diff --git a/Logs/ContentIdentifier.hs b/Logs/ContentIdentifier.hs index 8329eb17c6..5ce4ec3b61 100644 --- a/Logs/ContentIdentifier.hs +++ b/Logs/ContentIdentifier.hs @@ -6,6 +6,7 @@ -} module Logs.ContentIdentifier ( + module X, recordContentIdentifier, getContentIdentifiers, ) where @@ -15,7 +16,7 @@ import Logs import Logs.MapLog import Types.Remote (ContentIdentifier) import qualified Annex.Branch -import Logs.ContentIdentifier.Pure +import Logs.ContentIdentifier.Pure as X import qualified Annex import qualified Data.Map as M diff --git a/Logs/ContentIdentifier/Pure.hs b/Logs/ContentIdentifier/Pure.hs index 8e8e7e04c4..ee45f61ef0 100644 --- a/Logs/ContentIdentifier/Pure.hs +++ b/Logs/ContentIdentifier/Pure.hs @@ -7,11 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} -module Logs.ContentIdentifier.Pure - ( ContentIdentifierLog - , parseLog - , buildLog - ) where +module Logs.ContentIdentifier.Pure where import Annex.Common import Logs.MapLog @@ -28,11 +24,14 @@ import Data.ByteString.Builder type ContentIdentifierLog = MapLog UUID [ContentIdentifier] buildLog :: ContentIdentifierLog -> Builder -buildLog = buildMapLog buildUUID valuebuilder +buildLog = buildMapLog buildUUID buildContentIdentifierList + +buildContentIdentifierList :: [ContentIdentifier] -> Builder +buildContentIdentifierList l = case l of + [] -> mempty + [c] -> buildcid c + (c:cs) -> buildcid c <> charUtf8 ' ' <> buildContentIdentifierList cs where - valuebuilder [] = mempty - valuebuilder [c] = buildcid c - valuebuilder (c:cs) = buildcid c <> charUtf8 ' ' <> valuebuilder cs buildcid (ContentIdentifier c) | S8.any (`elem` [' ', '\r', '\n']) c || "!" `S8.isPrefixOf` c = charUtf8 '!' <> byteString (toB64' c) @@ -41,7 +40,10 @@ buildLog = buildMapLog buildUUID valuebuilder parseLog :: L.ByteString -> ContentIdentifierLog parseLog = parseMapLog (toUUID <$> A.takeByteString) - (reverse . catMaybes <$> valueparser []) + parseContentIdentifierList + +parseContentIdentifierList :: A.Parser [ContentIdentifier] +parseContentIdentifierList = reverse . catMaybes <$> valueparser [] where valueparser l = do b <- A8.takeWhile1 (/= ' ') @@ -54,3 +56,7 @@ parseLog = parseMapLog _ <- A8.char ' ' valueparser (cid:l) ) + +prop_parse_build_contentidentifier_log :: ContentIdentifierLog -> Bool +prop_parse_build_contentidentifier_log l = + parseLog (toLazyByteString (buildLog l)) == l diff --git a/Logs/MapLog.hs b/Logs/MapLog.hs index 72307b2fb0..bd4b8866ac 100644 --- a/Logs/MapLog.hs +++ b/Logs/MapLog.hs @@ -20,6 +20,7 @@ module Logs.MapLog ( import Common import Annex.VectorClock import Logs.Line +import Utility.QuickCheck import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as M @@ -32,6 +33,9 @@ data LogEntry v = LogEntry , value :: v } deriving (Eq, Show) +instance Arbitrary v => Arbitrary (LogEntry v) where + arbitrary = LogEntry <$> arbitrary <*> arbitrary + type MapLog f v = M.Map f (LogEntry v) buildMapLog :: (f -> Builder) -> (v -> Builder) -> MapLog f v -> Builder diff --git a/Logs/Presence/Pure.hs b/Logs/Presence/Pure.hs index 778f9c6458..a508f2125e 100644 --- a/Logs/Presence/Pure.hs +++ b/Logs/Presence/Pure.hs @@ -122,6 +122,5 @@ instance Arbitrary LogLine where arbinfo = (encodeBS <$> arbitrary) `suchThat` (\b -> C8.notElem '\n' b && C8.notElem '\r' b) -prop_parse_build_log :: [LogLine] -> Bool -prop_parse_build_log l = parseLog (toLazyByteString (buildLog l)) == l - +prop_parse_build_presence_log :: [LogLine] -> Bool +prop_parse_build_presence_log l = parseLog (toLazyByteString (buildLog l)) == l diff --git a/Test.hs b/Test.hs index 4cc15ea87c..25849d2b93 100644 --- a/Test.hs +++ b/Test.hs @@ -48,6 +48,7 @@ import qualified Logs.Remote import qualified Logs.Unused import qualified Logs.Transfer import qualified Logs.Presence +import qualified Logs.ContentIdentifier import qualified Logs.PreferredContent import qualified Types.MetaData import qualified Remote @@ -175,7 +176,8 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" , testProperty "prop_segment_regressionTest" Utility.Misc.prop_segment_regressionTest , testProperty "prop_read_write_transferinfo" Logs.Transfer.prop_read_write_transferinfo , testProperty "prop_read_show_inodecache" Utility.InodeCache.prop_read_show_inodecache - , testProperty "prop_parse_build_log" Logs.Presence.prop_parse_build_log + , testProperty "prop_parse_build_presence_log" Logs.Presence.prop_parse_build_presence_log + , testProperty "prop_parse_build_contentidentifier_log" Logs.ContentIdentifier.prop_parse_build_contentidentifier_log , testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel , testProperty "prop_parse_build_TrustLevelLog" Logs.Trust.prop_parse_build_TrustLevelLog , testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable diff --git a/Types/Remote.hs b/Types/Remote.hs index a33d2c85bc..dea51aaf32 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -45,6 +45,7 @@ import Utility.Metered import Git.Types (RemoteName) import Utility.SafeCommand import Utility.Url +import Utility.QuickCheck type RemoteConfigKey = String @@ -246,7 +247,7 @@ data ExportActions a = ExportActions {- An identifier for content stored on a remote. It should be reasonably - short since it is stored in the git-annex branch. -} newtype ContentIdentifier = ContentIdentifier S.ByteString - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Arbitrary) {- Some remotes may support importing a history of versions of content that - is stored in them. This is equivilant to a git commit history. -} @@ -256,6 +257,7 @@ data ContentHistory t { contentHistoryCurrent :: t , contentHistoryPrev :: [ContentHistory t] } + deriving (Show) data ImportActions a = ImportActions -- Finds the current set of files that are stored in the remote, diff --git a/Types/UUID.hs b/Types/UUID.hs index 3910f34481..61bfab06dd 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -14,10 +14,12 @@ import qualified Data.Map as M import qualified Data.UUID as U import Data.Maybe import Data.String +import Data.Char import Data.ByteString.Builder import qualified Data.Semigroup as Sem import Utility.FileSystemEncoding +import Utility.QuickCheck import qualified Utility.SimpleProtocol as Proto -- A UUID is either an arbitrary opaque string, or UUID info may be missing. @@ -81,3 +83,11 @@ type UUIDDescMap = M.Map UUID UUIDDesc instance Proto.Serializable UUID where serialize = fromUUID deserialize = Just . toUUID + +instance Arbitrary UUID where + arbitrary = frequency [(1, return NoUUID), (3, UUID <$> arb)] + where + -- Avoid non-ascii because fully arbitrary + -- strings may not be encoded using the filesystem + -- encoding, which is normally applied to all input. + arb = encodeBS <$> arbitrary `suchThat` all isAscii