factor observe_
This commit is contained in:
parent
5cd44282a9
commit
fc80b8d96b
3 changed files with 10 additions and 13 deletions
|
@ -115,13 +115,11 @@ tryGitConfigRead r
|
||||||
pOpen ReadFromPipe "git" ["config", "--null", "--list", "--file", tmpfile] $
|
pOpen ReadFromPipe "git" ["config", "--null", "--list", "--file", tmpfile] $
|
||||||
Git.Config.hRead r
|
Git.Config.hRead r
|
||||||
|
|
||||||
store a = do
|
store = observe $ \r' -> do
|
||||||
r' <- a
|
|
||||||
g <- gitRepo
|
g <- gitRepo
|
||||||
let l = Git.remotes g
|
let l = Git.remotes g
|
||||||
let g' = g { Git.remotes = exchange l r' }
|
let g' = g { Git.remotes = exchange l r' }
|
||||||
Annex.changeState $ \s -> s { Annex.repo = g' }
|
Annex.changeState $ \s -> s { Annex.repo = g' }
|
||||||
return r'
|
|
||||||
|
|
||||||
exchange [] _ = []
|
exchange [] _ = []
|
||||||
exchange (old:ls) new =
|
exchange (old:ls) new =
|
||||||
|
@ -184,9 +182,7 @@ onLocal r a = do
|
||||||
-- No need to update the branch; its data is not used
|
-- No need to update the branch; its data is not used
|
||||||
-- for anything onLocal is used to do.
|
-- for anything onLocal is used to do.
|
||||||
Annex.BranchState.disableUpdate
|
Annex.BranchState.disableUpdate
|
||||||
ret <- a
|
observe_ (liftIO Git.Command.reap) a
|
||||||
liftIO Git.Command.reap
|
|
||||||
return ret
|
|
||||||
|
|
||||||
keyUrls :: Git.Repo -> Key -> [String]
|
keyUrls :: Git.Repo -> Key -> [String]
|
||||||
keyUrls r key = map tourl (annexLocations key)
|
keyUrls r key = map tourl (annexLocations key)
|
||||||
|
@ -221,10 +217,9 @@ copyToRemote r key
|
||||||
-- run copy from perspective of remote
|
-- run copy from perspective of remote
|
||||||
liftIO $ onLocal r $ do
|
liftIO $ onLocal r $ do
|
||||||
ensureInitialized
|
ensureInitialized
|
||||||
ok <- Annex.Content.getViaTmp key $
|
observe_ Annex.Content.saveState $
|
||||||
rsyncOrCopyFile params keysrc
|
Annex.Content.getViaTmp key $
|
||||||
Annex.Content.saveState
|
rsyncOrCopyFile params keysrc
|
||||||
return ok
|
|
||||||
| Git.repoIsSsh r = do
|
| Git.repoIsSsh r = do
|
||||||
keysrc <- inRepo $ gitAnnexLocation key
|
keysrc <- inRepo $ gitAnnexLocation key
|
||||||
rsyncHelper =<< rsyncParamsRemote r False key keysrc
|
rsyncHelper =<< rsyncParamsRemote r False key keysrc
|
||||||
|
|
|
@ -172,9 +172,7 @@ withRsyncScratchDir a = do
|
||||||
let tmp = t </> "rsynctmp" </> show pid
|
let tmp = t </> "rsynctmp" </> show pid
|
||||||
nuke tmp
|
nuke tmp
|
||||||
liftIO $ createDirectoryIfMissing True tmp
|
liftIO $ createDirectoryIfMissing True tmp
|
||||||
res <- a tmp
|
observe_ (nuke tmp) (a tmp)
|
||||||
nuke tmp
|
|
||||||
return res
|
|
||||||
where
|
where
|
||||||
nuke d = liftIO $
|
nuke d = liftIO $
|
||||||
doesDirectoryExist d >>? removeDirectoryRecursive d
|
doesDirectoryExist d >>? removeDirectoryRecursive d
|
||||||
|
|
|
@ -36,3 +36,7 @@ observe observer a = do
|
||||||
r <- a
|
r <- a
|
||||||
_ <- observer r
|
_ <- observer r
|
||||||
return r
|
return r
|
||||||
|
|
||||||
|
{- Like observe, but the observer is not passed the value. -}
|
||||||
|
observe_ :: (Monad m) => m b -> m a -> m a
|
||||||
|
observe_ observer = observe (const observer)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue