module Darcs.Repository.Inventory
    ( Inventory(..)
    , HeadInventory
    , InventoryEntry
    , ValidHash(..)
    , InventoryHash
    , PatchHash
    , PristineHash
    , inventoryPatchNames
    , parseInventory
    , parseHeadInventory -- not used
    , showInventory
    , showInventoryPatches
    , showInventoryEntry
    , emptyInventory
    , pokePristineHash
    , peekPristineHash
    , skipPristineHash
    , pristineName
    -- properties
    , prop_inventoryParseShow
    , prop_peekPokePristineHash
    , prop_skipPokePristineHash
    ) where

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.Util.Parser
    ( Parser, parse, 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 )

-- * Hash validation

-- TODO the ValidHash class and the newtypes for the various hashes
-- really don't belong here. They should be moved to D.R.Cache or
-- perhaps a separate module. Also, the validation should be extended
-- see D.R.Cache.checkHash.

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 String
h) = String
h
  mkValidHash :: String -> InventoryHash
mkValidHash String
s
    | String -> Bool
okayHash String
s = String -> InventoryHash
InventoryHash String
s
    | Bool
otherwise = String -> InventoryHash
forall a. HasCallStack => String -> a
error String
"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 String
h) = String
h
  mkValidHash :: String -> PatchHash
mkValidHash String
s
    | String -> Bool
okayHash String
s = String -> PatchHash
PatchHash String
s
    | Bool
otherwise = String -> PatchHash
forall a. HasCallStack => String -> a
error String
"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 String
h) = String
h
  mkValidHash :: String -> PristineHash
mkValidHash String
s
    | String -> Bool
okayHash String
s = String -> PristineHash
PristineHash String
s
    | Bool
otherwise = String -> PristineHash
forall a. HasCallStack => String -> a
error String
"Bad pristine hash!"

-- * Inventories

-- This type and the parser combinators for it aren't actually used. They are
-- here to serve as documentation for the API we would like to use but won't
-- because of efficiency: we want to be able to access the pristine hash
-- without forcing a complete parse of the head inventory. Thus we retain the
-- lower-level peek/poke/skip API for the 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)

-- The 'String' is the (hashed) patch filename.
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 []

-- * Parsing

parseHeadInventory :: B.ByteString -> Either String HeadInventory
parseHeadInventory :: ByteString -> Either String HeadInventory
parseHeadInventory = ((HeadInventory, ByteString) -> HeadInventory)
-> Either String (HeadInventory, ByteString)
-> Either String HeadInventory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HeadInventory, ByteString) -> HeadInventory
forall a b. (a, b) -> a
fst (Either String (HeadInventory, ByteString)
 -> Either String HeadInventory)
-> (ByteString -> Either String (HeadInventory, ByteString))
-> ByteString
-> Either String HeadInventory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser HeadInventory
-> ByteString -> Either String (HeadInventory, ByteString)
forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse Parser HeadInventory
pHeadInv

parseInventory :: B.ByteString -> Either String Inventory
parseInventory :: ByteString -> Either String Inventory
parseInventory = ((Inventory, ByteString) -> Inventory)
-> Either String (Inventory, ByteString) -> Either String Inventory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Inventory, ByteString) -> Inventory
forall a b. (a, b) -> a
fst (Either String (Inventory, ByteString) -> Either String Inventory)
-> (ByteString -> Either String (Inventory, ByteString))
-> ByteString
-> Either String Inventory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Inventory
-> ByteString -> Either String (Inventory, ByteString)
forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse Parser Inventory
pInv

pHeadInv :: Parser HeadInventory
pHeadInv :: Parser HeadInventory
pHeadInv = (,) (PristineHash -> Inventory -> HeadInventory)
-> Parser ByteString PristineHash
-> Parser ByteString (Inventory -> HeadInventory)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString PristineHash
pPristineHash Parser ByteString (Inventory -> HeadInventory)
-> Parser Inventory -> Parser HeadInventory
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Inventory
pInv

pPristineHash :: Parser PristineHash
pPristineHash :: Parser ByteString PristineHash
pPristineHash = do
  ByteString -> Parser ()
string ByteString
pristineName
  Parser ()
skipSpace
  Parser ByteString PristineHash
forall h. ValidHash h => Parser h
pHash

pInv :: Parser Inventory
pInv :: Parser Inventory
pInv = Maybe InventoryHash -> [InventoryEntry] -> Inventory
Inventory (Maybe InventoryHash -> [InventoryEntry] -> Inventory)
-> Parser ByteString (Maybe InventoryHash)
-> Parser ByteString ([InventoryEntry] -> Inventory)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Maybe InventoryHash)
pInvParent Parser ByteString ([InventoryEntry] -> Inventory)
-> Parser ByteString [InventoryEntry] -> Parser Inventory
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString [InventoryEntry]
pInvPatches

pInvParent :: Parser (Maybe InventoryHash)
pInvParent :: Parser ByteString (Maybe InventoryHash)
pInvParent = Parser ByteString InventoryHash
-> Parser ByteString (Maybe InventoryHash)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ByteString InventoryHash
 -> Parser ByteString (Maybe InventoryHash))
-> Parser ByteString InventoryHash
-> Parser ByteString (Maybe InventoryHash)
forall a b. (a -> b) -> a -> b
$ do
  ByteString -> Parser ()
string ByteString
parentName
  Parser ()
skipSpace
  Parser ByteString InventoryHash
forall h. ValidHash h => Parser h
pHash

pHash :: ValidHash h => Parser h
pHash :: Parser h
pHash = do
  String
hash <- ByteString -> String
BC.unpack (ByteString -> String)
-> Parser ByteString ByteString -> Parser ByteString String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
pLine
  Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String -> Bool
okayHash String
hash)
  h -> Parser h
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> h
forall a. ValidHash a => String -> a
mkValidHash String
hash)

pLine :: Parser B.ByteString
pLine :: Parser ByteString ByteString
pLine = Char -> Parser ByteString ByteString
takeTillChar Char
'\n' Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> Parser ByteString ByteString
take Int
1

pInvPatches :: Parser [InventoryEntry]
pInvPatches :: Parser ByteString [InventoryEntry]
pInvPatches = Parser ByteString InventoryEntry
-> Parser ByteString [InventoryEntry]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString InventoryEntry
pInvEntry

pInvEntry :: Parser InventoryEntry
pInvEntry :: Parser ByteString InventoryEntry
pInvEntry = do
  PatchInfo
info <- Parser PatchInfo
readPatchInfo
  Parser ()
skipSpace
  ByteString -> Parser ()
string ByteString
hashName
  Parser ()
skipSpace
  PatchHash
hash <- Parser PatchHash
forall h. ValidHash h => Parser h
pHash
  InventoryEntry -> Parser ByteString InventoryEntry
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchInfo
info, PatchHash
hash)

-- * Showing

showInventory :: Inventory -> Doc
showInventory :: Inventory -> Doc
showInventory 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 (PatchInfo
pinf, 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 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 Maybe InventoryHash
Nothing = Doc
forall a. Monoid a => a
mempty

-- * Accessing the pristine hash

-- | Replace the pristine hash at the start of a raw, unparsed 'HeadInventory'
-- or add it if none is present.
pokePristineHash :: PristineHash -> B.ByteString -> Doc
pokePristineHash :: PristineHash -> ByteString -> Doc
pokePristineHash (PristineHash String
h) 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 ByteString
input = do
  let (ByteString
hline,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 -> PristineHash
peekPristineHash :: ByteString -> PristineHash
peekPristineHash ByteString
inv =
  case ByteString -> Maybe ByteString
tryDropPristineName ByteString
inv of
    Just ByteString
rest ->
      case ByteString -> Maybe (String, ByteString)
takeHash ByteString
rest of
        Just (String
h, ByteString
_) -> String -> PristineHash
forall a. ValidHash a => String -> a
mkValidHash String
h
        Maybe (String, ByteString)
Nothing -> String -> PristineHash
forall a. HasCallStack => String -> a
error (String -> PristineHash) -> String -> PristineHash
forall a b. (a -> b) -> a -> b
$ String
"Bad hash in inventory!"
    Maybe ByteString
Nothing -> String -> PristineHash
forall a. ValidHash a => String -> a
mkValidHash (String -> PristineHash) -> String -> PristineHash
forall a b. (a -> b) -> a -> b
$ ByteString -> String
sha256sum ByteString
B.empty

-- |skipPristineHash drops the 'pristine: HASH' prefix line, if present.
skipPristineHash :: B.ByteString -> B.ByteString
skipPristineHash :: ByteString -> ByteString
skipPristineHash ByteString
ps =
  case ByteString -> Maybe ByteString
tryDropPristineName ByteString
ps of
    Just ByteString
rest -> Int -> ByteString -> ByteString
B.drop Int
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
/= Char
'\n') ByteString
rest
    Maybe ByteString
Nothing -> ByteString
ps

tryDropPristineName :: B.ByteString -> Maybe B.ByteString
tryDropPristineName :: ByteString -> Maybe ByteString
tryDropPristineName 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
    (ByteString
prefix, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt (ByteString -> Int
B.length ByteString
pristineName) ByteString
input

-- * Key phrases

pristineName :: B.ByteString
pristineName :: ByteString
pristineName = String -> ByteString
BC.pack String
"pristine:"

parentName :: B.ByteString
parentName :: ByteString
parentName = String -> ByteString
BC.pack String
"Starting with inventory:"

hashName :: B.ByteString
hashName :: ByteString
hashName = String -> ByteString
BC.pack String
"hash:"

newline :: B.ByteString
newline :: ByteString
newline = String -> ByteString
BC.pack String
"\n"

-- * Properties

prop_inventoryParseShow :: Inventory -> Bool
prop_inventoryParseShow :: Inventory -> Bool
prop_inventoryParseShow Inventory
inv =
  Inventory -> Either String Inventory
forall a b. b -> Either a b
Right Inventory
inv Either String Inventory -> Either String Inventory -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Either String 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, ByteString
raw) =
  PristineHash
hash PristineHash -> PristineHash -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> PristineHash
peekPristineHash (Doc -> ByteString
renderPS (PristineHash -> ByteString -> Doc
pokePristineHash PristineHash
hash ByteString
raw))

prop_skipPokePristineHash :: (PristineHash, B.ByteString) -> Bool
prop_skipPokePristineHash :: (PristineHash, ByteString) -> Bool
prop_skipPokePristineHash (PristineHash
hash, ByteString
raw) =
  ByteString
raw ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
skipPristineHash (Doc -> ByteString
renderPS (PristineHash -> ByteString -> Doc
pokePristineHash PristineHash
hash ByteString
raw))