git-annex 7.20191106 → 7.20191114
raw patch · 41 files changed
+376/−237 lines, 41 files
Files
- Annex.hs +1/−1
- Annex/AdjustedBranch.hs +19/−11
- Annex/Branch.hs +10/−6
- Annex/Concurrent.hs +25/−15
- Annex/Content.hs +1/−1
- Annex/Link.hs +6/−5
- Annex/Queue.hs +13/−13
- Annex/RemoteTrackingBranch.hs +4/−2
- Annex/Url.hs +43/−4
- Annex/View.hs +3/−1
- Annex/YoutubeDl.hs +0/−1
- Assistant/MakeRepo.hs +3/−2
- Assistant/Restart.hs +3/−1
- Assistant/Threads/Committer.hs +2/−2
- Assistant/Threads/Merger.hs +8/−5
- Assistant/Threads/Watcher.hs +1/−1
- Assistant/Upgrade.hs +4/−3
- Assistant/WebApp/Configurators/IA.hs +1/−1
- CHANGELOG +13/−0
- CmdLine/Action.hs +6/−5
- Command/AddUrl.hs +1/−2
- Command/Import.hs +2/−2
- Command/ImportFeed.hs +7/−8
- Git/Queue.hs +21/−20
- NEWS +1/−1
- Remote/BitTorrent.hs +1/−1
- Remote/External.hs +1/−1
- Remote/GCrypt.hs +2/−2
- Remote/Git.hs +11/−12
- Remote/Helper/Ssh.hs +4/−4
- Remote/S3.hs +6/−7
- Remote/Web.hs +2/−3
- RemoteDaemon/Core.hs +1/−1
- RemoteDaemon/Transport/Tor.hs +1/−1
- Test.hs +27/−0
- Types/GitConfig.hs +6/−1
- Types/WorkerPool.hs +18/−5
- Utility/Url.hs +80/−83
- doc/git-annex-addurl.mdwn +4/−2
- doc/git-annex.mdwn +13/−0
- git-annex.cabal +1/−1
Annex.hs view
@@ -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
Annex/AdjustedBranch.hs view
@@ -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
Annex/Branch.hs view
@@ -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,
Annex/Concurrent.hs view
@@ -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)
Annex/Content.hs view
@@ -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. -}
Annex/Link.hs view
@@ -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
Annex/Queue.hs view
@@ -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 ()
Annex/RemoteTrackingBranch.hs view
@@ -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
Annex/Url.hs view
@@ -1,24 +1,39 @@ {- Url downloading, with git-annex user agent and configured http - headers, security restrictions, etc. -- - Copyright 2013-2018 Joey Hess <id@joeyh.name>+ - Copyright 2013-2019 Joey Hess <id@joeyh.name> - - 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
Annex/View.hs view
@@ -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
Annex/YoutubeDl.hs view
@@ -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
Assistant/MakeRepo.hs view
@@ -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"
Assistant/Restart.hs view
@@ -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
Assistant/Threads/Committer.hs view
@@ -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
Assistant/Threads/Merger.hs view
@@ -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
Assistant/Threads/Watcher.hs view
@@ -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
Assistant/Upgrade.hs view
@@ -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
Assistant/WebApp/Configurators/IA.hs view
@@ -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| <a href="#{url}"> Internet Archive item
CHANGELOG view
@@ -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 <id@joeyh.name> 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
CmdLine/Action.hs view
@@ -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
Command/AddUrl.hs view
@@ -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
Command/Import.hs view
@@ -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
Command/ImportFeed.hs view
@@ -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
Git/Queue.hs view
@@ -1,6 +1,6 @@ {- git repository command queue -- - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -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
NEWS view
@@ -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`
Remote/BitTorrent.hs view
@@ -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
Remote/External.hs view
@@ -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
Remote/GCrypt.hs view
@@ -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)
Remote/Git.hs view
@@ -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
Remote/Helper/Ssh.hs view
@@ -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 ]
Remote/S3.hs view
@@ -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"
Remote/Web.hs view
@@ -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
RemoteDaemon/Core.hs view
@@ -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)
RemoteDaemon/Transport/Tor.hs view
@@ -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
Test.hs view
@@ -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 -}
Types/GitConfig.hs view
@@ -1,6 +1,6 @@ {- git-annex configuration -- - Copyright 2012-2015 Joey Hess <id@joeyh.name>+ - Copyright 2012-2019 Joey Hess <id@joeyh.name> - - 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
Types/WorkerPool.hs view
@@ -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 }
Utility/Url.hs view
@@ -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
doc/git-annex-addurl.mdwn view
@@ -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
doc/git-annex.mdwn view
@@ -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
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 7.20191106+Version: 7.20191114 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>