From 1933f8a5599f33b95811710ad10e1ed17703699d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 Nov 2015 13:45:34 -0400 Subject: concurrent-output, first pass Output without -Jn should be unchanged from before. With -Jn, concurrent-output is used for messages, but regions are not used yet, so it's a mess. --- BuildFlags.hs | 3 +++ CmdLine.hs | 6 ++++-- CmdLine/Action.hs | 2 +- CmdLine/GitAnnex/Options.hs | 2 +- Messages.hs | 42 +++++++++++++++++++++--------------------- Messages/Concurrent.hs | 33 +++++++++++++++++++++++++++++++++ Messages/Internal.hs | 34 ++++++++++++++++++++++++++++++---- Messages/Progress.hs | 40 +++++++++++++++++----------------------- Remote/Git.hs | 6 +++--- Types/Messages.hs | 2 +- debian/changelog | 6 ++++++ git-annex.cabal | 10 +++++----- 12 files changed, 125 insertions(+), 61 deletions(-) create mode 100644 Messages/Concurrent.hs diff --git a/BuildFlags.hs b/BuildFlags.hs index 2e8d05ea3..bfdbb00d6 100644 --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -65,6 +65,9 @@ buildFlags = filter (not . null) #else #warning Building without XMPP. #endif +#ifdef WITH_CONCURRENTOUTPUT + , "ConcurrentOutput" +#endif #ifdef WITH_DNS , "DNS" #endif diff --git a/CmdLine.hs b/CmdLine.hs index e6ee0c2e6..073d4b32d 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -24,6 +24,7 @@ import Annex.Action import Annex.Environment import Command import Types.Messages +import Messages.Concurrent {- Runs the passed command line. -} dispatch :: Bool -> CmdParams -> [Command] -> [GlobalOption] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () @@ -45,8 +46,9 @@ dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progde whenM (annexDebug <$> Annex.getGitConfig) $ liftIO enableDebugOutput startup - performCommandAction cmd seek $ - shutdown $ cmdnocommit cmd + withConcurrentOutput $ + performCommandAction cmd seek $ + shutdown $ cmdnocommit cmd go (Left norepo) = do let ingitrepo = \a -> a =<< Git.Config.global -- Parse command line with full cmdparser first, diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index 15064fe42..eeb41394a 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -47,7 +47,7 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do commandAction :: CommandStart -> Annex () commandAction a = withOutputType go where - go (ParallelOutput n) = do + go (ConcurrentOutput n) = do ws <- Annex.getState Annex.workers (st, ws') <- if null ws then do diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 2651b92e4..06e04748d 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -283,7 +283,7 @@ jsonOption = globalFlag (Annex.setOutput JSONOutput) ) jobsOption :: GlobalOption -jobsOption = globalSetter (Annex.setOutput . ParallelOutput) $ +jobsOption = globalSetter (Annex.setOutput . ConcurrentOutput) $ option auto ( long "jobs" <> short 'J' <> metavar paramNumber <> help "enable concurrent jobs" diff --git a/Messages.hs b/Messages.hs index fce5c179a..74465a5b9 100644 --- a/Messages.hs +++ b/Messages.hs @@ -52,16 +52,15 @@ import Types.Key import qualified Annex showStart :: String -> FilePath -> Annex () -showStart command file = handleMessage (JSON.start command $ Just file) $ - flushed $ putStr $ command ++ " " ++ file ++ " " +showStart command file = outputMessage (JSON.start command $ Just file) $ + command ++ " " ++ file ++ " " showStart' :: String -> Key -> Maybe FilePath -> Annex () showStart' command key afile = showStart command $ fromMaybe (key2file key) afile showNote :: String -> Annex () -showNote s = handleMessage (JSON.note s) $ - flushed $ putStr $ "(" ++ s ++ ") " +showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") " showAction :: String -> Annex () showAction s = showNote $ s ++ "..." @@ -76,7 +75,7 @@ showSideAction m = Annex.getState Annex.output >>= go Annex.changeState $ \s -> s { Annex.output = st' } | sideActionBlock st == InBlock = return () | otherwise = p - p = handleMessage q $ putStrLn $ "(" ++ m ++ "...)" + p = outputMessage q $ "(" ++ m ++ "...)\n" showStoringStateAction :: Annex () showStoringStateAction = showSideAction "recording state in git" @@ -101,11 +100,10 @@ doSideAction' b a = do {- Make way for subsequent output of a command. -} showOutput :: Annex () showOutput = unlessM commandProgressDisabled $ - handleMessage q $ putStr "\n" + outputMessage q "\n" showLongNote :: String -> Annex () -showLongNote s = handleMessage (JSON.note s) $ - putStrLn $ '\n' : indent s +showLongNote s = outputMessage (JSON.note s) ('\n' : indent s ++ "\n") showEndOk :: Annex () showEndOk = showEndResult True @@ -114,7 +112,7 @@ showEndFail :: Annex () showEndFail = showEndResult False showEndResult :: Bool -> Annex () -showEndResult ok = handleMessage (JSON.end ok) $ putStrLn $ endResult ok +showEndResult ok = outputMessage (JSON.end ok) $ endResult ok ++ "\n" endResult :: Bool -> String endResult True = "ok" @@ -129,11 +127,10 @@ warning = warning' True . indent warning' :: Bool -> String -> Annex () warning' makeway w = do when makeway $ - handleMessage q $ putStr "\n" - liftIO $ do - hFlush stdout - hPutStrLn stderr w + outputMessage q "\n" + outputError (w ++ "\n") +{- Not concurrent output safe. -} warningIO :: String -> IO () warningIO w = do putStr "\n" @@ -145,7 +142,10 @@ indent = intercalate "\n" . map (\l -> " " ++ l) . lines {- Shows a JSON fragment only when in json mode. -} maybeShowJSON :: JSON a => [(String, a)] -> Annex () -maybeShowJSON v = handleMessage (JSON.add v) q +maybeShowJSON v = withOutputType $ liftIO . go + where + go JSONOutput = JSON.add v + go _ = return () {- Shows a complete JSON value, only when in json mode. -} showFullJSON :: JSON a => [(String, a)] -> Annex Bool @@ -157,19 +157,19 @@ showFullJSON v = withOutputType $ liftIO . go {- Performs an action that outputs nonstandard/customized output, and - in JSON mode wraps its output in JSON.start and JSON.end, so it's - a complete JSON document. - - This is only needed when showStart and showEndOk is not used. -} + - This is only needed when showStart and showEndOk is not used. + -} showCustom :: String -> Annex Bool -> Annex () showCustom command a = do - handleMessage (JSON.start command Nothing) q + outputMessage (JSON.start command Nothing) "" r <- a - handleMessage (JSON.end r) q + outputMessage (JSON.end r) "" showHeader :: String -> Annex () -showHeader h = handleMessage q $ - flushed $ putStr $ h ++ ": " +showHeader h = outputMessage q $ (h ++ ": ") showRaw :: String -> Annex () -showRaw s = handleMessage q $ putStrLn s +showRaw = outputMessage q setupConsole :: IO () setupConsole = do @@ -207,6 +207,6 @@ debugEnabled = do commandProgressDisabled :: Annex Bool commandProgressDisabled = withOutputType $ \t -> return $ case t of QuietOutput -> True - ParallelOutput _ -> True JSONOutput -> True NormalOutput -> False + ConcurrentOutput _ -> True diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs new file mode 100644 index 000000000..3b7b28d28 --- /dev/null +++ b/Messages/Concurrent.hs @@ -0,0 +1,33 @@ +{- git-annex concurrent output + - + - Copyright 2015 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Messages.Concurrent where + +import Common.Annex +import Messages.Internal +import Types.Messages + +#ifdef WITH_CONCURRENTOUTPUT +import qualified System.Console.Concurrent as Console +#endif + +{- Enable concurrent output when that has been requested. + - + - This should only be run once per git-annex lifetime, with + - everything that might generate messages run inside it. + -} +withConcurrentOutput :: Annex a -> Annex a +#ifdef WITH_CONCURRENTOUTPUT +withConcurrentOutput a = withOutputType go + where + go (ConcurrentOutput _) = Console.withConcurrentOutput a + go _ = a +#else +withConcurrentOutput = id +#endif diff --git a/Messages/Internal.hs b/Messages/Internal.hs index 2495f4fd3..1501c072a 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Messages.Internal where import Common @@ -12,14 +14,38 @@ import Types import Types.Messages import qualified Annex -handleMessage :: IO () -> IO () -> Annex () -handleMessage json normal = withOutputType go +#ifdef WITH_CONCURRENTOUTPUT +import System.Console.Concurrent +#endif + +outputMessage :: IO () -> String -> Annex () +outputMessage json s = withOutputType go where - go NormalOutput = liftIO normal + go NormalOutput = liftIO $ + flushed $ putStr s go QuietOutput = q - go (ParallelOutput _) = q + go (ConcurrentOutput _) = liftIO $ +#ifdef WITH_CONCURRENTOUTPUT + outputConcurrent s +#else + q +#endif go JSONOutput = liftIO $ flushed json +outputError :: String -> Annex () +outputError s = withOutputType go + where + go (ConcurrentOutput _) = liftIO $ +#ifdef WITH_CONCURRENTOUTPUT + errorConcurrent s +#else + q +#endif + go _ = liftIO $ do + hFlush stdout + hPutStr stderr s + hFlush stderr + q :: Monad m => m () q = noop diff --git a/Messages/Progress.hs b/Messages/Progress.hs index 25e2e03ae..a20ba098e 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -17,15 +17,14 @@ import Types import Types.Messages import Types.Key -#ifdef WITH_ASCIIPROGRESS -import System.Console.AsciiProgress -import qualified System.Console.Terminal.Size as Terminal +#ifdef WITH_CONCURRENTOUTPUT +import System.Console.Concurrent +import System.Console.Regions import Control.Concurrent -#else +#endif import Data.Progress.Meter import Data.Progress.Tracker import Data.Quantity -#endif {- Shows a progress meter while performing a transfer of a key. - The action is passed a callback to use to update the meter. -} @@ -36,7 +35,7 @@ metered combinemeterupdate key af a = case keySize key of where go _ QuietOutput = nometer go _ JSONOutput = nometer -#ifdef WITH_ASCIIPROGRESS +#if 0 go size _ = do showOutput liftIO $ putStrLn "" @@ -65,8 +64,8 @@ metered combinemeterupdate key af a = case keySize key of return r #else - -- Old progress bar code, not suitable for parallel output. - go _ (ParallelOutput _) = do + -- Old progress bar code, not suitable for concurrent output. + go _ (ConcurrentOutput _) = do r <- nometer liftIO $ putStrLn $ fromMaybe (key2file key) af return r @@ -79,7 +78,7 @@ metered combinemeterupdate key af a = case keySize key of return r #endif -#ifdef WITH_ASCIIPROGRESS +#if 0 pupdate pg n = do let i = fromBytesProcessed n sofar <- stCompleted <$> getProgressStats pg @@ -95,24 +94,17 @@ metered combinemeterupdate key af a = case keySize key of nometer = a (const noop) -#ifdef WITH_ASCIIPROGRESS - truncatepretty n s - | length s > n = take (n-2) s ++ ".." - | otherwise = s -#endif - -{- Use when the progress meter is only desired for parallel - - mode; as when a command's own progress output is preferred. -} -parallelMetered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a -parallelMetered combinemeterupdate key af a = withOutputType go +{- Use when the progress meter is only desired for concurrent + - output; as when a command's own progress output is preferred. -} +concurrentMetered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a +concurrentMetered combinemeterupdate key af a = withOutputType go where - go (ParallelOutput _) = metered combinemeterupdate key af a + go (ConcurrentOutput _) = metered combinemeterupdate key af a go _ = a (fromMaybe (const noop) combinemeterupdate) {- Progress dots. -} showProgressDots :: Annex () -showProgressDots = handleMessage q $ - flushed $ putStr "." +showProgressDots = outputMessage q "." {- Runs a command, that may output progress to either stdout or - stderr, as well as other messages. @@ -149,5 +141,7 @@ mkStderrRelayer = do mkStderrEmitter :: Annex (String -> IO ()) mkStderrEmitter = withOutputType go where - go (ParallelOutput _) = return $ \s -> hPutStrLn stderr ("E: " ++ s) +#ifdef WITH_CONCURRENTOUTPUT + go (ConcurrentOutput _) = return errorConcurrent +#endif go _ = return (hPutStrLn stderr) diff --git a/Remote/Git.hs b/Remote/Git.hs index 33eadd3d0..c8ef1aee0 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -421,7 +421,7 @@ lockKey r key callback {- Tries to copy a key's content from a remote's annex to a file. -} copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -copyFromRemote r key file dest p = parallelMetered (Just p) key file $ +copyFromRemote r key file dest p = concurrentMetered (Just p) key file $ copyFromRemote' r key file dest copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) @@ -522,7 +522,7 @@ copyFromRemoteCheap r key af file ) | Git.repoIsSsh (repo r) = ifM (Annex.Content.preseedTmp key file) - ( fst <$> parallelMetered Nothing key af + ( fst <$> concurrentMetered Nothing key af (copyFromRemote' r key af file) , return False ) @@ -533,7 +533,7 @@ copyFromRemoteCheap _ _ _ _ = return False {- Tries to copy a key's content to a remote's annex. -} copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool -copyToRemote r key file p = parallelMetered (Just p) key file $ copyToRemote' r key file +copyToRemote r key file p = concurrentMetered (Just p) key file $ copyToRemote' r key file copyToRemote' :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool copyToRemote' r key file p diff --git a/Types/Messages.hs b/Types/Messages.hs index c3696c015..5cbb53057 100644 --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -9,7 +9,7 @@ module Types.Messages where import Data.Default -data OutputType = NormalOutput | QuietOutput | ParallelOutput Int | JSONOutput +data OutputType = NormalOutput | QuietOutput | ConcurrentOutput Int | JSONOutput data SideActionBlock = NoBlock | StartBlock | InBlock deriving (Eq) diff --git a/debian/changelog b/debian/changelog index b0cb58c49..66f3af186 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +git-annex (5.20151102.2) UNRELEASED; urgency=medium + + * Use concurrent-output library for -Jn mode. + + -- Joey Hess Wed, 04 Nov 2015 12:50:20 -0400 + git-annex (5.20151102.1) unstable; urgency=medium * Avoid installing desktop file and program file if cabal install diff --git a/git-annex.cabal b/git-annex.cabal index 273477316..f38834bfe 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -93,8 +93,8 @@ Flag DesktopNotify Flag TorrentParser Description: Use haskell torrent library to parse torrent files -Flag AsciiProgress - Description: Use ascii-progress library (experimental) +Flag ConcurrentOutput + Description: Use concurrent-output library Default: False Flag EKG @@ -278,9 +278,9 @@ Executable git-annex Build-Depends: esqueleto, persistent-sqlite, persistent, persistent-template CPP-Options: -DWITH_DATABASE - if flag(AsciiProgress) - Build-Depends: ascii-progress (<= 0.2.1.2), terminal-size - CPP-Options: -DWITH_ASCIIPROGRESS + if flag(ConcurrentOutput) + Build-Depends: concurrent-output (>= 1.4.1) + CPP-Options: -DWITH_CONCURRENTOUTPUT if flag(EKG) Build-Depends: ekg -- cgit v1.2.3