module Darcs.Repository.Job
( RepoJob(..)
, withRepoLock
, withRepoLockCanFail
, withRepository
, withRepositoryDirectory
) where
import Darcs.Util.Global ( darcsdir )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.V1 ( Patch )
import Darcs.Patch.V2 ( RealPatch )
import Darcs.Patch.Named ( Named )
import Darcs.Patch.Prim.V1 ( Prim )
import Darcs.Patch.Prim ( PrimOf )
import Darcs.Patch.Rebase ( Rebasing )
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Repository.Flags
( UseCache(..), UpdateWorking(..), DryRun(..), UMask (..)
, Compression, Verbosity )
import Darcs.Repository.Format
( RepoProperty( Darcs2
, RebaseInProgress
)
, formatHas
, writeProblem
)
import Darcs.Repository.Internal
( identifyRepository
, revertRepositoryChanges
)
import Darcs.Repository.InternalTypes ( Repository(..) )
import Darcs.Repository.Rebase
( repoJobOnRebaseRepo
, startRebaseJob
, rebaseJob
)
import Darcs.Repository.Lock ( withLock, withLockCanFail )
import Darcs.Util.Progress ( debugMessage )
import Control.Monad ( when )
import Control.Exception ( bracket_ )
import Foreign.C.String ( CString, withCString )
import Foreign.C.Error ( throwErrno )
import Foreign.C.Types ( CInt(..) )
import Storage.Hashed.Tree ( Tree )
#include "impossible.h"
getUMask :: UMask -> Maybe String
getUMask (YesUMask s) = Just s
getUMask NoUMask = Nothing
withUMaskFlag :: UMask -> IO a -> IO a
withUMaskFlag = maybe id withUMask . getUMask
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 umask job =
do rc <- withCString umask set_umask
when (rc < 0) (throwErrno "Couldn't set umask")
bracket_
(return ())
(reset_umask rc)
job
data RepoJob a
=
RepoJob (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
=> Repository p wR wU wR -> IO a)
| V1Job (forall wR wU . Repository (Patch Prim) wR wU wR -> IO a)
| V2Job (forall wR wU . Repository (RealPatch Prim) wR wU wR -> IO a)
| PrimV1Job (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim)
=> Repository p wR wU wR -> IO a)
| RebaseAwareJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository p wR wU wR -> IO a)
| RebaseJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a)
| StartRebaseJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a)
onRepoJob :: RepoJob a
-> (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => (Repository p wR wU wR -> IO a) -> Repository p wR wU wR -> IO a)
-> RepoJob a
onRepoJob (RepoJob job) f = RepoJob (f job)
onRepoJob (V1Job job) f = V1Job (f job)
onRepoJob (V2Job job) f = V2Job (f job)
onRepoJob (PrimV1Job job) f = PrimV1Job (f job)
onRepoJob (RebaseAwareJob compr verb uw job) f = RebaseAwareJob compr verb uw (f job)
onRepoJob (RebaseJob compr verb uw job) f = RebaseJob compr verb uw (f job)
onRepoJob (StartRebaseJob compr verb uw job) f = StartRebaseJob compr verb uw (f job)
withRepository :: UseCache -> RepoJob a -> IO a
withRepository useCache = withRepositoryDirectory useCache "."
withRepositoryDirectory :: UseCache -> String -> RepoJob a -> IO a
withRepositoryDirectory useCache url repojob = do
Repo dir rf t c <- identifyRepository useCache url
let
startRebase =
case repojob of
StartRebaseJob {} -> True
_ -> False
case (formatHas Darcs2 rf, startRebase || formatHas RebaseInProgress rf) of
(True, False) -> do
debugMessage $ "Identified darcs-2 repo: " ++ dir
let therepo = Repo dir rf t c :: Repository (RealPatch Prim) wR wU wR
case repojob of
RepoJob job -> job therepo
PrimV1Job job -> job therepo
V2Job job -> job therepo
V1Job _ -> fail $ "This repository contains darcs v1 patches,"
++ " but the command requires darcs v2 patches."
RebaseAwareJob _compr _verb _uw job -> job therepo
RebaseJob {} -> fail "No rebase in progress. Try 'darcs rebase suspend' first."
StartRebaseJob {} -> impossible
(False, False) -> do
debugMessage $ "Identified darcs-1 repo: " ++ dir
let therepo = Repo dir rf t c :: Repository (Patch Prim) wR wU wR
case repojob of
RepoJob job -> job therepo
PrimV1Job job -> job therepo
V1Job job -> job therepo
V2Job _ -> fail $ "This repository contains darcs v2 patches,"
++ " but the command requires darcs v1 patches."
RebaseAwareJob _compr _verb _uw job -> job therepo
RebaseJob {} -> fail "No rebase in progress. Try 'darcs rebase suspend' first."
StartRebaseJob {} -> impossible
(True, True ) -> do
debugMessage $ "Identified darcs-2 rebase repo: " ++ dir
let therepo = Repo dir rf t c :: Repository (Rebasing (RealPatch Prim)) wR wU wR
case repojob of
RepoJob job -> repoJobOnRebaseRepo job therepo
PrimV1Job job -> repoJobOnRebaseRepo job therepo
V2Job _ -> fail "This command is not supported while a rebase is in progress."
V1Job _ -> fail $ "This repository contains darcs v1 patches,"
++ " but the command requires darcs v2 patches."
RebaseAwareJob compr verb uw job -> rebaseJob job therepo compr verb uw
RebaseJob compr verb uw job -> rebaseJob job therepo compr verb uw
StartRebaseJob compr verb uw job -> startRebaseJob job therepo compr verb uw
(False, True ) -> do
debugMessage $ "Identified darcs-1 rebase repo: " ++ dir
let therepo = Repo dir rf t c :: Repository (Rebasing (Patch Prim)) wR wU wR
case repojob of
RepoJob job -> repoJobOnRebaseRepo job therepo
PrimV1Job job -> repoJobOnRebaseRepo job therepo
V1Job _ -> fail "This command is not supported while a rebase is in progress."
V2Job _ -> fail $ "This repository contains darcs v2 patches,"
++ " but the command requires darcs v1 patches."
RebaseAwareJob compr verb uw job -> rebaseJob job therepo compr verb uw
RebaseJob compr verb uw job -> rebaseJob job therepo compr verb uw
StartRebaseJob compr verb uw job -> startRebaseJob job therepo compr verb uw
withRepoLock :: DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock dry useCache uw um repojob =
withRepository useCache $ onRepoJob repojob $ \job repository@(Repo _ rf _ _) ->
do maybe (return ()) fail $ writeProblem rf
let name = "./"++darcsdir++"/lock"
withUMaskFlag um $
if dry == YesDryRun
then job repository
else withLock name (revertRepositoryChanges repository uw >> job repository)
withRepoLockCanFail :: UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
withRepoLockCanFail useCache uw um repojob =
withRepository useCache $ onRepoJob repojob $ \job repository@(Repo _ rf _ _) ->
do maybe (return ()) fail $ writeProblem rf
let name = "./"++darcsdir++"/lock"
withUMaskFlag um $ do
eitherDone <- withLockCanFail name (revertRepositoryChanges repository uw >> job repository)
case eitherDone of
Left _ -> debugMessage "Lock could not be obtained, not doing the job."
Right _ -> return ()