-- Copyright (C) 2006-2007 David Roundy
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software Foundation,
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

{-# LANGUAGE CPP #-}
module Darcs.Repository.Hashed
    ( inventoriesDir
    , pristineDir
    , patchesDir
    , hashedInventory
    , revertTentativeChanges
    , revertRepositoryChanges
    , finalizeTentativeChanges
    , cleanPristine
    , filterDirContents
    , cleanInventories
    , cleanPatches
    , copyPristine
    , copyPartialsPristine
    , applyToTentativePristine
    , applyToTentativePristineCwd
    , addToSpecificInventory
    , addToTentativeInventory
    , removeFromTentativeInventory
    , readRepo
    , readRepoHashed
    , readTentativeRepo
    , readRepoUsingSpecificInventory
    , writeAndReadPatch
    , writeTentativeInventory
    , copyHashedInventory
    , readHashedPristineRoot
    , pris2inv
    , inv2pris
    , listInventories
    , listInventoriesLocal
    , listInventoriesRepoDir
    , listPatchesLocalBucketed
    , writePatchIfNecessary
    , readRepoFromInventoryList
    , readPatchIds
    , set
    , unset
    , withRecorded
    , withTentative
    , tentativelyAddPatch
    , tentativelyRemovePatches
    , tentativelyRemovePatches_
    , tentativelyAddPatch_
    , tentativelyAddPatches_
    , tentativelyReplacePatches
    , finalizeRepositoryChanges
    , unrevertUrl
    , createPristineDirectoryTree
    , createPartialsPristineDirectoryTree
    , reorderInventory
    , cleanRepository
    , UpdatePristine(..)
    , repoXor
    ) where

#include "impossible.h"

import Prelude ()
import Darcs.Prelude

import Control.Arrow ( (&&&) )
import Control.Exception ( catch, IOException )
import Darcs.Util.Exception ( catchall )
import Control.Monad ( when, unless, void )
import Data.Maybe
import Data.List( foldl' )


import qualified Data.ByteString as B ( null, length, empty ,tail, drop,
                                        ByteString, splitAt, readFile )
import qualified Data.ByteString.Char8 as BC
    ( unpack, dropWhile, break, pack, append, ByteString )
import qualified Data.Set as Set
import Darcs.Util.Hash( encodeBase16, Hash(..) )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Crypt.SHA1 ( SHA1, sha1Xor, zero )
import Darcs.Util.Tree( treeHash, Tree )
import Darcs.Util.Tree.Hashed( hashedTreeIO, readDarcsHashedNosize,
                             readDarcsHashed, writeDarcsHashed,
                             decodeDarcsHash, decodeDarcsSize )
import Darcs.Util.SignalHandler ( withSignalsBlocked )

import System.Directory ( createDirectoryIfMissing, getDirectoryContents
                        , doesFileExist, doesDirectoryExist )
import System.FilePath.Posix( (</>) )
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( stderr, hPutStrLn )

import Darcs.Util.External
    ( copyFileOrUrl
    , cloneFile
    , fetchFilePS
    , gzFetchFilePS
    , Cachable( Uncachable )
    )
import Darcs.Repository.Flags ( Compression, RemoteDarcs, remoteDarcs
    , Verbosity(..), UpdateWorking (..), WithWorkingDir (WithWorkingDir) )

import Darcs.Repository.Format ( RepoProperty( HashedInventory ), formatHas )
import Darcs.Repository.Pending
    ( readPending
    , pendingName
    , tentativelyRemoveFromPending
    , finalizePending
    , setTentativePending
    , prepend
    )
import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk, doesPatchIndexExist )
import Darcs.Repository.State ( readRecorded, updateIndex )

import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Lock
    ( writeBinFile
    , writeDocBinFile
    , writeAtomicFilePS
    , appendDocBinFile
    , removeFileMayNotExist
    )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..)
                       , SealedPatchSet, Origin
                       , patchSet2RL
                       )

import Darcs.Patch.Show ( ShowPatch, ShowPatchFor(..) )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch, info,
                                  extractHash, createHashed, hopefully )
import Darcs.Patch ( IsRepoType, RepoPatch, Patchy, showPatch, apply
                   , Effect
                   , description
                   , commuteRL
                   , readPatch
                   , effect
                   , invert
                   )

import Darcs.Patch.Apply ( ApplyState )

import Darcs.Patch.Prim ( PrimPatchBase )
import Darcs.Patch.Bundle ( scanBundle
                          , makeBundleN
                          )
import Darcs.Patch.Info ( isTag, makePatchname )
import Darcs.Patch.Named.Wrapped ( namedIsInternal )
import Darcs.Patch.Read ( ReadPatch )
import Darcs.Patch.ReadMonads ( parseStrictly )
import Darcs.Patch.Depends ( removeFromPatchSet, slightlyOptimizePatchset
                           , mergeThem, splitOnTag )
import Darcs.Patch.Info ( PatchInfo, showPatchInfo, displayPatchInfo,
                          readPatchInfo )
import Darcs.Util.Path ( FilePathLike, ioAbsoluteOrRemote, toPath
                       , AbsolutePath, toFilePath )
import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache,
                                speculateFilesUsingCache, writeFileUsingCache,
                                okayHash, takeHash,
                                HashedDir(..), hashedDir, peekInCache, bucketFolder )
import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,
                                   cleanHashdir )
import Darcs.Repository.InternalTypes
    ( Repository
    , repoCache
    , repoFormat
    , repoLocation
    , withRepoLocation
    , coerceT )
import qualified Darcs.Repository.Old as Old ( readOldRepo, oldRepoFailMsg )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Patch.Witnesses.Ordered
    ( (+<+), FL(..), RL(..), mapRL, foldFL_M
    , (:>)(..), lengthFL, filterOutFLFL
    , reverseFL, reverseRL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )


import Darcs.Util.ByteString ( gzReadFilePS, dropSpace )
import Darcs.Util.Crypt.SHA256 ( sha256sum )
import Darcs.Util.Printer.Color ( showDoc )
import Darcs.Util.Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text,
                 invisiblePS, putDocLn, (<+>) )
import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )
import Darcs.Patch.Progress (progressFL)
import Darcs.Util.Workaround ( renameFile )
import Darcs.Repository.Prefs ( globalCacheDir )

makeDarcsdirPath :: String -> String
makeDarcsdirPath name = darcsdir </> name

hashedInventory, hashedInventoryPath :: String
hashedInventory = "hashed_inventory"
hashedInventoryPath = makeDarcsdirPath hashedInventory

tentativeHashedInventory, tentativeHashedInventoryPath :: String
tentativeHashedInventory = "tentative_hashed_inventory"
tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory

inventoriesDir, inventoriesDirPath :: String
inventoriesDir = "inventories"
inventoriesDirPath = makeDarcsdirPath inventoriesDir

pristineDir, tentativePristinePath, pristineDirPath :: String
tentativePristinePath = makeDarcsdirPath "tentative_pristine"
pristineDir = "pristine.hashed"
pristineDirPath = makeDarcsdirPath pristineDir

patchesDir, patchesDirPath :: String
patchesDir = "patches"
patchesDirPath = makeDarcsdirPath patchesDir

pristineNamePrefix :: String
pristineNamePrefix = "pristine:"

pristineName :: B.ByteString
pristineName = BC.pack pristineNamePrefix

-- | 'applyToHashedPristine' takes a root hash, a patch @p@ and attempts to
-- apply the patch to the 'Tree' identified by @h@. If we encounter an old,
-- size-prefixed pristine, we first convert it to the non-size-prefixed format,
-- then apply the patch.
applyToHashedPristine :: (ApplyState p ~ Tree, Patchy p) => String -> p wX wY
                      -> IO String
applyToHashedPristine h p = applyOrConvertOldPristineAndApply
  where
    applyOrConvertOldPristineAndApply =
        tryApply hash `catch` \(_ :: IOException) -> handleOldPristineAndApply

    hash = decodeDarcsHash $ BC.pack h

    failOnMalformedRoot (SHA256 _) = return ()
    failOnMalformedRoot root = fail $ "Cannot handle hash: " ++ show root

    hash2root = BC.unpack . encodeBase16

    tryApply :: Hash -> IO String
    tryApply root = do
        failOnMalformedRoot root
        -- Read a non-size-prefixed pristine, failing if we encounter one.
        tree <- readDarcsHashedNosize pristineDirPath root
        (_, updatedTree) <- hashedTreeIO (apply p) tree pristineDirPath
        return . hash2root $ treeHash updatedTree

    warn = "WARNING: Doing a one-time conversion of pristine format.\n"
           ++ "This may take a while. The new format is backwards-compatible."

    handleOldPristineAndApply = do
        hPutStrLn stderr warn
        inv <- gzReadFilePS hashedInventoryPath
        let oldroot = BC.pack $ inv2pris inv
            oldrootSizeandHash = (decodeDarcsSize &&& decodeDarcsHash) oldroot
        -- Read the old size-prefixed pristine tree
        old <- readDarcsHashed pristineDirPath oldrootSizeandHash
        -- Write out the pristine tree as a non-size-prefixed pristine.
        root <- writeDarcsHashed old pristineDirPath
        let newroot = hash2root root
        -- Write out the new inventory.
        writeDocBinFile hashedInventoryPath $ pris2inv newroot inv
        cleanHashdir (Ca []) HashedPristineDir [newroot]
        hPutStrLn stderr "Pristine conversion done..."
        -- Retry applying the patch, which should now succeed.
        tryApply root

-- |revertTentativeChanges swaps the tentative and "real" hashed inventory
-- files, and then updates the tentative pristine with the "real" inventory
-- hash.
revertTentativeChanges :: IO ()
revertTentativeChanges = do
    cloneFile hashedInventoryPath tentativeHashedInventoryPath
    i <- gzReadFilePS hashedInventoryPath
    writeBinFile tentativePristinePath $ BC.append pristineName (BC.pack (inv2pris i))

-- |finalizeTentativeChanges trys to atomically swap the tentative
-- inventory/pristine pointers with the "real" pointers; it first re-reads the
-- inventory to optimize it, presumably to take account of any new tags, and
-- then writes out the new tentative inventory, and finally does the atomic
-- swap. In general, we can't clean the pristine cache at the same time, since
-- a simultaneous get might be in progress.
finalizeTentativeChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                         => Repository rt p wR wU wT -> Compression -> IO ()
finalizeTentativeChanges r compr = do
    debugMessage "Optimizing the inventory..."
    -- Read the tentative patches
    ps <- readTentativeRepo r "."
    writeTentativeInventory (repoCache r) compr ps
    i <- gzReadFilePS tentativeHashedInventoryPath
    p <- gzReadFilePS tentativePristinePath
    -- Write out the "optimised" tentative inventory.
    writeDocBinFile tentativeHashedInventoryPath $ pris2inv (inv2pris p) i
    -- Atomically swap.
    renameFile tentativeHashedInventoryPath hashedInventoryPath

-- |readHashedPristineRoot attempts to read the pristine hash from the current
-- inventory, returning Nothing if it cannot do so.
readHashedPristineRoot :: Repository rt p wR wU wT -> IO (Maybe String)
readHashedPristineRoot r = withRepoLocation r $ do
    i <- (Just <$> gzReadFilePS hashedInventoryPath)
         `catch` (\(_ :: IOException) -> return Nothing)
    return $ inv2pris <$> i

-- |cleanPristine removes any obsolete (unreferenced) entries in the pristine
-- cache.
cleanPristine :: Repository rt p wR wU wT -> IO ()
cleanPristine r = withRepoLocation r $ do
    debugMessage "Cleaning out the pristine cache..."
    i <- gzReadFilePS hashedInventoryPath
    cleanHashdir (repoCache r) HashedPristineDir [inv2pris i]

-- |filterDirContents returns the contents of the directory @d@
-- except files whose names begin with '.' (directories . and ..,
-- hidden files) and files whose names are filtered by the function @f@, if
-- @dir@ is empty, no paths are returned.
filterDirContents :: FilePath -> (FilePath -> Bool) -> IO [FilePath]
filterDirContents d f = do
    let realPath = makeDarcsdirPath d
    exists <- doesDirectoryExist realPath
    if exists
        then filter (\x -> head x /= '.' && f x) <$>
            getDirectoryContents realPath
        else return []

-- |set converts a list of strings into a set of Char8 ByteStrings for faster
-- Set operations.
set :: [String] -> Set.Set BC.ByteString
set = Set.fromList . map BC.pack

-- |unset is the inverse of set.
unset :: Set.Set BC.ByteString -> [String]
unset = map BC.unpack . Set.toList

-- |cleanInventories removes any obsolete (unreferenced) files in the
-- inventories directory.
cleanInventories :: Repository rt p wR wU wT -> IO ()
cleanInventories _ = do
    debugMessage "Cleaning out inventories..."
    hs <- listInventoriesLocal
    fs <- filterDirContents inventoriesDir (const True)
    mapM_ (removeFileMayNotExist . (inventoriesDirPath </>))
        (unset $ (set fs) `Set.difference` (set hs))

-- |specialPatches list of special patch files that may exist in the directory
-- _darcs/patches/.
specialPatches :: [FilePath]
specialPatches = ["unrevert", "pending", "pending.tentative"]

-- |cleanPatches removes any obsolete (unreferenced) files in the
-- patches directory.
cleanPatches :: Repository rt p wR wU wT -> IO ()
cleanPatches _ = do
    debugMessage "Cleaning out patches..."
    hs <- listPatchesLocal darcsdir
    fs <- filterDirContents patchesDir (`notElem` specialPatches)
    mapM_ (removeFileMayNotExist . (patchesDirPath </>))
        (unset $ (set fs) `Set.difference` (set hs))


-- |addToSpecificInventory adds a patch to a specific inventory file, and
-- returns the FilePath whichs corresponds to the written-out patch.
addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression
                       -> PatchInfoAnd rt p wX wY -> IO FilePath
addToSpecificInventory invPath c compr p = do
    let invFile = darcsdir </> invPath
    hash <- snd <$> writePatchIfNecessary c compr p
    appendDocBinFile invFile $ showPatchInfo ForStorage (info p) $$ text ("hash: " ++ hash ++ "\n")
    return $ darcsdir </> "patches" </> hash

addToTentativeInventory :: RepoPatch p => Cache -> Compression
                        -> PatchInfoAnd rt p wX wY -> IO FilePath
addToTentativeInventory = addToSpecificInventory tentativeHashedInventory

-- | Attempt to remove an FL of patches from the tentative inventory.
-- This is used for commands that wish to modify already-recorded patches.
--
-- Precondition: it must be possible to remove the patches, i.e.
--
-- * the patches are in the repository
--
-- * any necessary commutations will succeed
removeFromTentativeInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                             => Repository rt p wR wU wT -> Compression
                             -> FL (PatchInfoAnd rt p) wX wT -> IO ()
removeFromTentativeInventory repo compr to_remove = do
    debugMessage $ "Start removeFromTentativeInventory"
    allpatches <- readTentativeRepo repo "."
    remaining <- case removeFromPatchSet to_remove allpatches of
        Nothing -> bug "Hashed.removeFromTentativeInventory: precondition violated"
        Just r -> return r
    writeTentativeInventory (repoCache repo) compr remaining
    debugMessage $ "Done removeFromTentativeInventory"

-- |writeHashFile takes a Doc and writes it as a hash-named file, returning the
-- filename that the contents were written to.
writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String
writeHashFile c compr subdir d = do
    debugMessage $ "Writing hash file to " ++ hashedDir subdir
    writeFileUsingCache c compr subdir $ renderPS d

-- |readRepo returns the "current" repo patchset.
readRepoHashed :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT
               -> String -> IO (PatchSet rt p Origin wR)
readRepoHashed = readRepoUsingSpecificInventory hashedInventory

-- |readRepo returns the tentative repo patchset.
readTentativeRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                  => Repository rt p wR wU wT -> String
                  -> IO (PatchSet rt p Origin wT)
readTentativeRepo = readRepoUsingSpecificInventory tentativeHashedInventory

-- |readRepoUsingSpecificInventory uses the inventory at @invPath@ to read the
-- repository @repo@.
readRepoUsingSpecificInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                               => String -> Repository rt p wR wU wT
                               -> String -> IO (PatchSet rt p Origin wS)
readRepoUsingSpecificInventory invPath repo dir = do
    realdir <- toPath <$> ioAbsoluteOrRemote dir
    Sealed ps <- readRepoPrivate (repoCache repo) realdir invPath
                 `catch` \e -> do
                     hPutStrLn stderr ("Invalid repository: " ++ realdir)
                     ioError e
    return $ unsafeCoerceP ps
  where
    readRepoPrivate :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Cache -> FilePath
                    -> FilePath -> IO (SealedPatchSet rt p Origin)
    readRepoPrivate cache d iname = do
      inventory <- readInventoryPrivate (d </> darcsdir) iname
      readRepoFromInventoryList cache inventory

-- |readRepoFromInventoryList allows the caller to provide an optional "from
-- inventory" hash, and a list of info/hash pairs that identify a list of
-- patches, returning a patchset of the resulting repo.
readRepoFromInventoryList :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Cache
                          -> (Maybe String, [(PatchInfo, String)])
                          -> IO (SealedPatchSet rt p Origin)
readRepoFromInventoryList cache = parseinvs
  where
    speculateAndParse h is i = speculate h is >> parse i h

    read_patches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]
                 -> IO (Sealed (RL (PatchInfoAnd rt p) wX))
    read_patches [] = return $ seal NilRL
    read_patches allis@((i1, h1) : is1) =
        lift2Sealed (\p rest -> rest :<: i1 `patchInfoAndPatch` p) (rp is1)
                    (createHashed h1 (const $ speculateAndParse h1 allis i1))
      where
        rp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]
           -> IO (Sealed (RL (PatchInfoAnd rt p) wX))
        rp [] = return $ seal NilRL
        rp [(i, h), (il, hl)] =
            lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)
                        (rp [(il, hl)])
                        (createHashed h
                            (const $ speculateAndParse h (reverse allis) i))
        rp ((i, h) : is) =
            lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)
                        (rp is)
                        (createHashed h (parse i))

    read_tag :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String)
             -> IO (Sealed (PatchInfoAnd rt p wX))
    read_tag (i, h) =
        mapSeal (patchInfoAndPatch i) <$> createHashed h (parse i)

    speculate :: String -> [(PatchInfo, String)] -> IO ()
    speculate h is = do
        already_got_one <- peekInCache cache HashedPatchesDir h
        unless already_got_one $
            speculateFilesUsingCache cache HashedPatchesDir (map snd is)

    parse :: ReadPatch p => PatchInfo -> String -> IO (Sealed (p wX))
    parse i h = do
        debugMessage ("Reading patch file: "++ showDoc (displayPatchInfo i))
        (fn, ps) <- fetchFileUsingCache cache HashedPatchesDir h
        case readPatch ps of
            Just p -> return p
            Nothing -> fail $ unlines [ "Couldn't parse file " ++ fn
                                      , "which is patch"
                                      , renderString $ displayPatchInfo i ]

    parseinvs :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
              => (Maybe String, [(PatchInfo, String)])
              -> IO (SealedPatchSet rt p Origin)
    parseinvs (Nothing, ris) =
        mapSeal (PatchSet NilRL) <$> read_patches (reverse ris)
    parseinvs (Just h, []) =
        bug $ "bad inventory " ++ h ++ " (no tag) in parseinvs!"
    parseinvs (Just h, t : ris) = do
        Sealed ts <- unseal seal <$> unsafeInterleaveIO (read_ts t h)
        Sealed ps <- unseal seal <$>
                        unsafeInterleaveIO (read_patches $ reverse ris)
        return $ seal $ PatchSet ts ps

    read_ts :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String)
            -> String -> IO (Sealed (RL (Tagged rt p) Origin))
    read_ts tag0 h0 = do
        contents <- unsafeInterleaveIO $ readTaggedInventoryFromHash h0
        let is = reverse $ case contents of
                               (Just _, _ : ris0) -> ris0
                               (Nothing, ris0) -> ris0
                               (Just _, []) -> bug "inventory without tag!"
        Sealed ts <- unseal seal <$>
                         unsafeInterleaveIO
                            (case contents of
                                 (Just h', t' : _) -> read_ts t' h'
                                 (Just _, []) -> bug "inventory without tag!"
                                 (Nothing, _) -> return $ seal NilRL)
        Sealed ps <- unseal seal <$> unsafeInterleaveIO (read_patches is)
        Sealed tag00 <- read_tag tag0
        return $ seal $ ts :<: Tagged tag00 (Just h0) ps

    readTaggedInventoryFromHash :: String
                                -> IO (Maybe String, [(PatchInfo, String)])
    readTaggedInventoryFromHash invHash = do
        (fileName, pristineAndInventory) <-
            fetchFileUsingCache cache HashedInventoriesDir invHash
        readInventoryFromContent fileName pristineAndInventory

    lift2Sealed :: (forall wY wZ . q wY wZ -> p wX wY -> r wX wZ)
                -> IO (Sealed (p wX))
                -> (forall wB . IO (Sealed (q wB)))
                -> IO (Sealed (r wX))
    lift2Sealed f iox ioy = do
        Sealed x <- unseal seal <$> unsafeInterleaveIO iox
        Sealed y <- unseal seal <$> unsafeInterleaveIO ioy
        return $ seal $ f y x

-- |readInventoryPrivate reads the inventory with name @invName@ in @dir@.
readInventoryPrivate :: String -> String
                     -> IO (Maybe String, [(PatchInfo, String)])
readInventoryPrivate dir invName = do
    inv <- skipPristine <$> gzFetchFilePS (dir </> invName) Uncachable
    readInventoryFromContent (toPath dir ++ "/" ++ darcsdir ++ invName) inv

-- |readInventoryFromContent extracts an inventory from the content of an
-- inventory file, who's path is @fileName@.
readInventoryFromContent :: FilePath -> B.ByteString
                         -> IO (Maybe String, [(PatchInfo, String)])
readInventoryFromContent fileName pristineAndInventory = do
    (hash, patchIds) <-
        if mbStartingWith == BC.pack "Starting with inventory:"
            then let (hash, pids) = BC.break ('\n' ==) $ B.tail pistr
                     hashStr = BC.unpack hash in
                 if okayHash hashStr
                     then return (Just hashStr, pids)
                     else fail $ "Bad hash in file " ++ fileName
            else return (Nothing, inventory)
    return (hash, readPatchIds patchIds)
  where
    inventory = skipPristine pristineAndInventory
    (mbStartingWith, pistr) = BC.break ('\n' ==) inventory

-- |copyRepo copies the hashed inventory of @repo@ to the repository located at
-- @remote@.
copyHashedInventory :: RepoPatch p => Repository rt p wR wU wT -> RemoteDarcs -> String -> IO ()
copyHashedInventory outrepo rdarcs inloc | remote <- remoteDarcs rdarcs = do
    let outloc = repoLocation outrepo
    createDirectoryIfMissing False (outloc ++ "/" ++ inventoriesDirPath)
    copyFileOrUrl remote (inloc </> darcsdir </> hashedInventory)
                         (outloc </> darcsdir </> hashedInventory)
                  Uncachable -- no need to copy anything but hashed_inventory!
    debugMessage "Done copying hashed inventory."

-- |writeAndReadPatch makes a patch lazy, by writing it out to disk (thus
-- forcing it), and then re-reads the patch lazily.
writeAndReadPatch :: (IsRepoType rt, RepoPatch p) => Cache -> Compression
                  -> PatchInfoAnd rt p wX wY -> IO (PatchInfoAnd rt p wX wY)
writeAndReadPatch c compr p = do
    (i, h) <- writePatchIfNecessary c compr p
    unsafeInterleaveIO $ readp h i
  where
    parse i h = do
        debugMessage ("Rereading patch file: "++ showDoc (displayPatchInfo i))
        (fn, ps) <- fetchFileUsingCache c HashedPatchesDir h
        case readPatch ps of
            Just x -> return x
            Nothing -> fail $ unlines [ "Couldn't parse patch file " ++ fn
                                      , "which is"
                                      , renderString $ displayPatchInfo i]

    readp h i = do Sealed x <- createHashed h (parse i)
                   return . patchInfoAndPatch i $ unsafeCoerceP x

-- | writeTentativeInventory writes @patchSet@ as the tentative inventory.
writeTentativeInventory :: RepoPatch p => Cache -> Compression
                        -> PatchSet rt p Origin wX -> IO ()
writeTentativeInventory cache compr patchSet = do
    debugMessage "in writeTentativeInventory..."
    createDirectoryIfMissing False inventoriesDirPath
    beginTedious tediousName
    hsh <- writeInventoryPrivate $ slightlyOptimizePatchset patchSet
    endTedious tediousName
    debugMessage "still in writeTentativeInventory..."
    case hsh of
        Nothing -> writeBinFile (darcsdir </> tentativeHashedInventory) B.empty
        Just h -> do
            content <- snd <$> fetchFileUsingCache cache HashedInventoriesDir h
            writeAtomicFilePS (darcsdir </> tentativeHashedInventory) content
  where
    tediousName = "Writing inventory"
    writeInventoryPrivate :: RepoPatch p => PatchSet rt p Origin wX
                          -> IO (Maybe String)
    writeInventoryPrivate (PatchSet NilRL NilRL) = return Nothing
    writeInventoryPrivate (PatchSet NilRL ps) = do
        inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) ps
        let inventorylist = hcat (map pihash $ reverse inventory)
        hash <- writeHashFile cache compr HashedInventoriesDir inventorylist
        return $ Just hash
    writeInventoryPrivate
        (PatchSet xs@(_ :<: Tagged t _ _) x) = do
        resthash <- write_ts xs
        finishedOneIO tediousName $ fromMaybe "" resthash
        inventory <- sequence $ mapRL (writePatchIfNecessary cache compr)
                                    (NilRL :<: t +<+ x)
        let inventorylist = hcat (map pihash $ reverse inventory)
            inventorycontents =
                case resthash of
                    Just h -> text ("Starting with inventory:\n" ++ h) $$
                                  inventorylist
                    Nothing -> inventorylist
        hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents
        return $ Just hash
      where
        -- | write_ts writes out a tagged patchset. If it has already been
        -- written, we'll have the hash, so we can immediately return it.
        write_ts :: RepoPatch p => RL (Tagged rt p) Origin wX
                 -> IO (Maybe String)
        write_ts (_ :<: Tagged _ (Just h) _) = return (Just h)
        write_ts (tts :<: Tagged _ Nothing pps) =
            writeInventoryPrivate $ PatchSet tts pps
        write_ts NilRL = return Nothing

-- |writeHashIfNecessary writes the patch and returns the resulting info/hash,
-- if it has not already been written. If it has been written, we have the hash
-- in the PatchInfoAnd, so we extract and return the info/hash.
writePatchIfNecessary :: RepoPatch p => Cache -> Compression
                      -> PatchInfoAnd rt p wX wY -> IO (PatchInfo, String)
writePatchIfNecessary c compr hp = infohp `seq`
    case extractHash hp of
        Right h -> return (infohp, h)
        Left p -> (\h -> (infohp, h)) <$>
                        writeHashFile c compr HashedPatchesDir (showPatch ForStorage p)
  where
    infohp = info hp

-- |pihash takes an info/hash pair, and renders the info, along with the hash
-- as a Doc.
pihash :: (PatchInfo, String) -> Doc
pihash (pinf, hash) = showPatchInfo ForStorage pinf $$ text ("hash: " ++ hash ++ "\n")

-- |listInventoriesWith returns a list of the inventories hashes.
-- The function @f@ can be readInventoryPrivate or readInventoryLocalPrivate.
-- The argument @hashedRepoDir@ is the path to the repository,
-- where it's the 'hashed_inventory' file.
-- The argument @darcsDir@ is the path to the directory of inventories files.
listInventoriesWith ::  (String -> String
    -> IO (Maybe String, [(PatchInfo, String)]))
    -> String -> String -> IO [String]
listInventoriesWith f darcsDir hashedRepoDir = do
    mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory
    followStartingWiths mbStartingWithInv
  where
    getStartingWithHash invDir inv =
        fst <$> f invDir inv

    followStartingWiths Nothing = return []
    followStartingWiths (Just startingWith) = do
        mbNextInv <- getStartingWithHash (darcsDir </> inventoriesDir) startingWith
        (startingWith :) <$> followStartingWiths mbNextInv

-- |listInventoriesBucketedWith is similar to listInventoriesWith, but
-- it read the inventory directory under @darcsDir@ in bucketed format.
listInventoriesBucketedWith ::  (String -> String
    -> IO (Maybe String, [(PatchInfo, String)]))
    -> String -> String -> IO [String]
listInventoriesBucketedWith f darcsDir hashedRepoDir = do
    mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory
    followStartingWiths mbStartingWithInv
  where
    getStartingWithHash invDir inv =
        fst <$> f invDir inv

    followStartingWiths Nothing = return []
    followStartingWiths (Just startingWith) = do
        mbNextInv <- getStartingWithHash
            (darcsDir </> inventoriesDir </> bucketFolder startingWith) startingWith
        (startingWith :) <$> followStartingWiths mbNextInv

-- |listInventories returns a list of the inventories hashes.
-- This function attempts to retrieve missing inventory files.
listInventories :: IO [String]
listInventories = listInventoriesWith readInventoryPrivate darcsdir darcsdir

-- |readInventoryLocalPrivate reads the inventory with name @invName@ in @dir@
-- if it exist, otherwise returns an empty inventory.
readInventoryLocalPrivate :: String -> String
    -> IO (Maybe String, [(PatchInfo, String)])
readInventoryLocalPrivate dir invName = do
    b <- doesFileExist (dir </> invName)
    if b then readInventoryPrivate dir invName
        else return (Nothing, [])

-- |listInventoriesLocal returns a list of the inventories hashes.
-- This function does not attempt to retrieve missing inventory files.
listInventoriesLocal :: IO [String]
listInventoriesLocal = listInventoriesWith readInventoryLocalPrivate darcsdir darcsdir

-- |listInventoriesRepoDir returns a list of the inventories hashes.
-- The argument @repoDir@ is the directory of the repository from which
-- we are going to read the "hashed_inventory" file.
-- The rest of hashed files are read from the global cache.
listInventoriesRepoDir :: String -> IO [String]
listInventoriesRepoDir repoDir = do
    gCacheDir' <- globalCacheDir
    let gCacheInvDir = fromJust gCacheDir'
    listInventoriesBucketedWith readInventoryLocalPrivate gCacheInvDir (repoDir </> darcsdir)

-- |listPatchesLocal returns a list of the patches hashes, extracted
-- from inventory files, by following the inventory "chain" of "Starting
-- with inventory" hashes. This function does not attempt to download missing
-- inventory files.
-- The argument @darcsDir@ is the path to the darcs directory (e.g. "_darcs")
-- of the repository from which we're going to read the inventories.
listPatchesLocal :: String -> IO [String]
listPatchesLocal darcsDir = do
    inventory <- readInventoryPrivate darcsDir hashedInventory
    followStartingWiths (fst inventory) (getPatches inventory)
    where
        followStartingWiths Nothing patches = return patches
        followStartingWiths (Just startingWith) patches = do
            inv <- readInventoryLocalPrivate (darcsDir </> inventoriesDir) startingWith
            (patches++) <$> followStartingWiths (fst inv) (getPatches inv)

        getPatches inv = map snd (snd inv)

-- |listPatchesLocalBucketed is similar to listPatchesLocal, but
-- it read the inventory directory under @darcsDir@ in bucketed format.
listPatchesLocalBucketed :: String -> String -> IO [String]
listPatchesLocalBucketed darcsDir hashedRepoDir = do
    inventory <- readInventoryPrivate hashedRepoDir hashedInventory
    followStartingWiths (fst inventory) (getPatches inventory)
    where
        followStartingWiths Nothing patches = return patches
        followStartingWiths (Just startingWith) patches = do
            inv <- readInventoryLocalPrivate
                (darcsDir </> inventoriesDir </> bucketFolder startingWith) startingWith
            (patches++) <$> followStartingWiths (fst inv) (getPatches inv)

        getPatches inv = map snd (snd inv)

-- | 'readPatchIds inventory' parses the content of a hashed_inventory file
-- after the "pristine:" and "Starting with inventory:" header lines have
-- been removed.  The second value in the resulting tuples is the file hash
-- of the associated patch (the "hash:" line).
readPatchIds :: B.ByteString -> [(PatchInfo, String)]
readPatchIds inv | B.null inv = []
readPatchIds inv = case parseStrictly readPatchInfo inv of
                       Nothing -> []
                       Just (pinfo, r) ->
                           case readHash r of
                               Nothing -> []
                               Just (h, r') -> (pinfo, h) : readPatchIds r'
  where
    readHash :: B.ByteString -> Maybe (String, B.ByteString)
    readHash s = let s' = dropSpace s
                     (l, r) = BC.break ('\n' ==) s'
                     (kw, h) = BC.break (' ' ==) l in
                 if kw /= BC.pack "hash:" || B.length h <= 1
                     then Nothing
                     else Just (BC.unpack $ B.tail h, r)

-- | copyPristine copies a pristine tree into the current pristine dir,
--   and possibly copies a clean working copy.
--   The target is read from the passed-in dir/inventory name combination.
copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO ()
copyPristine cache dir iname wwd = do
    i <- fetchFilePS (dir ++ "/" ++ iname) Uncachable
    debugMessage $ "Copying hashed pristine tree: " ++ inv2pris i
    let tediousName = "Copying pristine"
    beginTedious tediousName
    copyHashed tediousName cache wwd $ inv2pris i
    endTedious tediousName

-- |copyPartialsPristine copies the pristine entries for a given list of
-- filepaths.
copyPartialsPristine :: FilePathLike fp => Cache -> String
                     -> String -> [fp] -> IO ()
copyPartialsPristine c d iname fps = do
    i <- fetchFilePS (d ++ "/" ++ iname) Uncachable
    copyPartialsHashed c (inv2pris i) fps

-- |pris2inv takes an updated pristine hash and an inventory, and outputs the
-- new pristine hash followed by the original inventory (having skipped the old
-- inventory hash).
pris2inv :: String -> B.ByteString -> Doc
pris2inv h inv = invisiblePS pristineName <> text h $$
                     invisiblePS (skipPristine inv)

-- |inv2pris takes the content of an inventory, and extracts the corresponding
-- pristine hash from the inventory (the hash is prefixed by "pristine:").
inv2pris :: B.ByteString -> String
inv2pris inv = case tryDropPristineName inv of
                   Just rest -> case takeHash rest of
                                    Just (h, _) -> h
                                    Nothing -> error "Bad hash in inventory!"
                   Nothing -> sha256sum B.empty

-- |skipPristine drops the 'pristine: HASH' prefix line, if present.
skipPristine :: B.ByteString -> B.ByteString
skipPristine ps = case tryDropPristineName ps of
    Just rest -> B.drop 1 $ BC.dropWhile (/= '\n') rest
    Nothing -> ps

-- |tryDropPristineName returns the result of dropping the pristineName from
-- the input, if it was present, otherwise it returns Nothing.
tryDropPristineName :: B.ByteString -> Maybe B.ByteString
tryDropPristineName input =
    if prefix == pristineName then Just rest else Nothing
  where
    (prefix, rest) = B.splitAt (B.length pristineName) input

unrevertUrl :: Repository rt p wR wU wT -> String
unrevertUrl r = repoLocation r ++ "/"++darcsdir++"/patches/unrevert"

tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)
                    => Repository rt p wR wU wT
                    -> Compression
                    -> Verbosity
                    -> UpdateWorking
                    -> PatchInfoAnd rt p wT wY
                    -> IO (Repository rt p wR wU wY)
tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine

data UpdatePristine = UpdatePristine 
                    | DontUpdatePristine
                    | DontUpdatePristineNorRevert deriving Eq

tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree)
                       => UpdatePristine
                       -> Repository rt p wR wU wT
                       -> Compression
                       -> Verbosity
                       -> UpdateWorking
                       -> FL (PatchInfoAnd rt p) wT wY
                       -> IO (Repository rt p wR wU wY)
tentativelyAddPatches_ up r c v uw ps =
    foldFL_M (\r' p -> tentativelyAddPatch_ up r' c v uw p) r ps

-- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun
-- :: Bool, with dryRun = unsafePerformIO $ readIORef ...
tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree)
                     => UpdatePristine
                     -> Repository rt p wR wU wT
                     -> Compression
                     -> Verbosity
                     -> UpdateWorking
                     -> PatchInfoAnd rt p wT wY
                     -> IO (Repository rt p wR wU wY)

tentativelyAddPatch_ up r compr verb uw p =
    withRepoLocation r $ do
       void $ addToTentativeInventory (repoCache r) compr p
       when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."
                                        applyToTentativePristine r verb p
                                        debugMessage "Updating pending..."
                                        tentativelyRemoveFromPending r uw p
       return (coerceT r)


-- |applyToTentativePristine applies a patch @p@ to the tentative pristine
-- tree, and updates the tentative pristine hash
applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, ShowPatch q, PrimPatchBase q)
                         => Repository rt p wR wU wT
                         -> Verbosity
                         -> q wT wY
                         -> IO ()
applyToTentativePristine r verb p =
    withRepoLocation r $
    do when (verb == Verbose) $ putDocLn $ text "Applying to pristine..." <+> description p
       applyToTentativePristineCwd p

applyToTentativePristineCwd :: (ApplyState p ~ Tree, Patchy p) => p wX wY
                            -> IO ()
applyToTentativePristineCwd p = do
    tentativePristine <- gzReadFilePS tentativePristinePath
    -- Extract the pristine hash from the tentativePristine file, using
    -- inv2pris (this is valid since we normally just extract the hash from the
    -- first line of an inventory file; we can pass in a one-line file that
    -- just contains said hash).
    let tentativePristineHash = inv2pris tentativePristine
    newPristineHash <- applyToHashedPristine tentativePristineHash p
    writeDocBinFile tentativePristinePath $
        pris2inv newPristineHash tentativePristine

tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                         => Repository rt p wR wU wT
                         -> Compression
                         -> UpdateWorking
                         -> FL (PatchInfoAnd rt p) wX wT
                         -> IO (Repository rt p wR wU wX)
tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine

tentativelyRemovePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                          => UpdatePristine
                          -> Repository rt p wR wU wT
                          -> Compression
                          -> UpdateWorking
                          -> FL (PatchInfoAnd rt p) wX wT
                          -> IO (Repository rt p wR wU wX)
tentativelyRemovePatches_ up r compr uw ps =
    withRepoLocation r $ do
      when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."
                                       prepend r uw $ effect ps
      unless (up == DontUpdatePristineNorRevert) $ removeFromUnrevertContext r ps
      debugMessage "Removing changes from tentative inventory..."
      if formatHas HashedInventory (repoFormat r)
        then do removeFromTentativeInventory r compr ps
                when (up == UpdatePristine) $
                     applyToTentativePristineCwd $
                     progressFL "Applying inverse to pristine" $ invert ps
        else fail Old.oldRepoFailMsg
      return (coerceT r)

-- FIXME this is a rather weird API. If called with a patch that isn't already
-- in the repo, it fails with an obscure error from 'commuteToEnd'. It also
-- ends up redoing the work that the caller has already done - if it has
-- already commuted these patches to the end, it must also know the commuted
-- versions of the other patches in the repo.
-- |Given a sequence of patches anchored at the end of the current repository,
-- actually pull them to the end of the repository by removing any patches
-- with the same name and then adding the passed in sequence.
-- Typically callers will have obtained the passed in sequence using
-- 'findCommon' and friends.
tentativelyReplacePatches :: forall rt p wR wU wT wX
                           . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                          => Repository rt p wR wU wT
                          -> Compression
                          -> UpdateWorking
                          -> Verbosity
                          -> FL (PatchInfoAnd rt p) wX wT
                          -> IO ()
tentativelyReplacePatches repository compr uw verb ps =
    do let ps' = filterOutFLFL (namedIsInternal . hopefully) ps
       repository' <- tentativelyRemovePatches_ DontUpdatePristineNorRevert repository compr uw ps'
       mapAdd repository' ps'
  where mapAdd :: Repository rt p wM wL wI
               -> FL (PatchInfoAnd rt p) wI wJ
               -> IO ()
        mapAdd _ NilFL = return ()
        mapAdd r (a:>:as) =
               do r' <- tentativelyAddPatch_ DontUpdatePristine r compr verb uw a
                  mapAdd r' as

-- The type here should rather be
--  ... -> Repo rt p wR wU wT -> IO (Repo rt p wT wU wT)
-- In other words: we set the recorded state to the tentative state.
finalizeRepositoryChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                          => Repository rt p wR wU wT
                          -> UpdateWorking
                          -> Compression
                          -> IO ()
finalizeRepositoryChanges r updateWorking compr
    | formatHas HashedInventory (repoFormat r) =
        withRepoLocation r $ do
            debugMessage "Finalizing changes..."
            withSignalsBlocked $ do
                 finalizeTentativeChanges r compr
                 recordedState <- readRecorded r
                 finalizePending r updateWorking recordedState
            debugMessage "Done finalizing changes..."
            ps <- readRepo r
            doesPatchIndexExist (repoLocation r) >>= (`when` createOrUpdatePatchIndexDisk r ps)
            updateIndex r
    | otherwise = fail Old.oldRepoFailMsg

-- TODO: rename this and document the transaction protocol (revert/finalize)
-- clearly.
-- |Slightly confusingly named: as well as throwing away any tentative
-- changes, revertRepositoryChanges also re-initialises the tentative state.
-- It's therefore used before makign any changes to the repo.
-- So the type should rather be
--
-- > ... -> Repo rt p wR wU wT -> IO (Repo rt p wR wU wR)
revertRepositoryChanges :: RepoPatch p
                        => Repository rt p wR wU wT
                        -> UpdateWorking
                        -> IO ()
revertRepositoryChanges r uw
 | formatHas HashedInventory (repoFormat r) =
    withRepoLocation r $
    do removeFileMayNotExist (pendingName ++ ".tentative")
       Sealed x <- readPending r
       setTentativePending r uw x
       when (uw == NoUpdateWorking) $ removeFileMayNotExist pendingName
       revertTentativeChanges
 | otherwise = fail Old.oldRepoFailMsg

removeFromUnrevertContext :: forall rt p wR wU wT wX
                           . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                          => Repository rt p wR wU wT
                          -> FL (PatchInfoAnd rt p) wX wT
                          -> IO ()
removeFromUnrevertContext r ps = do
  Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (PatchSet NilRL NilRL))
  remove_from_unrevert_context_ bundle
  where unrevert_impossible =
            do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?"
               if confirmed then removeFileMayNotExist (unrevertUrl r)
                            else fail "Cancelled."
        unrevert_patch_bundle :: IO (SealedPatchSet rt p Origin)
        unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl r)
                                   case scanBundle pf of
                                     Right foo -> return foo
                                     Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
        remove_from_unrevert_context_ :: PatchSet rt p Origin wZ -> IO ()
        remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return ()
        remove_from_unrevert_context_ bundle =
         do debugMessage "Adjusting the context of the unrevert changes..."
            debugMessage $ "Removing "++ show (lengthFL ps) ++
                                  " patches in removeFromUnrevertContext!"
            ref <- readTentativeRepo r (repoLocation r)
            let withSinglet :: Sealed (FL ppp wXxx)
                            -> (forall wYyy . ppp wXxx wYyy -> IO ()) -> IO ()
                withSinglet (Sealed (x :>: NilFL)) j = j x
                withSinglet _ _ = return ()
            withSinglet (mergeThem ref bundle) $ \h_us ->
                  case commuteRL (reverseFL ps :> h_us) of
                    Nothing -> unrevert_impossible
                    Just (us' :> _) ->
                      case removeFromPatchSet ps ref of
                      Nothing -> unrevert_impossible
                      Just common ->
                          do debugMessage "Have now found the new context..."
                             bundle' <- makeBundleN Nothing common (hopefully us':>:NilFL)
                             writeDocBinFile (unrevertUrl r) bundle'
            debugMessage "Done adjusting the context of the unrevert changes!"

cleanRepository :: RepoPatch p => Repository rt p wR wU wT -> IO ()
cleanRepository r = cleanPristine r >> cleanInventories r >> cleanPatches r

-- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree,
--   possibly writing a clean working copy in the process.
createPristineDirectoryTree :: RepoPatch p => Repository rt p wR wU wT -> FilePath -> WithWorkingDir -> IO ()
createPristineDirectoryTree r reldir wwd
    | formatHas HashedInventory (repoFormat r) =
        do createDirectoryIfMissing True reldir
           withCurrentDirectory reldir $
              copyPristine (repoCache r) (repoLocation r) (darcsdir++"/hashed_inventory") wwd
    | otherwise = fail Old.oldRepoFailMsg

-- fp below really should be FileName
-- | Used by the commands dist and diff
createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p)
                                    => Repository rt p wR wU wT
                                    -> [fp]
                                    -> FilePath
                                    -> IO ()
createPartialsPristineDirectoryTree r prefs dir
    | formatHas HashedInventory (repoFormat r) =
        do createDirectoryIfMissing True dir
           withCurrentDirectory dir $
            copyPartialsPristine (repoCache r) (repoLocation r)
              (darcsdir++"/hashed_inventory") prefs
    | otherwise = fail Old.oldRepoFailMsg

withRecorded :: RepoPatch p
             => Repository rt p wR wU wT
             -> ((AbsolutePath -> IO a) -> IO a)
             -> (AbsolutePath -> IO a)
             -> IO a
withRecorded repository mk_dir f
    = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) WithWorkingDir
                        f d

withTentative :: forall rt p a wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
              => Repository rt p wR wU wT
              -> ((AbsolutePath -> IO a) -> IO a)
              -> (AbsolutePath -> IO a)
              -> IO a
withTentative r mk_dir f
    | formatHas HashedInventory (repoFormat r) =
        mk_dir $ \d -> do copyPristine
                              (repoCache r)
                              (repoLocation r)
                              (darcsdir++"/tentative_pristine")
                              WithWorkingDir
                          f d
    | otherwise = fail Old.oldRepoFailMsg

-- | Writes out a fresh copy of the inventory that minimizes the
-- amount of inventory that need be downloaded when people pull from
-- the repository.
--
-- Specifically, it breaks up the inventory on the most recent tag.
-- This speeds up most commands when run remotely, both because a
-- smaller file needs to be transfered (only the most recent
-- inventory).  It also gives a guarantee that all the patches prior
-- to a given tag are included in that tag, so less commutation and
-- history traversal is needed.  This latter issue can become very
-- important in large repositories.
reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                 => Repository rt p wR wU wR
                 -> Compression
                 -> UpdateWorking
                 -> Verbosity
                 -> IO ()
reorderInventory repository compr uw verb = do
        debugMessage "Reordering the inventory."
        PatchSet _ ps <- misplacedPatches `fmap` readRepo repository
        tentativelyReplacePatches repository compr uw verb $ reverseRL ps
        finalizeTentativeChanges repository compr
        debugMessage "Done reordering the inventory."

-- | Returns the patches that make the most recent tag dirty.
misplacedPatches :: forall rt p wS wX . RepoPatch p
                 => PatchSet rt p wS wX
                 -> PatchSet rt p wS wX
misplacedPatches ps = 
        -- Filter the repository keeping only with the tags, ordered from the
        -- most recent.
        case filter isTag $ mapRL info $ patchSet2RL ps of
                [] -> ps
                (lt:_) -> 
                    -- Take the most recent tag, and split the repository in,
                    -- the clean PatchSet "up to" the tag (ts), and a RL of
                    -- patches after the tag (r).
                    case splitOnTag lt ps of
                        Just (PatchSet ts xs :> r) -> PatchSet ts (xs+<+r)
                        _ -> impossible -- Because the tag is in ps.

-- @todo: we should not have to open the result of HashedRepo and
-- seal it.  Instead, update this function to work with type witnesses
-- by fixing DarcsRepo to match HashedRepo in the handling of
-- Repository state.
readRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
         => Repository rt p wR wU wT
         -> IO (PatchSet rt p Origin wR)
readRepo r
    | formatHas HashedInventory (repoFormat r) = readRepoHashed r (repoLocation r)
    | otherwise = do Sealed ps <- Old.readOldRepo (repoLocation r)
                     return $ unsafeCoerceP ps

-- | XOR of all hashes of the patches' metadata.
-- It enables to quickly see whether two repositories
-- have the same patches, independently of their order.
-- It relies on the assumption that the same patch cannot
-- be present twice in a repository.
-- This checksum is not cryptographically secure,
-- see http://robotics.stanford.edu/~xb/crypto06b/ .
repoXor :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
        => Repository rt p wR wU wR -> IO SHA1
repoXor repo = do
  hashes <- mapRL (makePatchname . info) . patchSet2RL <$> readRepo repo
  return $ foldl' sha1Xor zero hashes