diff --git a/Logs/ContentIdentifier.hs b/Logs/ContentIdentifier.hs index 1a0f29021b..b59f7a962e 100644 --- a/Logs/ContentIdentifier.hs +++ b/Logs/ContentIdentifier.hs @@ -20,6 +20,7 @@ import Logs.ContentIdentifier.Pure as X import qualified Annex import qualified Data.Map as M +import Data.List.NonEmpty (NonEmpty(..)) -- | Records a remote's content identifier and the key that it corresponds to. -- @@ -32,7 +33,7 @@ recordContentIdentifier u cid k = do Annex.Branch.change (remoteContentIdentifierLogFile config k) $ buildLog . addcid c . parseLog where - addcid c l = changeMapLog c u (cid:fromMaybe [] (M.lookup u m)) l + addcid c l = changeMapLog c u (cid :| contentIdentifierList (M.lookup u m)) l where m = simpleMap l @@ -40,5 +41,5 @@ recordContentIdentifier u cid k = do getContentIdentifiers :: UUID -> Key -> Annex [ContentIdentifier] getContentIdentifiers u k = do config <- Annex.getGitConfig - fromMaybe [] . M.lookup u . simpleMap . parseLog + contentIdentifierList . M.lookup u . simpleMap . parseLog <$> Annex.Branch.get (remoteContentIdentifierLogFile config k) diff --git a/Logs/ContentIdentifier/Pure.hs b/Logs/ContentIdentifier/Pure.hs index 1ddc6820ac..70916f70a8 100644 --- a/Logs/ContentIdentifier/Pure.hs +++ b/Logs/ContentIdentifier/Pure.hs @@ -20,39 +20,52 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 import Data.ByteString.Builder +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty -type ContentIdentifierLog = Log [ContentIdentifier] +-- A ContentIdentifier can contain "", so to avoid ambiguity +-- in parsing, the list of them in the log must be non-empty. +type ContentIdentifierLog = Log (NonEmpty ContentIdentifier) + +contentIdentifierList :: Maybe (NonEmpty ContentIdentifier) -> [ContentIdentifier] +contentIdentifierList (Just l) = Data.List.NonEmpty.toList l +contentIdentifierList Nothing = [] buildLog :: ContentIdentifierLog -> Builder buildLog = buildLogNew buildContentIdentifierList -buildContentIdentifierList :: [ContentIdentifier] -> Builder +buildContentIdentifierList :: (NonEmpty ContentIdentifier) -> Builder buildContentIdentifierList l = case l of - [] -> mempty - [c] -> buildcid c - (c:cs) -> buildcid c <> charUtf8 ':' <> buildContentIdentifierList cs + c :| [] -> buildcid c + (c :| cs) -> go (c:cs) where buildcid (ContentIdentifier c) | S8.any (`elem` [':', '\r', '\n']) c || "!" `S8.isPrefixOf` c = charUtf8 '!' <> byteString (toB64' c) | otherwise = byteString c + go (c:cs) = buildcid c <> charUtf8 ':' <> go cs + go [] = mempty parseLog :: L.ByteString -> ContentIdentifierLog parseLog = parseLogNew parseContentIdentifierList -parseContentIdentifierList :: A.Parser [ContentIdentifier] -parseContentIdentifierList = reverse . catMaybes <$> valueparser [] +parseContentIdentifierList :: A.Parser (NonEmpty ContentIdentifier) +parseContentIdentifierList = do + first <- cidparser + listparser first [] where - valueparser l = do + cidparser = do b <- A8.takeWhile (/= ':') - let cid = if "!" `S8.isPrefixOf` b - then ContentIdentifier <$> fromB64Maybe' (S.drop 1 b) - else Just $ ContentIdentifier b + return $ if "!" `S8.isPrefixOf` b + then ContentIdentifier $ fromMaybe b (fromB64Maybe' (S.drop 1 b)) + else ContentIdentifier b + listparser first rest = do + cid <- cidparser ifM A8.atEnd - ( return (cid:l) + ( return (first :| reverse (cid:rest)) , do _ <- A8.char ':' - valueparser (cid:l) + listparser first (cid:rest) ) prop_parse_build_contentidentifier_log :: ContentIdentifierLog -> Bool diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index fb9932a227..6285a2e4fe 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -17,6 +17,7 @@ import Test.QuickCheck as X import Data.Time.Clock.POSIX import Data.Ratio import System.Posix.Types +import Data.List.NonEmpty (NonEmpty(..)) import Prelude {- Times before the epoch are excluded. Half with decimal and half without. -} @@ -41,6 +42,10 @@ instance Arbitrary FileID where instance Arbitrary FileOffset where arbitrary = nonNegative arbitrarySizedIntegral +{- Quickcheck lacks this instance. -} +instance Arbitrary l => Arbitrary (NonEmpty l) where + arbitrary = (:|) <$> arbitrary <*> arbitrary + nonNegative :: (Num a, Ord a) => Gen a -> Gen a nonNegative g = g `suchThat` (>= 0)