module Darcs.Repository.Inventory
( Inventory(..)
, HeadInventory
, InventoryEntry
, ValidHash(..)
, InventoryHash
, PatchHash
, PristineHash
, inventoryPatchNames
, parseInventory
, showInventory
, showInventoryPatches
, showInventoryEntry
, emptyInventory
, pokePristineHash
, peekPristineHash
, skipPristineHash
, pristineName
, prop_inventoryParseShow
, prop_peekPokePristineHash
, prop_skipPokePristineHash
) where
import Prelude ()
import Darcs.Prelude hiding ( take )
import Control.Applicative ( optional, many )
import Control.Monad ( guard )
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Darcs.Patch.Info ( PatchInfo, showPatchInfo, readPatchInfo )
import Darcs.Patch.ReadMonads
( ParserM, parseStrictly, string, skipSpace, take, takeTillChar )
import Darcs.Patch.Show ( ShowPatchFor(..) )
import Darcs.Repository.Cache ( okayHash )
import Darcs.Util.Hash ( sha256sum )
import Darcs.Util.Printer
( Doc, (<+>), ($$), hcat, text, invisiblePS, packedString, renderPS )
class ValidHash a where
getValidHash :: a -> String
mkValidHash :: String -> a
newtype InventoryHash = InventoryHash String
deriving (InventoryHash -> InventoryHash -> Bool
(InventoryHash -> InventoryHash -> Bool)
-> (InventoryHash -> InventoryHash -> Bool) -> Eq InventoryHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InventoryHash -> InventoryHash -> Bool
$c/= :: InventoryHash -> InventoryHash -> Bool
== :: InventoryHash -> InventoryHash -> Bool
$c== :: InventoryHash -> InventoryHash -> Bool
Eq, Int -> InventoryHash -> ShowS
[InventoryHash] -> ShowS
InventoryHash -> String
(Int -> InventoryHash -> ShowS)
-> (InventoryHash -> String)
-> ([InventoryHash] -> ShowS)
-> Show InventoryHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InventoryHash] -> ShowS
$cshowList :: [InventoryHash] -> ShowS
show :: InventoryHash -> String
$cshow :: InventoryHash -> String
showsPrec :: Int -> InventoryHash -> ShowS
$cshowsPrec :: Int -> InventoryHash -> ShowS
Show)
instance ValidHash InventoryHash where
getValidHash :: InventoryHash -> String
getValidHash (InventoryHash h :: String
h) = String
h
mkValidHash :: String -> InventoryHash
mkValidHash s :: String
s
| String -> Bool
okayHash String
s = String -> InventoryHash
InventoryHash String
s
| Bool
otherwise = String -> InventoryHash
forall a. HasCallStack => String -> a
error "Bad inventory hash!"
newtype PatchHash = PatchHash String
deriving (PatchHash -> PatchHash -> Bool
(PatchHash -> PatchHash -> Bool)
-> (PatchHash -> PatchHash -> Bool) -> Eq PatchHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PatchHash -> PatchHash -> Bool
$c/= :: PatchHash -> PatchHash -> Bool
== :: PatchHash -> PatchHash -> Bool
$c== :: PatchHash -> PatchHash -> Bool
Eq, Int -> PatchHash -> ShowS
[PatchHash] -> ShowS
PatchHash -> String
(Int -> PatchHash -> ShowS)
-> (PatchHash -> String)
-> ([PatchHash] -> ShowS)
-> Show PatchHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PatchHash] -> ShowS
$cshowList :: [PatchHash] -> ShowS
show :: PatchHash -> String
$cshow :: PatchHash -> String
showsPrec :: Int -> PatchHash -> ShowS
$cshowsPrec :: Int -> PatchHash -> ShowS
Show)
instance ValidHash PatchHash where
getValidHash :: PatchHash -> String
getValidHash (PatchHash h :: String
h) = String
h
mkValidHash :: String -> PatchHash
mkValidHash s :: String
s
| String -> Bool
okayHash String
s = String -> PatchHash
PatchHash String
s
| Bool
otherwise = String -> PatchHash
forall a. HasCallStack => String -> a
error "Bad patch hash!"
newtype PristineHash = PristineHash String
deriving (PristineHash -> PristineHash -> Bool
(PristineHash -> PristineHash -> Bool)
-> (PristineHash -> PristineHash -> Bool) -> Eq PristineHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PristineHash -> PristineHash -> Bool
$c/= :: PristineHash -> PristineHash -> Bool
== :: PristineHash -> PristineHash -> Bool
$c== :: PristineHash -> PristineHash -> Bool
Eq, Int -> PristineHash -> ShowS
[PristineHash] -> ShowS
PristineHash -> String
(Int -> PristineHash -> ShowS)
-> (PristineHash -> String)
-> ([PristineHash] -> ShowS)
-> Show PristineHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PristineHash] -> ShowS
$cshowList :: [PristineHash] -> ShowS
show :: PristineHash -> String
$cshow :: PristineHash -> String
showsPrec :: Int -> PristineHash -> ShowS
$cshowsPrec :: Int -> PristineHash -> ShowS
Show)
instance ValidHash PristineHash where
getValidHash :: PristineHash -> String
getValidHash (PristineHash h :: String
h) = String
h
mkValidHash :: String -> PristineHash
mkValidHash s :: String
s
| String -> Bool
okayHash String
s = String -> PristineHash
PristineHash String
s
| Bool
otherwise = String -> PristineHash
forall a. HasCallStack => String -> a
error "Bad pristine hash!"
type HeadInventory = (PristineHash, Inventory)
data Inventory = Inventory
{ Inventory -> Maybe InventoryHash
inventoryParent :: Maybe InventoryHash
, Inventory -> [InventoryEntry]
inventoryPatches :: [InventoryEntry]
} deriving (Inventory -> Inventory -> Bool
(Inventory -> Inventory -> Bool)
-> (Inventory -> Inventory -> Bool) -> Eq Inventory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Inventory -> Inventory -> Bool
$c/= :: Inventory -> Inventory -> Bool
== :: Inventory -> Inventory -> Bool
$c== :: Inventory -> Inventory -> Bool
Eq, Int -> Inventory -> ShowS
[Inventory] -> ShowS
Inventory -> String
(Int -> Inventory -> ShowS)
-> (Inventory -> String)
-> ([Inventory] -> ShowS)
-> Show Inventory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Inventory] -> ShowS
$cshowList :: [Inventory] -> ShowS
show :: Inventory -> String
$cshow :: Inventory -> String
showsPrec :: Int -> Inventory -> ShowS
$cshowsPrec :: Int -> Inventory -> ShowS
Show)
type InventoryEntry = (PatchInfo, PatchHash)
inventoryPatchNames :: Inventory -> [String]
inventoryPatchNames :: Inventory -> [String]
inventoryPatchNames = (InventoryEntry -> String) -> [InventoryEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PatchHash -> String
forall a. ValidHash a => a -> String
getValidHash (PatchHash -> String)
-> (InventoryEntry -> PatchHash) -> InventoryEntry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InventoryEntry -> PatchHash
forall a b. (a, b) -> b
snd) ([InventoryEntry] -> [String])
-> (Inventory -> [InventoryEntry]) -> Inventory -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [InventoryEntry]
inventoryPatches
emptyInventory :: Inventory
emptyInventory :: Inventory
emptyInventory = Maybe InventoryHash -> [InventoryEntry] -> Inventory
Inventory Maybe InventoryHash
forall a. Maybe a
Nothing []
parseInventory :: B.ByteString -> Maybe Inventory
parseInventory :: ByteString -> Maybe Inventory
parseInventory = ((Inventory, ByteString) -> Inventory)
-> Maybe (Inventory, ByteString) -> Maybe Inventory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Inventory, ByteString) -> Inventory
forall a b. (a, b) -> a
fst (Maybe (Inventory, ByteString) -> Maybe Inventory)
-> (ByteString -> Maybe (Inventory, ByteString))
-> ByteString
-> Maybe Inventory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SM Inventory -> ByteString -> Maybe (Inventory, ByteString)
forall a. SM a -> ByteString -> Maybe (a, ByteString)
parseStrictly SM Inventory
forall (m :: * -> *). ParserM m => m Inventory
pInv
pInv :: ParserM m => m Inventory
pInv :: m Inventory
pInv = Maybe InventoryHash -> [InventoryEntry] -> Inventory
Inventory (Maybe InventoryHash -> [InventoryEntry] -> Inventory)
-> m (Maybe InventoryHash) -> m ([InventoryEntry] -> Inventory)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe InventoryHash)
forall (m :: * -> *). ParserM m => m (Maybe InventoryHash)
pInvParent m ([InventoryEntry] -> Inventory)
-> m [InventoryEntry] -> m Inventory
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [InventoryEntry]
forall (m :: * -> *). ParserM m => m [InventoryEntry]
pInvPatches
pInvParent :: ParserM m => m (Maybe InventoryHash)
pInvParent :: m (Maybe InventoryHash)
pInvParent = m InventoryHash -> m (Maybe InventoryHash)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (m InventoryHash -> m (Maybe InventoryHash))
-> m InventoryHash -> m (Maybe InventoryHash)
forall a b. (a -> b) -> a -> b
$ do
ByteString -> m ()
forall (m :: * -> *). ParserM m => ByteString -> m ()
string ByteString
parentName
m ()
forall (m :: * -> *). ParserM m => m ()
skipSpace
m InventoryHash
forall (m :: * -> *) h. (ParserM m, ValidHash h) => m h
pHash
pHash :: (ParserM m, ValidHash h) => m h
pHash :: m h
pHash = do
String
hash <- ByteString -> String
BC.unpack (ByteString -> String) -> m ByteString -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ByteString
forall (m :: * -> *). ParserM m => m ByteString
pLine
Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String -> Bool
okayHash String
hash)
h -> m h
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> h
forall a. ValidHash a => String -> a
mkValidHash String
hash)
pLine :: ParserM m => m B.ByteString
pLine :: m ByteString
pLine = Char -> m ByteString
forall (m :: * -> *). ParserM m => Char -> m ByteString
takeTillChar '\n' m ByteString -> m ByteString -> m ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> m ByteString
forall (m :: * -> *). ParserM m => Int -> m ByteString
take 1
pInvPatches :: ParserM m => m [InventoryEntry]
pInvPatches :: m [InventoryEntry]
pInvPatches = m InventoryEntry -> m [InventoryEntry]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m InventoryEntry
forall (m :: * -> *). ParserM m => m InventoryEntry
pInvEntry
pInvEntry :: ParserM m => m InventoryEntry
pInvEntry :: m InventoryEntry
pInvEntry = do
PatchInfo
info <- m PatchInfo
forall (m :: * -> *). ParserM m => m PatchInfo
readPatchInfo
m ()
forall (m :: * -> *). ParserM m => m ()
skipSpace
ByteString -> m ()
forall (m :: * -> *). ParserM m => ByteString -> m ()
string ByteString
hashName
m ()
forall (m :: * -> *). ParserM m => m ()
skipSpace
PatchHash
hash <- m PatchHash
forall (m :: * -> *) h. (ParserM m, ValidHash h) => m h
pHash
InventoryEntry -> m InventoryEntry
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchInfo
info, PatchHash
hash)
showInventory :: Inventory -> Doc
showInventory :: Inventory -> Doc
showInventory inv :: Inventory
inv =
Maybe InventoryHash -> Doc
showParent (Inventory -> Maybe InventoryHash
inventoryParent Inventory
inv) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
[InventoryEntry] -> Doc
showInventoryPatches (Inventory -> [InventoryEntry]
inventoryPatches Inventory
inv)
showInventoryPatches :: [InventoryEntry] -> Doc
showInventoryPatches :: [InventoryEntry] -> Doc
showInventoryPatches = [Doc] -> Doc
hcat ([Doc] -> Doc)
-> ([InventoryEntry] -> [Doc]) -> [InventoryEntry] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InventoryEntry -> Doc) -> [InventoryEntry] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map InventoryEntry -> Doc
showInventoryEntry
showInventoryEntry :: InventoryEntry -> Doc
showInventoryEntry :: InventoryEntry -> Doc
showInventoryEntry (pinf :: PatchInfo
pinf, hash :: PatchHash
hash) =
ShowPatchFor -> PatchInfo -> Doc
showPatchInfo ShowPatchFor
ForStorage PatchInfo
pinf Doc -> Doc -> Doc
$$
ByteString -> Doc
packedString ByteString
hashName Doc -> Doc -> Doc
<+> String -> Doc
text (PatchHash -> String
forall a. ValidHash a => a -> String
getValidHash PatchHash
hash) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
packedString ByteString
newline
showParent :: Maybe InventoryHash -> Doc
showParent :: Maybe InventoryHash -> Doc
showParent (Just (InventoryHash hash :: String
hash)) =
ByteString -> Doc
packedString ByteString
parentName Doc -> Doc -> Doc
$$ String -> Doc
text String
hash Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
packedString ByteString
newline
showParent Nothing = Doc
forall a. Monoid a => a
mempty
pokePristineHash :: String -> B.ByteString -> Doc
pokePristineHash :: String -> ByteString -> Doc
pokePristineHash h :: String
h inv :: ByteString
inv =
ByteString -> Doc
invisiblePS ByteString
pristineName Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
h Doc -> Doc -> Doc
$$ ByteString -> Doc
invisiblePS (ByteString -> ByteString
skipPristineHash ByteString
inv)
takeHash :: B.ByteString -> Maybe (String, B.ByteString)
takeHash :: ByteString -> Maybe (String, ByteString)
takeHash input :: ByteString
input = do
let (hline :: ByteString
hline,rest :: ByteString
rest) = ByteString -> ByteString -> (ByteString, ByteString)
BC.breakSubstring ByteString
newline ByteString
input
let hash :: String
hash = ByteString -> String
BC.unpack ByteString
hline
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
okayHash String
hash
(String, ByteString) -> Maybe (String, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
hash, ByteString
rest)
peekPristineHash :: B.ByteString -> String
peekPristineHash :: ByteString -> String
peekPristineHash inv :: ByteString
inv =
case ByteString -> Maybe ByteString
tryDropPristineName ByteString
inv of
Just rest :: ByteString
rest ->
case ByteString -> Maybe (String, ByteString)
takeHash ByteString
rest of
Just (h :: String
h, _) -> String
h
Nothing -> ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ "Bad hash in inventory!"
Nothing -> ByteString -> String
sha256sum ByteString
B.empty
skipPristineHash :: B.ByteString -> B.ByteString
skipPristineHash :: ByteString -> ByteString
skipPristineHash ps :: ByteString
ps =
case ByteString -> Maybe ByteString
tryDropPristineName ByteString
ps of
Just rest :: ByteString
rest -> Int -> ByteString -> ByteString
B.drop 1 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BC.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n') ByteString
rest
Nothing -> ByteString
ps
tryDropPristineName :: B.ByteString -> Maybe B.ByteString
tryDropPristineName :: ByteString -> Maybe ByteString
tryDropPristineName input :: ByteString
input =
if ByteString
prefix ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
pristineName then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
rest else Maybe ByteString
forall a. Maybe a
Nothing
where
(prefix :: ByteString
prefix, rest :: ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt (ByteString -> Int
B.length ByteString
pristineName) ByteString
input
pristineName :: B.ByteString
pristineName :: ByteString
pristineName = String -> ByteString
BC.pack "pristine:"
parentName :: B.ByteString
parentName :: ByteString
parentName = String -> ByteString
BC.pack "Starting with inventory:"
hashName :: B.ByteString
hashName :: ByteString
hashName = String -> ByteString
BC.pack "hash:"
newline :: B.ByteString
newline :: ByteString
newline = String -> ByteString
BC.pack "\n"
prop_inventoryParseShow :: Inventory -> Bool
prop_inventoryParseShow :: Inventory -> Bool
prop_inventoryParseShow inv :: Inventory
inv =
Inventory -> Maybe Inventory
forall a. a -> Maybe a
Just Inventory
inv Maybe Inventory -> Maybe Inventory -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe Inventory
parseInventory (Doc -> ByteString
renderPS (Inventory -> Doc
showInventory Inventory
inv))
prop_peekPokePristineHash :: (PristineHash, B.ByteString) -> Bool
prop_peekPokePristineHash :: (PristineHash, ByteString) -> Bool
prop_peekPokePristineHash (PristineHash hash :: String
hash, raw :: ByteString
raw) =
String
hash String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> String
peekPristineHash (Doc -> ByteString
renderPS (String -> ByteString -> Doc
pokePristineHash String
hash ByteString
raw))
prop_skipPokePristineHash :: (PristineHash, B.ByteString) -> Bool
prop_skipPokePristineHash :: (PristineHash, ByteString) -> Bool
prop_skipPokePristineHash (PristineHash hash :: String
hash, raw :: ByteString
raw) =
ByteString
raw ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
skipPristineHash (Doc -> ByteString
renderPS (String -> ByteString -> Doc
pokePristineHash String
hash ByteString
raw))