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
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
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 = forall a. HasCallStack => String -> a
error String
"Bad inventory hash!"

newtype PatchHash = PatchHash String
  deriving (PatchHash -> PatchHash -> Bool
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
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 = forall a. HasCallStack => String -> a
error String
"Bad patch hash!"

newtype PristineHash = PristineHash String
  deriving (PristineHash -> PristineHash -> Bool
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
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 = 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
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
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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. ValidHash a => a -> String
getValidHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [InventoryEntry]
inventoryPatches

emptyInventory :: Inventory
emptyInventory :: Inventory
emptyInventory = Maybe InventoryHash -> [InventoryEntry] -> Inventory
Inventory forall a. Maybe a
Nothing []

-- * Parsing

parseHeadInventory :: B.ByteString -> Either String HeadInventory
parseHeadInventory :: ByteString -> Either String HeadInventory
parseHeadInventory = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse Parser Inventory
pInv

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

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

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

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

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

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

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

pInvEntry :: Parser InventoryEntry
pInvEntry :: Parser InventoryEntry
pInvEntry = do
  PatchInfo
info <- Parser PatchInfo
readPatchInfo
  Parser ()
skipSpace
  ByteString -> Parser ()
string ByteString
hashName
  Parser ()
skipSpace
  PatchHash
hash <- forall h. ValidHash h => Parser h
pHash
  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) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall a. ValidHash a => a -> String
getValidHash PatchHash
hash) 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 forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
packedString ByteString
newline
showParent Maybe InventoryHash
Nothing = 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 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
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ String -> Bool
okayHash String
hash
  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
_) -> forall a. ValidHash a => String -> a
mkValidHash String
h
        Maybe (String, ByteString)
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Bad hash in inventory!"
    Maybe ByteString
Nothing -> forall a. ValidHash a => String -> a
mkValidHash 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 forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BC.dropWhile (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 forall a. Eq a => a -> a -> Bool
== ByteString
pristineName then forall a. a -> Maybe a
Just ByteString
rest else 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 =
  forall a b. b -> Either a b
Right Inventory
inv 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 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 forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
skipPristineHash (Doc -> ByteString
renderPS (PristineHash -> ByteString -> Doc
pokePristineHash PristineHash
hash ByteString
raw))