-- 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, ScopedTypeVariables #-}
module Darcs.Repository.HashedRepo
    ( inventoriesDir
    , pristineDir
    , patchesDir
    , hashedInventory
    , revertTentativeChanges
    , finalizeTentativeChanges
    , cleanPristine
    , filterDirContents
    , cleanInventories
    , cleanPatches
    , copyPristine
    , copyPartialsPristine
    , applyToTentativePristine
    , addToSpecificInventory
    , addToTentativeInventory
    , removeFromTentativeInventory
    , readRepo
    , readTentativeRepo
    , readRepoUsingSpecificInventory
    , writeAndReadPatch
    , writeTentativeInventory
    , copyHashedInventory
    , readHashedPristineRoot
    , pris2inv
    , inv2pris
    , listInventories
    , listInventoriesLocal
    , listInventoriesRepoDir
    , listPatchesLocalBucketed
    , writePatchIfNecessary
    , readRepoFromInventoryList
    , readPatchIds
    , set
    , unset
    ) where

#include "impossible.h"

import Prelude ()
import Darcs.Prelude

import Control.Arrow ( (&&&) )
import Control.Exception ( catch, IOException )
import Control.Monad ( unless )
import Data.Maybe
import qualified Data.ByteString as B ( null, length, empty ,tail, drop,
                                        ByteString, splitAt )
import qualified Data.ByteString.Char8 as BC ( unpack, dropWhile, break, pack,
                                                ByteString )
import qualified Data.Set as Set
import Darcs.Util.Hash( encodeBase16, Hash(..) )
import Darcs.Util.Tree( treeHash, Tree )
import Darcs.Util.Tree.Hashed( hashedTreeIO, readDarcsHashedNosize,
                             readDarcsHashed, writeDarcsHashed,
                             decodeDarcsHash, decodeDarcsSize )
import System.Directory ( createDirectoryIfMissing, getDirectoryContents
                        , doesFileExist, doesDirectoryExist )
import System.FilePath.Posix( (</>) )
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( stderr, hPutStrLn )

import Darcs.Util.Printer.Color ( showDoc )
import Darcs.Util.External
    ( copyFileOrUrl
    , cloneFile
    , fetchFilePS
    , gzFetchFilePS
    , Cachable( Uncachable )
    )
import Darcs.Repository.Flags ( Compression, RemoteDarcs, remoteDarcs, WithWorkingDir )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Lock
    ( writeBinFile
    , writeDocBinFile
    , writeAtomicFilePS
    ,  appendBinFile
    , appendDocBinFile
    , removeFileMayNotExist
    )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin )

import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch, info,
                                  extractHash, createHashed )
import Darcs.Patch ( IsRepoType, RepoPatch, Patchy, showPatch, readPatch, apply )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Read ( ReadPatch )
import Darcs.Patch.ReadMonads ( parseStrictly )
import Darcs.Patch.Depends ( removeFromPatchSet, slightlyOptimizePatchset )
import Darcs.Patch.Info ( PatchInfo, showPatchInfo, showPatchInfoUI,
                          readPatchInfo )
import Darcs.Util.Path ( FilePathLike, ioAbsoluteOrRemote, toPath )
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(..), extractCache )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Patch.Witnesses.Ordered
    ( (+<+), FL(..), RL(..), mapRL )
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 ( Doc, hcat, (<>), ($$), renderString, renderPS, text,
                 invisiblePS, RenderMode(..) )
import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )
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 $ pristineNamePrefix ++ 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 (extractCache 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 (Repo d _ _ _) = withCurrentDirectory d $ 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@(Repo d _ _ _) = withCurrentDirectory d $ do
    debugMessage "Cleaning out the pristine cache..."
    i <- gzReadFilePS hashedInventoryPath
    cleanHashdir (extractCache 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 $ info p
    appendBinFile invFile $ "\nhash: " ++ 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 "HashedRepo.removeFromTentativeInventory: precondition violated"
        Just r -> return r
    writeTentativeInventory (extractCache 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 Standard d

-- |readRepo returns the "current" repo patchset.
readRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT
         -> String -> IO (PatchSet rt p Origin wR)
readRepo = 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 (extractCache 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 Encode (showPatchInfoUI 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 Encode $ showPatchInfoUI 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 (Repo outr _ _ _) rdarcs inr | remote <- remoteDarcs rdarcs = do
    createDirectoryIfMissing False (outr ++ "/" ++ inventoriesDirPath)
    copyFileOrUrl remote (inr </> darcsdir </> hashedInventory)
                         (outr </> 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 Encode (showPatchInfoUI 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 Encode $ showPatchInfoUI 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) ""
        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 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 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)

-- |applyToTentativePristine applies a patch @p@ to the tentative pristine
-- tree, and updates the tentative pristine hash
applyToTentativePristine :: (ApplyState p ~ Tree, Patchy p) => p wX wY
                         -> IO ()
applyToTentativePristine 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

-- | 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
