module Darcs.Repository.State
( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir
, unrecordedChanges, unrecordedChangesWithPatches, readPending
, readRecorded, readUnrecorded, readRecordedAndPending, readWorking
, readPendingAndWorking
, readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..)
, filterOutConflicts ) where
import Prelude hiding ( filter, catch )
import Control.Monad( when )
import Control.Applicative( (<$>) )
import Control.Exception ( catch, IOException )
import Data.Maybe( isJust )
import Data.List( union )
import Text.Regex( matchRegex )
import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile )
import System.FilePath ( (</>) )
import qualified Data.ByteString as BS
( readFile, drop, writeFile, empty )
import qualified Data.ByteString.Char8 as BSC
( pack, split )
import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrim, fromPrims
, effect, anonymous )
import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths )
import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (+>+), mapFL_FL
, (:>)(..) )
import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal )
import Darcs.Patch.Commute ( selfCommuter )
import Darcs.Patch.CommuteFn ( commuterIdRL )
import Darcs.Patch.Permutations ( partitionConflictingFL )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )
import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..) )
import Darcs.Util.Global ( darcsdir )
import Darcs.Repository.InternalTypes ( Repository(..) )
import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir))
import qualified Darcs.Repository.LowLevel as LowLevel
import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps )
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Util.Path( AnchoredPath(..), anchorPath, floatPath, Name(..), fn2fp,
SubPath, sp2fn, filterPaths )
import Storage.Hashed.Tree( Tree, restrict, FilterTree, expand, filter, emptyTree, overlay, find )
import Storage.Hashed.Plain( readPlainTree )
import Storage.Hashed.Darcs( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )
import Storage.Hashed.Hash( Hash( NoHash ) )
import qualified Storage.Hashed.Index as I
import qualified Storage.Hashed.Tree as Tree
newtype TreeFilter m = TreeFilter { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m }
readPendingLL :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT -> IO (Sealed ((FL p) wT))
readPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` LowLevel.readPending repo
restrictSubpaths :: forall p m wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT -> [SubPath]
-> IO (TreeFilter m)
restrictSubpaths repo subpaths = do
Sealed pending <- readPendingLL repo
let paths = map (fn2fp . sp2fn) subpaths
paths' = paths `union` effectOnFilePaths pending paths
anchored = map floatPath paths'
restrictPaths :: FilterTree tree m => tree m -> tree m
restrictPaths = filter (filterPaths anchored)
return (TreeFilter restrictPaths)
inDarcsDir :: AnchoredPath -> Bool
inDarcsDir (AnchoredPath (Name x:_)) | x == BSC.pack darcsdir = True
inDarcsDir _ = False
restrictBoring :: forall m . Tree m -> IO (TreeFilter m)
restrictBoring guide = do
boring <- boringRegexps
let boring' p | inDarcsDir p = False
boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring
where p' = anchorPath "" p
restrictTree :: FilterTree t m => t m -> t m
restrictTree = filter $ \p _ -> case find guide p of
Nothing -> boring' p
_ -> True
return (TreeFilter restrictTree)
restrictDarcsdir :: forall m . TreeFilter m
restrictDarcsdir = TreeFilter $ filter $ \p _ -> not (inDarcsDir p)
unrecordedChanges :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree)
=> (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT
-> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU)
unrecordedChanges opts r paths = do
(pending :> working) <- readPendingAndWorking opts r paths
return $ sortCoalesceFL (pending +>+ working)
unrecordedChangesWithPatches :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
=> (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT
-> Maybe [SubPath]
-> FL (PrimOf p) wX wT
-> FL (PrimOf p) wT wT
-> IO (FL (PrimOf p) wT wU)
unrecordedChangesWithPatches opts r paths movesPs replacesPs = do
(pending :> working) <- readPendingAndWorkingWithPatches opts r paths movesPs replacesPs
return $ sortCoalesceFL (pending +>+ unsafeCoerceP (movesPs +>+ replacesPs) +>+ working)
readPendingAndWorkingWithPatches :: forall p wR wU wT wZ. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
=> (UseIndex, ScanKnown, DiffAlgorithm)
-> Repository p wR wU wT
-> Maybe [SubPath]
-> FL (PrimOf p) wZ wT
-> FL (PrimOf p) wT wT
-> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU)
readPendingAndWorkingWithPatches _ r@(Repo _ rf _ _) _ _ _ | (formatHas NoWorkingDir rf) = do
IsEq <- return $ workDirLessRepoWitness r
return (NilFL :> NilFL)
readPendingAndWorkingWithPatches (useidx', scan, dflag) repo mbpaths movesPs replacesPs = do
let allPatches = movesPs +>+ replacesPs
let useidx = case allPatches of
NilFL -> useidx'
_ -> IgnoreIndex
(all_current, Sealed (pending :: FL p wT wX)) <- readPending repo
all_current_with_patches <- applyToTree allPatches all_current
relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths
let getIndex = applyToTree movesPs =<< I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo)
current = applyTreeFilter relevant all_current_with_patches
index <- getIndex
working <- applyTreeFilter restrictDarcsdir <$> case scan of
ScanKnown -> case useidx of
UseIndex -> getIndex
IgnoreIndex -> do
guide <- expand current
applyTreeFilter relevant <$> restrict guide <$> readPlainTree "."
ScanAll -> do
nonboring <- restrictBoring index
plain <- applyTreeFilter relevant <$> applyTreeFilter nonboring <$> readPlainTree "."
return $ case useidx of
UseIndex -> plain `overlay` index
IgnoreIndex -> plain
ScanBoring -> do
plain <- applyTreeFilter relevant <$> readPlainTree "."
return $ case useidx of
UseIndex -> plain `overlay` index
IgnoreIndex -> plain
ft <- filetypeFunction
Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX))
IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU)
return (effect pending :> diff)
readPendingAndWorking :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree)
=> (UseIndex, ScanKnown, DiffAlgorithm)
-> Repository p wR wU wT
-> Maybe [SubPath]
-> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU)
readPendingAndWorking _ r@(Repo _ rf _ _) _ | (formatHas NoWorkingDir rf) = do
IsEq <- return $ workDirLessRepoWitness r
return (NilFL :> NilFL)
readPendingAndWorking (useidx, scan, dflag) repo mbpaths = do
(all_current, Sealed (pending :: FL p wT wX)) <- readPending repo
relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths
let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo)
current = applyTreeFilter relevant all_current
index <- getIndex
working <- applyTreeFilter restrictDarcsdir <$> case scan of
ScanKnown -> case useidx of
UseIndex -> getIndex
IgnoreIndex -> do
guide <- expand current
applyTreeFilter relevant <$> restrict guide <$> readPlainTree "."
ScanAll -> do
nonboring <- restrictBoring index
plain <- applyTreeFilter relevant <$> applyTreeFilter nonboring <$> readPlainTree "."
return $ case useidx of
UseIndex -> plain `overlay` index
IgnoreIndex -> plain
ScanBoring -> do
plain <- applyTreeFilter relevant <$> readPlainTree "."
return $ case useidx of
UseIndex -> plain `overlay` index
IgnoreIndex -> plain
ft <- filetypeFunction
Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX))
IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU)
return (effect pending :> diff)
workDirLessRepoWitness :: Repository p wR wU wT -> EqCheck wU wT
workDirLessRepoWitness (Repo _ rf _ _)
| formatHas NoWorkingDir rf = unsafeCoerceP IsEq
| otherwise = NotEq
readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO)
readRecorded _repo = do
let h_inventory = darcsdir </> "hashed_inventory"
hashed <- doesFileExist h_inventory
if hashed
then do inv <- BS.readFile h_inventory
let linesInv = BSC.split '\n' inv
case linesInv of
[] -> return emptyTree
(pris_line:_) -> do
let hash = decodeDarcsHash $ BS.drop 9 pris_line
size = decodeDarcsSize $ BS.drop 9 pris_line
when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line
readDarcsHashed (darcsdir </> "pristine.hashed") (size, hash)
else do have_pristine <- doesDirectoryExist $ darcsdir </> "pristine"
have_current <- doesDirectoryExist $ darcsdir </> "current"
case (have_pristine, have_current) of
(True, _) -> readPlainTree $ darcsdir </> "pristine"
(False, True) -> readPlainTree $ darcsdir </> "current"
(_, _) -> fail "No pristine tree is available!"
readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
readUnrecorded repo mbpaths = do
relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths
readIndex repo >>= I.updateIndex . applyTreeFilter relevant
readWorking :: IO (Tree IO)
readWorking = expand =<< (nodarcs `fmap` readPlainTree ".")
where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BSC.pack darcsdir)
readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT -> IO (Tree IO)
readRecordedAndPending repo = fst `fmap` readPending repo
readPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT -> IO (Tree IO, Sealed (FL p wT))
readPending repo =
do Sealed pending <- readPendingLL repo
pristine <- readRecorded repo
catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ (err :: IOException) -> do
putStrLn $ "Yikes, pending has conflicts! " ++ show err
putStrLn "Stashing the buggy pending as _darcs/patches/pending_buggy"
renameFile (darcsdir </> "patches" </> "pending")
(darcsdir </> "patches" </> "pending_buggy")
return (pristine, seal NilFL)
invalidateIndex :: t -> IO ()
invalidateIndex _ = BS.writeFile (darcsdir </> "index_invalid") BS.empty
readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO I.Index
readIndex repo = do
invalid <- doesFileExist $ darcsdir </> "index_invalid"
exists <- doesFileExist $ darcsdir </> "index"
formatValid <- if exists
then I.indexFormatValid $ darcsdir </> "index"
else return True
when (exists && not formatValid) $
#if mingw32_HOST_OS
renameFile (darcsdir </> "index") (darcsdir </> "index.old")
#else
removeFile $ darcsdir </> "index"
#endif
if not exists || invalid || not formatValid
then do pris <- readRecordedAndPending repo
idx <- I.updateIndexFrom (darcsdir </> "index") darcsTreeHash pris
when invalid $ removeFile $ darcsdir </> "index_invalid"
return idx
else I.readIndex (darcsdir </> "index") darcsTreeHash
updateIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()
updateIndex repo = do
invalid <- doesFileExist $ darcsdir </> "index_invalid"
exists <- doesFileExist $ darcsdir </> "index"
formatValid <- if exists
then I.indexFormatValid $ darcsdir </> "index"
else return True
when (exists && not formatValid) $
#if mingw32_HOST_OS
renameFile (darcsdir </> "index") (darcsdir </> "index.old")
#else
removeFile $ darcsdir </> "index"
#endif
pris <- readRecordedAndPending repo
_ <- I.updateIndexFrom (darcsdir </> "index") darcsTreeHash pris
when invalid $ removeFile $ darcsdir </> "index_invalid"
filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree)
=> RL (PatchInfoAnd p) wX wT
-> Repository p wR wU wT
-> FL (PatchInfoAnd p) wX wZ
-> IO (Bool, Sealed (FL (PatchInfoAnd p) wX))
filterOutConflicts us repository them
= do let commuter = commuterIdRL selfCommuter
unrec <- fmap n2pia . anonymous . fromPrims
=<< unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository Nothing
them' :> rest <- return $ partitionConflictingFL commuter them (unrec :<: us)
return (check rest, Sealed them')
where check :: FL p wA wB -> Bool
check NilFL = False
check _ = True