-- 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 OverloadedStrings #-}
module Darcs.Repository.Hashed
    ( revertTentativeChanges
    , finalizeTentativeChanges
    , addToTentativeInventory
    , readPatches
    , readTentativePatches
    , writeAndReadPatch
    , writeTentativeInventory
    , copyHashedInventory
    , writePatchIfNecessary
    , tentativelyAddPatch
    , tentativelyRemovePatches
    , tentativelyRemovePatches_
    , tentativelyAddPatch_
    , tentativelyAddPatches
    , tentativelyAddPatches_
    , reorderInventory
    , UpdatePristine(..)
    , repoXor
    ) where

import Darcs.Prelude

import Control.Monad ( unless, when )
import Data.List ( foldl' )
import System.Directory
    ( copyFile
    , createDirectoryIfMissing
    , renameFile
    )
import System.FilePath.Posix ( (</>) )
import System.IO.Unsafe ( unsafeInterleaveIO )

import Darcs.Patch ( RepoPatch, effect, invert, invertFL, readPatch )
import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Depends
    ( cleanLatestTag
    , removeFromPatchSet
    , slightlyOptimizePatchset
    , fullyOptimizePatchSet
    )
import Darcs.Patch.Format ( PatchListFormat )
import Darcs.Patch.Info ( displayPatchInfo, makePatchname, piName )
import Darcs.Patch.Invertible ( mkInvertible )
import Darcs.Patch.PatchInfoAnd
    ( PatchInfoAnd
    , createHashed
    , hopefully
    , info
    , patchInfoAndPatch
    )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Patch.Read ( ReadPatch )
import Darcs.Patch.Rebase.Suspended
    ( addFixupsToSuspended
    , removeFixupsFromSuspended
    )
import Darcs.Patch.Set ( Origin, PatchSet(..), patchSet2RL )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , foldlwFL
    , foldrwFL
    , mapRL
    , sequenceFL_
    , (+>+)
    , (+>>+)
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )

import Darcs.Repository.Flags
    ( OptimizeDeep(..)
    , RemoteDarcs
    , UpdatePending(..)
    , remoteDarcs
    )
import Darcs.Repository.Format
    ( RepoProperty(HashedInventory)
    , formatHas
    )
import Darcs.Repository.InternalTypes
    ( AccessType(..)
    , Repository
    , SAccessType(..)
    , repoAccessType
    , repoCache
    , repoFormat
    , repoLocation
    , unsafeCoerceR
    , withRepoDir
    )
import Darcs.Repository.Inventory
    ( peekPristineHash
    , pokePristineHash
    , readPatchesFromInventoryFile
    , showInventoryEntry
    , writeInventory
    , writePatchIfNecessary
    )
import qualified Darcs.Repository.Old as Old ( oldRepoFailMsg, readOldRepo )
import Darcs.Repository.Paths
import Darcs.Repository.Pending
    ( readTentativePending
    , writeTentativePending
    )
import Darcs.Repository.Pristine
    ( applyToTentativePristine
    , convertSizePrefixedPristine
    )
import Darcs.Repository.Rebase
    ( withTentativeRebase
    )
import Darcs.Repository.Traverse ( cleanRepository )
import Darcs.Repository.Unrevert
    ( removeFromUnrevertContext
    )

import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Cache ( Cache, fetchFileUsingCache )
import Darcs.Util.File ( Cachable(Uncachable), copyFileOrUrl )
import Darcs.Util.Hash ( SHA1, sha1Xor, sha1zero )
import Darcs.Util.Lock
    ( appendDocBinFile
    , writeAtomicFilePS
    , writeDocBinFile
    )
import Darcs.Util.Printer ( renderString )
import Darcs.Util.Progress ( beginTedious, debugMessage, endTedious )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Util.Tree ( Tree )

-- |revertTentativeChanges swaps the tentative and "real" hashed inventory
-- files, and then updates the tentative pristine with the "real" inventory
-- hash.
revertTentativeChanges :: Repository 'RO p wU wR -> IO ()
revertTentativeChanges :: forall (p :: * -> * -> *) wU wR. Repository 'RO p wU wR -> IO ()
revertTentativeChanges Repository 'RO p wU wR
repo = do
    String -> String -> IO ()
copyFile String
hashedInventoryPath String
tentativeHashedInventoryPath
    ByteString
inv <- String -> IO ByteString
gzReadFilePS String
tentativeHashedInventoryPath
    PristineHash
pristineHash <- Cache -> PristineHash -> IO PristineHash
convertSizePrefixedPristine (Repository 'RO p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository 'RO p wU wR
repo) (ByteString -> PristineHash
peekPristineHash ByteString
inv)
    String -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile String
tentativePristinePath (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ PristineHash -> ByteString -> Doc
pokePristineHash PristineHash
pristineHash ByteString
forall a. Monoid a => a
mempty
{-
    -- this is not needed, as we never again access the pristine hash in
    -- tentativeHashedInventoryPath, only that in tentativePristinePath
    writeDocBinFile tentativeHashedInventoryPath $
      pokePristineHash pristineHash inv
-}

-- |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 :: RepoPatch p
                         => Repository 'RW p wU wR -> IO ()
finalizeTentativeChanges :: forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RW p wU wR -> IO ()
finalizeTentativeChanges Repository 'RW p wU wR
r = do
    String -> IO ()
debugMessage String
"Optimizing the inventory..."
    -- Read the tentative patches
    PatchSet p Origin wR
ps <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) wU wR.
(PatchListFormat p, ReadPatch p) =>
Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
readTentativePatches Repository 'RW p wU wR
r
    Repository 'RW p wU wR -> PatchSet p Origin wR -> IO ()
forall (p :: * -> * -> *) wU wR wX.
RepoPatch p =>
Repository 'RW p wU wR -> PatchSet p Origin wX -> IO ()
writeTentativeInventory Repository 'RW p wU wR
r PatchSet p Origin wR
ps
    ByteString
i <- String -> IO ByteString
gzReadFilePS String
tentativeHashedInventoryPath
    ByteString
p <- String -> IO ByteString
gzReadFilePS String
tentativePristinePath
    -- Write out the "optimised" tentative inventory.
    String -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile String
tentativeHashedInventoryPath (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
        PristineHash -> ByteString -> Doc
pokePristineHash (ByteString -> PristineHash
peekPristineHash ByteString
p) ByteString
i
    -- Atomically swap.
    String -> String -> IO ()
renameFile String
tentativeHashedInventoryPath String
hashedInventoryPath

-- | Add (append) a patch to the tentative inventory.
-- Warning: this allows to add any arbitrary patch!
-- Used by convert import and 'tentativelyAddPatch_'.
addToTentativeInventory :: RepoPatch p => Cache
                        -> PatchInfoAnd p wX wY -> IO ()
addToTentativeInventory :: forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
Cache -> PatchInfoAnd p wX wY -> IO ()
addToTentativeInventory Cache
c PatchInfoAnd p wX wY
p = do
    PatchHash
hash <- (PatchInfo, PatchHash) -> PatchHash
forall a b. (a, b) -> b
snd ((PatchInfo, PatchHash) -> PatchHash)
-> IO (PatchInfo, PatchHash) -> IO PatchHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cache -> PatchInfoAnd p wX wY -> IO (PatchInfo, PatchHash)
forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
Cache -> PatchInfoAnd p wX wY -> IO (PatchInfo, PatchHash)
writePatchIfNecessary Cache
c PatchInfoAnd p wX wY
p
    String -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
appendDocBinFile String
tentativeHashedInventoryPath (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ (PatchInfo, PatchHash) -> Doc
showInventoryEntry (PatchInfoAnd p wX wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAnd p wX wY
p, PatchHash
hash)

-- | Read the recorded 'PatchSet' of a hashed 'Repository'.
readPatchesHashed :: (PatchListFormat p, ReadPatch p) => Repository rt p wU wR
                  -> IO (PatchSet p Origin wR)
readPatchesHashed :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(PatchListFormat p, ReadPatch p) =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatchesHashed Repository rt p wU wR
repo =
  case Repository rt p wU wR -> SAccessType rt
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> SAccessType rt
repoAccessType Repository rt p wU wR
repo of
    SAccessType rt
SRO -> String -> Repository rt p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wS.
(PatchListFormat p, ReadPatch p) =>
String -> Repository rt p wU wR -> IO (PatchSet p Origin wS)
readPatchesFromInventoryFile String
hashedInventoryPath Repository rt p wU wR
repo
    SAccessType rt
SRW -> String -> Repository rt p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wS.
(PatchListFormat p, ReadPatch p) =>
String -> Repository rt p wU wR -> IO (PatchSet p Origin wS)
readPatchesFromInventoryFile String
tentativeHashedInventoryPath Repository rt p wU wR
repo

-- | Read the tentative 'PatchSet' of a (hashed) 'Repository'.
readTentativePatches :: (PatchListFormat p, ReadPatch p)
                     => Repository 'RW p wU wR
                     -> IO (PatchSet p Origin wR)
readTentativePatches :: forall (p :: * -> * -> *) wU wR.
(PatchListFormat p, ReadPatch p) =>
Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
readTentativePatches = Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(PatchListFormat p, ReadPatch p) =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatchesHashed

-- |Copy the hashed inventory from the given location to the given repository,
-- possibly using the given remote darcs binary.
copyHashedInventory :: Repository 'RO p wU wR -> RemoteDarcs -> String -> IO ()
copyHashedInventory :: forall (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR -> RemoteDarcs -> String -> IO ()
copyHashedInventory Repository 'RO p wU wR
outrepo RemoteDarcs
rdarcs String
inloc | String
remote <- RemoteDarcs -> String
remoteDarcs RemoteDarcs
rdarcs = do
    let outloc :: String
outloc = Repository 'RO p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository 'RO p wU wR
outrepo
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
False (String
outloc String -> String -> String
</> String
inventoriesDirPath)
    String -> String -> String -> Cachable -> IO ()
copyFileOrUrl String
remote (String
inloc String -> String -> String
</> String
hashedInventoryPath)
                         (String
outloc String -> String -> String
</> String
hashedInventoryPath)
                  Cachable
Uncachable
    String -> IO ()
debugMessage String
"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 :: RepoPatch p => Cache
                  -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY)
writeAndReadPatch :: forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
Cache -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY)
writeAndReadPatch Cache
c PatchInfoAnd p wX wY
p = do
    (PatchInfo
i, PatchHash
h) <- Cache -> PatchInfoAnd p wX wY -> IO (PatchInfo, PatchHash)
forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
Cache -> PatchInfoAnd p wX wY -> IO (PatchInfo, PatchHash)
writePatchIfNecessary Cache
c PatchInfoAnd p wX wY
p
    IO (PatchInfoAnd p wX wY) -> IO (PatchInfoAnd p wX wY)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (PatchInfoAnd p wX wY) -> IO (PatchInfoAnd p wX wY))
-> IO (PatchInfoAnd p wX wY) -> IO (PatchInfoAnd p wX wY)
forall a b. (a -> b) -> a -> b
$ PatchHash -> PatchInfo -> IO (PatchInfoAnd p wX wY)
forall {a :: * -> * -> *} {wA} {wB}.
ReadPatch a =>
PatchHash -> PatchInfo -> IO (PatchInfoAndG a wA wB)
readp PatchHash
h PatchInfo
i
  where
    parse :: PatchInfo -> h -> IO (Sealed (p wX))
parse PatchInfo
i h
h = do
        String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Rereading patch file for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfo -> String
piName PatchInfo
i
        (String
fn, ByteString
ps) <- Cache -> h -> IO (String, ByteString)
forall h. ValidHash h => Cache -> h -> IO (String, ByteString)
fetchFileUsingCache Cache
c h
h
        case ByteString -> Either String (Sealed (p wX))
forall (p :: * -> * -> *) wX.
ReadPatch p =>
ByteString -> Either String (Sealed (p wX))
readPatch ByteString
ps of
            Right Sealed (p wX)
x -> Sealed (p wX) -> IO (Sealed (p wX))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Sealed (p wX)
x
            Left String
e -> String -> IO (Sealed (p wX))
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Sealed (p wX))) -> String -> IO (Sealed (p wX))
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                [ String
"Couldn't parse patch file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn
                , String
"which is"
                , Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> Doc
displayPatchInfo PatchInfo
i
                , String
e
                ]

    readp :: PatchHash -> PatchInfo -> IO (PatchInfoAndG a wA wB)
readp PatchHash
h PatchInfo
i = do Sealed Hopefully a Any wX
x <- PatchHash
-> (PatchHash -> IO (Sealed (a Any)))
-> IO (Sealed (Hopefully a Any))
forall (a :: * -> * -> *) wX.
PatchHash
-> (PatchHash -> IO (Sealed (a wX)))
-> IO (Sealed (Hopefully a wX))
createHashed PatchHash
h (PatchInfo -> PatchHash -> IO (Sealed (a Any))
forall {h} {p :: * -> * -> *} {wX}.
(ValidHash h, ReadPatch p) =>
PatchInfo -> h -> IO (Sealed (p wX))
parse PatchInfo
i)
                   PatchInfoAndG a wA wB -> IO (PatchInfoAndG a wA wB)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchInfoAndG a wA wB -> IO (PatchInfoAndG a wA wB))
-> (Hopefully a wA wB -> PatchInfoAndG a wA wB)
-> Hopefully a wA wB
-> IO (PatchInfoAndG a wA wB)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> Hopefully a wA wB -> PatchInfoAndG a wA wB
forall (p :: * -> * -> *) wA wB.
PatchInfo -> Hopefully p wA wB -> PatchInfoAndG p wA wB
patchInfoAndPatch PatchInfo
i (Hopefully a wA wB -> IO (PatchInfoAndG a wA wB))
-> Hopefully a wA wB -> IO (PatchInfoAndG a wA wB)
forall a b. (a -> b) -> a -> b
$ Hopefully a Any wX -> Hopefully a wA wB
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP Hopefully a Any wX
x

-- | Write a 'PatchSet' to the tentative inventory.
writeTentativeInventory :: RepoPatch p
                        => Repository 'RW p wU wR
                        -> PatchSet p Origin wX
                        -> IO ()
writeTentativeInventory :: forall (p :: * -> * -> *) wU wR wX.
RepoPatch p =>
Repository 'RW p wU wR -> PatchSet p Origin wX -> IO ()
writeTentativeInventory Repository 'RW p wU wR
repo PatchSet p Origin wX
patchSet = do
    String -> IO ()
debugMessage String
"in writeTentativeInventory..."
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
inventoriesDirPath
    let cache :: Cache
cache = Repository 'RW p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository 'RW p wU wR
repo
        tediousName :: String
tediousName = String
"Writing inventory"
    String -> IO ()
beginTedious String
tediousName
    InventoryHash
hash <-
      String -> Cache -> PatchSet p Origin wX -> IO InventoryHash
forall (p :: * -> * -> *) wX.
RepoPatch p =>
String -> Cache -> PatchSet p Origin wX -> IO InventoryHash
writeInventory String
tediousName Cache
cache (PatchSet p Origin wX -> IO InventoryHash)
-> PatchSet p Origin wX -> IO InventoryHash
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wX -> PatchSet p Origin wX
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> PatchSet p wStart wX
slightlyOptimizePatchset PatchSet p Origin wX
patchSet
    String -> IO ()
endTedious String
tediousName
    String -> IO ()
debugMessage String
"still in writeTentativeInventory..."
    (String
_filepath, ByteString
content) <- Cache -> InventoryHash -> IO (String, ByteString)
forall h. ValidHash h => Cache -> h -> IO (String, ByteString)
fetchFileUsingCache Cache
cache InventoryHash
hash
    String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS String
tentativeHashedInventoryPath ByteString
content

tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)
                    => Repository 'RW p wU wR
                    -> UpdatePending
                    -> PatchInfoAnd p wR wY
                    -> IO (Repository 'RW p wU wY)
tentativelyAddPatch :: forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> UpdatePending
-> PatchInfoAnd p wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatch = UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> PatchInfoAnd p wR wY
-> IO (Repository 'RW p wU wY)
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> PatchInfoAnd p wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatch_ UpdatePristine
UpdatePristine

tentativelyAddPatches :: (RepoPatch p, ApplyState p ~ Tree)
                      => Repository 'RW p wU wR
                      -> UpdatePending
                      -> FL (PatchInfoAnd p) wR wY
                      -> IO (Repository 'RW p wU wY)
tentativelyAddPatches :: forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatches = UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wY
-> IO (Repository 'RW p wU wY)
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatches_ UpdatePristine
UpdatePristine

data UpdatePristine = UpdatePristine 
                    | DontUpdatePristine
                    | DontUpdatePristineNorRevert deriving UpdatePristine -> UpdatePristine -> Bool
(UpdatePristine -> UpdatePristine -> Bool)
-> (UpdatePristine -> UpdatePristine -> Bool) -> Eq UpdatePristine
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpdatePristine -> UpdatePristine -> Bool
== :: UpdatePristine -> UpdatePristine -> Bool
$c/= :: UpdatePristine -> UpdatePristine -> Bool
/= :: UpdatePristine -> UpdatePristine -> Bool
Eq

tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree)
                       => UpdatePristine
                       -> Repository 'RW p wU wR
                       -> UpdatePending
                       -> FL (PatchInfoAnd p) wR wY
                       -> IO (Repository 'RW p wU wY)
tentativelyAddPatches_ :: forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatches_ UpdatePristine
upr Repository 'RW p wU wR
r UpdatePending
upe FL (PatchInfoAnd p) wR wY
ps = do
    let r' :: Repository 'RW p wU wR'
r' = Repository 'RW p wU wR -> Repository 'RW p wU wR'
forall (rt :: AccessType) (p :: * -> * -> *) wU wR wR'.
Repository rt p wU wR -> Repository rt p wU wR'
unsafeCoerceR Repository 'RW p wU wR
r
    Repository 'RW p wU wR
-> Repository 'RW p wU wY
-> (Suspended p wR -> Suspended p wY)
-> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wR'.
RepoPatch p =>
Repository rt p wU wR
-> Repository rt p wU wR'
-> (Suspended p wR -> Suspended p wR')
-> IO ()
withTentativeRebase Repository 'RW p wU wR
r Repository 'RW p wU wY
forall {wR'}. Repository 'RW p wU wR'
r' ((forall wA wB.
 PatchInfoAnd p wA wB -> Suspended p wA -> Suspended p wB)
-> FL (PatchInfoAnd p) wR wY -> Suspended p wR -> Suspended p wY
forall (p :: * -> * -> *) (r :: * -> *) wX wY.
(forall wA wB. p wA wB -> r wA -> r wB)
-> FL p wX wY -> r wX -> r wY
foldlwFL (Named p wA wB -> Suspended p wA -> Suspended p wB
forall (p :: * -> * -> *) wX wY.
(PrimPatchBase p, Effect p) =>
Named p wX wY -> Suspended p wX -> Suspended p wY
removeFixupsFromSuspended (Named p wA wB -> Suspended p wA -> Suspended p wB)
-> (PatchInfoAnd p wA wB -> Named p wA wB)
-> PatchInfoAnd p wA wB
-> Suspended p wA
-> Suspended p wB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wA wB -> Named p wA wB
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully) FL (PatchInfoAnd p) wR wY
ps)
    Repository 'RW p wU wR
-> IO (Repository 'RW p wU wY) -> IO (Repository 'RW p wU wY)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR a.
Repository rt p wU wR -> IO a -> IO a
withRepoDir Repository 'RW p wU wR
r (IO (Repository 'RW p wU wY) -> IO (Repository 'RW p wU wY))
-> IO (Repository 'RW p wU wY) -> IO (Repository 'RW p wU wY)
forall a b. (a -> b) -> a -> b
$ do
       (forall wW wZ. PatchInfoAnd p wW wZ -> IO ())
-> FL (PatchInfoAnd p) wR wY -> IO ()
forall (m :: * -> *) (a :: * -> * -> *) b wX wY.
Monad m =>
(forall wW wZ. a wW wZ -> m b) -> FL a wX wY -> m ()
sequenceFL_ (Cache -> PatchInfoAndG (Named p) wW wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
Cache -> PatchInfoAnd p wX wY -> IO ()
addToTentativeInventory (Repository 'RW p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository 'RW p wU wR
r)) FL (PatchInfoAnd p) wR wY
ps
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UpdatePristine
upr UpdatePristine -> UpdatePristine -> Bool
forall a. Eq a => a -> a -> Bool
== UpdatePristine
UpdatePristine) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Repository 'RW p wU wR
-> Invertible (FL (PatchInfoAnd p)) wR wY -> IO ()
forall (p :: * -> * -> *) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository 'RW p wU wR
-> Invertible (FL (PatchInfoAnd p)) wR wY -> IO ()
applyToTentativePristine Repository 'RW p wU wR
r (Invertible (FL (PatchInfoAnd p)) wR wY -> IO ())
-> Invertible (FL (PatchInfoAnd p)) wR wY -> IO ()
forall a b. (a -> b) -> a -> b
$
            FL (PatchInfoAnd p) wR wY -> Invertible (FL (PatchInfoAnd p)) wR wY
forall (p :: * -> * -> *) wX wY. p wX wY -> Invertible p wX wY
mkInvertible (FL (PatchInfoAnd p) wR wY
 -> Invertible (FL (PatchInfoAnd p)) wR wY)
-> FL (PatchInfoAnd p) wR wY
-> Invertible (FL (PatchInfoAnd p)) wR wY
forall a b. (a -> b) -> a -> b
$ String -> FL (PatchInfoAnd p) wR wY -> FL (PatchInfoAnd p) wR wY
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Applying to pristine" FL (PatchInfoAnd p) wR wY
ps
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UpdatePending
upe UpdatePending -> UpdatePending -> Bool
forall a. Eq a => a -> a -> Bool
== UpdatePending
YesUpdatePending) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          String -> IO ()
debugMessage String
"Updating pending..."
          Sealed FL (PrimOf p) wR wX
pend <- Repository 'RW p wU wR -> IO (Sealed (FL (PrimOf p) wR))
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RW p wU wR -> IO (Sealed (FL (PrimOf p) wR))
readTentativePending Repository 'RW p wU wR
r
          Repository 'RW p wU wY -> FL (PrimOf p) wY wX -> IO ()
forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
writeTentativePending Repository 'RW p wU wY
forall {wR'}. Repository 'RW p wU wR'
r' (FL (PrimOf p) wY wX -> IO ()) -> FL (PrimOf p) wY wX -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wR wY -> RL (PrimOf p) wY wR
forall (p :: * -> * -> *) wX wY.
Invert p =>
FL p wX wY -> RL p wY wX
invertFL (FL (PatchInfoAnd p) wR wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wR wY
forall wX wY.
FL (PatchInfoAnd p) wX wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd p) wR wY
ps) RL (PrimOf p) wY wR -> FL (PrimOf p) wR wX -> FL (PrimOf p) wY wX
forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> FL p wY wZ -> FL p wX wZ
+>>+ FL (PrimOf p) wR wX
pend
       Repository 'RW p wU wY -> IO (Repository 'RW p wU wY)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Repository 'RW p wU wY
forall {wR'}. Repository 'RW p wU wR'
r'

tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree)
                     => UpdatePristine
                     -> Repository 'RW p wU wR
                     -> UpdatePending
                     -> PatchInfoAnd p wR wY
                     -> IO (Repository 'RW p wU wY)
tentativelyAddPatch_ :: forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> PatchInfoAnd p wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatch_ UpdatePristine
upr Repository 'RW p wU wR
r UpdatePending
upe PatchInfoAnd p wR wY
p =
    UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wY
-> IO (Repository 'RW p wU wY)
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatches_ UpdatePristine
upr Repository 'RW p wU wR
r UpdatePending
upe (PatchInfoAnd p wR wY
p PatchInfoAnd p wR wY
-> FL (PatchInfoAnd p) wY wY -> FL (PatchInfoAnd p) wR wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd p) wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)

tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree)
                         => Repository 'RW p wU wR
                         -> UpdatePending
                         -> FL (PatchInfoAnd p) wX wR
                         -> IO (Repository 'RW p wU wX)
tentativelyRemovePatches :: forall (p :: * -> * -> *) wU wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wX wR
-> IO (Repository 'RW p wU wX)
tentativelyRemovePatches = UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wX wR
-> IO (Repository 'RW p wU wX)
forall (p :: * -> * -> *) wU wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wX wR
-> IO (Repository 'RW p wU wX)
tentativelyRemovePatches_ UpdatePristine
UpdatePristine

tentativelyRemovePatches_ :: (RepoPatch p, ApplyState p ~ Tree)
                          => UpdatePristine
                          -> Repository 'RW p wU wR
                          -> UpdatePending
                          -> FL (PatchInfoAnd p) wX wR
                          -> IO (Repository 'RW p wU wX)
tentativelyRemovePatches_ :: forall (p :: * -> * -> *) wU wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wX wR
-> IO (Repository 'RW p wU wX)
tentativelyRemovePatches_ UpdatePristine
upr Repository 'RW p wU wR
r UpdatePending
upe FL (PatchInfoAnd p) wX wR
ps
  | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory (Repository 'RW p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository 'RW p wU wR
r) = do
      Repository 'RW p wU wR
-> IO (Repository 'RW p wU wX) -> IO (Repository 'RW p wU wX)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR a.
Repository rt p wU wR -> IO a -> IO a
withRepoDir Repository 'RW p wU wR
r (IO (Repository 'RW p wU wX) -> IO (Repository 'RW p wU wX))
-> IO (Repository 'RW p wU wX) -> IO (Repository 'RW p wU wX)
forall a b. (a -> b) -> a -> b
$ do
        PatchSet p Origin wR
ref <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) wU wR.
(PatchListFormat p, ReadPatch p) =>
Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
readTentativePatches Repository 'RW p wU wR
r
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UpdatePristine
upr UpdatePristine -> UpdatePristine -> Bool
forall a. Eq a => a -> a -> Bool
== UpdatePristine
DontUpdatePristineNorRevert) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> FL (PatchInfoAnd p) wX wR -> IO ()
forall (p :: * -> * -> *) wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
PatchSet p Origin wR -> FL (PatchInfoAnd p) wX wR -> IO ()
removeFromUnrevertContext PatchSet p Origin wR
ref FL (PatchInfoAnd p) wX wR
ps
        String -> IO ()
debugMessage String
"Removing changes from tentative inventory..."
        Repository 'RW p wU wX
r' <- Repository 'RW p wU wR
-> FL (PatchInfoAnd p) wX wR -> IO (Repository 'RW p wU wX)
forall (p :: * -> * -> *) wU wR wX.
RepoPatch p =>
Repository 'RW p wU wR
-> FL (PatchInfoAnd p) wX wR -> IO (Repository 'RW p wU wX)
removeFromTentativeInventory Repository 'RW p wU wR
r FL (PatchInfoAnd p) wX wR
ps
        Repository 'RW p wU wR
-> Repository 'RW p wU wX
-> (Suspended p wR -> Suspended p wX)
-> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wR'.
RepoPatch p =>
Repository rt p wU wR
-> Repository rt p wU wR'
-> (Suspended p wR -> Suspended p wR')
-> IO ()
withTentativeRebase Repository 'RW p wU wR
r Repository 'RW p wU wX
r' ((forall wA wB.
 PatchInfoAnd p wA wB -> Suspended p wB -> Suspended p wA)
-> FL (PatchInfoAnd p) wX wR -> Suspended p wR -> Suspended p wX
forall (p :: * -> * -> *) (r :: * -> *) wX wY.
(forall wA wB. p wA wB -> r wB -> r wA)
-> FL p wX wY -> r wY -> r wX
foldrwFL (Named p wA wB -> Suspended p wB -> Suspended p wA
forall (p :: * -> * -> *) wX wY.
(PrimPatchBase p, Effect p) =>
Named p wX wY -> Suspended p wY -> Suspended p wX
addFixupsToSuspended (Named p wA wB -> Suspended p wB -> Suspended p wA)
-> (PatchInfoAnd p wA wB -> Named p wA wB)
-> PatchInfoAnd p wA wB
-> Suspended p wB
-> Suspended p wA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wA wB -> Named p wA wB
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully) FL (PatchInfoAnd p) wX wR
ps)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UpdatePristine
upr UpdatePristine -> UpdatePristine -> Bool
forall a. Eq a => a -> a -> Bool
== UpdatePristine
UpdatePristine) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Repository 'RW p wU wR
-> Invertible (FL (PatchInfoAnd p)) wR wX -> IO ()
forall (p :: * -> * -> *) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository 'RW p wU wR
-> Invertible (FL (PatchInfoAnd p)) wR wY -> IO ()
applyToTentativePristine Repository 'RW p wU wR
r (Invertible (FL (PatchInfoAnd p)) wR wX -> IO ())
-> Invertible (FL (PatchInfoAnd p)) wR wX -> IO ()
forall a b. (a -> b) -> a -> b
$
            Invertible (FL (PatchInfoAnd p)) wX wR
-> Invertible (FL (PatchInfoAnd p)) wR wX
forall wX wY.
Invertible (FL (PatchInfoAnd p)) wX wY
-> Invertible (FL (PatchInfoAnd p)) wY wX
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert (Invertible (FL (PatchInfoAnd p)) wX wR
 -> Invertible (FL (PatchInfoAnd p)) wR wX)
-> Invertible (FL (PatchInfoAnd p)) wX wR
-> Invertible (FL (PatchInfoAnd p)) wR wX
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd p) wX wR -> Invertible (FL (PatchInfoAnd p)) wX wR
forall (p :: * -> * -> *) wX wY. p wX wY -> Invertible p wX wY
mkInvertible (FL (PatchInfoAnd p) wX wR
 -> Invertible (FL (PatchInfoAnd p)) wX wR)
-> FL (PatchInfoAnd p) wX wR
-> Invertible (FL (PatchInfoAnd p)) wX wR
forall a b. (a -> b) -> a -> b
$ String -> FL (PatchInfoAnd p) wX wR -> FL (PatchInfoAnd p) wX wR
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Applying inverse to pristine" FL (PatchInfoAnd p) wX wR
ps
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UpdatePending
upe UpdatePending -> UpdatePending -> Bool
forall a. Eq a => a -> a -> Bool
== UpdatePending
YesUpdatePending) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          String -> IO ()
debugMessage String
"Adding changes to pending..."
          Sealed FL (PrimOf p) wR wX
pend <- Repository 'RW p wU wR -> IO (Sealed (FL (PrimOf p) wR))
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RW p wU wR -> IO (Sealed (FL (PrimOf p) wR))
readTentativePending Repository 'RW p wU wR
r
          Repository 'RW p wU wX -> FL (PrimOf p) wX wX -> IO ()
forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
writeTentativePending Repository 'RW p wU wX
r' (FL (PrimOf p) wX wX -> IO ()) -> FL (PrimOf p) wX wX -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd p) wX wR
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wR
forall wX wY.
FL (PatchInfoAnd p) wX wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd p) wX wR
ps FL (PrimOf p) wX wR -> FL (PrimOf p) wR wX -> FL (PrimOf p) wX wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wR wX
pend
        Repository 'RW p wU wX -> IO (Repository 'RW p wU wX)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Repository 'RW p wU wX
r'
  | Bool
otherwise = String -> IO (Repository 'RW p wU wX)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
Old.oldRepoFailMsg

-- | Attempt to remove an FL of patches from the tentative inventory.
--
-- Precondition: it must be possible to remove the patches, i.e.
--
-- * the patches are in the repository
--
-- * any necessary commutations will succeed
removeFromTentativeInventory :: forall p wU wR wX. RepoPatch p
                             => Repository 'RW p wU wR
                             -> FL (PatchInfoAnd p) wX wR
                             -> IO (Repository 'RW p wU wX)
removeFromTentativeInventory :: forall (p :: * -> * -> *) wU wR wX.
RepoPatch p =>
Repository 'RW p wU wR
-> FL (PatchInfoAnd p) wX wR -> IO (Repository 'RW p wU wX)
removeFromTentativeInventory Repository 'RW p wU wR
repo FL (PatchInfoAnd p) wX wR
to_remove = do
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Start removeFromTentativeInventory"
    PatchSet p Origin wR
allpatches :: PatchSet p Origin wR <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) wU wR.
(PatchListFormat p, ReadPatch p) =>
Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
readTentativePatches Repository 'RW p wU wR
repo
    PatchSet p Origin wX
remaining :: PatchSet p Origin wX <-
      case FL (PatchInfoAnd p) wX wR
-> PatchSet p Origin wR -> Maybe (PatchSet p Origin wX)
forall (p :: * -> * -> *) wX wY wStart.
(Commute p, Eq2 p) =>
FL (PatchInfoAnd p) wX wY
-> PatchSet p wStart wY -> Maybe (PatchSet p wStart wX)
removeFromPatchSet FL (PatchInfoAnd p) wX wR
to_remove PatchSet p Origin wR
allpatches of
        Maybe (PatchSet p Origin wX)
Nothing -> String -> IO (PatchSet p Origin wX)
forall a. HasCallStack => String -> a
error String
"Hashed.removeFromTentativeInventory: precondition violated"
        Just PatchSet p Origin wX
r -> PatchSet p Origin wX -> IO (PatchSet p Origin wX)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PatchSet p Origin wX
r
    let repo' :: Repository 'RW p wU wR'
repo' = Repository 'RW p wU wR -> Repository 'RW p wU wR'
forall (rt :: AccessType) (p :: * -> * -> *) wU wR wR'.
Repository rt p wU wR -> Repository rt p wU wR'
unsafeCoerceR Repository 'RW p wU wR
repo
    Repository 'RW p wU Any -> PatchSet p Origin wX -> IO ()
forall (p :: * -> * -> *) wU wR wX.
RepoPatch p =>
Repository 'RW p wU wR -> PatchSet p Origin wX -> IO ()
writeTentativeInventory Repository 'RW p wU Any
forall {wR'}. Repository 'RW p wU wR'
repo' PatchSet p Origin wX
remaining
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Done removeFromTentativeInventory"
    Repository 'RW p wU wX -> IO (Repository 'RW p wU wX)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Repository 'RW p wU wX
forall {wR'}. Repository 'RW p wU wR'
repo'

-- | Writes out a fresh copy of the inventory that minimizes the
-- amount of inventory that need be downloaded when people pull from
-- the repository. The exact beavior depends on the 3rd parameter:
--
-- For 'OptimizeShallow' 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.
--
-- For 'OptimizeDeep', the whole repo is traversed, from oldest to newest
-- patch. Every tag we encounter is made clean, but only if that doesn't make
-- any previous clean tag unclean. Every clean tags gets its own inventory.
-- This speeds up "deep" operations, too, such as cloning a specific tag.
-- It does not necessarily make the latest tag clean, but the benefits are
-- similar to the shallow case.
reorderInventory :: (RepoPatch p, ApplyState p ~ Tree)
                 => Repository 'RW p wU wR
                 -> OptimizeDeep
                 -> IO ()
reorderInventory :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> OptimizeDeep -> IO ()
reorderInventory Repository 'RW p wU wR
r OptimizeDeep
deep
  | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory (Repository 'RW p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository 'RW p wU wR
r) = do
      let optimize :: PatchSet p Origin wZ -> PatchSet p Origin wZ
optimize =
            case OptimizeDeep
deep of
              OptimizeDeep
OptimizeDeep -> PatchSet p Origin wZ -> PatchSet p Origin wZ
forall (p :: * -> * -> *) wZ.
Commute p =>
PatchSet p Origin wZ -> PatchSet p Origin wZ
fullyOptimizePatchSet
              OptimizeDeep
OptimizeShallow -> PatchSet p Origin wZ -> PatchSet p Origin wZ
forall (p :: * -> * -> *) wStart wX.
Commute p =>
PatchSet p wStart wX -> PatchSet p wStart wX
cleanLatestTag
      Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RW p wU wR
r IO (PatchSet p Origin wR)
-> (PatchSet p Origin wR -> IO (PatchSet p Origin wR))
-> IO (PatchSet p Origin wR)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PatchSet p Origin wR -> IO (PatchSet p Origin wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchSet p Origin wR -> IO (PatchSet p Origin wR))
-> (PatchSet p Origin wR -> PatchSet p Origin wR)
-> PatchSet p Origin wR
-> IO (PatchSet p Origin wR)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchSet p Origin wR -> PatchSet p Origin wR
forall {wZ}. PatchSet p Origin wZ -> PatchSet p Origin wZ
optimize IO (PatchSet p Origin wR)
-> (PatchSet p Origin wR -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Repository 'RW p wU wR -> PatchSet p Origin wR -> IO ()
forall (p :: * -> * -> *) wU wR wX.
RepoPatch p =>
Repository 'RW p wU wR -> PatchSet p Origin wX -> IO ()
writeTentativeInventory Repository 'RW p wU wR
r
      Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanRepository Repository 'RW p wU wR
r
      IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RW p wU wR -> IO ()
finalizeTentativeChanges Repository 'RW p wU wR
r
  | Bool
otherwise = String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
Old.oldRepoFailMsg

-- | Read inventories and patches from a 'Repository' and return them as a
-- 'PatchSet'. Note that patches and inventories are read lazily.
readPatches :: RepoPatch p
            => Repository rt p wU wR
            -> IO (PatchSet p Origin wR)
readPatches :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository rt p wU wR
r
    | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory (Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
r) = Repository rt p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(PatchListFormat p, ReadPatch p) =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatchesHashed Repository rt p wU wR
r
    | Bool
otherwise = do Sealed PatchSet p Origin wX
ps <- String -> IO (Sealed (PatchSet p Origin))
forall (p :: * -> * -> *).
RepoPatch p =>
String -> IO (SealedPatchSet p Origin)
Old.readOldRepo (Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
r)
                     PatchSet p Origin wR -> IO (PatchSet p Origin wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchSet p Origin wR -> IO (PatchSet p Origin wR))
-> PatchSet p Origin wR -> IO (PatchSet p Origin wR)
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wX -> PatchSet p Origin wR
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP PatchSet p Origin wX
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 :: RepoPatch p => Repository rt p wU wR -> IO SHA1
repoXor :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO SHA1
repoXor Repository rt p wU wR
repo = do
  [SHA1]
hashes <- (forall wW wZ. PatchInfoAnd p wW wZ -> SHA1)
-> RL (PatchInfoAnd p) Origin wR -> [SHA1]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL (PatchInfo -> SHA1
makePatchname (PatchInfo -> SHA1)
-> (PatchInfoAnd p wW wZ -> PatchInfo)
-> PatchInfoAnd p wW wZ
-> SHA1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wW wZ -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info) (RL (PatchInfoAnd p) Origin wR -> [SHA1])
-> (PatchSet p Origin wR -> RL (PatchInfoAnd p) Origin wR)
-> PatchSet p Origin wR
-> [SHA1]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchSet p Origin wR -> RL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX
patchSet2RL (PatchSet p Origin wR -> [SHA1])
-> IO (PatchSet p Origin wR) -> IO [SHA1]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository rt p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository rt p wU wR
repo
  SHA1 -> IO SHA1
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SHA1 -> IO SHA1) -> SHA1 -> IO SHA1
forall a b. (a -> b) -> a -> b
$ (SHA1 -> SHA1 -> SHA1) -> SHA1 -> [SHA1] -> SHA1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SHA1 -> SHA1 -> SHA1
sha1Xor SHA1
sha1zero [SHA1]
hashes