git-annex 8.20211011 → 8.20211028
raw patch · 41 files changed
+313/−596 lines, 41 files
Files
- Annex/Branch.hs +37/−16
- Annex/Content.hs +4/−1
- Annex/Content/PointerFile.hs +2/−2
- Annex/Journal.hs +27/−7
- Annex/Link.hs +6/−1
- Annex/Transfer.hs +6/−1
- Assistant/WebApp/Configurators/IA.hs +2/−2
- CHANGELOG +34/−0
- CmdLine/GitAnnexShell.hs +9/−18
- CmdLine/GitAnnexShell/Fields.hs +0/−9
- Command/AddUrl.hs +11/−1
- Command/Commit.hs +0/−32
- Command/Fix.hs +2/−2
- Command/LockContent.hs +0/−41
- Command/RecvKey.hs +1/−7
- Command/SendKey.hs +1/−2
- Command/TransferInfo.hs +0/−69
- Database/Benchmark.hs +1/−1
- Database/ContentIdentifier.hs +1/−1
- Database/Export.hs +1/−1
- Database/Fsck.hs +1/−1
- Database/Handle.hs +20/−59
- Database/Keys.hs +2/−2
- Database/Queue.hs +3/−7
- Git/Construct.hs +4/−1
- Remote/GCrypt.hs +2/−4
- Remote/Git.hs +14/−169
- Remote/Helper/Chunked.hs +10/−5
- Remote/Helper/P2P.hs +4/−4
- Remote/Helper/Ssh.hs +7/−20
- Remote/P2P.hs +3/−10
- RemoteDaemon/Transport/Ssh.hs +3/−23
- Test.hs +15/−7
- Utility/InodeCache.hs +2/−7
- Utility/LinuxMkLibs.hs +1/−1
- Utility/Path.hs +22/−3
- Utility/Path/Tests.hs +16/−0
- doc/git-annex-inprogress.mdwn +3/−0
- doc/git-annex-shell.mdwn +29/−51
- git-annex.cabal +1/−4
- stack.yaml +6/−4
Annex/Branch.hs view
@@ -280,8 +280,11 @@ st <- getState content <- if journalIgnorable st then pure branchcontent- else fromMaybe branchcontent- <$> getJournalFileStale (GetPrivate True) file+ else getJournalFileStale (GetPrivate True) file >>= return . \case+ NoJournalledContent -> branchcontent+ JournalledContent journalcontent -> journalcontent+ PossiblyStaleJournalledContent journalcontent ->+ branchcontent <> journalcontent Annex.BranchState.setCache file content {- Like get, but does not merge the branch, so the info returned may not@@ -296,8 +299,11 @@ fastDebug "Annex.Branch" ("read " ++ fromRawFilePath file) go =<< getJournalFileStale getprivate file where- go (Just journalcontent) = return journalcontent- go Nothing = getRef fullname file+ go NoJournalledContent = getRef fullname file+ go (JournalledContent journalcontent) = return journalcontent+ go (PossiblyStaleJournalledContent journalcontent) = do+ v <- getRef fullname file+ return (v <> journalcontent) {- Gets the content of a file as staged in the branch's index. -} getStaged :: RawFilePath -> Annex L.ByteString@@ -813,12 +819,7 @@ buf <- liftIO newEmptyMVar let go' reader = go $ liftIO reader >>= \case Just ((v, f), content) -> do- -- Check the journal if it did not get- -- committed to the branch- content' <- if journalIgnorable st- then pure content- else maybe content Just - <$> getJournalFileStale (GetPrivate True) f+ content' <- checkjournal st f content return (Just (v, f, content')) Nothing | journalIgnorable st -> return Nothing@@ -834,16 +835,36 @@ catObjectStreamLsTree l (select' . getTopFilePath . Git.LsTree.file) g go' `finally` liftIO (void cleanup) where- getnext [] = Nothing- getnext (f:fs) = case select f of- Nothing -> getnext fs- Just v -> Just (v, f, fs)- + -- Check the journal, in case it did not get committed to the branch+ checkjournal st f branchcontent+ | journalIgnorable st = return branchcontent+ | otherwise = getJournalFileStale (GetPrivate True) f >>= return . \case+ NoJournalledContent -> branchcontent+ JournalledContent journalledcontent ->+ Just journalledcontent+ PossiblyStaleJournalledContent journalledcontent ->+ Just (fromMaybe mempty branchcontent <> journalledcontent)+ drain buf fs = case getnext fs of Just (v, f, fs') -> do liftIO $ putMVar buf fs'- content <- getJournalFileStale (GetPrivate True) f+ content <- getJournalFileStale (GetPrivate True) f >>= \case+ NoJournalledContent -> return Nothing+ JournalledContent journalledcontent ->+ return (Just journalledcontent)+ PossiblyStaleJournalledContent journalledcontent -> do+ -- This is expensive, but happens+ -- only when there is a private+ -- journal file.+ content <- getRef fullname f+ return (Just (content <> journalledcontent)) return (Just (v, f, content)) Nothing -> do liftIO $ putMVar buf [] return Nothing+ + getnext [] = Nothing+ getnext (f:fs) = case select f of+ Nothing -> getnext fs+ Just v -> Just (v, f, fs)+
Annex/Content.hs view
@@ -342,10 +342,13 @@ storeobject dest = ifM (liftIO $ R.doesPathExist dest) ( alreadyhave , adjustedBranchRefresh af $ modifyContent dest $ do- freezeContent src liftIO $ moveFile (fromRawFilePath src) (fromRawFilePath dest)+ -- Freeze the object file now that it is in place.+ -- Waiting until now to freeze it allows for freeze+ -- hooks that prevent moving the file.+ freezeContent dest g <- Annex.gitRepo fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
Annex/Content/PointerFile.hs view
@@ -19,7 +19,7 @@ import qualified Utility.RawFilePath as R #if ! defined(mingw32_HOST_OS) import Utility.Touch-import System.Posix.Files (modificationTimeHiRes)+import qualified System.Posix.Files as Posix #endif {- Populates a pointer file with the content of a key. @@ -66,7 +66,7 @@ -- by git in some cases. liftIO $ maybe noop (\t -> touch tmp' t False)- (fmap modificationTimeHiRes st)+ (fmap Posix.modificationTimeHiRes st) #endif withTSDelta (liftIO . genInodeCache (toRawFilePath tmp)) maybe noop (restagePointerFile (Restage True) file) ic
Annex/Journal.hs view
@@ -89,8 +89,20 @@ withFile tmpfile WriteMode $ \h -> writeJournalHandle h content moveFile tmpfile (fromRawFilePath (jd P.</> jfile)) +data JournalledContent+ = NoJournalledContent+ | JournalledContent L.ByteString+ | PossiblyStaleJournalledContent L.ByteString+ -- ^ This is used when the journalled content may have been + -- supersceded by content in the git-annex branch. The returned+ -- content should be combined with content from the git-annex branch.+ -- This is particularly the case when a file is in the private+ -- journal, which does not get written to the git-annex branch,+ -- and so the git-annex branch can contain changes to non-private+ -- information that were made after that journal file was written.+ {- Gets any journalled content for a file in the branch. -}-getJournalFile :: JournalLocked -> GetPrivate -> RawFilePath -> Annex (Maybe L.ByteString)+getJournalFile :: JournalLocked -> GetPrivate -> RawFilePath -> Annex JournalledContent getJournalFile _jl = getJournalFileStale data GetPrivate = GetPrivate Bool@@ -106,7 +118,7 @@ - concurrency or other issues with a lazy read, and the minor loss of - laziness doesn't matter much, as the files are not very large. -}-getJournalFileStale :: GetPrivate -> RawFilePath -> Annex (Maybe L.ByteString)+getJournalFileStale :: GetPrivate -> RawFilePath -> Annex JournalledContent getJournalFileStale (GetPrivate getprivate) file = do -- Optimisation to avoid a second MVar access. st <- Annex.getState id@@ -115,11 +127,19 @@ if getprivate && privateUUIDsKnown' st then do x <- getfrom (gitAnnexJournalDir g)- y <- getfrom (gitAnnexPrivateJournalDir g)- -- This concacenation is the same as happens in a- -- merge of two git-annex branches.- return (x <> y)- else getfrom (gitAnnexJournalDir g)+ getfrom (gitAnnexPrivateJournalDir g) >>= \case+ Nothing -> return $ case x of+ Nothing -> NoJournalledContent+ Just b -> JournalledContent b+ Just y -> return $ PossiblyStaleJournalledContent $ case x of+ Nothing -> y+ -- This concacenation is the same as+ -- happens in a merge of two+ -- git-annex branches.+ Just x' -> x' <> y+ else getfrom (gitAnnexJournalDir g) >>= return . \case+ Nothing -> NoJournalledContent+ Just b -> JournalledContent b where jfile = journalFile file getfrom d = catchMaybeIO $
Annex/Link.hs view
@@ -203,7 +203,12 @@ -- updated index file. runner :: Git.Queue.InternalActionRunner Annex runner = Git.Queue.InternalActionRunner "restagePointerFile" $ \r l -> do- liftIO . Database.Keys.Handle.flushDbQueue+ -- Flush any queued changes to the keys database, so they+ -- are visible to child processes.+ -- The database is closed because that may improve behavior+ -- when run in Windows's WSL1, which has issues with+ -- multiple writers to SQL databases.+ liftIO . Database.Keys.Handle.closeDbHandle =<< Annex.getRead Annex.keysdbhandle realindex <- liftIO $ Git.Index.currentIndexFile r let lock = fromRawFilePath (Git.Index.indexFileLock realindex)
Annex/Transfer.hs view
@@ -132,7 +132,7 @@ (lck, inprogress) <- prep tfile createtfile mode if inprogress && not ignorelock then do- showNote "transfer already in progress, or unable to take transfer lock"+ warning "transfer already in progress, or unable to take transfer lock" return observeFailure else do v <- retry 0 info metervar $@@ -151,6 +151,11 @@ createAnnexDirectory $ P.takeDirectory lck tryLockExclusive (Just mode) lck >>= \case Nothing -> return (Nothing, True)+ -- Since the lock file is removed in cleanup,+ -- there's a race where different processes+ -- may have a deleted and a new version of the same+ -- lock file open. checkSaneLock guards against+ -- that. Just lockhandle -> ifM (checkSaneLock lck lockhandle) ( do createtfile
Assistant/WebApp/Configurators/IA.hs view
@@ -180,11 +180,11 @@ getRepoInfo :: RemoteConfig -> Widget getRepoInfo c = do uo <- liftAnnex Url.getUrlOptions- exists <- liftAnnex $ catchDefaultIO False $ Url.exists url uo+ urlexists <- liftAnnex $ catchDefaultIO False $ Url.exists url uo [whamlet| <a href="#{url}"> Internet Archive item-$if (not exists)+$if (not urlexists) <p> The page will only be available once some files # have been uploaded, and the Internet Archive has processed them.
CHANGELOG view
@@ -1,3 +1,37 @@+git-annex (8.20211028) upstream; urgency=medium++ * Removed support for accessing git remotes that use versions of+ git-annex older than 6.20180312.+ * git-annex-shell: Removed several commands that were only needed to+ support git-annex versions older than 6.20180312.+ * Negotiate P2P protocol version with tor remotes, allowing+ use of protocol version 1. This negotiation is not supported+ by versions of git-annex older than 6.20180312.+ * Fix bug that caused stale git-annex branch information to read+ when annex.private or remote.name.annex-private is set.+ * git-annex get when run as the first git-annex command in a new repo+ did not populate all unlocked files.+ (Reversion in version 8.20210621)+ * Fix using lookupkey and info inside a subdirectory of the git repository.+ (Reversion in version 8.20211011)+ * Avoid some sqlite crashes on Windows SubSystem for Linux (WSL).+ * Call annex.freezecontent-command on the annex object file+ after it has been moved into place in annex/objects/. This allows+ the hook to freeze the file in ways that prevent moving it, such as+ removing the Windows delete permission.+ Thanks, Reiko Asakura.+ * addurl: Support adding the same url to multiple files at the same+ time when using -J with --batch --with-files.+ * When retrieval from a chunked remote fails, display the error that+ occurred when downloading the chunk, rather than the error that+ occurred when trying to download the unchunked content, which is less+ likely to actually be stored in the remote.+ * Avoid crashing tilde expansion on user who does not exist.+ * test: Put gpg temp home directory in system temp directory,+ not filesystem being tested.++ -- Joey Hess <id@joeyh.name> Thu, 28 Oct 2021 11:58:29 -0400+ git-annex (8.20211011) upstream; urgency=medium * Added annex.bwlimit and remote.name.annex-bwlimit config to limit
CmdLine/GitAnnexShell.hs view
@@ -1,6 +1,6 @@ {- git-annex-shell main program -- - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -20,16 +20,13 @@ import P2P.Protocol (ServerMode(..)) import qualified Command.ConfigList-import qualified Command.InAnnex-import qualified Command.LockContent-import qualified Command.DropKey-import qualified Command.RecvKey-import qualified Command.SendKey-import qualified Command.TransferInfo-import qualified Command.Commit import qualified Command.NotifyChanges import qualified Command.GCryptSetup import qualified Command.P2PStdIO+import qualified Command.InAnnex+import qualified Command.RecvKey+import qualified Command.SendKey+import qualified Command.DropKey import qualified Data.Map as M @@ -42,20 +39,17 @@ where readonlycmds = map addGlobalOptions [ Command.ConfigList.cmd- , gitAnnexShellCheck Command.InAnnex.cmd- , gitAnnexShellCheck Command.LockContent.cmd- , gitAnnexShellCheck Command.SendKey.cmd- , gitAnnexShellCheck Command.TransferInfo.cmd , gitAnnexShellCheck Command.NotifyChanges.cmd -- p2pstdio checks the enviroment variables to -- determine the security policy to use , gitAnnexShellCheck Command.P2PStdIO.cmd+ , gitAnnexShellCheck Command.InAnnex.cmd+ , gitAnnexShellCheck Command.SendKey.cmd ] appendcmds = readonlycmds ++ map addGlobalOptions [ gitAnnexShellCheck Command.RecvKey.cmd- , gitAnnexShellCheck Command.Commit.cmd ]- allcmds = map addGlobalOptions+ allcmds = appendcmds ++ map addGlobalOptions [ gitAnnexShellCheck Command.DropKey.cmd , Command.GCryptSetup.cmd ]@@ -67,7 +61,7 @@ cmdsFor = fromMaybe [] . flip M.lookup cmdsMap cmdsList :: [Command]-cmdsList = concat $ M.elems cmdsMap+cmdsList = nub $ concat $ M.elems cmdsMap addGlobalOptions :: Command -> Command addGlobalOptions c = c { cmdglobaloptions = globalOptions ++ cmdglobaloptions c }@@ -166,9 +160,6 @@ checkField :: (String, String) -> Bool checkField (field, val) | field == fieldName remoteUUID = fieldCheck remoteUUID val- | field == fieldName associatedFile = fieldCheck associatedFile val- | field == fieldName unlocked = fieldCheck unlocked val- | field == fieldName direct = fieldCheck direct val | field == fieldName autoInit = fieldCheck autoInit val | otherwise = False
CmdLine/GitAnnexShell/Fields.hs view
@@ -9,7 +9,6 @@ import Annex.Common import qualified Annex-import Git.FilePath import Data.Char @@ -26,14 +25,6 @@ remoteUUID = Field "remoteuuid" $ -- does it look like a UUID? all (\c -> isAlphaNum c || c == '-')--associatedFile :: Field-associatedFile = Field "associatedfile" $ \f ->- -- is the file a safe relative filename?- not (absoluteGitPath (toRawFilePath f)) && not ("../" `isPrefixOf` f)--direct :: Field-direct = Field "direct" $ \f -> f == "1" unlocked :: Field unlocked = Field "unlocked" $ \f -> f == "1"
Command/AddUrl.hs view
@@ -372,11 +372,21 @@ - a filename. It's not displayed then for output consistency, - but is added to the json when available. -} startingAddUrl :: SeekInput -> URLString -> AddUrlOptions -> CommandPerform -> CommandStart-startingAddUrl si url o p = starting "addurl" (ActionItemOther (Just url)) si $ do+startingAddUrl si url o p = starting "addurl" ai si $ do case fileOption (downloadOptions o) of Nothing -> noop Just file -> maybeShowJSON $ JSONChunk [("file", file)] p+ where+ -- Avoid failure when the same url is downloaded concurrently+ -- to two different files, by using OnlyActionOn with a key+ -- based on the url. Note that this may not be the actual key+ -- that is used for the download; later size information may be+ -- available and get added to it. That's ok, this is only+ -- used to prevent two threads running concurrently when that would+ -- likely fail.+ ai = OnlyActionOn urlkey (ActionItemOther (Just url))+ urlkey = Backend.URL.fromUrl url Nothing showDestinationFile :: FilePath -> Annex () showDestinationFile file = do
− Command/Commit.hs
@@ -1,32 +0,0 @@-{- git-annex command- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Command.Commit where--import Command-import qualified Annex.Branch-import qualified Git-import Git.Types--cmd :: Command-cmd = command "commit" SectionPlumbing - "commits any staged changes to the git-annex branch"- paramNothing (withParams seek)--seek :: CmdParams -> CommandSeek-seek = withNothing (commandAction start)--start :: CommandStart-start = starting "commit" ai si $ do- Annex.Branch.commit =<< Annex.Branch.commitMessage- _ <- runhook <=< inRepo $ Git.hookPath "annex-content"- next $ return True- where- runhook (Just hook) = liftIO $ boolSystem hook []- runhook Nothing = return True- ai = ActionItemOther (Just (fromRef Annex.Branch.name))- si = SeekInput []
Command/Fix.hs view
@@ -21,7 +21,7 @@ #if ! defined(mingw32_HOST_OS) import Utility.Touch-import System.Posix.Files+import qualified System.Posix.Files as Posix #endif cmd :: Command@@ -94,7 +94,7 @@ fixSymlink file link = do #if ! defined(mingw32_HOST_OS) -- preserve mtime of symlink- mtime <- liftIO $ catchMaybeIO $ modificationTimeHiRes+ mtime <- liftIO $ catchMaybeIO $ Posix.modificationTimeHiRes <$> R.getSymbolicLinkStatus file #endif createWorkTreeDirectory (parentDir file)
− Command/LockContent.hs
@@ -1,41 +0,0 @@-{- git-annex-shell command- -- - Copyright 2015 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Command.LockContent where--import Command-import Annex.Content-import Remote.Helper.Ssh (contentLockedMarker)-import Utility.SimpleProtocol--cmd :: Command-cmd = noCommit $ - command "lockcontent" SectionPlumbing - "locks key's content in the annex, preventing it being dropped"- paramKey- (withParams seek)--seek :: CmdParams -> CommandSeek-seek = withWords (commandAction . start)---- First, lock the content, then print out "OK". --- Wait for the caller to send a line before dropping the lock.-start :: [String] -> CommandStart-start [ks] = do- ok <- lockContentShared k (const locksuccess)- `catchNonAsync` (const $ return False)- liftIO $ if ok- then exitSuccess- else exitFailure- where- k = fromMaybe (giveup "bad key") (deserializeKey ks)- locksuccess = liftIO $ do- putStrLn contentLockedMarker- hFlush stdout- _ <- getProtocolLine stdin- return True-start _ = giveup "Specify exactly 1 key."
Command/RecvKey.hs view
@@ -15,7 +15,6 @@ import Types.Transfer import Logs.Location import Command.SendKey (fieldTransfer)-import qualified CmdLine.GitAnnexShell.Fields as Fields cmd :: Command cmd = noCommit $ command "recvkey" SectionPlumbing @@ -27,14 +26,9 @@ start :: (SeekInput, Key) -> CommandStart start (_, key) = fieldTransfer Download key $ \_p -> do- -- Always verify content when a repo is sending an unlocked file,- -- as the file could change while being transferred.- fromunlocked <- (isJust <$> Fields.getField Fields.unlocked)- <||> (isJust <$> Fields.getField Fields.direct)- let verify = if fromunlocked then AlwaysVerify else DefaultVerify -- This matches the retrievalSecurityPolicy of Remote.Git let rsp = RetrievalAllKeysSecure- ifM (getViaTmp rsp verify key (AssociatedFile Nothing) go)+ ifM (getViaTmp rsp DefaultVerify key (AssociatedFile Nothing) go) ( do logStatus key InfoPresent -- forcibly quit after receiving one key,
Command/SendKey.hs view
@@ -46,8 +46,7 @@ fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart fieldTransfer direction key a = do fastDebug "Command.SendKey" "transfer start"- afile <- AssociatedFile . (fmap toRawFilePath)- <$> Fields.getField Fields.associatedFile+ let afile = AssociatedFile Nothing ok <- maybe (a $ const noop) -- Using noRetry here because we're the sender. (\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile Nothing noRetry a)
− Command/TransferInfo.hs
@@ -1,69 +0,0 @@-{- git-annex command- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Command.TransferInfo where--import Command-import Annex.Content-import Types.Transfer-import Logs.Transfer-import Utility.Metered-import Utility.SimpleProtocol-import qualified CmdLine.GitAnnexShell.Fields as Fields-import qualified Utility.RawFilePath as R--cmd :: Command-cmd = noCommit $ - command "transferinfo" SectionPlumbing- "updates sender on number of bytes of content received"- paramKey (withParams seek)--seek :: CmdParams -> CommandSeek-seek = withWords (commandAction . start)--{- Security:- - - - The transfer info file contains the user-supplied key, but- - the built-in guards prevent slashes in it from showing up in the filename.- - It also contains the UUID of the remote. But slashes are also filtered- - out of that when generating the filename.- - - - Checks that the key being transferred is inAnnex, to prevent- - malicious spamming of bogus keys. Does not check that a transfer- - of the key is actually in progress, because this could be started- - concurrently with sendkey, and win the race.- -}-start :: [String] -> CommandStart-start (k:[]) = do- case deserializeKey k of- Nothing -> error "bad key"- (Just key) -> whenM (inAnnex key) $ do- afile <- AssociatedFile . (fmap toRawFilePath)- <$> Fields.getField Fields.associatedFile- u <- maybe (error "missing remoteuuid") toUUID- <$> Fields.getField Fields.remoteUUID- let t = Transfer- { transferDirection = Upload- , transferUUID = u- , transferKeyData = fromKey id key- }- tinfo <- liftIO $ startTransferInfo afile- (update, tfile, createtfile, _) <- mkProgressUpdater t tinfo- createtfile- liftIO $ mapM_ void- [ tryIO $ forever $ do- bytes <- readUpdate- maybe (error "transferinfo protocol error")- (update . toBytesProcessed) bytes- , tryIO $ R.removeLink tfile- , exitSuccess- ]- stop-start _ = giveup "wrong number of parameters"--readUpdate :: IO (Maybe Integer)-readUpdate = maybe Nothing readish <$> getProtocolLine stdin
Database/Benchmark.hs view
@@ -107,7 +107,7 @@ benchDb tmpdir num = do liftIO $ putStrLn $ "setting up database with " ++ show num ++ " items" initDb db SQL.createTables- h <- liftIO $ H.openDbQueue H.MultiWriter db SQL.containedTable+ h <- liftIO $ H.openDbQueue db SQL.containedTable liftIO $ populateAssociatedFiles h num sz <- liftIO $ getFileSize db liftIO $ putStrLn $ "size of database on disk: " ++
Database/ContentIdentifier.hs view
@@ -89,7 +89,7 @@ , liftIO $ runSqlite (T.pack (fromRawFilePath db)) $ void $ runMigrationSilent migrateContentIdentifier )- h <- liftIO $ H.openDbQueue H.SingleWriter db "content_identifiers"+ h <- liftIO $ H.openDbQueue db "content_identifiers" return $ ContentIdentifierHandle h closeDb :: ContentIdentifierHandle -> Annex ()
Database/Export.hs view
@@ -104,7 +104,7 @@ unlessM (liftIO $ R.doesPathExist db) $ do initDb db $ void $ runMigrationSilent migrateExport- h <- liftIO $ H.openDbQueue H.SingleWriter db "exported"+ h <- liftIO $ H.openDbQueue db "exported" return $ ExportHandle h u closeDb :: ExportHandle -> Annex ()
Database/Fsck.hs view
@@ -76,7 +76,7 @@ initDb db $ void $ runMigrationSilent migrateFsck lockFileCached =<< fromRepo (gitAnnexFsckDbLock u)- h <- liftIO $ H.openDbQueue H.MultiWriter db "fscked"+ h <- liftIO $ H.openDbQueue db "fscked" return $ FsckHandle h u closeDb :: FsckHandle -> Annex ()
Database/Handle.hs view
@@ -9,7 +9,6 @@ module Database.Handle ( DbHandle,- DbConcurrency(..), openDb, TableName, queryDb,@@ -37,46 +36,27 @@ {- A DbHandle is a reference to a worker thread that communicates with - the database. It has a MVar which Jobs are submitted to. -}-data DbHandle = DbHandle DbConcurrency (Async ()) (MVar Job)+data DbHandle = DbHandle (Async ()) (MVar Job) {- Name of a table that should exist once the database is initialized. -} type TableName = String -{- Sqlite only allows a single write to a database at a time; a concurrent- - write will crash. - - - - MultiWrter works around this limitation.- - The downside of using MultiWriter is that after writing a change to the- - database, the a query using the same DbHandle will not immediately see- - the change! This is because the change is actually written using a- - separate database connection, and caching can prevent seeing the change.- - Also, consider that if multiple processes are writing to a database,- - you can't rely on seeing values you've just written anyway, as another- - process may change them.- -- - When a database can only be written to by a single process (enforced by- - a lock file), use SingleWriter. Changes written to the database will- - always be immediately visible then. Multiple threads can write; their- - writes will be serialized.- -}-data DbConcurrency = SingleWriter | MultiWriter- {- Opens the database, but does not perform any migrations. Only use - once the database is known to exist and have the right tables. -}-openDb :: DbConcurrency -> RawFilePath -> TableName -> IO DbHandle-openDb dbconcurrency db tablename = do+openDb :: RawFilePath -> TableName -> IO DbHandle+openDb db tablename = do jobs <- newEmptyMVar worker <- async (workerThread (T.pack (fromRawFilePath db)) tablename jobs) -- work around https://github.com/yesodweb/persistent/issues/474 liftIO $ fileEncoding stderr - return $ DbHandle dbconcurrency worker jobs+ return $ DbHandle worker jobs {- This is optional; when the DbHandle gets garbage collected it will - auto-close. -} closeDb :: DbHandle -> IO ()-closeDb (DbHandle _ worker jobs) = do+closeDb (DbHandle worker jobs) = do putMVar jobs CloseJob wait worker @@ -89,12 +69,9 @@ - Only one action can be run at a time against a given DbHandle. - If called concurrently in the same process, this will block until - it is able to run.- -- - Note that when the DbHandle was opened in MultiWriter mode, recent- - writes may not be seen by queryDb. -} queryDb :: DbHandle -> SqlPersistM a -> IO a-queryDb (DbHandle _ _ jobs) a = do+queryDb (DbHandle _ jobs) a = do res <- newEmptyMVar putMVar jobs $ QueryJob $ liftIO . putMVar res =<< tryNonAsync a@@ -103,10 +80,9 @@ {- Writes a change to the database. -- - In MultiWriter mode, writes can fail if another write is happening- - concurrently. So write failures are caught and retried repeatedly- - for up to 10 seconds, which should avoid all but the most exceptional- - problems.+ - Writes can fail if another write is happening concurrently.+ - So write failures are caught and retried repeatedly for up to 10+ - seconds, which should avoid all but the most exceptional problems. -} commitDb :: DbHandle -> SqlPersistM () -> IO () commitDb h wa = robustly Nothing 100 (commitDb' h wa)@@ -122,59 +98,44 @@ robustly (Just e) (n-1) a commitDb' :: DbHandle -> SqlPersistM () -> IO (Either SomeException ())-commitDb' (DbHandle MultiWriter _ jobs) a = do- res <- newEmptyMVar- putMVar jobs $ RobustChangeJob $ \runner ->- liftIO $ putMVar res =<< tryNonAsync (runner a)- takeMVar res-commitDb' (DbHandle SingleWriter _ jobs) a = do+commitDb' (DbHandle _ jobs) a = do res <- newEmptyMVar putMVar jobs $ ChangeJob $ liftIO . putMVar res =<< tryNonAsync a takeMVar res- `catchNonAsync` (const $ error "sqlite commit crashed") data Job = QueryJob (SqlPersistM ()) | ChangeJob (SqlPersistM ())- | RobustChangeJob ((SqlPersistM () -> IO ()) -> IO ()) | CloseJob workerThread :: T.Text -> TableName -> MVar Job -> IO ()-workerThread db tablename jobs = go+workerThread db tablename jobs = newconn where- go = do+ newconn = do v <- tryNonAsync (runSqliteRobustly tablename db loop) case v of Left e -> hPutStrLn stderr $ "sqlite worker thread crashed: " ++ show e- Right True -> go- Right False -> return ()+ Right cont -> cont - getjob :: IO (Either BlockedIndefinitelyOnMVar Job)- getjob = try $ takeMVar jobs- loop = do job <- liftIO getjob case job of -- Exception is thrown when the MVar is garbage -- collected, which means the whole DbHandle -- is not used any longer. Shutdown cleanly.- Left BlockedIndefinitelyOnMVar -> return False- Right CloseJob -> return False+ Left BlockedIndefinitelyOnMVar -> return (return ())+ Right CloseJob -> return (return ()) Right (QueryJob a) -> a >> loop Right (ChangeJob a) -> do a- -- Exit this sqlite transaction so the+ -- Exit the sqlite connection so the -- database gets updated on disk.- return True- -- Change is run in a separate database connection- -- since sqlite only supports a single writer at a- -- time, and it may crash the database connection- -- that the write is made to.- Right (RobustChangeJob a) -> do- liftIO (a (runSqliteRobustly tablename db))- loop+ return newconn+ + getjob :: IO (Either BlockedIndefinitelyOnMVar Job)+ getjob = try $ takeMVar jobs -- Like runSqlite, but more robust. --
Database/Keys.hs view
@@ -37,7 +37,7 @@ import Annex.LockFile import Annex.Content.PointerFile import Annex.Content.Presence.LowLevel-import Annex.Link+import Annex.Link (Restage(..), maxPointerSz, parseLinkTargetOrPointerLazy) import Utility.InodeCache import Annex.InodeSentinal import Git@@ -134,7 +134,7 @@ | otherwise = return DbUnavailable open db = do- qh <- liftIO $ H.openDbQueue H.MultiWriter db SQL.containedTable+ qh <- liftIO $ H.openDbQueue db SQL.containedTable reconcileStaged qh return $ DbOpen qh
Database/Queue.hs view
@@ -9,7 +9,6 @@ module Database.Queue ( DbQueue,- DbConcurrency(..), openDbQueue, queryDbQueue, closeDbQueue,@@ -37,9 +36,9 @@ {- Opens the database queue, but does not perform any migrations. Only use - if the database is known to exist and have the right tables; ie after - running initDb. -}-openDbQueue :: DbConcurrency -> RawFilePath -> TableName -> IO DbQueue-openDbQueue dbconcurrency db tablename = DQ- <$> openDb dbconcurrency db tablename+openDbQueue :: RawFilePath -> TableName -> IO DbQueue+openDbQueue db tablename = DQ+ <$> openDb db tablename <*> (newMVar =<< emptyQueue) {- This or flushDbQueue must be called, eg at program exit to ensure@@ -64,9 +63,6 @@ - - Queries will not see changes that have been recently queued, - so use with care.- -- - Also, when the database was opened in MultiWriter mode,- - queries may not see changes even after flushDbQueue. -} queryDbQueue :: DbQueue -> SqlPersistM a -> IO a queryDbQueue (DQ hdl _) = queryDb hdl
Git/Construct.hs view
@@ -184,7 +184,10 @@ #ifdef mingw32_HOST_OS expandTilde = return #else-expandTilde = expandt True+expandTilde p = expandt True p+ -- If unable to expand a tilde, eg due to a user not existing,+ -- use the path as given.+ `catchNonAsync` (const (return p)) where expandt _ [] = return "" expandt _ ('/':cs) = do
Remote/GCrypt.hs view
@@ -396,8 +396,7 @@ then fileStorer $ \k f p -> do oh <- mkOutputHandler ok <- Ssh.rsyncHelper oh (Just p)- =<< Ssh.rsyncParamsRemote False r Upload k f- (AssociatedFile Nothing)+ =<< Ssh.rsyncParamsRemote r Upload k f unless ok $ giveup "rsync failed" else storersync@@ -418,9 +417,8 @@ sink =<< liftIO (L.readFile $ gCryptLocation repo k) | Git.repoIsSsh repo = if accessShell r then fileRetriever $ \f k p -> do- ps <- Ssh.rsyncParamsRemote False r Download k+ ps <- Ssh.rsyncParamsRemote r Download k (fromRawFilePath f)- (AssociatedFile Nothing) oh <- mkOutputHandler unlessM (Ssh.rsyncHelper oh (Just p) ps) $ giveup "rsync failed"
Remote/Git.hs view
@@ -48,7 +48,6 @@ import Utility.Metered import Utility.Env import Utility.Batch-import Utility.SimpleProtocol import Remote.Helper.Git import Remote.Helper.Messages import Remote.Helper.ExportImport@@ -70,7 +69,6 @@ #endif import Control.Concurrent-import Control.Concurrent.MSampleVar import qualified Data.Map as M import qualified Data.ByteString as S import Network.URI@@ -413,9 +411,7 @@ ( return True , giveup "not found" )- checkremote = - let fallback = Ssh.inAnnex repo key- in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) key+ checkremote = P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt)) key checklocal = ifM duc ( guardUsable repo (cantCheck repo) $ maybe (cantCheck repo) return@@ -458,9 +454,7 @@ , giveup "remote does not have expected annex.uuid value" ) | Git.repoIsHttp repo = giveup "dropping from http remote not supported"- | otherwise = commitOnCleanup repo r st $ do- let fallback = Ssh.dropKey' repo key- P2PHelper.remove (Ssh.runProto r connpool (return False) fallback) key+ | otherwise = P2PHelper.remove (Ssh.runProto r connpool (return False)) key lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r lockKey r st key callback = do@@ -482,63 +476,20 @@ ) | Git.repoIsSsh repo = do showLocking r- let withconn = Ssh.withP2PSshConnection r connpool fallback+ let withconn = Ssh.withP2PSshConnection r connpool failedlock P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback | otherwise = failedlock where- fallback = withNullHandle $ \nullh -> do- Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin- repo "lockcontent"- [Param $ serializeKey key] []- let p = (proc cmd (toCommand params))- { std_in = CreatePipe- , std_out = CreatePipe- , std_err = UseHandle nullh- }- bracketIO (createProcess p) cleanupProcess fallback'-- fallback' (Just hin, Just hout, Nothing, p) = do- v <- liftIO $ tryIO $ getProtocolLine hout- let signaldone = void $ tryNonAsync $ liftIO $ mapM_ tryNonAsync- [ hPutStrLn hout ""- , hFlush hout- , hClose hin- , hClose hout- , void $ waitForProcess p- ]- let checkexited = not . isJust <$> getProcessExitCode p- case v of- Left _exited -> do- showNote "lockcontent failed"- liftIO $ do- hClose hin- hClose hout- void $ waitForProcess p- failedlock- Right l - | l == Just Ssh.contentLockedMarker -> bracket_- noop- signaldone - (withVerifiedCopy LockedCopy r checkexited callback)- | otherwise -> do- showNote "lockcontent failed"- signaldone- failedlock- fallback' _ = error "internal"- failedlock = giveup "can't lock content" {- Tries to copy a key's content from a remote's annex to a file. -} copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification-copyFromRemote = copyFromRemote' False--copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification-copyFromRemote' forcersync r st key file dest meterupdate vc = do+copyFromRemote r st key file dest meterupdate vc = do repo <- getRepo r- copyFromRemote'' repo forcersync r st key file dest meterupdate vc+ copyFromRemote'' repo r st key file dest meterupdate vc -copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification-copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate vc+copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification+copyFromRemote'' repo r st@(State connpool _ _ _ _) key file dest meterupdate vc | Git.repoIsHttp repo = do iv <- startVerifyKeyContentIncrementally vc key gc <- Annex.getGitConfig@@ -566,91 +517,13 @@ then return v else giveup "failed to retrieve content from remote" Nothing -> giveup "content is not present in remote"- | Git.repoIsSsh repo = if forcersync- then do- (ok, v) <- fallback meterupdate- if ok- then return v- else giveup "failed to retrieve content from remote"- else P2PHelper.retrieve+ | Git.repoIsSsh repo =+ P2PHelper.retrieve (gitconfig r)- (\p -> Ssh.runProto r connpool (return (False, UnVerified)) (fallback p))+ (Ssh.runProto r connpool (return (False, UnVerified))) key file dest meterupdate vc | otherwise = giveup "copying from non-ssh, non-http remote not supported"- where- fallback p = unVerified $ feedprogressback $ \p' -> do- oh <- mkOutputHandlerQuiet- Ssh.rsyncHelper oh (Just (combineMeterUpdate p' p))- =<< Ssh.rsyncParamsRemote False r Download key dest file - {- Feed local rsync's progress info back to the remote,- - by forking a feeder thread that runs- - git-annex-shell transferinfo at the same time- - git-annex-shell sendkey is running.- -- - To avoid extra password prompts, this is only done when ssh- - connection caching is supported.- - Note that it actually waits for rsync to indicate- - progress before starting transferinfo, in order- - to ensure ssh connection caching works and reuses - - the connection set up for the sendkey.- -- - Also note that older git-annex-shell does not support- - transferinfo, so stderr is dropped and failure ignored.- -}- feedprogressback a = ifM (isJust <$> sshCacheDir)- ( feedprogressback' a- , a $ const noop- )- feedprogressback' a = do- u <- getUUID- let AssociatedFile afile = file- let fields = (Fields.remoteUUID, fromUUID u)- : maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile- Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin- repo "transferinfo" - [Param $ serializeKey key] fields- v <- liftIO (newEmptySV :: IO (MSampleVar Integer))- pv <- liftIO $ newEmptyMVar- tid <- liftIO $ forkIO $ void $ tryIO $ do- bytes <- readSV v- p <- createProcess $- (proc cmd (toCommand params))- { std_in = CreatePipe- , std_err = CreatePipe- }- putMVar pv p- hClose $ stderrHandle p- let h = stdinHandle p- let send b = do- hPrint h b- hFlush h- send bytes- forever $- send =<< readSV v- let feeder = \n -> do- meterupdate n- writeSV v (fromBytesProcessed n)-- -- It can easily take 0.3 seconds to clean up after- -- the transferinfo, and all that's involved is shutting- -- down the process and associated thread cleanly. So,- -- do it in the background.- let cleanup = forkIO $ do- void $ tryIO $ killThread tid- void $ tryNonAsync $ - maybe noop (void . waitForProcess . processHandle)- =<< tryTakeMVar pv-- let forcestop = do- void $ tryIO $ killThread tid- void $ tryNonAsync $ - maybe noop cleanupProcess- =<< tryTakeMVar pv-- bracketIO noop (const cleanup) (const $ a feeder)- `onException` liftIO forcestop- copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) #ifndef mingw32_HOST_OS copyFromRemoteCheap st repo@@ -681,9 +554,9 @@ copylocal =<< Annex.Content.prepSendAnnex' key , giveup "remote does not have expected annex.uuid value" )- | Git.repoIsSsh repo = commitOnCleanup repo r st $+ | Git.repoIsSsh repo = P2PHelper.store (gitconfig r)- (Ssh.runProto r connpool (return False) . copyremotefallback)+ (Ssh.runProto r connpool (return False)) key file meterupdate | otherwise = giveup "copying to non-ssh repo not supported"@@ -715,24 +588,10 @@ ) unless res $ giveup "failed to send content to remote"- copyremotefallback p = either (const False) id- <$> tryNonAsync (copyremotefallback' p)- copyremotefallback' p = Annex.Content.sendAnnex key noop $ \object -> do- -- This is too broad really, but recvkey normally- -- verifies content anyway, so avoid complicating- -- it with a local sendAnnex check and rollback.- let unlocked = True- oh <- mkOutputHandlerQuiet- Ssh.rsyncHelper oh (Just p)- =<< Ssh.rsyncParamsRemote unlocked r Upload key object file fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool) fsckOnRemote r params- | Git.repoIsUrl r = do- s <- Ssh.git_annex_shell NoConsumeStdin r "fsck" params []- return $ case s of- Nothing -> return False- Just (c, ps) -> batchCommand c ps+ | Git.repoIsUrl r = return $ return False | otherwise = return $ do program <- programPath r' <- Git.Config.read r@@ -820,21 +679,7 @@ | not $ Git.repoIsUrl repo = onLocalFast st $ doQuietSideAction $ Annex.Branch.commit =<< Annex.Branch.commitMessage- | otherwise = do- Just (shellcmd, shellparams) <-- Ssh.git_annex_shell NoConsumeStdin- repo "commit" [] []- - -- Throw away stderr, since the remote may not- -- have a new enough git-annex shell to- -- support committing.- liftIO $ void $ catchMaybeIO $ withNullHandle $ \nullh ->- let p = (proc shellcmd (toCommand shellparams))- { std_out = UseHandle nullh- , std_err = UseHandle nullh- }- in withCreateProcess p $ \_ _ _ ->- forceSuccessProcess p+ | otherwise = noop wantHardLink :: Annex Bool wantHardLink = (annexHardLink <$> Annex.getGitConfig)
Remote/Helper/Chunked.hs view
@@ -286,9 +286,9 @@ firstavail Nothing _ [] = giveup "unable to determine the chunks to use for this remote" firstavail (Just e) _ [] = throwM e firstavail pe currsize ([]:ls) = firstavail pe currsize ls- firstavail _ currsize ((k:ks):ls)+ firstavail pe currsize ((k:ks):ls) | k == basek = getunchunked- `catchNonAsync` (\e -> firstavail (Just e) currsize ls)+ `catchNonAsync` (\e -> firstavail (Just (pickerr e)) currsize ls) | otherwise = do let offset = resumeOffset currsize k let p = maybe basep@@ -302,10 +302,15 @@ fromMaybe 0 $ fromKey keyChunkSize k getrest p h iv sz sz ks case v of- Left e- | null ls -> throwM e- | otherwise -> firstavail (Just e) currsize ls+ Left e -> firstavail (Just (pickerr e)) currsize ls Right r -> return r+ where+ -- Prefer an earlier exception to a later one, because the+ -- more probable location is tried first and less probable+ -- ones later.+ pickerr e = case pe of+ Just pe' -> pe'+ Nothing -> e getrest _ _ iv _ _ [] = return (Right iv) getrest p h iv sz bytesprocessed (k:ks) = do
Remote/Helper/P2P.hs view
@@ -31,22 +31,22 @@ -- the pool when done. type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a -store :: RemoteGitConfig -> (MeterUpdate -> ProtoRunner Bool) -> Key -> AssociatedFile -> MeterUpdate -> Annex ()+store :: RemoteGitConfig -> ProtoRunner Bool -> Key -> AssociatedFile -> MeterUpdate -> Annex () store gc runner k af p = do let sizer = KeySizer k (fmap (toRawFilePath . fst) <$> prepSendAnnex k) let bwlimit = remoteAnnexBwLimit gc metered (Just p) sizer bwlimit $ \_ p' ->- runner p' (P2P.put k af p') >>= \case+ runner (P2P.put k af p') >>= \case Just True -> return () Just False -> giveup "Transfer failed" Nothing -> remoteUnavail -retrieve :: RemoteGitConfig -> (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification+retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieve gc runner k af dest p verifyconfig = do iv <- startVerifyKeyContentIncrementally verifyconfig k let bwlimit = remoteAnnexBwLimit gc metered (Just p) k bwlimit $ \m p' -> - runner p' (P2P.get dest k iv af m p') >>= \case+ runner (P2P.get dest k iv af m p') >>= \case Just (True, v) -> return v Just (False, _) -> giveup "Transfer failed" Nothing -> remoteUnavail
Remote/Helper/Ssh.hs view
@@ -130,20 +130,14 @@ {- Generates rsync parameters that ssh to the remote and asks it - to either receive or send the key's content. -}-rsyncParamsRemote :: Bool -> Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]-rsyncParamsRemote unlocked r direction key file (AssociatedFile afile) = do+rsyncParamsRemote :: Remote -> Direction -> Key -> FilePath -> Annex [CommandParam]+rsyncParamsRemote r direction key file = do u <- getUUID- let fields = (Fields.remoteUUID, fromUUID u)- : (Fields.unlocked, if unlocked then "1" else "")- -- Send direct field for unlocked content, for backwards- -- compatability.- : (Fields.direct, if unlocked then "1" else "")- : maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile repo <- getRepo r Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo (if direction == Download then "sendkey" else "recvkey") [ Param $ serializeKey key ]- fields+ [(Fields.remoteUUID, fromUUID u)] -- Convert the ssh command into rsync command line. let eparam = rsyncShell (Param shellcmd:shellparams) o <- rsyncParams r direction@@ -183,11 +177,6 @@ | otherwise = remoteAnnexRsyncUploadOptions gc gc = gitconfig r --- Used by git-annex-shell lockcontent to indicate the content is--- successfully locked.-contentLockedMarker :: String-contentLockedMarker = "OK"- -- A connection over ssh to git-annex shell speaking the P2P protocol. type P2PSshConnection = P2P.ClosableConnection (P2P.RunState, P2P.P2PConnection, ProcessHandle, TVar StderrHandlerState)@@ -320,9 +309,9 @@ -- Runs a P2P Proto action on a remote when it supports that, -- otherwise the fallback action.-runProto :: Remote -> P2PSshConnectionPool -> Annex a -> Annex a -> P2P.Proto a -> Annex (Maybe a)-runProto r connpool badproto fallback proto = Just <$>- (getP2PSshConnection r connpool >>= maybe fallback go)+runProto :: Remote -> P2PSshConnectionPool -> Annex a -> P2P.Proto a -> Annex (Maybe a)+runProto r connpool onerr proto = Just <$>+ (getP2PSshConnection r connpool >>= maybe onerr go) where go c = do (c', v) <- runProtoConn proto c@@ -330,9 +319,7 @@ Just res -> do liftIO $ storeP2PSshConnection connpool c' return res- -- Running the proto failed, either due to a protocol- -- error or a network error.- Nothing -> badproto+ Nothing -> onerr runProtoConn :: P2P.Proto a -> P2PSshConnection -> Annex (P2PSshConnection, Maybe a) runProtoConn _ P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing)
Remote/P2P.hs view
@@ -55,8 +55,8 @@ { uuid = u , cost = cst , name = Git.repoDescribe r- , storeKey = store gc (const protorunner)- , retrieveKeyFile = retrieve gc (const protorunner)+ , storeKey = store gc protorunner+ , retrieveKeyFile = retrieve gc protorunner , retrieveKeyFileCheap = Nothing , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = remove protorunner@@ -148,14 +148,7 @@ authtoken <- fromMaybe nullAuthToken <$> loadP2PRemoteAuthToken addr let proto = P2P.auth myuuid authtoken $- -- Before 6.20180312, the protocol server- -- had a bug that made negotiating the- -- protocol version terminate the- -- connection. So, this must stay disabled- -- until the old version is not in use- -- anywhere.- --P2P.negotiateProtocolVersion P2P.maxProtocolVersion- return ()+ P2P.negotiateProtocolVersion P2P.maxProtocolVersion runst <- liftIO $ mkRunState Client res <- liftIO $ runNetProto runst conn proto case res of
RemoteDaemon/Transport/Ssh.hs view
@@ -42,15 +42,13 @@ p = (proc cmd (toCommand params)) { std_in = CreatePipe , std_out = CreatePipe- , std_err = CreatePipe } - go (Just toh) (Just fromh) (Just errh) pid = do+ go (Just toh) (Just fromh) Nothing pid = do -- Run all threads until one finishes and get the status -- of the first to finish. Cancel the rest. status <- catchDefaultIO (Right ConnectionClosed) $- handlestderr errh- `race` handlestdout fromh+ handlestdout fromh `race` handlecontrol send (DISCONNECTED url)@@ -58,7 +56,7 @@ hClose fromh void $ waitForProcess pid - return $ either (either id id) id status+ return $ either id id status go _ _ _ _ = error "internal" send msg = atomically $ writeTChan ochan msg@@ -88,21 +86,3 @@ STOP -> return ConnectionStopping LOSTNET -> return ConnectionStopping _ -> handlecontrol-- -- Old versions of git-annex-shell that do not support- -- the notifychanges command will exit with a not very useful- -- error message. Detect that error, and avoid reconnecting.- -- Propigate all stderr.- handlestderr errh = do- s <- hGetSomeString errh 1024- hPutStr stderr s- hFlush stderr- if "git-annex-shell: git-shell failed" `isInfixOf` s- then do- send $ WARNING url $ unwords- [ "Remote", Git.repoDescribe r- , "needs its git-annex upgraded"- , "to 5.20140405 or newer"- ]- return ConnectionStopping- else handlestderr errh
Test.hs view
@@ -194,6 +194,7 @@ , testProperty "prop_upFrom_basics" Utility.Path.Tests.prop_upFrom_basics , testProperty "prop_relPathDirToFileAbs_basics" Utility.Path.Tests.prop_relPathDirToFileAbs_basics , testProperty "prop_relPathDirToFileAbs_regressionTest" Utility.Path.Tests.prop_relPathDirToFileAbs_regressionTest+ , testProperty "prop_dirContains_regressionTest" Utility.Path.Tests.prop_dirContains_regressionTest , testProperty "prop_cost_sane" Config.Cost.prop_cost_sane , testProperty "prop_matcher_sane" Utility.Matcher.prop_matcher_sane , testProperty "prop_HmacSha1WithCipher_sane" Crypto.prop_HmacSha1WithCipher_sane@@ -1821,13 +1822,20 @@ testscheme "pubkey" where gpgcmd = Utility.Gpg.mkGpgCmd Nothing- testscheme scheme = do- abstmp <- fromRawFilePath <$> absPath (toRawFilePath tmpdir)- testscheme' scheme abstmp- testscheme' scheme abstmp = intmpclonerepo $ do- gpgtmp <- (</> "gpgtmp") . fromRawFilePath- <$> relPathCwdToFile (toRawFilePath abstmp)- createDirectoryIfMissing False gpgtmp+ testscheme scheme = Utility.Tmp.Dir.withTmpDir "gpgtmp" $ \gpgtmp -> do+ -- Use the system temp directory as gpg temp directory because + -- it needs to be able to store the agent socket there,+ -- which can be problimatic when testing some filesystems.+ absgpgtmp <- fromRawFilePath <$> absPath (toRawFilePath gpgtmp)+ testscheme' scheme absgpgtmp+ testscheme' scheme absgpgtmp = intmpclonerepo $ do+ -- Since gpg uses a unix socket, which is limited to a+ -- short path, use whichever is shorter of absolute+ -- or relative path.+ relgpgtmp <- fromRawFilePath <$> relPathCwdToFile (toRawFilePath absgpgtmp)+ let gpgtmp = if length relgpgtmp < length absgpgtmp+ then relgpgtmp + else absgpgtmp Utility.Gpg.testTestHarness gpgtmp gpgcmd @? "test harness self-test failed" void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ do
Utility/InodeCache.hs view
@@ -55,7 +55,7 @@ #ifdef mingw32_HOST_OS import Data.Word (Word64) #else-import System.Posix.Files+import qualified System.Posix.Files as Posix #endif data InodeCachePrim = InodeCachePrim FileID FileSize MTime@@ -200,7 +200,7 @@ #ifdef mingw32_HOST_OS mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f) #else- let mtime = modificationTimeHiRes s+ let mtime = Posix.modificationTimeHiRes s #endif return $ Just $ InodeCache $ InodeCachePrim inode sz (MTimeHighRes (mtime + highResTime delta)) | otherwise = pure Nothing@@ -299,11 +299,6 @@ [ (50, MTimeLowRes <$> (abs . fromInteger <$> arbitrary)) , (50, MTimeHighRes <$> arbitrary) ]--#ifdef mingw32_HOST_OS-instance Arbitrary FileID where- arbitrary = fromIntegral <$> (arbitrary :: Gen Word64)-#endif prop_read_show_inodecache :: InodeCache -> Bool prop_read_show_inodecache c = case readInodeCache (showInodeCache c) of
Utility/LinuxMkLibs.hs view
@@ -69,7 +69,7 @@ - XXX Debian specific. -} glibcLibs :: IO [FilePath] glibcLibs = lines <$> readProcess "sh"- ["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so' | grep -v /gconv/ | grep -v ld.so.conf | grep -v sotruss-lib"]+ ["-c", "dpkg -L libc6:$(dpkg --print-architecture) | egrep '\\.so' | grep -v /gconv/ | grep -v ld.so.conf | grep -v sotruss-lib"] {- Get gblibc's gconv libs, which are handled specially.. -} gconvLibs :: IO [FilePath]
Utility/Path.hs view
@@ -97,6 +97,7 @@ || a' == b' || (a'' `B.isPrefixOf` b' && avoiddotdotb) || a' == "." && normalise ("." </> b') == b' && nodotdot b'+ || dotdotcontains where a' = norm a a'' = addTrailingPathSeparator a'@@ -115,9 +116,27 @@ -} avoiddotdotb = nodotdot $ B.drop (B.length a'') b' - nodotdot p = all- (\s -> dropTrailingPathSeparator s /= "..")- (splitPath p)+ nodotdot p = all (not . isdotdot) (splitPath p)+ + isdotdot s = dropTrailingPathSeparator s == ".."++ {- This handles the case where a is ".." or "../.." etc,+ - and b is "foo" or "../foo" etc. The rule is that when+ - a is entirely ".." components, b is under it when it starts+ - with fewer ".." components. + - + - Due to the use of norm, cases like "../../foo/../../" get+ - converted to eg "../../../" and so do not need to be handled+ - specially here.+ -}+ dotdotcontains+ | isAbsolute b' = False+ | otherwise = + let aps = splitPath a'+ bps = splitPath b'+ in if all isdotdot aps+ then length (takeWhile isdotdot bps) < length aps+ else False {- Given an original list of paths, and an expanded list derived from it, - which may be arbitrarily reordered, generates a list of lists, where
Utility/Path/Tests.hs view
@@ -14,6 +14,7 @@ prop_upFrom_basics, prop_relPathDirToFileAbs_basics, prop_relPathDirToFileAbs_regressionTest,+ prop_dirContains_regressionTest, ) where import System.FilePath.ByteString@@ -62,3 +63,18 @@ relPathDirToFileAbs (joinPath [pathSeparator `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"]) (joinPath [pathSeparator `B.cons` "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]++prop_dirContains_regressionTest :: Bool+prop_dirContains_regressionTest = and+ [ not $ dirContains "." ".."+ , not $ dirContains ".." "../.."+ , dirContains "." "foo"+ , dirContains "." "."+ , dirContains ".." ".."+ , dirContains "../.." "../.."+ , dirContains "." "./foo"+ , dirContains ".." "../foo"+ , dirContains "../.." "../foo"+ , dirContains "../.." "../../foo"+ , not $ dirContains "../.." "../../.."+ ]
doc/git-annex-inprogress.mdwn view
@@ -13,6 +13,9 @@ name of the temporary file that is being used to download the specified annexed file. +Nothing will be output when the download is from an encrypted or chunked +special remote.+ This can sometimes be used to stream a file before it's been fully downloaded, for example:
doc/git-annex-shell.mdwn view
@@ -31,79 +31,58 @@ When run in a repository that does not yet have an annex.uuid, one will be created, as long as a git-annex branch has already been pushed to- the repository, or if the autoinit= flag is used to indicate+ the repository, or if the autoinit=1 flag is used to indicate initialization is desired. -* inannex directory [key ...]+* p2pstdio directory uuid - This checks if all specified keys are present in the annex, - and exits zero if so.+ This causes git-annex-shell to communicate using the git-annex p2p+ protocol over stdio. - Exits 1 if the key is certainly not present in the annex.- Exits 100 if it's unable to tell (perhaps the key is in the process of- being removed from the annex).+ The uuid is the one belonging to the repository that will be+ communicating with git-annex-shell. -* lockcontent directory key+* notifychanges directory - This locks a key's content in place in the annex, preventing it from- being dropped.+ This is used by `git-annex remotedaemon` to be notified when+ refs in the remote repository are changed. - Once the content is successfully locked, outputs "OK". Then the content- remains locked until a newline is received from the caller or the- connection is broken.+* gcryptsetup directory gcryptid - Exits nonzero if the content is not present, or could not be locked.+ Sets up a repository as a gcrypt repository. -* dropkey directory [key ...]+* inannex directory [key ...] - This drops the annexed data for the specified keys.+ This checks if all specified keys are present in the annex, + and exits zero if so. + Exits 1 if the key is certainly not present in the annex.+ Exits 100 if it's unable to tell (perhaps the key is in the process of+ being removed from the annex).+ + Used only by the gcrypt special remote.+ * recvkey directory key This runs rsync in server mode to receive the content of a key, and stores the content in the annex.+ + Used only by the gcrypt special remote. * sendkey directory key This runs rsync in server mode to transfer out the content of a key.--* transferinfo directory key-- This is typically run at the same time as sendkey is sending a key- to the remote. Using it is optional, but is used to update- progress information for the transfer of the key.-- It reads lines from standard input, each giving the number of bytes- that have been received so far. --* commit directory-- This commits any staged changes to the git-annex branch.- It also runs the annex-content hook.--* notifychanges directory-- This is used by `git-annex remotedaemon` to be notified when- refs in the remote repository are changed.--* gcryptsetup directory gcryptid-- Sets up a repository as a gcrypt repository.--* p2pstdio directory uuid+ + Used only by the gcrypt special remote. - This causes git-annex-shell to communicate using the git-annex p2p- protocol over stdio. When supported by git-annex-shell, this allows- multiple actions to be run over a single connection, improving speed.+* dropkey directory [key ...] - The uuid is the one belonging to the repository that will be- communicating with git-annex-shell.+ This drops the annexed data for the specified keys.+ + Used only by the gcrypt special remote. # OPTIONS -Most options are the same as in git-annex. The ones specific-to git-annex-shell are:- * --uuid=UUID git-annex uses this to specify the UUID of the repository it was expecting@@ -117,8 +96,7 @@ past versions of git-annex-shell (that ignore these, but would choke on new dashed options). - Currently used fields include remoteuuid=, associatedfile=,- unlocked=, direct=, and autoinit=+ Currently used fields are autoinit= and remoteuuid= # HOOK
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20211011+Version: 8.20211028 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -728,7 +728,6 @@ Command.Benchmark Command.CalcKey Command.CheckPresentKey- Command.Commit Command.Config Command.ConfigList Command.ContentLocation@@ -768,7 +767,6 @@ Command.Inprogress Command.List Command.Lock- Command.LockContent Command.Log Command.LookupKey Command.Map@@ -809,7 +807,6 @@ Command.Sync Command.Test Command.TestRemote- Command.TransferInfo Command.Transferrer Command.TransferKey Command.TransferKeys
stack.yaml view
@@ -14,17 +14,19 @@ httpclientrestricted: true packages: - '.'+resolver: lts-18.13 extra-deps: - IfElse-0.85 - aws-0.22 - bloomfilter-2.0.1.0-- filepath-bytestring-1.4.2.1.6-- git-lfs-1.1.0-- http-client-restricted-0.0.3+- git-lfs-1.1.2+- http-client-restricted-0.0.4 - network-multicast-0.3.2 - sandi-0.5 - torrent-10000.1.1+- base16-bytestring-0.1.1.7+- base64-bytestring-1.0.0.3 - bencode-0.6.1.1+- http-client-0.7.9 explicit-setup-deps: git-annex: true-resolver: lts-16.27