From 99536e3a0bae7f4dcd7c7379036090266c396169 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 12 Nov 2019 10:44:51 -0400 Subject: remove one more warningIO Had to generalize Git.Queue so it can run an Annex action, yipes. Only remaining warningIO are in the legacy chunk code. --- Annex.hs | 2 +- Annex/Link.hs | 11 ++++++----- Annex/Queue.hs | 26 +++++++++++++------------- Git/Queue.hs | 41 +++++++++++++++++++++-------------------- 4 files changed, 41 insertions(+), 39 deletions(-) diff --git a/Annex.hs b/Annex.hs index efb3cc6a4b..9eb4c5f391 100644 --- a/Annex.hs +++ b/Annex.hs @@ -114,7 +114,7 @@ data AnnexState = AnnexState , fast :: Bool , daemon :: Bool , branchstate :: BranchState - , repoqueue :: Maybe Git.Queue.Queue + , repoqueue :: Maybe (Git.Queue.Queue Annex) , catfilehandles :: M.Map FilePath CatFileHandle , hashobjecthandle :: Maybe HashObjectHandle , checkattrhandle :: Maybe CheckAttrHandle diff --git a/Annex/Link.hs b/Annex/Link.hs index 62a5635de4..00c2d68d9e 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -192,12 +192,13 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do -- 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 -- updated index file. + runner :: Git.Queue.InternalActionRunner Annex 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 - lockindex = catchMaybeIO $ Git.LockFile.openLock' lock - unlockindex = maybe noop Git.LockFile.closeLock - showwarning = warningIO $ unableToRestage Nothing + lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock + unlockindex = liftIO . maybe noop Git.LockFile.closeLock + showwarning = warning $ unableToRestage Nothing go Nothing = showwarning go (Just _) = withTmpDirIn (Git.localGitDir r) "annexindex" $ \tmpdir -> do let tmpindex = tmpdir "index" @@ -216,7 +217,7 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do let replaceindex = catchBoolIO $ do moveFile tmpindex realindex return True - ok <- createLinkOrCopy realindex tmpindex + ok <- liftIO $ createLinkOrCopy realindex tmpindex <&&> updatetmpindex <&&> replaceindex unless ok showwarning diff --git a/Annex/Queue.hs b/Annex/Queue.hs index 0e98897800..5bbe04dbc5 100644 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -28,24 +28,24 @@ import qualified Git.UpdateIndex addCommand :: String -> [CommandParam] -> [FilePath] -> Annex () addCommand command params files = do q <- get - store <=< flushWhenFull <=< inRepo $ - Git.Queue.addCommand command params files q + store =<< flushWhenFull =<< + (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 q <- get - store <=< flushWhenFull <=< inRepo $ - Git.Queue.addInternalAction runner files q + store =<< flushWhenFull =<< + (Git.Queue.addInternalAction runner files q =<< gitRepo) {- Adds an update-index stream to the queue. -} addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex () addUpdateIndex streamer = do q <- get - store <=< flushWhenFull <=< inRepo $ - Git.Queue.addUpdateIndex streamer q + store =<< flushWhenFull =<< + (Git.Queue.addUpdateIndex streamer q =<< gitRepo) {- 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 | Git.Queue.full q = flush' q | otherwise = return q @@ -64,25 +64,25 @@ flush = do - 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. -} -flush' :: Git.Queue.Queue -> Annex Git.Queue.Queue +flush' :: Git.Queue.Queue Annex -> Annex (Git.Queue.Queue Annex) flush' q = withExclusiveLock gitAnnexGitQueueLock $ do showStoringStateAction - inRepo $ Git.Queue.flush q + Git.Queue.flush q =<< gitRepo {- Gets the size of the queue. -} size :: Annex Int size = Git.Queue.size <$> get -get :: Annex Git.Queue.Queue +get :: Annex (Git.Queue.Queue Annex) get = maybe new return =<< getState repoqueue -new :: Annex Git.Queue.Queue +new :: Annex (Git.Queue.Queue Annex) new = do q <- Git.Queue.new . annexQueueSize <$> getGitConfig store q return q -store :: Git.Queue.Queue -> Annex () +store :: Git.Queue.Queue Annex -> Annex () store q = changeState $ \s -> s { repoqueue = Just q } mergeFrom :: AnnexState -> Annex () diff --git a/Git/Queue.hs b/Git/Queue.hs index 175cd3f58b..eb4bbb0694 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -1,6 +1,6 @@ {- git repository command queue - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -27,9 +27,10 @@ import Git.Command import qualified Git.UpdateIndex import qualified Data.Map.Strict as M +import Control.Monad.IO.Class {- 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 - be added to as the queue grows. -} = 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 - to as the queue grows. -} | InternalAction - { getRunner :: InternalActionRunner + { getRunner :: InternalActionRunner m , getInternalFiles :: [(FilePath, IO Bool)] } {- 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 {- A key that can uniquely represent an action in a Map. -} data ActionKey = UpdateIndexActionKey | CommandActionKey String | InternalActionKey String deriving (Eq, Ord) -actionKey :: Action -> ActionKey +actionKey :: Action m -> ActionKey actionKey (UpdateIndexAction _) = UpdateIndexActionKey actionKey CommandAction { getSubcommand = s } = CommandActionKey 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, - with lists of files to perform them on. This allows coalescing - similar git commands. -} -data Queue = Queue +data Queue m = Queue { size :: 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 @@ -84,7 +85,7 @@ defaultLimit :: Int defaultLimit = 10240 {- Constructor for empty queue. -} -new :: Maybe Int -> Queue +new :: Maybe Int -> Queue m new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty {- 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 - 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 = updateQueue action different (length files) q repo where @@ -107,7 +108,7 @@ addCommand subcommand params files q repo = different _ = True {- 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 = updateQueue action different (length files) q repo where @@ -120,7 +121,7 @@ addInternalAction runner files q repo = different _ = True {- 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 = updateQueue action different 1 q repo where @@ -133,7 +134,7 @@ addUpdateIndex streamer q repo = {- 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 - 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 | null (filter different (M.elems (items q))) = return $ go q | 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 old value. So, the list append of the new value first is more - efficient. -} -combineNewOld :: Action -> Action -> Action +combineNewOld :: Action m -> Action m -> Action m combineNewOld (CommandAction _sc1 _ps1 fs1) (CommandAction sc2 ps2 fs2) = CommandAction sc2 ps2 (fs1++fs2) combineNewOld (UpdateIndexAction s1) (UpdateIndexAction s2) = @@ -162,18 +163,18 @@ combineNewOld anew _aold = anew {- Merges the contents of the second queue into the first. - This should only be used when the two queues are known to contain - non-conflicting actions. -} -merge :: Queue -> Queue -> Queue +merge :: Queue m -> Queue m -> Queue m merge origq newq = origq { size = size origq + size newq , items = M.unionWith combineNewOld (items newq) (items origq) } {- Is a queue large enough that it should be flushed? -} -full :: Queue -> Bool +full :: Queue m -> Bool full (Queue cur lim _) = cur >= lim {- 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 forM_ (M.elems m) $ runAction repo 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; - 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) = -- list is stored in reverse order - Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers -runAction repo action@(CommandAction {}) = do + liftIO $ Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers +runAction repo action@(CommandAction {}) = liftIO $ do #ifndef mingw32_HOST_OS let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo } withHandle StdinHandle createProcessSuccess p $ \h -> do -- cgit v1.2.3