diff options
| -rw-r--r-- | Assistant/Threads/Transferrer.hs | 4 | ||||
| -rw-r--r-- | Assistant/TransferSlots.hs | 30 | ||||
| -rw-r--r-- | Assistant/TransferrerPool.hs | 19 | ||||
| -rw-r--r-- | Build/Configure.hs | 1 | ||||
| -rw-r--r-- | Command/Fsck.hs | 4 | ||||
| -rw-r--r-- | Utility/Batch.hs | 25 | ||||
| -rw-r--r-- | doc/devblog/day_68__bits_and_pieces.mdwn | 14 | ||||
| -rw-r--r-- | doc/ikiwiki/pagespec.mdwn | 86 | ||||
| -rw-r--r-- | doc/todo/dumb_plaindir_remote___40__e.g._for_NAS_mounts__41__.mdwn | 2 |
9 files changed, 64 insertions, 121 deletions
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 0bc419e15..53d8a578c 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -12,12 +12,14 @@ import Assistant.TransferQueue import Assistant.TransferSlots import Logs.Transfer import Config.Files +import Utility.Batch {- Dispatches transfers from the queue. -} transfererThread :: NamedThread transfererThread = namedThread "Transferrer" $ do program <- liftIO readProgramFile - forever $ inTransferSlot program $ + batchmaker <- liftIO getBatchCommandMaker + forever $ inTransferSlot program batchmaker $ maybe (return Nothing) (uncurry genTransfer) =<< getNextTransfer notrunning where diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index cb66e845a..4852c36f8 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -29,6 +29,7 @@ import qualified Types.Remote as Remote import Annex.Content import Annex.Wanted import Config.Files +import Utility.Batch import qualified Data.Map as M import qualified Control.Exception as E @@ -44,17 +45,17 @@ type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer - {- Waits until a transfer slot becomes available, then runs a - TransferGenerator, and then runs the transfer action in its own thread. -} -inTransferSlot :: FilePath -> TransferGenerator -> Assistant () -inTransferSlot program gen = do +inTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant () +inTransferSlot program batchmaker gen = do flip MSemN.wait 1 <<~ transferSlots - runTransferThread program =<< gen + runTransferThread program batchmaker =<< gen {- Runs a TransferGenerator, and its transfer action, - without waiting for a slot to become available. -} -inImmediateTransferSlot :: FilePath -> TransferGenerator -> Assistant () -inImmediateTransferSlot program gen = do +inImmediateTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant () +inImmediateTransferSlot program batchmaker gen = do flip MSemN.signal (-1) <<~ transferSlots - runTransferThread program =<< gen + runTransferThread program batchmaker =<< gen {- Runs a transfer action, in an already allocated transfer slot. - Once it finishes, frees the transfer slot. @@ -66,19 +67,19 @@ inImmediateTransferSlot program gen = do - then pausing the thread until a ResumeTransfer exception is raised, - then rerunning the action. -} -runTransferThread :: FilePath -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant () -runTransferThread _ Nothing = flip MSemN.signal 1 <<~ transferSlots -runTransferThread program (Just (t, info, a)) = do +runTransferThread :: FilePath -> BatchCommandMaker -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant () +runTransferThread _ _ Nothing = flip MSemN.signal 1 <<~ transferSlots +runTransferThread program batchmaker (Just (t, info, a)) = do d <- getAssistant id aio <- asIO1 a - tid <- liftIO $ forkIO $ runTransferThread' program d aio + tid <- liftIO $ forkIO $ runTransferThread' program batchmaker d aio updateTransferInfo t $ info { transferTid = Just tid } -runTransferThread' :: FilePath -> AssistantData -> (Transferrer -> IO ()) -> IO () -runTransferThread' program d run = go +runTransferThread' :: FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO () +runTransferThread' program batchmaker d run = go where go = catchPauseResume $ - withTransferrer program (transferrerPool d) + withTransferrer program batchmaker (transferrerPool d) run pause = catchPauseResume $ runEvery (Seconds 86400) noop @@ -279,7 +280,8 @@ startTransfer t = do liftIO $ throwTo tid ResumeTransfer start info = do program <- liftIO readProgramFile - inImmediateTransferSlot program $ + batchmaker <- liftIO getBatchCommandMaker + inImmediateTransferSlot program batchmaker $ genTransfer t info getCurrentTransfers :: Assistant TransferMap diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs index 79b609a1d..8ebe81f60 100644 --- a/Assistant/TransferrerPool.hs +++ b/Assistant/TransferrerPool.hs @@ -24,9 +24,9 @@ import Control.Exception (throw) import Control.Concurrent {- Runs an action with a Transferrer from the pool. -} -withTransferrer :: FilePath -> TransferrerPool -> (Transferrer -> IO a) -> IO a -withTransferrer program pool a = do - t <- maybe (mkTransferrer program) (checkTransferrer program) +withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a +withTransferrer program batchmaker pool a = do + t <- maybe (mkTransferrer program batchmaker) (checkTransferrer program batchmaker) =<< atomically (tryReadTChan pool) v <- tryNonAsync $ a t unlessM (putback t) $ @@ -53,8 +53,8 @@ performTransfer transferrer t f = catchBoolIO $ do {- Starts a new git-annex transferkeys process, setting up a pipe - that will be used to communicate with it. -} -mkTransferrer :: FilePath -> IO Transferrer -mkTransferrer program = do +mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer +mkTransferrer program batchmaker = do #ifndef mingw32_HOST_OS (myread, twrite) <- createPipe (tread, mywrite) <- createPipe @@ -65,7 +65,7 @@ mkTransferrer program = do , Param "--writefd", Param $ show twrite ] {- It runs as a batch job. -} - (program', params') <- toBatchCommand (program, params) + let (program', params') = batchmaker (program, params) {- It's put into its own group so that the whole group can be - killed to stop a transfer. -} (_, _, _, pid) <- createProcess (proc program' $ toCommand params') @@ -86,9 +86,10 @@ mkTransferrer program = do #endif {- Checks if a Transferrer is still running. If not, makes a new one. -} -checkTransferrer :: FilePath -> Transferrer -> IO Transferrer -checkTransferrer program t = maybe (return t) (const $ mkTransferrer program) - =<< getProcessExitCode (transferrerHandle t) +checkTransferrer :: FilePath -> BatchCommandMaker -> Transferrer -> IO Transferrer +checkTransferrer program batchmaker t = + maybe (return t) (const $ mkTransferrer program batchmaker) + =<< getProcessExitCode (transferrerHandle t) {- Closing the fds will stop the transferrer. -} stopTransferrer :: Transferrer -> IO () diff --git a/Build/Configure.hs b/Build/Configure.hs index d17f6cbf0..0926496f8 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -38,6 +38,7 @@ tests = , TestCase "newquvi" $ testCmd "newquvi" "quvi info >/dev/null" , TestCase "nice" $ testCmd "nice" "nice true >/dev/null" , TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null" + , TestCase "nocache" $ testCmd "nocache" "nocache true >/dev/null" , TestCase "gpg" $ maybeSelectCmd "gpg" [ ("gpg", "--version >/dev/null") , ("gpg2", "--version >/dev/null") ] diff --git a/Command/Fsck.hs b/Command/Fsck.hs index a8e52af98..d3a8b3083 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -236,7 +236,7 @@ verifyLocationLogRemote key desc remote present = (Remote.logStatus remote key) verifyLocationLog' :: Key -> String -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool -verifyLocationLog' key desc present u bad = do +verifyLocationLog' key desc present u updatestatus = do uuids <- Remote.keyLocations key case (present, u `elem` uuids) of (True, False) -> do @@ -254,7 +254,7 @@ verifyLocationLog' key desc present u bad = do where fix s = do showNote "fixing location log" - bad s + updatestatus s {- Ensures the direct mode mapping file is consistent. Each file - it lists for the key should exist, and the specified file should be diff --git a/Utility/Batch.hs b/Utility/Batch.hs index 958801e88..61026f19e 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -45,22 +45,28 @@ maxNice = 19 {- Makes a command be run by whichever of nice, ionice, and nocache - are available in the path. -} -toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam]) -toBatchCommand (command, params) = do +type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam]) + +getBatchCommandMaker :: IO BatchCommandMaker +getBatchCommandMaker = do #ifndef mingw32_HOST_OS nicers <- filterM (inPath . fst) [ ("nice", []) , ("ionice", ["-c3"]) , ("nocache", []) ] - let (command', params') = case nicers of - [] -> (command, params) - (first:rest) -> (fst first, map Param (snd first ++ concatMap (\p -> fst p : snd p) rest ++ [command]) ++ params) + return $ \(command, params) -> + case nicers of + [] -> (command, params) + (first:rest) -> (fst first, map Param (snd first ++ concatMap (\p -> fst p : snd p) rest ++ [command]) ++ params) #else - let command' = command - let params' = params + return id #endif - return (command', params') + +toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam]) +toBatchCommand v = do + batchmaker <- getBatchCommandMaker + return $ batchmaker v {- Runs a command in a way that's suitable for batch jobs that can be - interrupted. @@ -73,7 +79,8 @@ batchCommand command params = batchCommandEnv command params Nothing batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool batchCommandEnv command params environ = do - (command', params') <- toBatchCommand (command, params) + batchmaker <- getBatchCommandMaker + let (command', params') = batchmaker (command, params) let p = proc command' $ toCommand params' (_, _, _, pid) <- createProcess $ p { env = environ } r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode) diff --git a/doc/devblog/day_68__bits_and_pieces.mdwn b/doc/devblog/day_68__bits_and_pieces.mdwn new file mode 100644 index 000000000..1caa6e38b --- /dev/null +++ b/doc/devblog/day_68__bits_and_pieces.mdwn @@ -0,0 +1,14 @@ +Made a release yesterday to fix a bug that made git-annex init in a bare +repository set core.bare=false. This bug only affected git-annex 5, it +was introduced when building the direct mode guard. Currently recovering +from it is a [manual (pretty easy) process](http://git-annex.branchable.com/bugs/assistant_creating_.git_directory_inside_bare_repo/#comment-73a8ce8aa100baa7c03861b769fdca29). +Perhas I should automate that, but I mostly wanted to get a fix out +before too many people encountered the bug. + +Today, I made the assistant run batch jobs with ionice and nocache, when +those commands are available. Also, when the assistant transfers files, +that also runs as a batch job. + +Changed how git-annex does commits, avoiding using `git commit` in direct +mode, since in some situations `git commit` (not with `-a`!) wants to +read the contents of files in the work tree, which can be very slow. diff --git a/doc/ikiwiki/pagespec.mdwn b/doc/ikiwiki/pagespec.mdwn deleted file mode 100644 index 0f298ad78..000000000 --- a/doc/ikiwiki/pagespec.mdwn +++ /dev/null @@ -1,86 +0,0 @@ -[[!meta robots="noindex, follow"]] -To select a set of pages, such as pages that are locked, pages -whose commit emails you want subscribe to, or pages to combine into a -blog, the wiki uses a PageSpec. This is an expression that matches -a set of pages. - -The simplest PageSpec is a simple list of pages. For example, this matches -any of the three listed pages: - - foo or bar or baz - -More often you will want to match any pages that have a particular thing in -their name. You can do this using a glob pattern. "`*`" stands for any part -of a page name, and "`?`" for any single letter of a page name. So this -matches all pages about music, and any [[SubPage]]s of the SandBox, but does -not match the SandBox itself: - - *music* or SandBox/* - -You can also prefix an item with "`!`" to skip pages that match it. So to -match all pages except for Discussion pages and the SandBox: - - * and !SandBox and !*/Discussion - -Some more elaborate limits can be added to what matches using these functions: - -* "`glob(someglob)`" - matches pages and other files that match the given glob. - Just writing the glob by itself is actually a shorthand for this function. -* "`page(glob)`" - like `glob()`, but only matches pages, not other files -* "`link(page)`" - matches only pages that link to a given page (or glob) -* "`tagged(tag)`" - matches pages that are tagged or link to the given tag (or - tags matched by a glob) -* "`backlink(page)`" - matches only pages that a given page links to -* "`creation_month(month)`" - matches only files created on the given month - number -* "`creation_day(mday)`" - or day of the month -* "`creation_year(year)`" - or year -* "`created_after(page)`" - matches only files created after the given page - was created -* "`created_before(page)`" - matches only files created before the given page - was created -* "`internal(glob)`" - like `glob()`, but matches even internal-use - pages that globs do not usually match. -* "`title(glob)`", "`author(glob)`", "`authorurl(glob)`", - "`license(glob)`", "`copyright(glob)`", "`guid(glob)`" - - match pages that have the given metadata, matching the specified glob. -* "`user(username)`" - tests whether a modification is being made by a - user with the specified username. If openid is enabled, an openid can also - be put here. Glob patterns can be used in the username. For example, - to match all openid users, use `user(*://*)` -* "`admin()`" - tests whether a modification is being made by one of the - wiki admins. -* "`ip(address)`" - tests whether a modification is being made from the - specified IP address. Glob patterns can be used in the address. For - example, `ip(127.0.0.*)` -* "`comment(glob)`" - matches comments to a page matching the glob. -* "`comment_pending(glob)`" - matches unmoderated, pending comments. -* "`postcomment(glob)`" - matches only when comments are being - posted to a page matching the specified glob - -For example, to match all pages in a blog that link to the page about music -and were written in 2005: - - blog/* and link(music) and creation_year(2005) - -Note the use of "and" in the above example, that means that only pages that -match each of the three expressions match the whole. Use "and" when you -want to combine expression like that; "or" when it's enough for a page to -match one expression. Note that it doesn't make sense to say "index and -SandBox", since no page can match both expressions. - -More complex expressions can also be created, by using parentheses for -grouping. For example, to match pages in a blog that are tagged with either -of two tags, use: - - blog/* and (tagged(foo) or tagged(bar)) - -Note that page names in PageSpecs are matched against the absolute -filenames of the pages in the wiki, so a pagespec "foo" used on page -"a/b" will not match a page named "a/foo" or "a/b/foo". To match -relative to the directory of the page containing the pagespec, you can -use "./". For example, "./foo" on page "a/b" matches page "a/foo". - -To indicate the name of the page the PageSpec is used in, you can -use a single dot. For example, `link(.)` matches all the pages -linking to the page containing the PageSpec. diff --git a/doc/todo/dumb_plaindir_remote___40__e.g._for_NAS_mounts__41__.mdwn b/doc/todo/dumb_plaindir_remote___40__e.g._for_NAS_mounts__41__.mdwn index 8ce910ac3..09123cb4c 100644 --- a/doc/todo/dumb_plaindir_remote___40__e.g._for_NAS_mounts__41__.mdwn +++ b/doc/todo/dumb_plaindir_remote___40__e.g._for_NAS_mounts__41__.mdwn @@ -3,3 +3,5 @@ I've an external USB hard disc attached to my (fritzbox) router that is only acc I tried to put a direct-mode repo on the drive but this is painfully slow. The git-annex process than runs on my desktop and accesses the repo over SMB over the slow fritzbox over USB. I'd wish that git-annex could be told to just use a (mounted) folder as a direct-mode remote. + +> [[done]]; dup. --[[Joey]] |