diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -114,7 +114,7 @@ , 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/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -224,8 +224,9 @@ adjustToCrippledFileSystem = do warning "Entering an adjusted branch where files are unlocked as this filesystem does not support locked files." checkVersionSupported - whenM (isNothing <$> inRepo Git.Branch.current) $ - void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit + whenM (isNothing <$> inRepo Git.Branch.current) $ do + cmode <- annexCommitMode <$> Annex.getGitConfig + void $ inRepo $ Git.Branch.commitCommand cmode [ Param "--quiet" , Param "--allow-empty" , Param "-m" @@ -310,12 +311,16 @@ commitAdjustedTree' treesha (BasisBranch basis) parents = go =<< catCommit basis where - go Nothing = inRepo mkcommit - go (Just basiscommit) = inRepo $ commitWithMetaData - (commitAuthorMetaData basiscommit) - (commitCommitterMetaData basiscommit) - mkcommit - mkcommit = Git.Branch.commitTree Git.Branch.AutomaticCommit + go Nothing = do + cmode <- annexCommitMode <$> Annex.getGitConfig + inRepo $ mkcommit cmode + go (Just basiscommit) = do + cmode <- annexCommitMode <$> Annex.getGitConfig + inRepo $ commitWithMetaData + (commitAuthorMetaData basiscommit) + (commitCommitterMetaData basiscommit) + (mkcommit cmode) + mkcommit cmode = Git.Branch.commitTree cmode adjustedBranchCommitMessage parents treesha {- This message should never be changed. -} @@ -444,7 +449,8 @@ reparent adjtree adjmergecommit (Just currentcommit) = do if (commitTree currentcommit /= adjtree) then do - c <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit + cmode <- annexCommitMode <$> Annex.getGitConfig + c <- inRepo $ Git.Branch.commitTree cmode ("Merged " ++ fromRef tomerge) [adjmergecommit] (commitTree currentcommit) inRepo $ Git.Branch.update "updating adjusted branch" currbranch c @@ -534,12 +540,14 @@ | length (commitParent basiscommit) > 1 = return $ Left $ "unable to propigate merge commit " ++ show csha ++ " back to " ++ show origbranch | otherwise = do + cmode <- annexCommitMode <$> Annex.getGitConfig treesha <- reverseAdjustedTree commitparent adj csha revadjcommit <- inRepo $ commitWithMetaData (commitAuthorMetaData basiscommit) (commitCommitterMetaData basiscommit) $ - Git.Branch.commitTree Git.Branch.AutomaticCommit - (commitMessage basiscommit) [commitparent] treesha + Git.Branch.commitTree cmode + (commitMessage basiscommit) + [commitparent] treesha return (Right revadjcommit) {- Adjusts the tree of the basis, changing only the files that the diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -109,8 +109,9 @@ [Param "branch", Param $ fromRef name, Param $ fromRef originname] fromMaybe (error $ "failed to create " ++ fromRef name) <$> branchsha - go False = withIndex' True $ - inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit "branch created" fullname [] + go False = withIndex' True $ do + cmode <- annexCommitMode <$> Annex.getGitConfig + inRepo $ Git.Branch.commitAlways cmode "branch created" fullname [] use sha = do setIndexSha sha return sha @@ -317,7 +318,8 @@ commitIndex' :: JournalLocked -> Git.Ref -> String -> String -> Integer -> [Git.Ref] -> Annex () commitIndex' jl branchref message basemessage retrynum parents = do updateIndex jl branchref - committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname parents + cmode <- annexCommitMode <$> Annex.getGitConfig + committedref <- inRepo $ Git.Branch.commitAlways cmode message fullname parents setIndexSha committedref parentrefs <- commitparents <$> catObject committedref when (racedetected branchref parentrefs) $ @@ -551,7 +553,8 @@ Annex.Queue.flush if neednewlocalbranch then do - committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname transitionedrefs + cmode <- annexCommitMode <$> Annex.getGitConfig + committedref <- inRepo $ Git.Branch.commitAlways cmode message fullname transitionedrefs setIndexSha committedref else do ref <- getBranch @@ -657,9 +660,10 @@ origtree <- fromMaybe (giveup "unable to determine git-annex branch tree") <$> inRepo (Git.Ref.tree branchref) addedt <- inRepo $ Git.Tree.graftTree treeish graftpoint origtree - c <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit + cmode <- annexCommitMode <$> Annex.getGitConfig + c <- inRepo $ Git.Branch.commitTree cmode "graft" [branchref] addedt - c' <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit + c' <- inRepo $ Git.Branch.commitTree cmode "graft cleanup" [c] origtree inRepo $ Git.Branch.update' fullname c' -- The tree in c' is the same as the tree in branchref, diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -90,10 +90,20 @@ Nothing -> a Just tv -> do mytid <- liftIO myThreadId - let set = changeStageTo mytid tv newstage - let restore = maybe noop (void . changeStageTo mytid tv) + let set = changeStageTo mytid tv (const newstage) + let restore = maybe noop (void . changeStageTo mytid tv . const) bracket set restore (const a) +{- Transition the current thread to the initial stage. + - This is done once the thread is ready to begin work. + -} +enteringInitialStage :: Annex () +enteringInitialStage = Annex.getState Annex.workers >>= \case + Nothing -> noop + Just tv -> do + mytid <- liftIO myThreadId + void $ changeStageTo mytid tv initialStage + {- This needs to leave the WorkerPool with the same number of - idle and active threads, and with the same number of threads for each - WorkerStage. So, all it can do is swap the WorkerStage of our thread's @@ -110,14 +120,15 @@ - in the pool than spareVals. That does not prevent other threads that call - this from using them though, so it's fine. -} -changeStageTo :: ThreadId -> TMVar (WorkerPool AnnexState) -> WorkerStage -> Annex (Maybe WorkerStage) -changeStageTo mytid tv newstage = liftIO $ +changeStageTo :: ThreadId -> TMVar (WorkerPool AnnexState) -> (UsedStages -> WorkerStage) -> Annex (Maybe WorkerStage) +changeStageTo mytid tv getnewstage = liftIO $ replaceidle >>= maybe (return Nothing) (either waitidle (return . Just)) where replaceidle = atomically $ do pool <- takeTMVar tv + let newstage = getnewstage (usedStages pool) let notchanging = do putTMVar tv pool return Nothing @@ -128,7 +139,7 @@ Nothing -> do putTMVar tv $ addWorkerPool (IdleWorker oldstage) pool' - return $ Just $ Left (myaid, oldstage) + return $ Just $ Left (myaid, newstage, oldstage) Just pool'' -> do -- optimisation putTMVar tv $ @@ -139,27 +150,26 @@ _ -> notchanging else notchanging - waitidle (myaid, oldstage) = atomically $ do + waitidle (myaid, newstage, oldstage) = atomically $ do pool <- waitIdleWorkerSlot newstage =<< takeTMVar tv putTMVar tv $ addWorkerPool (ActiveWorker myaid newstage) pool return (Just oldstage) --- | Waits until there's an idle worker in the worker pool --- for its initial stage, removes it from the pool, and returns its state. +-- | Waits until there's an idle StartStage worker in the worker pool, +-- removes it from the pool, and returns its state. -- -- If the worker pool is not already allocated, returns Nothing. -waitInitialWorkerSlot :: TMVar (WorkerPool Annex.AnnexState) -> STM (Maybe (Annex.AnnexState, WorkerStage)) -waitInitialWorkerSlot tv = do +waitStartWorkerSlot :: TMVar (WorkerPool Annex.AnnexState) -> STM (Maybe (Annex.AnnexState, WorkerStage)) +waitStartWorkerSlot tv = do pool <- takeTMVar tv - let stage = initialStage (usedStages pool) - st <- go stage pool - return $ Just (st, stage) + st <- go pool + return $ Just (st, StartStage) where - go wantstage pool = case spareVals pool of + go pool = case spareVals pool of [] -> retry (v:vs) -> do let pool' = pool { spareVals = vs } - putTMVar tv =<< waitIdleWorkerSlot wantstage pool' + putTMVar tv =<< waitIdleWorkerSlot StartStage pool' return v waitIdleWorkerSlot :: WorkerStage -> WorkerPool Annex.AnnexState -> STM (WorkerPool Annex.AnnexState) diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -776,7 +776,7 @@ -- download command is used. meteredFile file (Just p) k $ Url.withUrlOptions $ \uo -> - liftIO $ anyM (\u -> Url.download p u file uo) urls + anyM (\u -> Url.download p u file uo) urls {- Copies a key's content, when present, to a temp file. - This is used to speed up some rsyncs. -} diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -192,12 +192,13 @@ -- 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 @@ 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 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -28,24 +28,24 @@ 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 @@ - 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/Annex/RemoteTrackingBranch.hs b/Annex/RemoteTrackingBranch.hs --- a/Annex/RemoteTrackingBranch.hs +++ b/Annex/RemoteTrackingBranch.hs @@ -17,6 +17,7 @@ import Annex.Common import Annex.CatFile +import qualified Annex import Git.Types import qualified Git.Ref import qualified Git.Branch @@ -72,9 +73,10 @@ _ -> return commitsha makeRemoteTrackingBranchMergeCommit' :: Sha -> Sha -> Sha -> Annex Sha -makeRemoteTrackingBranchMergeCommit' commitsha importedhistory treesha = +makeRemoteTrackingBranchMergeCommit' commitsha importedhistory treesha = do + cmode <- annexCommitMode <$> Annex.getGitConfig inRepo $ Git.Branch.commitTree - Git.Branch.AutomaticCommit + cmode "remote tracking branch" [commitsha, importedhistory] treesha diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -1,24 +1,39 @@ {- Url downloading, with git-annex user agent and configured http - headers, security restrictions, etc. - - - Copyright 2013-2018 Joey Hess + - Copyright 2013-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Url ( - module U, withUrlOptions, getUrlOptions, getUserAgent, ipAddressesUnlimited, + checkBoth, + download, + exists, + getUrlInfo, + U.downloadQuiet, + U.URLString, + U.UrlOptions(..), + U.UrlInfo(..), + U.sinkResponseFile, + U.matchStatusCodeException, + U.downloadConduit, + U.downloadPartial, + U.parseURIRelaxed, + U.allowedScheme, + U.assumeUrlExists, ) where import Annex.Common import qualified Annex -import Utility.Url as U +import qualified Utility.Url as U import Utility.IPAddress import Utility.HttpManagerRestricted +import Utility.Metered import qualified BuildInfo import Network.Socket @@ -43,7 +58,7 @@ where mk = do (urldownloader, manager) <- checkallowedaddr - mkUrlOptions + U.mkUrlOptions <$> (Just <$> getUserAgent) <*> headers <*> pure urldownloader @@ -108,3 +123,27 @@ withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a withUrlOptions a = a =<< getUrlOptions + +checkBoth :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex Bool +checkBoth url expected_size uo = + liftIO (U.checkBoth url expected_size uo) >>= \case + Right r -> return r + Left err -> warning err >> return False + +download :: MeterUpdate -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool +download meterupdate url file uo = + liftIO (U.download meterupdate url file uo) >>= \case + Right () -> return True + Left err -> warning err >> return False + +exists :: U.URLString -> U.UrlOptions -> Annex Bool +exists url uo = liftIO (U.exists url uo) >>= \case + Right b -> return b + Left err -> warning err >> return False + +getUrlInfo :: U.URLString -> U.UrlOptions -> Annex U.UrlInfo +getUrlInfo url uo = liftIO (U.getUrlInfo url uo) >>= \case + Right i -> return i + Left err -> do + warning err + return $ U.UrlInfo False Nothing Nothing diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -12,6 +12,7 @@ import Types.View import Types.MetaData import Annex.MetaData +import qualified Annex import qualified Git import qualified Git.DiffTree as DiffTree import qualified Git.Branch @@ -418,7 +419,8 @@ genViewBranch :: View -> Annex Git.Branch genViewBranch view = withViewIndex $ do let branch = branchView view - void $ inRepo $ Git.Branch.commit Git.Branch.AutomaticCommit True (fromRef branch) branch [] + cmode <- annexCommitMode <$> Annex.getGitConfig + void $ inRepo $ Git.Branch.commit cmode True (fromRef branch) branch [] return branch withCurrentView :: (View -> Annex a) -> Annex a diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -18,7 +18,6 @@ import qualified Annex import Annex.Content import Annex.Url -import Utility.Url (URLString) import Utility.DiskFree import Utility.HtmlDetect import Utility.Process.Transcript diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -53,8 +53,9 @@ initRepo' desc mgroup {- Initialize the master branch, so things that expect - to have it will work, before any files are added. -} - unlessM (Git.Config.isBare <$> gitRepo) $ - void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit + unlessM (Git.Config.isBare <$> gitRepo) $ do + cmode <- annexCommitMode <$> Annex.getGitConfig + void $ inRepo $ Git.Branch.commitCommand cmode [ Param "--quiet" , Param "--allow-empty" , Param "-m" diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -95,7 +95,9 @@ - warp-tls listens to http, in order to show an error page, so this works. -} assistantListening :: URLString -> IO Bool -assistantListening url = catchBoolIO $ exists url' =<< defUrlOptions +assistantListening url = catchBoolIO $ do + uo <- defUrlOptions + (== Right True) <$> exists url' uo where url' = case parseURI url of Nothing -> url diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -36,7 +36,6 @@ import Utility.InodeCache import qualified Database.Keys import qualified Command.Sync -import qualified Git.Branch import Utility.Tuple import Utility.Metered @@ -231,7 +230,8 @@ case v of Left _ -> return False Right _ -> do - ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg + cmode <- annexCommitMode <$> Annex.getGitConfig + ok <- Command.Sync.commitStaged cmode msg when ok $ Command.Sync.updateBranches =<< getCurrentBranch return ok diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -14,6 +14,7 @@ import Utility.DirWatcher import Utility.DirWatcher.Types import Annex.CurrentBranch +import qualified Annex import qualified Annex.Branch import qualified Git import qualified Git.Branch @@ -80,11 +81,13 @@ [ "merging", Git.fromRef changedbranch , "into", Git.fromRef b ] - void $ liftAnnex $ Command.Sync.merge - currbranch Command.Sync.mergeConfig - def - Git.Branch.AutomaticCommit - changedbranch + void $ liftAnnex $ do + cmode <- annexCommitMode <$> Annex.getGitConfig + Command.Sync.merge + currbranch Command.Sync.mergeConfig + def + cmode + changedbranch mergecurrent' _ = noop {- Is the first branch a synced branch or remote tracking branch related diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -183,7 +183,7 @@ runHandler handler file filestatus = void $ do r <- tryIO <~> handler (normalize file) filestatus case r of - Left e -> liftIO $ warningIO $ show e + Left e -> liftAnnex $ warning $ show e Right Nothing -> noop Right (Just change) -> recordChange change where diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -40,9 +40,10 @@ import qualified Utility.Lsof as Lsof import qualified BuildInfo import qualified Utility.Url as Url -import qualified Annex.Url as Url +import qualified Annex.Url as Url hiding (download) import Utility.Tuple +import Data.Either import qualified Data.Map as M {- Upgrade without interaction in the webapp. -} @@ -323,8 +324,8 @@ liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do let infof = tmpdir "info" let sigf = infof ++ ".sig" - ifM (Url.download nullMeterUpdate distributionInfoUrl infof uo - <&&> Url.download nullMeterUpdate distributionInfoSigUrl sigf uo + ifM (isRight <$> Url.download nullMeterUpdate distributionInfoUrl infof uo + <&&> (isRight <$> Url.download nullMeterUpdate distributionInfoSigUrl sigf uo) <&&> verifyDistributionSig gpgcmd sigf) ( parseInfoFile <$> readFileStrict infof , return Nothing diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -192,7 +192,7 @@ getRepoInfo :: RemoteConfig -> Widget getRepoInfo c = do uo <- liftAnnex Url.getUrlOptions - exists <- liftIO $ catchDefaultIO False $ Url.exists url uo + exists <- liftAnnex $ catchDefaultIO False $ Url.exists url uo [whamlet| Internet Archive item diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,16 @@ +git-annex (7.20191114) upstream; urgency=medium + + * Added annex.allowsign option. + * Make --json-error-messages capture more errors, + particularly url download errors. + * Fix a crash (STM deadlock) when -J is used with multiple files + that point to the same key. + * linuxstandalone: Fix a regression that broke git-remote-https. + * OSX git-annex.app: Fix a problem that prevented using the bundled + git-remote-https, git-remote-http, and git-shell. + + -- Joey Hess Thu, 14 Nov 2019 21:57:59 -0400 + git-annex (7.20191106) upstream; urgency=medium * init: Fix bug that lost modifications to unlocked files when init is diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -63,7 +63,7 @@ runconcurrent = Annex.getState Annex.workers >>= \case Nothing -> runnonconcurrent Just tv -> - liftIO (atomically (waitInitialWorkerSlot tv)) >>= + liftIO (atomically (waitStartWorkerSlot tv)) >>= maybe runnonconcurrent (runconcurrent' tv) runconcurrent' tv (workerst, workerstage) = do aid <- liftIO $ async $ snd <$> Annex.run workerst @@ -99,12 +99,13 @@ case mkActionItem startmsg' of OnlyActionOn k' _ | k' /= k -> concurrentjob' workerst startmsg' perform' - _ -> mkjob workerst startmsg' perform' + _ -> beginjob workerst startmsg' perform' Nothing -> noop - _ -> mkjob workerst startmsg perform + _ -> beginjob workerst startmsg perform - mkjob workerst startmsg perform = - inOwnConsoleRegion (Annex.output workerst) $ + beginjob workerst startmsg perform = + inOwnConsoleRegion (Annex.output workerst) $ do + enteringInitialStage void $ accountCommandAction startmsg $ performconcurrent startmsg perform diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -197,8 +197,7 @@ pathmax <- liftIO $ fileNameLengthLimit "." urlinfo <- if relaxedOption (downloadOptions o) then pure Url.assumeUrlExists - else Url.withUrlOptions $ - liftIO . Url.getUrlInfo urlstring + else Url.withUrlOptions $ Url.getUrlInfo urlstring file <- adjustFile o <$> case fileOption (downloadOptions o) of Just f -> pure f Nothing -> case Url.urlSuggestedFile urlinfo of diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -30,7 +30,6 @@ import Logs.Location import Git.FilePath import Git.Types -import Git.Branch import Types.Import import Utility.Metered @@ -266,7 +265,8 @@ Nothing -> giveup $ "Unable to find base tree for branch " ++ fromRef branch trackingcommit <- fromtrackingbranch Git.Ref.sha - let importcommitconfig = ImportCommitConfig trackingcommit AutomaticCommit importmessage + cmode <- annexCommitMode <$> Annex.getGitConfig + let importcommitconfig = ImportCommitConfig trackingcommit cmode importmessage let commitimport = commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importabletvar <- liftIO $ newTVarIO Nothing diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -146,13 +146,12 @@ downloadFeed :: URLString -> Annex (Maybe String) downloadFeed url | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url" - | otherwise = Url.withUrlOptions $ \uo -> - liftIO $ withTmpFile "feed" $ \f h -> do - hClose h - ifM (Url.download nullMeterUpdate url f uo) - ( Just <$> readFileStrict f - , return Nothing - ) + | otherwise = withTmpFile "feed" $ \f h -> do + liftIO $ hClose h + ifM (Url.withUrlOptions $ Url.download nullMeterUpdate url f) + ( Just <$> liftIO (readFileStrict f) + , return Nothing + ) performDownload :: ImportFeedOptions -> Cache -> ToDownload -> Annex Bool performDownload opts cache todownload = case location todownload of @@ -164,7 +163,7 @@ urlinfo <- if relaxedOption (downloadOptions opts) then pure Url.assumeUrlExists else Url.withUrlOptions $ - liftIO . Url.getUrlInfo url + Url.getUrlInfo url let dlopts = (downloadOptions opts) -- force using the filename -- chosen here diff --git a/Git/Queue.hs b/Git/Queue.hs --- 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 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 @@ {- 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 @@ {- 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 = 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 @@ - 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 @@ 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 @@ 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 @@ {- 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 @@ {- 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 @@ {- 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 @@ - - 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 diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,4 +1,4 @@ -git-annex (7.20191024) UNRELEASED; urgency=medium +git-annex (7.20191024) upstream; urgency=medium When annex.largefiles is not configured, `git add` and `git commit -a` add files to git, not to the annex. If you have gotten used to `git add` diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -206,7 +206,7 @@ withTmpFileIn othertmp "torrent" $ \f h -> do liftIO $ hClose h ok <- Url.withUrlOptions $ - liftIO . Url.download nullMeterUpdate u f + Url.download nullMeterUpdate u f when ok $ liftIO $ renameFile f torrent return ok diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -716,7 +716,7 @@ checkKeyUrl r k = do showChecking r us <- getWebUrls k - anyM (\u -> withUrlOptions $ liftIO . checkBoth u (keySize k)) us + anyM (\u -> withUrlOptions $ checkBoth u (keySize k)) us getWebUrls :: Key -> Annex [URLString] getWebUrls key = filter supported <$> getUrls key diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -286,7 +286,7 @@ {- Ask git-annex-shell to configure the repository as a gcrypt - repository. May fail if it is too old. -} gitannexshellsetup = Ssh.onRemote NoConsumeStdin r - (boolSystem, return False) + (\f p -> liftIO (boolSystem f p), return False) "gcryptsetup" [ Param gcryptid ] [] denyNonFastForwards = "receive.denyNonFastForwards" @@ -451,7 +451,7 @@ | Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> liftIO (catchMaybeIO $ Git.Config.read r) | not fast = extract . liftM fst <$> getM (eitherToMaybe <$>) - [ Ssh.onRemote NoConsumeStdin r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] [] + [ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p), return (Left $ error "configlist failed")) "configlist" [] [] , getConfigViaRsync r gc ] | otherwise = return (Nothing, r) diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -249,21 +249,21 @@ haveconfig = not . M.null . Git.config pipedconfig cmd params = do - v <- Git.Config.fromPipe r cmd params + v <- liftIO $ Git.Config.fromPipe r cmd params case v of Right (r', val) -> do unless (isUUIDConfigured r' || null val) $ do - warningIO $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r - warningIO $ "Instead, got: " ++ show val - warningIO $ "This is unexpected; please check the network transport!" + warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r + warning $ "Instead, got: " ++ show val + warning $ "This is unexpected; please check the network transport!" return $ Right r' Left l -> return $ Left l geturlconfig = Url.withUrlOptions $ \uo -> do - v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do - hClose h + v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do + liftIO $ hClose h let url = Git.repoLocation r ++ "/config" - ifM (Url.downloadQuiet nullMeterUpdate url tmpfile uo) + ifM (liftIO $ Url.downloadQuiet nullMeterUpdate url tmpfile uo) ( Just <$> pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] , return Nothing ) @@ -352,11 +352,10 @@ checkhttp = do showChecking repo gc <- Annex.getGitConfig - ifM (Url.withUrlOptions $ \uo -> liftIO $ - anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls gc repo rmt key)) - ( return True - , giveup "not found" - ) + ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls gc repo rmt key)) + ( return True + , giveup "not found" + ) checkremote = let fallback = Ssh.inAnnex repo key in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) key diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -83,7 +83,7 @@ onRemote :: ConsumeStdin -> Git.Repo - -> (FilePath -> [CommandParam] -> IO a, Annex a) + -> (FilePath -> [CommandParam] -> Annex a, Annex a) -> String -> [CommandParam] -> [(Field, String)] @@ -91,7 +91,7 @@ onRemote cs r (with, errorval) command params fields = do s <- git_annex_shell cs r command params fields case s of - Just (c, ps) -> liftIO $ with c ps + Just (c, ps) -> with c ps Nothing -> errorval {- Checks if a remote contains a key. -} @@ -100,14 +100,14 @@ showChecking r onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ serializeKey k] [] where - runcheck c p = dispatch =<< safeSystem c p + runcheck c p = liftIO $ dispatch =<< safeSystem c p dispatch ExitSuccess = return True dispatch (ExitFailure 1) = return False dispatch _ = cantCheck r {- Removes a key from a remote. -} dropKey :: Git.Repo -> Key -> Annex Bool -dropKey r key = onRemote NoConsumeStdin r (boolSystem, return False) "dropkey" +dropKey r key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey" [ Param "--quiet", Param "--force" , Param $ serializeKey key ] diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -58,11 +58,10 @@ import Logs.MetaData import Types.MetaData import Utility.Metered -import qualified Annex.Url as Url import Utility.DataUnits import Annex.Content -import Annex.Url (getUrlOptions, withUrlOptions) -import Utility.Url (checkBoth, UrlOptions(..)) +import qualified Annex.Url as Url +import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env type BucketName = String @@ -348,7 +347,7 @@ Right us -> do showChecking r let check u = withUrlOptions $ - liftIO . checkBoth u (keySize k) + Url.checkBoth u (keySize k) anyM check us checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool @@ -397,7 +396,7 @@ warning $ needS3Creds (uuid r) return False Just geturl -> Url.withUrlOptions $ - liftIO . Url.download p (geturl exportloc) f + Url.download p (geturl exportloc) f exportloc = bucketExportLocation info loc removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex Bool @@ -417,8 +416,8 @@ checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc)) Nothing -> case getPublicUrlMaker info of - Just geturl -> withUrlOptions $ liftIO . - checkBoth (geturl $ bucketExportLocation info loc) (keySize k) + Just geturl -> withUrlOptions $ + Url.checkBoth (geturl $ bucketExportLocation info loc) (keySize k) Nothing -> do warning $ needS3Creds (uuid r) giveup "No S3 credentials configured" diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -116,9 +116,8 @@ showChecking u' case downloader of YoutubeDownloader -> youtubeDlCheck u' - _ -> do - Url.withUrlOptions $ liftIO . catchMsgIO . - Url.checkBoth u' (keySize key) + _ -> catchMsgIO $ + Url.withUrlOptions $ Url.checkBoth u' (keySize key) where firsthit [] miss _ = return miss firsthit (u:rest) _ a = do diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -170,5 +170,5 @@ updateTransportHandle h@(TransportHandle _g annexstate) = do g' <- liftAnnex h $ do reloadConfig - Annex.fromRepo id + Annex.gitRepo return (TransportHandle (LocalRepo g') annexstate) diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -69,7 +69,7 @@ ) unless ok $ do hClose conn - warningIO "dropped Tor connection, too busy" + liftAnnex th $ warning "dropped Tor connection, too busy" handlecontrol servicerunning = do msg <- atomically $ readTChan ichan diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -84,6 +84,7 @@ import qualified Utility.Tmp.Dir import qualified Utility.FileSystemEncoding import qualified Utility.Aeson +import qualified Utility.CopyFile #ifndef mingw32_HOST_OS import qualified Remote.Helper.Encryptable import qualified Types.Crypto @@ -248,6 +249,7 @@ , testCase "info" test_info , testCase "version" test_version , testCase "sync" test_sync + , testCase "concurrent get of dup key regression" test_concurrent_get_of_dup_key_regression , testCase "union merge regression" test_union_merge_regression , testCase "adjusted branch merge regression" test_adjusted_branch_merge_regression , testCase "adjusted branch subtree regression" test_adjusted_branch_subtree_regression @@ -950,6 +952,31 @@ git_annex_expectoutput "find" ["--in", "."] [] git_annex "sync" ["--content"] @? "sync failed" git_annex_expectoutput "find" ["--in", "."] [] + +{- Regression test for the concurrency bug fixed in + - 667d38a8f11c1ee8f256cdbd80e225c2bae06595 -} +test_concurrent_get_of_dup_key_regression :: Assertion +test_concurrent_get_of_dup_key_regression = intmpclonerepo $ do + makedup dupfile + -- This was sufficient currency to trigger the bug. + git_annex "get" ["-J1", annexedfile, dupfile] + @? "concurrent get -J1 with dup failed" + git_annex "drop" ["-J1"] + @? "drop with dup failed" + -- With -J2, one more dup file was needed to trigger the bug. + makedup dupfile2 + git_annex "get" ["-J2", annexedfile, dupfile, dupfile2] + @? "concurrent get -J2 with dup failed" + git_annex "drop" ["-J2"] + @? "drop with dup failed" + where + dupfile = annexedfile ++ "2" + dupfile2 = annexedfile ++ "3" + makedup f = do + Utility.CopyFile.copyFileExternal Utility.CopyFile.CopyAllMetaData annexedfile f + @? "copying annexed file failed" + boolSystem "git" [Param "add", File f] + @? "git add failed" {- Regression test for union merge bug fixed in - 0214e0fb175a608a49b812d81b4632c081f63027 -} diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -1,6 +1,6 @@ {- git-annex configuration - - - Copyright 2012-2015 Joey Hess + - Copyright 2012-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,6 +21,7 @@ import qualified Git.Construct import Git.Types import Git.ConfigTypes +import Git.Branch (CommitMode(..)) import Utility.DataUnits import Config.Cost import Types.UUID @@ -105,6 +106,7 @@ , annexJobs :: Concurrency , annexCacheCreds :: Bool , annexAutoUpgradeRepository :: Bool + , annexCommitMode :: CommitMode , coreSymlinks :: Bool , coreSharedRepository :: SharedRepository , receiveDenyCurrentBranch :: DenyCurrentBranch @@ -186,6 +188,9 @@ parseConcurrency =<< getmaybe (annex "jobs") , annexCacheCreds = getbool (annex "cachecreds") True , annexAutoUpgradeRepository = getbool (annex "autoupgraderepository") True + , annexCommitMode = if getbool (annex "allowsign") False + then ManualCommit + else AutomaticCommit , coreSymlinks = getbool "core.symlinks" True , coreSharedRepository = getSharedRepository r , receiveDenyCurrentBranch = getDenyCurrentBranch r diff --git a/Types/WorkerPool.hs b/Types/WorkerPool.hs --- a/Types/WorkerPool.hs +++ b/Types/WorkerPool.hs @@ -20,8 +20,15 @@ -- but there can temporarily be fewer values, when a thread is -- changing between stages. } - deriving (Show) +instance Show (WorkerPool t) where + show p = unwords + [ "WorkerPool" + , show (usedStages p) + , show (workerList p) + , show (length (spareVals p)) + ] + -- | A worker can either be idle or running an Async action. -- And it is used for some stage. data Worker t @@ -33,7 +40,12 @@ show (ActiveWorker _ s) = "ActiveWorker " ++ show s data WorkerStage - = PerformStage + = StartStage + -- ^ All threads start in this stage, and then transition away from + -- it to the initialStage when they begin doing work. This should + -- never be included in UsedStages, because transition from some + -- other stage back to this one could result in a deadlock. + | PerformStage -- ^ Running a CommandPerform action. | CleanupStage -- ^ Running a CommandCleanup action. @@ -95,12 +107,13 @@ allocateWorkerPool :: t -> Int -> UsedStages -> WorkerPool t allocateWorkerPool t n u = WorkerPool { usedStages = u - , workerList = take totalthreads $ map IdleWorker stages + , workerList = map IdleWorker $ + take totalthreads $ concat $ repeat stages , spareVals = replicate totalthreads t } where - stages = concat $ repeat $ S.toList $ stageSet u - totalthreads = n * S.size (stageSet u) + stages = StartStage : S.toList (stageSet u) + totalthreads = n * length stages addWorkerPool :: Worker t -> WorkerPool t -> WorkerPool t addWorkerPool w pool = pool { workerList = w : workerList pool } diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -138,22 +138,14 @@ ] schemelist = map fromScheme $ S.toList $ allowedSchemes uo -checkPolicy :: UrlOptions -> URI -> a -> (String -> IO b) -> IO a -> IO a -checkPolicy uo u onerr displayerror a +checkPolicy :: UrlOptions -> URI -> IO (Either String a) -> IO (Either String a) +checkPolicy uo u a | allowedScheme uo u = a - | otherwise = do - void $ displayerror $ - "Configuration does not allow accessing " ++ show u - return onerr - -unsupportedUrlScheme :: URI -> (String -> IO a) -> IO a -unsupportedUrlScheme u displayerror = - displayerror $ "Unsupported url scheme " ++ show u + | otherwise = return $ Left $ + "Configuration does not allow accessing " ++ show u -warnError :: String -> IO () -warnError msg = do - hPutStrLn stderr msg - hFlush stderr +unsupportedUrlScheme :: URI -> String +unsupportedUrlScheme u = "Unsupported url scheme " ++ show u allowedScheme :: UrlOptions -> URI -> Bool allowedScheme uo u = uscheme `S.member` allowedSchemes uo @@ -161,14 +153,18 @@ uscheme = mkScheme $ takeWhile (/=':') (uriScheme u) {- Checks that an url exists and could be successfully downloaded, - - also checking that its size, if available, matches a specified size. -} -checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO Bool -checkBoth url expected_size uo = do - v <- check url expected_size uo - return (fst v && snd v) + - also checking that its size, if available, matches a specified size. + - + - The Left error is returned if policy does not allow accessing the url + - or the url scheme is not supported. + -} +checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO (Either String Bool) +checkBoth url expected_size uo = fmap go <$> check url expected_size uo + where + go v = fst v && snd v -check :: URLString -> Maybe Integer -> UrlOptions -> IO (Bool, Bool) -check url expected_size uo = go <$> getUrlInfo url uo +check :: URLString -> Maybe Integer -> UrlOptions -> IO (Either String (Bool, Bool)) +check url expected_size uo = fmap go <$> getUrlInfo url uo where go (UrlInfo False _ _) = (False, False) go (UrlInfo True Nothing _) = (True, True) @@ -176,8 +172,8 @@ Just _ -> (True, expected_size == s) Nothing -> (True, True) -exists :: URLString -> UrlOptions -> IO Bool -exists url uo = urlExists <$> getUrlInfo url uo +exists :: URLString -> UrlOptions -> IO (Either String Bool) +exists url uo = fmap urlExists <$> getUrlInfo url uo data UrlInfo = UrlInfo { urlExists :: Bool @@ -190,32 +186,36 @@ assumeUrlExists = UrlInfo True Nothing Nothing {- Checks that an url exists and could be successfully downloaded, - - also returning its size and suggested filename if available. -} -getUrlInfo :: URLString -> UrlOptions -> IO UrlInfo + - also returning its size and suggested filename if available. + - + - The Left error is returned if policy does not allow accessing the url + - or the url scheme is not supported. + -} +getUrlInfo :: URLString -> UrlOptions -> IO (Either String UrlInfo) getUrlInfo url uo = case parseURIRelaxed url of - Just u -> checkPolicy uo u dne warnError $ - case (urlDownloader uo, parseUrlRequest (show u)) of - (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust - -- When http redirects to a protocol which - -- conduit does not support, it will throw - -- a StatusCodeException with found302 - -- and a Response with the redir Location. - (matchStatusCodeException (== found302)) - (existsconduit req) - (followredir r) - `catchNonAsync` (const $ return dne) - (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) - | isfileurl u -> existsfile u - | isftpurl u -> existscurlrestricted r u url ftpport - `catchNonAsync` (const $ return dne) - | otherwise -> do - unsupportedUrlScheme u warnError - return dne - (DownloadWithCurl _, _) - | isfileurl u -> existsfile u - | otherwise -> existscurl u (basecurlparams url) - Nothing -> return dne - where + Just u -> checkPolicy uo u (go u) + Nothing -> return (Right dne) + where + go :: URI -> IO (Either String UrlInfo) + go u = case (urlDownloader uo, parseUrlRequest (show u)) of + (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust + -- When http redirects to a protocol which + -- conduit does not support, it will throw + -- a StatusCodeException with found302 + -- and a Response with the redir Location. + (matchStatusCodeException (== found302)) + (Right <$> existsconduit req) + (followredir r) + `catchNonAsync` (const $ return $ Right dne) + (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) + | isfileurl u -> Right <$> existsfile u + | isftpurl u -> (Right <$> existscurlrestricted r u url ftpport) + `catchNonAsync` (const $ return $ Right dne) + | otherwise -> return $ Left $ unsupportedUrlScheme u + (DownloadWithCurl _, _) + | isfileurl u -> Right <$> existsfile u + | otherwise -> Right <$> existscurl u (basecurlparams url) + dne = UrlInfo False Nothing Nothing found sz f = return $ UrlInfo True sz f @@ -291,11 +291,11 @@ -- http to file redirect would not be secure, -- and http-conduit follows http to http. Just u' | isftpurl u' -> - checkPolicy uo u' dne warnError $ + checkPolicy uo u' $ Right <$> existscurlrestricted r u' url' ftpport - _ -> return dne - Nothing -> return dne - followredir _ _ = return dne + _ -> return (Right dne) + Nothing -> return (Right dne) + followredir _ _ = return (Right dne) -- Parse eg: attachment; filename="fname.ext" -- per RFC 2616 @@ -317,31 +317,32 @@ {- Download a perhaps large file, with auto-resume of incomplete downloads. - - - Displays error message on stderr when download failed. + - When the download fails, returns an error message. -} -download :: MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO Bool +download :: MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO (Either String ()) download = download' False -{- Avoids displaying any error message. -} +{- Avoids displaying any error message, including silencing curl errors. -} downloadQuiet :: MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO Bool -downloadQuiet = download' True +downloadQuiet meterupdate url file uo = isRight + <$> download' True meterupdate url file uo -download' :: Bool -> MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO Bool -download' noerror meterupdate url file uo = +download' :: Bool -> MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO (Either String ()) +download' nocurlerror meterupdate url file uo = catchJust matchHttpException go showhttpexception `catchNonAsync` (dlfailed . show) where go = case parseURIRelaxed url of - Just u -> checkPolicy uo u False dlfailed $ + Just u -> checkPolicy uo u $ case (urlDownloader uo, parseUrlRequest (show u)) of (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust (matchStatusCodeException (== found302)) - (downloadConduit meterupdate req file uo >> return True) + (downloadConduit meterupdate req file uo >> return (Right ())) (followredir r) (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) | isfileurl u -> downloadfile u | isftpurl u -> downloadcurlrestricted r u url ftpport - | otherwise -> unsupportedUrlScheme u dlfailed + | otherwise -> dlfailed $ unsupportedUrlScheme u (DownloadWithCurl _, _) | isfileurl u -> downloadfile u | otherwise -> downloadcurl url basecurlparams @@ -354,27 +355,20 @@ ftpport = 21 - showhttpexception he = do - let msg = case he of - HttpExceptionRequest _ (StatusCodeException r _) -> - B8.toString $ statusMessage $ responseStatus r - HttpExceptionRequest _ (InternalException ie) -> - case fromException ie of - Nothing -> show ie - Just (ConnectionRestricted why) -> why - HttpExceptionRequest _ other -> show other - _ -> show he - dlfailed msg - - dlfailed msg - | noerror = return False - | otherwise = do - hPutStrLn stderr $ "download failed: " ++ msg - hFlush stderr - return False + showhttpexception he = dlfailed $ case he of + HttpExceptionRequest _ (StatusCodeException r _) -> + B8.toString $ statusMessage $ responseStatus r + HttpExceptionRequest _ (InternalException ie) -> + case fromException ie of + Nothing -> show ie + Just (ConnectionRestricted why) -> why + HttpExceptionRequest _ other -> show other + _ -> show he + dlfailed msg = return $ Left $ "download failed: " ++ msg + basecurlparams = curlParams uo - [ if noerror + [ if nocurlerror then Param "-S" else Param "-sS" , Param "-f" @@ -387,7 +381,10 @@ -- if the url happens to be empty, so pre-create. unlessM (doesFileExist file) $ writeFile file "" - boolSystem "curl" (curlparams ++ [Param "-o", File file, File rawurl]) + ifM (boolSystem "curl" (curlparams ++ [Param "-o", File file, File rawurl])) + ( return $ Right () + , return $ Left "download failed" + ) downloadcurlrestricted r u rawurl defport = downloadcurl rawurl =<< curlRestrictedParams r u defport basecurlparams @@ -396,7 +393,7 @@ let src = unEscapeString (uriPath u) withMeteredFile src meterupdate $ L.writeFile file - return True + return $ Right () -- Conduit does not support ftp, so will throw an exception on a -- redirect to a ftp url; fall back to curl. @@ -404,7 +401,7 @@ case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of Just url' -> case parseURIRelaxed url' of Just u' | isftpurl u' -> - checkPolicy uo u' False dlfailed $ + checkPolicy uo u' $ downloadcurlrestricted r u' url' ftpport _ -> throwIO ex Nothing -> throwIO ex diff --git a/doc/git-annex-addurl.mdwn b/doc/git-annex-addurl.mdwn --- a/doc/git-annex-addurl.mdwn +++ b/doc/git-annex-addurl.mdwn @@ -16,8 +16,10 @@ See the documentation of annex.security.allowed-ip-addresses in [[git-annex]](1) for details.) -Urls to torrent files (including magnet links) will cause the content of -the torrent to be downloaded, using `aria2c`. +Special remotes can add other special handling of particular urls. For +example, the bittorrent special remotes makes urls to torrent files +(including magnet links) download the content of the torrent, +using `aria2c`. Normally the filename is based on the full url, so will look like "www.example.com_dir_subdir_bigfile". In some cases, addurl is able to diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1028,6 +1028,19 @@ This works well in combination with annex.alwayscommit=false, to gather up a set of changes and commit them with a message you specify. +* `annex.allowsign` + + By default git-annex avoids gpg signing commits that it makes when + they're not the purpose of a command, but only a side effect. + That default avoids lots of gpg password prompts when + commit.gpgSign is set. A command like `git annex sync` or `git annex merge` + will gpg sign its commit, but a command like `git annex get`, + that updates the git-annex branch, will not. The assistant also avoids + signing commits. + + Setting annex.allowsign to true lets all commits be signed, as + controlled by commit.gpgSign and other git configuration. + * `annex.merge-annex-branches` By default, git-annex branches that have been pulled from remotes diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 7.20191106 +Version: 7.20191114 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess