{-# LANGUAGE OverloadedStrings #-}
module Darcs.Repository.Transaction
    ( revertRepositoryChanges
    , finalizeRepositoryChanges
    , upgradeOldStyleRebase
    ) where

import Darcs.Prelude

import Control.Monad ( unless, void, when )
import System.Directory ( doesFileExist, removeFile )
import System.IO ( IOMode(..), hClose, hPutStrLn, openBinaryFile, stderr )
import System.IO.Error ( catchIOError )

import Darcs.Patch ( ApplyState, PatchInfoAnd, RepoPatch )
import qualified Darcs.Patch.Rebase.Legacy.Wrapped as W
import Darcs.Patch.Rebase.Suspended ( Suspended(..), showSuspended )
import Darcs.Patch.Set ( Origin, PatchSet(..), Tagged(..) )
import Darcs.Patch.Show ( ShowPatchFor(..) )
import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) )
import Darcs.Patch.Witnesses.Sealed ( Dup(..), Sealed(..) )

import Darcs.Repository.Flags ( DryRun(..) )
import Darcs.Repository.Format
    ( RepoProperty(HashedInventory, RebaseInProgress, RebaseInProgress_2_16)
    , addToFormat
    , formatHas
    , removeFromFormat
    )
import Darcs.Repository.Hashed
    ( finalizeTentativeChanges
    , readPatches
    , readTentativePatches
    , revertTentativeChanges
    , writeTentativeInventory
    )
import Darcs.Repository.InternalTypes
    ( AccessType(..)
    , Repository
    , modifyRepoFormat
    , repoCache
    , repoFormat
    , repoLocation
    , unsafeCoerceR
    , unsafeEndTransaction
    , unsafeStartTransaction
    , withRepoDir
    )
import Darcs.Repository.Inventory ( readOneInventory )
import qualified Darcs.Repository.Old as Old ( oldRepoFailMsg )
import Darcs.Repository.PatchIndex
    ( createOrUpdatePatchIndexDisk
    , doesPatchIndexExist
    )
import Darcs.Repository.Paths
    ( indexInvalidPath
    , indexPath
    , tentativeHashedInventoryPath
    )
import Darcs.Repository.Pending ( finalizePending, revertPending )
import Darcs.Repository.Rebase
    ( extractOldStyleRebase
    , finalizeTentativeRebase
    , readTentativeRebase
    , revertTentativeRebase
    , updateRebaseFormat
    , writeTentativeRebase
    )
import Darcs.Repository.State ( updateIndex )
import Darcs.Repository.Unrevert
    ( finalizeTentativeUnrevert
    , revertTentativeUnrevert
    )

import Darcs.Util.Printer ( text, ($$) )
import Darcs.Util.Printer.Color ( ePutDocLn )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Util.Tree ( Tree )


-- 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.
revertRepositoryChanges :: RepoPatch p
                        => Repository 'RO p wU wR
                        -> IO (Repository 'RW p wU wR)
revertRepositoryChanges :: forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RO p wU wR -> IO (Repository 'RW p wU wR)
revertRepositoryChanges Repository 'RO p wU wR
r
  | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory (Repository 'RO p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository 'RO p wU wR
r) =
      Repository 'RO p wU wR
-> IO (Repository 'RW p wU wR) -> IO (Repository 'RW p wU wR)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR a.
Repository rt p wU wR -> IO a -> IO a
withRepoDir Repository 'RO p wU wR
r (IO (Repository 'RW p wU wR) -> IO (Repository 'RW p wU wR))
-> IO (Repository 'RW p wU wR) -> IO (Repository 'RW p wU wR)
forall a b. (a -> b) -> a -> b
$ do
        IO ()
checkIndexIsWritable
          IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
e -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ([String] -> String
unlines [String
"Cannot write index", IOError -> String
forall a. Show a => a -> String
show IOError
e])
        IO ()
revertTentativeUnrevert
        Repository 'RO p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RO p wU wR -> IO ()
revertPending Repository 'RO p wU wR
r
        Repository 'RO p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RO p wU wR -> IO ()
revertTentativeChanges Repository 'RO p wU wR
r
        let r' :: Repository 'RO p wU wR'
r' = Repository 'RO p wU wR -> Repository 'RO p wU wR'
forall (rt :: AccessType) (p :: * -> * -> *) wU wR wR'.
Repository rt p wU wR -> Repository rt p wU wR'
unsafeCoerceR Repository 'RO p wU wR
r
        Repository 'RO p wU (ZonkAny 3) -> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO ()
revertTentativeRebase Repository 'RO p wU (ZonkAny 3)
forall {wR'}. Repository 'RO p wU wR'
r'
        Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository 'RW p wU wR -> IO (Repository 'RW p wU wR))
-> Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
forall a b. (a -> b) -> a -> b
$ Repository 'RO p wU wR -> Repository 'RW p wU wR
forall (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR -> Repository 'RW p wU wR
unsafeStartTransaction Repository 'RO p wU wR
forall {wR'}. Repository 'RO p wU wR'
r'
  | Bool
otherwise = String -> IO (Repository 'RW p wU wR)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
Old.oldRepoFailMsg

-- | Atomically copy the tentative state to the recorded state,
-- thereby committing the tentative changes that were made so far.
-- This includes inventories, pending, rebase, and the index.
finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree)
                          => Repository 'RW p wU wR
                          -> DryRun
                          -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges Repository 'RW p wU wR
r DryRun
dryrun
    | 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) =
        Repository 'RW p wU wR
-> IO (Repository 'RO p wU wR) -> IO (Repository 'RO p wU wR)
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 'RO p wU wR) -> IO (Repository 'RO p wU wR))
-> IO (Repository 'RO p wU wR) -> IO (Repository 'RO p wU wR)
forall a b. (a -> b) -> a -> b
$ do
          let r' :: Repository 'RO p wU wR
r' = Repository 'RW p wU wR -> Repository 'RO p wU wR
forall (p :: * -> * -> *) wU wR.
Repository 'RW p wU wR -> Repository 'RO p wU wR
unsafeEndTransaction (Repository 'RW p wU wR -> Repository 'RO p wU wR)
-> Repository 'RW p wU wR -> Repository 'RO p wU wR
forall a b. (a -> b) -> a -> b
$ 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
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DryRun
dryrun DryRun -> DryRun -> Bool
forall a. Eq a => a -> a -> Bool
== DryRun
NoDryRun) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
debugMessage String
"Finalizing changes..."
            IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RW p wU wR -> IO ()
updateRebaseFormat Repository 'RW p wU wR
r
                IO ()
finalizeTentativeRebase
                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
                Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
finalizePending Repository 'RW p wU wR
r
                IO ()
finalizeTentativeUnrevert
            String -> IO ()
debugMessage String
"Done finalizing changes..."
            ps <- Repository 'RO p wU (ZonkAny 0)
-> IO (PatchSet p Origin (ZonkAny 0))
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RO p wU (ZonkAny 0)
forall {wR}. Repository 'RO p wU wR
r'
            pi_exists <- doesPatchIndexExist (repoLocation r')
            when pi_exists $
              createOrUpdatePatchIndexDisk r' ps
              `catchIOError` \IOError
e ->
                Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot create or update patch index: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e
            updateIndex r'
          Repository 'RO p wU wR -> IO (Repository 'RO p wU wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Repository 'RO p wU wR
forall {wR}. Repository 'RO p wU wR
r'
    | Bool
otherwise = String -> IO (Repository 'RO p wU wR)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
Old.oldRepoFailMsg

-- | Upgrade a possible old-style rebase in progress to the new style.
upgradeOldStyleRebase :: forall p wU wR.
                         (RepoPatch p, ApplyState p ~ Tree)
                      => Repository 'RW p wU wR -> IO ()
upgradeOldStyleRebase :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> IO ()
upgradeOldStyleRebase Repository 'RW p wU wR
repo = do
  PatchSet (ts :: RL (Tagged p) Origin wX) _ <- 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
  Sealed wps <-
    readOneInventory @(W.WrappedNamed p) (repoCache repo) tentativeHashedInventoryPath
  case extractOldStyleRebase wps of
    Maybe ((:>) (RL (PatchInfoAnd p)) (Dup (Suspended p)) wX wX)
Nothing ->
      Doc -> IO ()
ePutDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"No old-style rebase state found, no upgrade needed."
    Just ((RL (PatchInfoAnd p) wX wZ
ps :: RL (PatchInfoAnd p) wX wZ) :> Dup Suspended p wZ
r) -> do
      -- low-level call, must not try to update an existing rebase patch,
      -- nor update anything else beside the inventory
      Repository 'RW p wU wR -> PatchSet p Origin wZ -> IO ()
forall (p :: * -> * -> *) wU wR wX.
RepoPatch p =>
Repository 'RW p wU wR -> PatchSet p Origin wX -> IO ()
writeTentativeInventory Repository 'RW p wU wR
repo (RL (Tagged p) Origin wX
-> RL (PatchInfoAnd p) wX wZ -> PatchSet p Origin wZ
forall (p :: * -> * -> *) wX wY.
RL (Tagged p) Origin wX
-> RL (PatchInfoAnd p) wX wY -> PatchSet p Origin wY
PatchSet RL (Tagged p) Origin wX
ts RL (PatchInfoAnd p) wX wZ
ps)
      Items old_r <- Repository 'RW p wU wR -> IO (Suspended p wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (Suspended p wR)
readTentativeRebase Repository 'RW p wU wR
repo
      case old_r of
        FL (RebaseChange (PrimOf p)) wR wY
NilFL -> do
          Repository 'RW p wU wZ -> Suspended p wZ -> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> Suspended p wR -> IO ()
writeTentativeRebase (Repository 'RW p wU wR -> Repository 'RW p wU wZ
forall (rt :: AccessType) (p :: * -> * -> *) wU wR wR'.
Repository rt p wU wR -> Repository rt p wU wR'
unsafeCoerceR Repository 'RW p wU wR
repo) Suspended p wZ
r
          repo' <-
            (RepoFormat -> RepoFormat)
-> Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoFormat -> RepoFormat)
-> Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
modifyRepoFormat
              (RepoProperty -> RepoFormat -> RepoFormat
addToFormat RepoProperty
RebaseInProgress_2_16 (RepoFormat -> RepoFormat)
-> (RepoFormat -> RepoFormat) -> RepoFormat -> RepoFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoProperty -> RepoFormat -> RepoFormat
removeFromFormat RepoProperty
RebaseInProgress)
              Repository 'RW p wU wR
repo
          void $ finalizeRepositoryChanges repo' NoDryRun
        FL (RebaseChange (PrimOf p)) wR wY
_ -> do
          Doc -> IO ()
ePutDocLn
            (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$  Doc
"A new-style rebase is already in progress, not overwriting it."
            Doc -> Doc -> Doc
$$ Doc
"This should not have happened! This is the old-style rebase I found"
            Doc -> Doc -> Doc
$$ Doc
"and removed from the repository:"
            Doc -> Doc -> Doc
$$ ShowPatchFor -> Suspended p wZ -> Doc
forall (p :: * -> * -> *) wX.
PrimPatchBase p =>
ShowPatchFor -> Suspended p wX -> Doc
showSuspended ShowPatchFor
ForDisplay Suspended p wZ
r

checkIndexIsWritable :: IO ()
checkIndexIsWritable :: IO ()
checkIndexIsWritable = do
    String -> IO ()
checkWritable String
indexInvalidPath
    String -> IO ()
checkWritable String
indexPath
  where
    checkWritable :: String -> IO ()
checkWritable String
path = do
      exists <- String -> IO Bool
doesFileExist String
path
      touchFile path
      unless exists $ removeFile path
    touchFile :: String -> IO ()
touchFile String
path = String -> IOMode -> IO Handle
openBinaryFile String
path IOMode
AppendMode IO Handle -> (Handle -> 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
>>= Handle -> IO ()
hClose