-- Copyright (C) 2002-2004,2007-2008 David Roundy
-- Copyright (C) 2005 Juliusz Chroboczek
--
-- 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; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# LANGUAGE MultiWayIf #-}

module Darcs.Repository.Job
    ( RepoJob(..)
    , IsPrimV1(..)
    , withRepoLock
    , withOldRepoLock
    , withRepoLockCanFail
    , withRepository
    , withRepositoryLocation
    , withUMaskFlag
    ) where

import Darcs.Prelude

import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.V1 ( RepoPatchV1 )
import Darcs.Patch.V2 ( RepoPatchV2 )
import Darcs.Patch.V3 ( RepoPatchV3 )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )
import Darcs.Patch ( PrimOf )
import Darcs.Patch.Prim.V1 ( Prim )
import Darcs.Patch.RepoPatch ( RepoPatch )

import Darcs.Repository.Flags ( UMask(..), UseCache(..) )
import Darcs.Repository.Format
    ( RepoProperty( Darcs2
                  , Darcs3
                  , HashedInventory
                  )
    , formatHas
    , writeProblem
    )
import Darcs.Repository.Identify ( identifyRepository )
import Darcs.Repository.Transaction( revertRepositoryChanges )
import Darcs.Repository.InternalTypes
    ( Repository
    , AccessType(..)
    , repoFormat
    , unsafeCoercePatchType
    , unsafeStartTransaction
    )
import Darcs.Repository.Paths ( lockPath )
import Darcs.Repository.Rebase
    ( displayRebaseStatus
    , checkOldStyleRebaseStatus
    )
import Darcs.Util.Lock ( withLock, withLockCanFail )

import Darcs.Util.Progress ( debugMessage )

import Control.Monad ( when )
import Control.Exception ( bracket_, finally )
import Data.Constraint ( Dict(..) )

import Foreign.C.String ( CString, withCString )
import Foreign.C.Error ( throwErrno )
import Foreign.C.Types ( CInt(..) )

import Darcs.Util.Tree ( Tree )

withUMaskFlag :: UMask -> IO a -> IO a
withUMaskFlag :: forall a. UMask -> IO a -> IO a
withUMaskFlag UMask
NoUMask = IO a -> IO a
forall a. a -> a
id
withUMaskFlag (YesUMask String
umask) = String -> IO a -> IO a
forall a. String -> IO a -> IO a
withUMask String
umask

foreign import ccall unsafe "umask.h set_umask" set_umask
    :: CString -> IO CInt
foreign import ccall unsafe "umask.h reset_umask" reset_umask
    :: CInt -> IO CInt

withUMask :: String
          -> IO a
          -> IO a
withUMask :: forall a. String -> IO a -> IO a
withUMask String
umask IO a
job =
    do CInt
rc <- String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
umask CString -> IO CInt
set_umask
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0) (String -> IO ()
forall a. String -> IO a
throwErrno String
"Couldn't set umask")
       IO () -> IO CInt -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
           (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
           (CInt -> IO CInt
reset_umask CInt
rc)
           IO a
job

type Job rt p wR wU a = Repository rt p wU wR -> IO a

type TreePatch p = (RepoPatch p, ApplyState p ~ Tree)
type V1Patch p = p ~ RepoPatchV1 V1.Prim
type V2Patch p = p ~ RepoPatchV2 V2.Prim
type PrimV1Patch p = (TreePatch p, IsPrimV1 (PrimOf p))

type TreePatchJob rt a = forall p wR wU . TreePatch p => Job rt p wR wU a
type V1PatchJob rt a = forall p wR wU . V1Patch p => Job rt p wR wU a
type V2PatchJob rt a = forall p wR wU . V2Patch p => Job rt p wR wU a
type PrimV1PatchJob rt a = forall p wR wU . PrimV1Patch p => Job rt p wR wU a

-- |A @RepoJob@ wraps up an action to be performed with a repository. Because
-- repositories can contain different types of patches, such actions typically
-- need to be polymorphic in the kind of patch they work on. @RepoJob@ is used
-- to wrap up the polymorphism, and the various functions that act on a
-- @RepoJob@ are responsible for instantiating the underlying action with the
-- appropriate patch type.
data RepoJob rt a
    -- TODO: Unbind Tree from RepoJob, possibly renaming existing RepoJob

    -- |The most common 'RepoJob'; the underlying action can accept any patch
    -- whose 'ApplyState' is 'Tree'.
    = RepoJob (TreePatchJob rt a)
    -- |A job that only works on darcs 1 patches
    | V1Job (V1PatchJob rt a)
    -- |A job that only works on darcs 2 patches
    | V2Job (V2PatchJob rt a)
    -- |A job that works on any repository where the patch type @p@ has
    -- 'PrimOf' @p@ = 'Prim'. This was added to support darcsden, which
    -- inspects the internals of V1 prim patches. In future it should be
    -- replaced with a more abstract inspection API as part of 'PrimPatch'.
    | PrimV1Job (PrimV1PatchJob rt a)
    -- |A job that works even if there is an old-style rebase in progress.
    | OldRebaseJob (TreePatchJob rt a)

onRepoJob
  :: RepoJob rt1 a -- original repojob passed to withXxx
  -> (  forall p wR wU
      . TreePatch p
     => (Repository rt1 p wU wR -> IO a)
     -> (Repository rt2 p wU wR -> IO a)
     )
  -> RepoJob rt2 a -- result job takes a Repo rt2
onRepoJob :: forall (rt1 :: AccessType) a (rt2 :: AccessType).
RepoJob rt1 a
-> (forall (p :: * -> * -> *) wR wU.
    TreePatch p =>
    (Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a)
-> RepoJob rt2 a
onRepoJob (RepoJob TreePatchJob rt1 a
job) forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f = TreePatchJob rt2 a -> RepoJob rt2 a
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob ((Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f Repository rt1 p wU wR -> IO a
TreePatchJob rt1 a
job)
onRepoJob (V1Job V1PatchJob rt1 a
job) forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f = V1PatchJob rt2 a -> RepoJob rt2 a
forall (rt :: AccessType) a. V1PatchJob rt a -> RepoJob rt a
V1Job ((Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f Repository rt1 p wU wR -> IO a
V1PatchJob rt1 a
job)
onRepoJob (V2Job V2PatchJob rt1 a
job) forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f = V2PatchJob rt2 a -> RepoJob rt2 a
forall (rt :: AccessType) a. V2PatchJob rt a -> RepoJob rt a
V2Job ((Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f Repository rt1 p wU wR -> IO a
V2PatchJob rt1 a
job)
onRepoJob (PrimV1Job PrimV1PatchJob rt1 a
job) forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f = PrimV1PatchJob rt2 a -> RepoJob rt2 a
forall (rt :: AccessType) a. PrimV1PatchJob rt a -> RepoJob rt a
PrimV1Job ((Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f Repository rt1 p wU wR -> IO a
PrimV1PatchJob rt1 a
job)
onRepoJob (OldRebaseJob TreePatchJob rt1 a
job) forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f = TreePatchJob rt2 a -> RepoJob rt2 a
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
OldRebaseJob ((Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
forall (p :: * -> * -> *) wR wU.
TreePatch p =>
(Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a
f Repository rt1 p wU wR -> IO a
TreePatchJob rt1 a
job)

-- | This is just an internal type to Darcs.Repository.Job for
-- calling runJob in a strongly-typed way
data RepoPatchType p where
  RepoV1 :: RepoPatchType (RepoPatchV1 V1.Prim)
  RepoV2 :: RepoPatchType (RepoPatchV2 V2.Prim)
  RepoV3 :: RepoPatchType (RepoPatchV3 V2.Prim)

-- | Check multiple patch types against the
-- constraints required by most repository jobs
checkTree :: RepoPatchType p -> Dict (ApplyState p ~ Tree)
checkTree :: forall (p :: * -> * -> *).
RepoPatchType p -> Dict (ApplyState p ~ Tree)
checkTree RepoPatchType p
RepoV1 = Dict (Tree ~ Tree)
Dict (ApplyState p ~ Tree)
forall (a :: Constraint). a => Dict a
Dict
checkTree RepoPatchType p
RepoV2 = Dict (Tree ~ Tree)
Dict (ApplyState p ~ Tree)
forall (a :: Constraint). a => Dict a
Dict
checkTree RepoPatchType p
RepoV3 = Dict (Tree ~ Tree)
Dict (ApplyState p ~ Tree)
forall (a :: Constraint). a => Dict a
Dict

class IsPrimV1 p where
  toPrimV1 :: p wX wY -> Prim wX wY
instance IsPrimV1 V1.Prim where
  toPrimV1 :: forall wX wY. Prim wX wY -> Prim wX wY
toPrimV1 = Prim wX wY -> Prim wX wY
forall wX wY. Prim wX wY -> Prim wX wY
V1.unPrim
instance IsPrimV1 V2.Prim where
  toPrimV1 :: forall wX wY. Prim wX wY -> Prim wX wY
toPrimV1 = Prim wX wY -> Prim wX wY
forall wX wY. Prim wX wY -> Prim wX wY
V2.unPrim

-- | Check multiple patch types against the
-- constraints required by 'PrimV1Job'
checkPrimV1 :: RepoPatchType p -> Dict (IsPrimV1 (PrimOf p))
checkPrimV1 :: forall (p :: * -> * -> *).
RepoPatchType p -> Dict (IsPrimV1 (PrimOf p))
checkPrimV1 RepoPatchType p
RepoV1 = Dict (IsPrimV1 (PrimOf p))
Dict (IsPrimV1 Prim)
forall (a :: Constraint). a => Dict a
Dict
checkPrimV1 RepoPatchType p
RepoV2 = Dict (IsPrimV1 (PrimOf p))
Dict (IsPrimV1 Prim)
forall (a :: Constraint). a => Dict a
Dict
checkPrimV1 RepoPatchType p
RepoV3 = Dict (IsPrimV1 (PrimOf p))
Dict (IsPrimV1 Prim)
forall (a :: Constraint). a => Dict a
Dict

runJob
  :: forall rt p pDummy wR wU a
   . RepoPatch p
  => RepoPatchType p
  -> Repository rt pDummy wU wR
  -> RepoJob rt a
  -> IO a
runJob :: forall (rt :: AccessType) (p :: * -> * -> *)
       (pDummy :: * -> * -> *) wR wU a.
RepoPatch p =>
RepoPatchType p
-> Repository rt pDummy wU wR -> RepoJob rt a -> IO a
runJob RepoPatchType p
patchType Repository rt pDummy wU wR
repo RepoJob rt a
repojob = do
  -- The actual type the repository should have is only known when
  -- when this function is called, so we need to "cast" it to its proper type
  let
    therepo :: Repository rt p wU wR
therepo = Repository rt pDummy wU wR -> Repository rt p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR
       (p' :: * -> * -> *).
Repository rt p wU wR -> Repository rt p' wU wR
unsafeCoercePatchType Repository rt pDummy wU wR
repo :: Repository rt p wU wR
    incompatible :: String -> String -> m a
incompatible String
want String
got = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$
      String
"This repository contains darcs "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
gotString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" patches,\
      \ but the command requires darcs "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
wantString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" patches."
  Dict (ApplyState (PrimOf p) ~ Tree)
Dict <- Dict (ApplyState (PrimOf p) ~ Tree)
-> IO (Dict (ApplyState (PrimOf p) ~ Tree))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dict (ApplyState (PrimOf p) ~ Tree)
 -> IO (Dict (ApplyState (PrimOf p) ~ Tree)))
-> Dict (ApplyState (PrimOf p) ~ Tree)
-> IO (Dict (ApplyState (PrimOf p) ~ Tree))
forall a b. (a -> b) -> a -> b
$ RepoPatchType p -> Dict (ApplyState p ~ Tree)
forall (p :: * -> * -> *).
RepoPatchType p -> Dict (ApplyState p ~ Tree)
checkTree RepoPatchType p
patchType
  let thejob :: IO a
thejob =
        case RepoJob rt a
repojob of
          RepoJob TreePatchJob rt a
job -> do
            Repository rt p wU wR -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO ()
checkOldStyleRebaseStatus Repository rt p wU wR
therepo
            Job rt p wR wU a
TreePatchJob rt a
job Repository rt p wU wR
therepo
          PrimV1Job PrimV1PatchJob rt a
job -> do
            Dict (IsPrimV1 (PrimOf p))
Dict <- Dict (IsPrimV1 (PrimOf p)) -> IO (Dict (IsPrimV1 (PrimOf p)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dict (IsPrimV1 (PrimOf p)) -> IO (Dict (IsPrimV1 (PrimOf p))))
-> Dict (IsPrimV1 (PrimOf p)) -> IO (Dict (IsPrimV1 (PrimOf p)))
forall a b. (a -> b) -> a -> b
$ RepoPatchType p -> Dict (IsPrimV1 (PrimOf p))
forall (p :: * -> * -> *).
RepoPatchType p -> Dict (IsPrimV1 (PrimOf p))
checkPrimV1 RepoPatchType p
patchType
            Repository rt p wU wR -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO ()
checkOldStyleRebaseStatus Repository rt p wU wR
therepo
            Job rt p wR wU a
PrimV1PatchJob rt a
job Repository rt p wU wR
therepo
          V2Job V2PatchJob rt a
job ->
            case RepoPatchType p
patchType of
              RepoPatchType p
RepoV2 -> do
                Repository rt p wU wR -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO ()
checkOldStyleRebaseStatus Repository rt p wU wR
therepo
                Job rt p wR wU a
V2PatchJob rt a
job Repository rt p wU wR
therepo
              RepoPatchType p
RepoV1 -> String -> String -> IO a
forall {m :: * -> *} {a}. MonadFail m => String -> String -> m a
incompatible String
"v2" String
"v1"
              RepoPatchType p
RepoV3 -> String -> String -> IO a
forall {m :: * -> *} {a}. MonadFail m => String -> String -> m a
incompatible String
"v2" String
"v3"
          V1Job V1PatchJob rt a
job ->
            case RepoPatchType p
patchType of
              RepoPatchType p
RepoV1 -> do
                Repository rt p wU wR -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO ()
checkOldStyleRebaseStatus Repository rt p wU wR
therepo
                Job rt p wR wU a
V1PatchJob rt a
job Repository rt p wU wR
therepo
              RepoPatchType p
RepoV2 -> String -> String -> IO a
forall {m :: * -> *} {a}. MonadFail m => String -> String -> m a
incompatible String
"v1" String
"v2"
              RepoPatchType p
RepoV3 -> String -> String -> IO a
forall {m :: * -> *} {a}. MonadFail m => String -> String -> m a
incompatible String
"v1" String
"v3"
          OldRebaseJob TreePatchJob rt a
job -> Job rt p wR wU a
TreePatchJob rt a
job Repository rt p wU wR
therepo
  IO a
thejob IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Repository rt p wU wR -> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO ()
displayRebaseStatus Repository rt p wU wR
therepo

-- | apply a given RepoJob to a repository in a given url
withRepositoryLocation :: UseCache -> String -> RepoJob 'RO a -> IO a
withRepositoryLocation :: forall a. UseCache -> String -> RepoJob 'RO a -> IO a
withRepositoryLocation UseCache
useCache String
url RepoJob 'RO a
repojob = do
  Repository 'RO Any Any Any
repo <- UseCache -> String -> IO (Repository 'RO Any Any Any)
forall (p :: * -> * -> *) wU wR.
UseCache -> String -> IO (Repository 'RO p wU wR)
identifyRepository UseCache
useCache String
url
  let rf :: RepoFormat
rf = Repository 'RO Any Any Any -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository 'RO Any Any Any
repo
  if | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs3 RepoFormat
rf -> RepoPatchType (RepoPatchV3 PrimPatchId Prim)
-> Repository 'RO Any Any Any -> RepoJob 'RO a -> IO a
forall (rt :: AccessType) (p :: * -> * -> *)
       (pDummy :: * -> * -> *) wR wU a.
RepoPatch p =>
RepoPatchType p
-> Repository rt pDummy wU wR -> RepoJob rt a -> IO a
runJob RepoPatchType (RepoPatchV3 PrimPatchId Prim)
RepoV3 Repository 'RO Any Any Any
repo RepoJob 'RO a
repojob
     | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs2 RepoFormat
rf -> RepoPatchType (RepoPatchV2 Prim)
-> Repository 'RO Any Any Any -> RepoJob 'RO a -> IO a
forall (rt :: AccessType) (p :: * -> * -> *)
       (pDummy :: * -> * -> *) wR wU a.
RepoPatch p =>
RepoPatchType p
-> Repository rt pDummy wU wR -> RepoJob rt a -> IO a
runJob RepoPatchType (RepoPatchV2 Prim)
RepoV2 Repository 'RO Any Any Any
repo RepoJob 'RO a
repojob
     | Bool
otherwise -> RepoPatchType (RepoPatchV1 Prim)
-> Repository 'RO Any Any Any -> RepoJob 'RO a -> IO a
forall (rt :: AccessType) (p :: * -> * -> *)
       (pDummy :: * -> * -> *) wR wU a.
RepoPatch p =>
RepoPatchType p
-> Repository rt pDummy wU wR -> RepoJob rt a -> IO a
runJob RepoPatchType (RepoPatchV1 Prim)
RepoV1 Repository 'RO Any Any Any
repo RepoJob 'RO a
repojob

-- | apply a given RepoJob to a repository in the current working directory
withRepository :: UseCache -> RepoJob 'RO a -> IO a
withRepository :: forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository UseCache
useCache = UseCache -> String -> RepoJob 'RO a -> IO a
forall a. UseCache -> String -> RepoJob 'RO a -> IO a
withRepositoryLocation UseCache
useCache String
"."

-- | Apply a given RepoJob to a repository in the current working directory.
-- However, before doing the job, take the repo lock and initializes a repo
-- transaction.
withRepoLock :: UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock :: forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock UseCache
useCache UMask
um RepoJob 'RW a
repojob =
  String -> IO a -> IO a
forall a. String -> IO a -> IO a
withLock String
lockPath (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
    UseCache -> RepoJob 'RO a -> IO a
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository UseCache
useCache (RepoJob 'RO a -> IO a) -> RepoJob 'RO a -> IO a
forall a b. (a -> b) -> a -> b
$ RepoJob 'RW a
-> (forall {p :: * -> * -> *} {wR} {wU}.
    TreePatch p =>
    (Repository 'RW p wU wR -> IO a) -> Repository 'RO p wU wR -> IO a)
-> RepoJob 'RO a
forall (rt1 :: AccessType) a (rt2 :: AccessType).
RepoJob rt1 a
-> (forall (p :: * -> * -> *) wR wU.
    TreePatch p =>
    (Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a)
-> RepoJob rt2 a
onRepoJob RepoJob 'RW a
repojob ((forall {p :: * -> * -> *} {wR} {wU}.
  TreePatch p =>
  (Repository 'RW p wU wR -> IO a) -> Repository 'RO p wU wR -> IO a)
 -> RepoJob 'RO a)
-> (forall {p :: * -> * -> *} {wR} {wU}.
    TreePatch p =>
    (Repository 'RW p wU wR -> IO a) -> Repository 'RO p wU wR -> IO a)
-> RepoJob 'RO a
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR -> IO a
job Repository 'RO p wU wR
repository -> do
      IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ RepoFormat -> Maybe String
writeProblem (Repository 'RO p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository 'RO p wU wR
repository)
      UMask -> IO a -> IO a
forall a. UMask -> IO a -> IO a
withUMaskFlag UMask
um (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Repository 'RO p wU wR -> IO (Repository 'RW p wU wR)
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RO p wU wR -> IO (Repository 'RW p wU wR)
revertRepositoryChanges Repository 'RO p wU wR
repository IO (Repository 'RW p wU wR)
-> (Repository 'RW p wU wR -> IO a) -> IO a
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 -> IO a
job

-- | run a lock-taking job in an old-fashion repository.
--   only used by `darcs optimize upgrade`.
withOldRepoLock :: RepoJob 'RW a -> IO a
withOldRepoLock :: forall a. RepoJob 'RW a -> IO a
withOldRepoLock RepoJob 'RW a
repojob =
  UseCache -> RepoJob 'RO a -> IO a
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository UseCache
NoUseCache (RepoJob 'RO a -> IO a) -> RepoJob 'RO a -> IO a
forall a b. (a -> b) -> a -> b
$ RepoJob 'RW a
-> (forall {p :: * -> * -> *} {wR} {wU}.
    TreePatch p =>
    (Repository 'RW p wU wR -> IO a) -> Repository 'RO p wU wR -> IO a)
-> RepoJob 'RO a
forall (rt1 :: AccessType) a (rt2 :: AccessType).
RepoJob rt1 a
-> (forall (p :: * -> * -> *) wR wU.
    TreePatch p =>
    (Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a)
-> RepoJob rt2 a
onRepoJob RepoJob 'RW a
repojob ((forall {p :: * -> * -> *} {wR} {wU}.
  TreePatch p =>
  (Repository 'RW p wU wR -> IO a) -> Repository 'RO p wU wR -> IO a)
 -> RepoJob 'RO a)
-> (forall {p :: * -> * -> *} {wR} {wU}.
    TreePatch p =>
    (Repository 'RW p wU wR -> IO a) -> Repository 'RO p wU wR -> IO a)
-> RepoJob 'RO a
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR -> IO a
job Repository 'RO p wU wR
repository ->
    String -> IO a -> IO a
forall a. String -> IO a -> IO a
withLock String
lockPath (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Repository 'RW p wU wR -> IO a
job (Repository 'RW p wU wR -> IO a) -> Repository 'RW p wU wR -> IO a
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
repository

-- | Apply a given RepoJob to a repository in the current working directory,
-- taking a lock. If lock not takeable, do nothing. If old-fashioned
-- repository, do nothing. The job must not touch pending or pending.tentative,
-- because there is no call to revertRepositoryChanges. This entry point is
-- currently only used for attemptCreatePatchIndex.
withRepoLockCanFail :: UseCache -> RepoJob 'RO () -> IO ()
withRepoLockCanFail :: UseCache -> RepoJob 'RO () -> IO ()
withRepoLockCanFail UseCache
useCache RepoJob 'RO ()
repojob = do
  Either () ()
eitherDone <-
    String -> IO () -> IO (Either () ())
forall a. String -> IO a -> IO (Either () a)
withLockCanFail String
lockPath (IO () -> IO (Either () ())) -> IO () -> IO (Either () ())
forall a b. (a -> b) -> a -> b
$
      UseCache -> RepoJob 'RO () -> IO ()
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository UseCache
useCache (RepoJob 'RO () -> IO ()) -> RepoJob 'RO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RepoJob 'RO ()
-> (forall {p :: * -> * -> *} {wR} {wU}.
    TreePatch p =>
    (Repository 'RO p wU wR -> IO ())
    -> Repository 'RO p wU wR -> IO ())
-> RepoJob 'RO ()
forall (rt1 :: AccessType) a (rt2 :: AccessType).
RepoJob rt1 a
-> (forall (p :: * -> * -> *) wR wU.
    TreePatch p =>
    (Repository rt1 p wU wR -> IO a) -> Repository rt2 p wU wR -> IO a)
-> RepoJob rt2 a
onRepoJob RepoJob 'RO ()
repojob ((forall {p :: * -> * -> *} {wR} {wU}.
  TreePatch p =>
  (Repository 'RO p wU wR -> IO ())
  -> Repository 'RO p wU wR -> IO ())
 -> RepoJob 'RO ())
-> (forall {p :: * -> * -> *} {wR} {wU}.
    TreePatch p =>
    (Repository 'RO p wU wR -> IO ())
    -> Repository 'RO p wU wR -> IO ())
-> RepoJob 'RO ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR -> IO ()
job Repository 'RO p wU wR
repository -> do
        let rf :: RepoFormat
rf = Repository 'RO p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository 'RO p wU wR
repository
        if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf then do
          IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ RepoFormat -> Maybe String
writeProblem RepoFormat
rf
          Repository 'RO p wU wR -> IO ()
job Repository 'RO p wU wR
repository
        else
          String -> IO ()
debugMessage
            String
"Not doing the job because this is an old-fashioned repository."
  case Either () ()
eitherDone of
    Left  ()
_ -> String -> IO ()
debugMessage String
"Lock could not be obtained, not doing the job."
    Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()