mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

remove one more warningIO

Browse source 
Had to generalize Git.Queue so it can run an Annex action, yipes.

Only remaining warningIO are in the legacy chunk code.
This commit is contained in:
Joey Hess 2019-11-12 10:44:51 -04:00
parent 3edd427b84
commit 99536e3a0b
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 41 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Annex.hs
View file

@ -114,7 +114,7 @@ data AnnexState = AnnexState
, fast :: Bool , fast :: Bool
, daemon :: Bool , daemon :: Bool
, branchstate :: BranchState , branchstate :: BranchState
, repoqueue :: Maybe Git.Queue.Queue , repoqueue :: Maybe (Git.Queue.Queue Annex)
, catfilehandles :: M.Map FilePath CatFileHandle , catfilehandles :: M.Map FilePath CatFileHandle
, hashobjecthandle :: Maybe HashObjectHandle , hashobjecthandle :: Maybe HashObjectHandle
, checkattrhandle :: Maybe CheckAttrHandle , checkattrhandle :: Maybe CheckAttrHandle

11
Annex/Link.hs
View file

@ -192,12 +192,13 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do
-- on all still-unmodified files, using a copy of the index file, -- on all still-unmodified files, using a copy of the index file,
-- to bypass the lock. Then replace the old index file with the new -- to bypass the lock. Then replace the old index file with the new
-- updated index file. -- updated index file.
runner :: Git.Queue.InternalActionRunner Annex
runner = Git.Queue.InternalActionRunner "restagePointerFile" $ \r l -> do runner = Git.Queue.InternalActionRunner "restagePointerFile" $ \r l -> do
realindex <- Git.Index.currentIndexFile r realindex <- liftIO $ Git.Index.currentIndexFile r
let lock = Git.Index.indexFileLock realindex let lock = Git.Index.indexFileLock realindex
lockindex = catchMaybeIO $ Git.LockFile.openLock' lock lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock
unlockindex = maybe noop Git.LockFile.closeLock unlockindex = liftIO . maybe noop Git.LockFile.closeLock
showwarning = warningIO $ unableToRestage Nothing showwarning = warning $ unableToRestage Nothing
go Nothing = showwarning go Nothing = showwarning
go (Just _) = withTmpDirIn (Git.localGitDir r) "annexindex" $ \tmpdir -> do go (Just _) = withTmpDirIn (Git.localGitDir r) "annexindex" $ \tmpdir -> do
let tmpindex = tmpdir </> "index" let tmpindex = tmpdir </> "index"
@ -216,7 +217,7 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do
let replaceindex = catchBoolIO $ do let replaceindex = catchBoolIO $ do
moveFile tmpindex realindex moveFile tmpindex realindex
return True return True
ok <- createLinkOrCopy realindex tmpindex ok <- liftIO $ createLinkOrCopy realindex tmpindex
<&&> updatetmpindex <&&> updatetmpindex
<&&> replaceindex <&&> replaceindex
unless ok showwarning unless ok showwarning

26
Annex/Queue.hs
View file

@ -28,24 +28,24 @@ import qualified Git.UpdateIndex
addCommand :: String -> [CommandParam] -> [FilePath] -> Annex () addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()
addCommand command params files = do addCommand command params files = do
q <- get q <- get
store <=< flushWhenFull <=< inRepo $ store =<< flushWhenFull =<<
Git.Queue.addCommand command params files q (Git.Queue.addCommand command params files q =<< gitRepo)
addInternalAction :: Git.Queue.InternalActionRunner -> [(FilePath, IO Bool)] -> Annex () addInternalAction :: Git.Queue.InternalActionRunner Annex -> [(FilePath, IO Bool)] -> Annex ()
addInternalAction runner files = do addInternalAction runner files = do
q <- get q <- get
store <=< flushWhenFull <=< inRepo $ store =<< flushWhenFull =<<
Git.Queue.addInternalAction runner files q (Git.Queue.addInternalAction runner files q =<< gitRepo)
{- Adds an update-index stream to the queue. -} {- Adds an update-index stream to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex () addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex ()
addUpdateIndex streamer = do addUpdateIndex streamer = do
q <- get q <- get
store <=< flushWhenFull <=< inRepo $ store =<< flushWhenFull =<<
Git.Queue.addUpdateIndex streamer q (Git.Queue.addUpdateIndex streamer q =<< gitRepo)
{- Runs the queue if it is full. -} {- Runs the queue if it is full. -}
flushWhenFull :: Git.Queue.Queue -> Annex Git.Queue.Queue flushWhenFull :: Git.Queue.Queue Annex -> Annex (Git.Queue.Queue Annex)
flushWhenFull q flushWhenFull q
| Git.Queue.full q = flush' q | Git.Queue.full q = flush' q
| otherwise = return q | otherwise = return q
@ -64,25 +64,25 @@ flush = do
- But, flushing two queues at the same time could lead to failures due to - But, flushing two queues at the same time could lead to failures due to
- git locking files. So, only one queue is allowed to flush at a time. - git locking files. So, only one queue is allowed to flush at a time.
-} -}
flush' :: Git.Queue.Queue -> Annex Git.Queue.Queue flush' :: Git.Queue.Queue Annex -> Annex (Git.Queue.Queue Annex)
flush' q = withExclusiveLock gitAnnexGitQueueLock $ do flush' q = withExclusiveLock gitAnnexGitQueueLock $ do
showStoringStateAction showStoringStateAction
inRepo $ Git.Queue.flush q Git.Queue.flush q =<< gitRepo
{- Gets the size of the queue. -} {- Gets the size of the queue. -}
size :: Annex Int size :: Annex Int
size = Git.Queue.size <$> get size = Git.Queue.size <$> get
get :: Annex Git.Queue.Queue get :: Annex (Git.Queue.Queue Annex)
get = maybe new return =<< getState repoqueue get = maybe new return =<< getState repoqueue
new :: Annex Git.Queue.Queue new :: Annex (Git.Queue.Queue Annex)
new = do new = do
q <- Git.Queue.new . annexQueueSize <$> getGitConfig q <- Git.Queue.new . annexQueueSize <$> getGitConfig
store q store q
return q return q
store :: Git.Queue.Queue -> Annex () store :: Git.Queue.Queue Annex -> Annex ()
store q = changeState $ \s -> s { repoqueue = Just q } store q = changeState $ \s -> s { repoqueue = Just q }
mergeFrom :: AnnexState -> Annex () mergeFrom :: AnnexState -> Annex ()

41
Git/Queue.hs
View file

@ -1,6 +1,6 @@
{- git repository command queue {- git repository command queue
- -
- Copyright 2010-2018 Joey Hess <id@joeyh.name> - Copyright 2010-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -27,9 +27,10 @@ import Git.Command
import qualified Git.UpdateIndex import qualified Git.UpdateIndex
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Control.Monad.IO.Class
{- Queable actions that can be performed in a git repository. -} {- Queable actions that can be performed in a git repository. -}
data Action data Action m
{- Updating the index file, using a list of streamers that can {- Updating the index file, using a list of streamers that can
- be added to as the queue grows. -} - be added to as the queue grows. -}
= UpdateIndexAction [Git.UpdateIndex.Streamer] -- in reverse order = UpdateIndexAction [Git.UpdateIndex.Streamer] -- in reverse order
@ -43,21 +44,21 @@ data Action
{- An internal action to run, on a list of files that can be added {- An internal action to run, on a list of files that can be added
- to as the queue grows. -} - to as the queue grows. -}
| InternalAction | InternalAction
{ getRunner :: InternalActionRunner { getRunner :: InternalActionRunner m
, getInternalFiles :: [(FilePath, IO Bool)] , getInternalFiles :: [(FilePath, IO Bool)]
} }
{- The String must be unique for each internal action. -} {- The String must be unique for each internal action. -}
data InternalActionRunner = InternalActionRunner String (Repo -> [(FilePath, IO Bool)] -> IO ()) data InternalActionRunner m = InternalActionRunner String (Repo -> [(FilePath, IO Bool)] -> m ())
instance Eq InternalActionRunner where instance Eq (InternalActionRunner m) where
InternalActionRunner s1 _ == InternalActionRunner s2 _ = s1 == s2 InternalActionRunner s1 _ == InternalActionRunner s2 _ = s1 == s2
{- A key that can uniquely represent an action in a Map. -} {- A key that can uniquely represent an action in a Map. -}
data ActionKey = UpdateIndexActionKey | CommandActionKey String | InternalActionKey String data ActionKey = UpdateIndexActionKey | CommandActionKey String | InternalActionKey String
deriving (Eq, Ord) deriving (Eq, Ord)
actionKey :: Action -> ActionKey actionKey :: Action m -> ActionKey
actionKey (UpdateIndexAction _) = UpdateIndexActionKey actionKey (UpdateIndexAction _) = UpdateIndexActionKey
actionKey CommandAction { getSubcommand = s } = CommandActionKey s actionKey CommandAction { getSubcommand = s } = CommandActionKey s
actionKey InternalAction { getRunner = InternalActionRunner s _ } = InternalActionKey s actionKey InternalAction { getRunner = InternalActionRunner s _ } = InternalActionKey s
@ -65,10 +66,10 @@ actionKey InternalAction { getRunner = InternalActionRunner s _ } = InternalActi
{- A queue of actions to perform (in any order) on a git repository, {- A queue of actions to perform (in any order) on a git repository,
- with lists of files to perform them on. This allows coalescing - with lists of files to perform them on. This allows coalescing
- similar git commands. -} - similar git commands. -}
data Queue = Queue data Queue m = Queue
{ size :: Int { size :: Int
, _limit :: Int , _limit :: Int
, items :: M.Map ActionKey Action , items :: M.Map ActionKey (Action m)
} }
{- A recommended maximum size for the queue, after which it should be {- A recommended maximum size for the queue, after which it should be
@ -84,7 +85,7 @@ defaultLimit :: Int
defaultLimit = 10240 defaultLimit = 10240
{- Constructor for empty queue. -} {- Constructor for empty queue. -}
new :: Maybe Int -> Queue new :: Maybe Int -> Queue m
new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
{- Adds an git command to the queue. {- Adds an git command to the queue.
@ -93,7 +94,7 @@ new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
- assumed to be equivilant enough to perform in any order with the same - assumed to be equivilant enough to perform in any order with the same
- result. - result.
-} -}
addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue addCommand :: MonadIO m => String -> [CommandParam] -> [FilePath] -> Queue m -> Repo -> m (Queue m)
addCommand subcommand params files q repo = addCommand subcommand params files q repo =
updateQueue action different (length files) q repo updateQueue action different (length files) q repo
where where
@ -107,7 +108,7 @@ addCommand subcommand params files q repo =
different _ = True different _ = True
{- Adds an internal action to the queue. -} {- Adds an internal action to the queue. -}
addInternalAction :: InternalActionRunner -> [(FilePath, IO Bool)] -> Queue -> Repo -> IO Queue addInternalAction :: MonadIO m => InternalActionRunner m -> [(FilePath, IO Bool)] -> Queue m -> Repo -> m (Queue m)
addInternalAction runner files q repo = addInternalAction runner files q repo =
updateQueue action different (length files) q repo updateQueue action different (length files) q repo
where where
@ -120,7 +121,7 @@ addInternalAction runner files q repo =
different _ = True different _ = True
{- Adds an update-index streamer to the queue. -} {- Adds an update-index streamer to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue addUpdateIndex :: MonadIO m => Git.UpdateIndex.Streamer -> Queue m -> Repo -> m (Queue m)
addUpdateIndex streamer q repo = addUpdateIndex streamer q repo =
updateQueue action different 1 q repo updateQueue action different 1 q repo
where where
@ -133,7 +134,7 @@ addUpdateIndex streamer q repo =
{- Updates or adds an action in the queue. If the queue already contains a {- Updates or adds an action in the queue. If the queue already contains a
- different action, it will be flushed; this is to ensure that conflicting - different action, it will be flushed; this is to ensure that conflicting
- actions, like add and rm, are run in the right order.-} - actions, like add and rm, are run in the right order.-}
updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue updateQueue :: MonadIO m => Action m -> (Action m -> Bool) -> Int -> Queue m -> Repo -> m (Queue m)
updateQueue !action different sizeincrease q repo updateQueue !action different sizeincrease q repo
| null (filter different (M.elems (items q))) = return $ go q | null (filter different (M.elems (items q))) = return $ go q
| otherwise = go <$> flush q repo | otherwise = go <$> flush q repo
@ -150,7 +151,7 @@ updateQueue !action different sizeincrease q repo
{- The new value comes first. It probably has a smaller list of files than {- The new value comes first. It probably has a smaller list of files than
- the old value. So, the list append of the new value first is more - the old value. So, the list append of the new value first is more
- efficient. -} - efficient. -}
combineNewOld :: Action -> Action -> Action combineNewOld :: Action m -> Action m -> Action m
combineNewOld (CommandAction _sc1 _ps1 fs1) (CommandAction sc2 ps2 fs2) = combineNewOld (CommandAction _sc1 _ps1 fs1) (CommandAction sc2 ps2 fs2) =
CommandAction sc2 ps2 (fs1++fs2) CommandAction sc2 ps2 (fs1++fs2)
combineNewOld (UpdateIndexAction s1) (UpdateIndexAction s2) = combineNewOld (UpdateIndexAction s1) (UpdateIndexAction s2) =
@ -162,18 +163,18 @@ combineNewOld anew _aold = anew
{- Merges the contents of the second queue into the first. {- Merges the contents of the second queue into the first.
- This should only be used when the two queues are known to contain - This should only be used when the two queues are known to contain
- non-conflicting actions. -} - non-conflicting actions. -}
merge :: Queue -> Queue -> Queue merge :: Queue m -> Queue m -> Queue m
merge origq newq = origq merge origq newq = origq
{ size = size origq + size newq { size = size origq + size newq
, items = M.unionWith combineNewOld (items newq) (items origq) , items = M.unionWith combineNewOld (items newq) (items origq)
} }
{- Is a queue large enough that it should be flushed? -} {- Is a queue large enough that it should be flushed? -}
full :: Queue -> Bool full :: Queue m -> Bool
full (Queue cur lim _) = cur >= lim full (Queue cur lim _) = cur >= lim
{- Runs a queue on a git repository. -} {- Runs a queue on a git repository. -}
flush :: Queue -> Repo -> IO Queue flush :: MonadIO m => Queue m -> Repo -> m (Queue m)
flush (Queue _ lim m) repo = do flush (Queue _ lim m) repo = do
forM_ (M.elems m) $ runAction repo forM_ (M.elems m) $ runAction repo
return $ Queue 0 lim M.empty return $ Queue 0 lim M.empty
@ -184,11 +185,11 @@ flush (Queue _ lim m) repo = do
- -
- Intentionally runs the command even if the list of files is empty; - Intentionally runs the command even if the list of files is empty;
- this allows queueing commands that do not need a list of files. -} - this allows queueing commands that do not need a list of files. -}
runAction :: Repo -> Action -> IO () runAction :: MonadIO m => Repo -> Action m -> m ()
runAction repo (UpdateIndexAction streamers) = runAction repo (UpdateIndexAction streamers) =
-- list is stored in reverse order -- list is stored in reverse order
Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers liftIO $ Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
runAction repo action@(CommandAction {}) = do runAction repo action@(CommandAction {}) = liftIO $ do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo } let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo }
withHandle StdinHandle createProcessSuccess p $ \h -> do withHandle StdinHandle createProcessSuccess p $ \h -> do