git-annex 8.20211028 → 8.20211117
raw patch · 38 files changed
+857/−215 lines, 38 filesdep ~git-lfs
Dependency ranges changed: git-lfs
Files
- Annex/Content.hs +2/−2
- Annex/CopyFile.hs +3/−3
- Annex/Link.hs +50/−6
- Annex/Queue.hs +1/−1
- Annex/Verify.hs +10/−10
- Annex/YoutubeDl.hs +1/−1
- CHANGELOG +22/−0
- CmdLine/GitAnnex.hs +2/−0
- Command/AddUrl.hs +11/−7
- Command/FilterProcess.hs +89/−0
- Command/Import.hs +1/−1
- Command/ImportFeed.hs +57/−38
- Command/MetaData.hs +6/−25
- Command/Migrate.hs +36/−13
- Command/Smudge.hs +73/−40
- Command/Uninit.hs +12/−6
- Config/Smudge.hs +1/−0
- Git/Config.hs +8/−0
- Git/FilterProcess.hs +168/−0
- Git/PktLine.hs +153/−0
- Git/Queue.hs +3/−3
- Messages/JSON.hs +17/−8
- P2P/Annex.hs +3/−3
- Remote/GitLFS.hs +5/−1
- Remote/Helper/Chunked.hs +2/−2
- Remote/Helper/Http.hs +7/−1
- Remote/WebDAV.hs +1/−1
- Utility/GitLFS.hs +25/−9
- Utility/Hash.hs +42/−22
- Utility/Url.hs +4/−4
- doc/git-annex-adjust.mdwn +8/−1
- doc/git-annex-metadata.mdwn +3/−4
- doc/git-annex-migrate.mdwn +12/−0
- doc/git-annex-rekey.mdwn +5/−0
- doc/git-annex-smudge.mdwn +1/−0
- doc/git-annex.mdwn +7/−0
- git-annex.cabal +5/−2
- stack.yaml +1/−1
Annex/Content.hs view
@@ -656,8 +656,8 @@ -- to be used for the other urls. case iv of Just iv' -> - liftIO $ positionIncremental iv' >>= \case- Just n | n > 0 -> unableIncremental iv'+ liftIO $ positionIncrementalVerifier iv' >>= \case+ Just n | n > 0 -> unableIncrementalVerifier iv' _ -> noop Nothing -> noop go us ((u, err) : errs)
Annex/CopyFile.hs view
@@ -86,7 +86,7 @@ fileCopier copycowtried src dest meterupdate iv = ifM (liftIO $ tryCopyCoW copycowtried src dest meterupdate) ( do- liftIO $ maybe noop unableIncremental iv+ liftIO $ maybe noop unableIncrementalVerifier iv return CopiedCoW , docopy )@@ -119,7 +119,7 @@ else do let sofar' = addBytesProcessed sofar (S.length s) S.hPut hdest s- maybe noop (flip updateIncremental s) iv+ maybe noop (flip updateIncrementalVerifier s) iv meterupdate sofar' docopy' hdest hsrc sofar' @@ -134,7 +134,7 @@ s' <- getnoshort (S.length s) hsrc if s == s' then do- maybe noop (flip updateIncremental s) iv+ maybe noop (flip updateIncrementalVerifier s) iv let sofar' = addBytesProcessed sofar (S.length s) meterupdate sofar' compareexisting hdest hsrc sofar'
Annex/Link.hs view
@@ -12,7 +12,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE CPP, BangPatterns, OverloadedStrings #-} module Annex.Link where @@ -35,6 +35,7 @@ import Utility.InodeCache import Utility.Tmp.Dir import Utility.CopyFile+import Utility.Tuple import qualified Database.Keys.Handle import qualified Utility.RawFilePath as R @@ -89,9 +90,9 @@ else -- If there are any NUL or newline -- characters, or whitespace, we- -- certianly don't have a symlink to a+ -- certainly don't have a symlink to a -- git-annex key.- if any (`S8.elem` s) "\0\n\r \t"+ if any (`S8.elem` s) ("\0\n\r \t" :: [Char]) then mempty else s @@ -189,7 +190,7 @@ -- fails on "../../repo/path/file" when cwd is not in the repo -- being acted on. Avoid these problems with an absolute path. absf <- liftIO $ absPath f- Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)]+ Annex.Queue.addInternalAction runner [(absf, isunmodified tsd, inodeCacheFileSize orig)] where isunmodified tsd = genInodeCache f tsd >>= return . \case Nothing -> False@@ -226,9 +227,9 @@ [ Param "-c" , Param $ "core.safecrlf=" ++ boolConfig False ] }- runsGitAnnexChildProcessViaGit' r'' $ \r''' ->+ configfilterprocess l $ runsGitAnnexChildProcessViaGit' r'' $ \r''' -> liftIO $ Git.UpdateIndex.refreshIndex r''' $ \feed ->- forM_ l $ \(f', checkunmodified) ->+ forM_ l $ \(f', checkunmodified, _) -> whenM checkunmodified $ feed f' let replaceindex = catchBoolIO $ do@@ -239,6 +240,49 @@ <&&> liftIO replaceindex unless ok showwarning bracket lockindex unlockindex go+ + {- filter.annex.process configured to use git-annex filter-process+ - is sometimes faster and sometimes slower than using+ - git-annex smudge. The latter is run once per file, while+ - the former has the content of files piped to it.+ -}+ filterprocessfaster l = + let numfiles = genericLength l+ sizefiles = sum (map thd3 l)+ -- estimates based on benchmarking+ estimate_enabled = sizefiles `div` 191739611+ estimate_disabled = numfiles `div` 7+ in estimate_enabled <= estimate_disabled+ + {- This disables filter.annex.process if it's set when it would+ - probably not be faster to use it. Unfortunately, simply+ - passing -c filter.annex.process= also prevents git from+ - running the smudge filter, so .git/config has to be modified+ - to disable it. The modification is reversed at the end. In+ - case this process is terminated early, the next time this+ - runs it will take care of reversing the modification.+ -}+ configfilterprocess l = bracket setup cleanup . const+ where+ setup+ | filterprocessfaster l = return Nothing+ | otherwise = fromRepo (Git.Config.getMaybe ck) >>= \case+ Nothing -> return Nothing+ Just v -> do+ void $ inRepo (Git.Config.change ckd (fromConfigValue v))+ void $ inRepo (Git.Config.unset ck)+ return (Just v)+ cleanup (Just v) = do+ void $ inRepo $ Git.Config.change ck (fromConfigValue v)+ void $ inRepo (Git.Config.unset ckd)+ cleanup Nothing = fromRepo (Git.Config.getMaybe ckd) >>= \case+ Nothing -> return ()+ Just v -> do+ whenM (isNothing <$> fromRepo (Git.Config.getMaybe ck)) $+ void $ inRepo (Git.Config.change ck (fromConfigValue v))+ void $ inRepo (Git.Config.unset ckd)+ ck = ConfigKey "filter.annex.process"+ ckd = ConfigKey "filter.annex.process-temp-disabled" unableToRestage :: Maybe FilePath -> String unableToRestage mf = unwords
Annex/Queue.hs view
@@ -31,7 +31,7 @@ store =<< flushWhenFull =<< (Git.Queue.addCommand commonparams command params files q =<< gitRepo) -addInternalAction :: Git.Queue.InternalActionRunner Annex -> [(RawFilePath, IO Bool)] -> Annex ()+addInternalAction :: Git.Queue.InternalActionRunner Annex -> [(RawFilePath, IO Bool, FileSize)] -> Annex () addInternalAction runner files = do q <- get store =<< flushWhenFull =<<
Annex/Verify.hs view
@@ -102,7 +102,7 @@ Just verifier -> verifier k f resumeVerifyKeyContent :: Key -> RawFilePath -> IncrementalVerifier -> Annex Bool-resumeVerifyKeyContent k f iv = liftIO (positionIncremental iv) >>= \case+resumeVerifyKeyContent k f iv = liftIO (positionIncrementalVerifier iv) >>= \case Nothing -> fallback Just endpos -> do fsz <- liftIO $ catchDefaultIO 0 $ getFileSize f@@ -119,21 +119,21 @@ go fsz endpos | fsz == endpos = liftIO $ catchDefaultIO (Just False) $- finalizeIncremental iv+ finalizeIncrementalVerifier iv | otherwise = do- showAction (descVerify iv)+ showAction (descIncrementalVerifier iv) liftIO $ catchDefaultIO (Just False) $ withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do hSeek h AbsoluteSeek endpos feedincremental h- finalizeIncremental iv+ finalizeIncrementalVerifier iv feedincremental h = do b <- S.hGetSome h chunk if S.null b then return () else do- updateIncremental iv b+ updateIncrementalVerifier iv b feedincremental h chunk = 65536@@ -174,7 +174,7 @@ finishVerifyKeyContentIncrementally Nothing = return (True, UnVerified) finishVerifyKeyContentIncrementally (Just iv) =- liftIO (finalizeIncremental iv) >>= \case+ liftIO (finalizeIncrementalVerifier iv) >>= \case Just True -> return (True, Verified) Just False -> do warning "verification of content failed"@@ -224,7 +224,7 @@ tailVerify iv f finished = tryNonAsync go >>= \case Right r -> return r- Left _ -> unableIncremental iv+ Left _ -> unableIncrementalVerifier iv where -- Watch the directory containing the file, and wait for -- the file to be modified. It's possible that the file already@@ -249,7 +249,7 @@ let cleanup = void . tryNonAsync . INotify.removeWatch let stop w = do cleanup w- unableIncremental iv+ unableIncrementalVerifier iv waitopen modified >>= \case Nothing -> stop wd Just h -> do@@ -301,12 +301,12 @@ <$> takeTMVar finished) cont else do- updateIncremental iv b+ updateIncrementalVerifier iv b atomically (tryTakeTMVar finished) >>= \case Nothing -> follow h modified Just () -> return () chunk = 65536 #else-tailVerify iv _ _ = unableIncremental iv+tailVerify iv _ _ = unableIncrementalVerifier iv #endif
Annex/YoutubeDl.hs view
@@ -249,7 +249,7 @@ return (opts ++ addopts) youtubeDlCommand :: Annex String-youtubeDlCommand = fromMaybe "yooutube-dl" . annexYoutubeDlCommand +youtubeDlCommand = fromMaybe "youtube-dl" . annexYoutubeDlCommand <$> Annex.getGitConfig supportedScheme :: UrlOptions -> URLString -> Bool
CHANGELOG view
@@ -1,3 +1,25 @@+git-annex (8.20211117) upstream; urgency=medium++ * filter-process: New command that can make git add/checkout faster when+ there are a lot of unlocked annexed files or non-annexed files, but that+ also makes git add of large annexed files slower. Use it by running:+ git config filter.annex.process 'git-annex filter-process'+ * Fix a typo in the name of youtube-dl+ (reversion introduced in version 8.20210903)+ * git-lfs: Fix interoperability with gitlab's implementation of the+ git-lfs protocol, which requests Content-Encoding chunked.+ * importfeed: Fix a crash when used in a non-unicode locale.+ * migrate: New --remove-size option.+ * uninit: Avoid error message when no commits have been made to the+ repository yet.+ * uninit: Avoid error message when there is no git-annex branch.+ * metadata --batch: Avoid crashing when a non-annexed file is input,+ instead output a blank line like other batch commands do.+ * metadata --batch --json: Reject input whose "fields" does not consist+ of arrays of strings. Such invalid input used to be silently ignored.++ -- Joey Hess <id@joeyh.name> Wed, 17 Nov 2021 12:18:49 -0400+ git-annex (8.20211028) upstream; urgency=medium * Removed support for accessing git remotes that use versions of
CmdLine/GitAnnex.hs view
@@ -113,6 +113,7 @@ import qualified Command.Proxy import qualified Command.DiffDriver import qualified Command.Smudge+import qualified Command.FilterProcess import qualified Command.Undo import qualified Command.Version import qualified Command.RemoteDaemon@@ -226,6 +227,7 @@ , Command.Proxy.cmd , Command.DiffDriver.cmd , Command.Smudge.cmd+ , Command.FilterProcess.cmd , Command.Undo.cmd , Command.Version.cmd , Command.RemoteDaemon.cmd
Command/AddUrl.hs view
@@ -271,7 +271,8 @@ addurl = addUrlChecked o url file webUUID $ \k -> ifM (pure (not (rawOption (downloadOptions o))) <&&> youtubeDlSupported url) ( return (True, True, setDownloader url YoutubeDownloader)- , checkRaw (downloadOptions o) $ return (Url.urlExists urlinfo, Url.urlSize urlinfo == fromKey keySize k, url)+ , checkRaw Nothing (downloadOptions o) $+ return (Url.urlExists urlinfo, Url.urlSize urlinfo == fromKey keySize k, url) ) {- Check that the url exists, and has the same size as the key,@@ -332,7 +333,7 @@ in ifAnnexed f (alreadyannexed (fromRawFilePath f)) (dl f)- Left _ -> checkRaw o (normalfinish tmp)+ Left err -> checkRaw (Just err) o (normalfinish tmp) where dl dest = withTmpWorkDir mediakey $ \workdir -> do let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)@@ -346,7 +347,7 @@ showDestinationFile (fromRawFilePath dest) addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile)) return $ Just mediakey- Right Nothing -> checkRaw o (normalfinish tmp)+ Right Nothing -> checkRaw Nothing o (normalfinish tmp) Left msg -> do cleanuptmp warning msg@@ -363,9 +364,12 @@ warning $ dest ++ " already exists; not overwriting" return Nothing -checkRaw :: DownloadOptions -> Annex a -> Annex a-checkRaw o a- | noRawOption o = giveup "Unable to use youtube-dl or a special remote and --no-raw was specified."+checkRaw :: (Maybe String) -> DownloadOptions -> Annex a -> Annex a+checkRaw failreason o a+ | noRawOption o = giveup $ "Unable to use youtube-dl or a special remote and --no-raw was specified" +++ case failreason of+ Just msg -> ": " ++ msg+ Nothing -> "" | otherwise = a {- The destination file is not known at start time unless the user provided@@ -487,7 +491,7 @@ then nomedia else youtubeDlFileName url >>= \case Right mediafile -> usemedia (toRawFilePath mediafile)- Left _ -> checkRaw o nomedia+ Left err -> checkRaw (Just err) o nomedia | otherwise = do warning $ "unable to access url: " ++ url return Nothing
+ Command/FilterProcess.hs view
@@ -0,0 +1,89 @@+{- git-annex command+ -+ - Copyright 2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.FilterProcess where++import Command+import qualified Command.Smudge+import Git.FilterProcess+import Git.PktLine+import Annex.Link++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++cmd :: Command+cmd = noCommit $ noMessages $+ command "filter-process" SectionPlumbing + "long running git filter process"+ paramNothing (withParams seek)++seek :: CmdParams -> CommandSeek+seek _ = liftIO longRunningFilterProcessHandshake >>= \case+ Left err -> giveup err+ Right () -> go+ where+ go = liftIO getFilterRequest >>= \case+ Just (Smudge f) -> do+ smudge f+ go+ Just (Clean f) -> do+ clean f+ go+ Nothing -> return ()++smudge :: FilePath -> Annex ()+smudge file = do+ {- The whole git file content is necessarily buffered in memory,+ - because we have to consume everything git is sending before+ - we can respond to it. An annexed file will be only a pointer+ - though. -}+ b <- B.concat . map pktLineToByteString <$> liftIO readUntilFlushPkt+ Command.Smudge.smudge' file (L.fromStrict b)+ {- Git expects us to output the content of unlocked annexed files,+ - but if we got a pointer, we output only the pointer.+ - See Command.Smudge.smudge for details of how this works. -}+ liftIO $ respondFilterRequest b++clean :: FilePath -> Annex ()+clean file = do+ {- We have to consume everything git is sending before we can+ - respond to it. But it can be an arbitrarily large file,+ - which is being added to the annex, and we do not want to buffer+ - all that in memory. + -+ - Start by reading enough to determine if the file is an annex+ - pointer.+ -}+ let conv b l = (B.concat (map pktLineToByteString l), b)+ (b, readcomplete) <- + either (conv False) (conv True)+ <$> liftIO (readUntilFlushPktOrSize unpaddedMaxPointerSz)+ + let passthrough+ | readcomplete = liftIO $ respondFilterRequest b+ | otherwise = liftIO $ do+ -- Have to buffer the file content in memory here,+ -- but it's not an annexed file, so not typically+ -- large, and it's all stored in git, which also+ -- buffers files in memory.+ b' <- B.concat . (map pktLineToByteString)+ <$> readUntilFlushPkt+ respondFilterRequest (b <> b')+ let discardreststdin+ | readcomplete = return ()+ | otherwise = liftIO discardUntilFlushPkt+ let emitpointer = liftIO . respondFilterRequest . formatPointer+ -- This does not incrementally hash, so both git and git-annex+ -- read from the file. It may be less expensive to incrementally+ -- hash the content provided by git, but Backend does not currently+ -- have an interface to do so.+ Command.Smudge.clean' (toRawFilePath file)+ (parseLinkTargetOrPointer b)+ passthrough+ discardreststdin+ emitpointer
Command/Import.hs view
@@ -43,7 +43,7 @@ withGlobalOptions opts $ command "import" SectionCommon "add a tree of files to the repository"- (paramPaths ++ "|BRANCH[:SUBDIR]")+ (paramPaths ++ "|BRANCH") (seek <$$> optParser) where opts =
Command/ImportFeed.hs view
@@ -20,7 +20,9 @@ import Data.Time.Calendar import Data.Time.LocalTime import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import qualified System.FilePath.ByteString as P+import qualified Data.ByteString as B import Command import qualified Annex@@ -76,22 +78,29 @@ getFeed :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> URLString -> CommandSeek getFeed addunlockedmatcher opts cache url = do showStartOther "importfeed" (Just url) (SeekInput [])- downloadFeed url >>= \case- Nothing -> showEndResult =<< feedProblem url- "downloading the feed failed"- Just feedcontent -> case parseFeedString feedcontent of- Nothing -> debugfeedcontent feedcontent "parsing the feed failed"- Just f -> case findDownloads url f of- [] -> debugfeedcontent feedcontent "bad feed content; no enclosures to download"- l -> do- showEndOk- ifM (and <$> mapM (performDownload addunlockedmatcher opts cache) l)- ( clearFeedProblem url- , void $ feedProblem url - "problem downloading some item(s) from feed"- )+ withTmpFile "feed" $ \tmpf h -> do+ liftIO $ hClose h+ ifM (downloadFeed url tmpf)+ ( go tmpf+ , showEndResult =<< feedProblem url+ "downloading the feed failed"+ ) where- debugfeedcontent feedcontent msg = do+ -- Use parseFeedFromFile rather than reading the file+ -- ourselves because it goes out of its way to handle encodings.+ go tmpf = liftIO (parseFeedFromFile tmpf) >>= \case+ Nothing -> debugfeedcontent tmpf "parsing the feed failed"+ Just f -> case findDownloads url f of+ [] -> debugfeedcontent tmpf "bad feed content; no enclosures to download"+ l -> do+ showEndOk+ ifM (and <$> mapM (performDownload addunlockedmatcher opts cache) l)+ ( clearFeedProblem url+ , void $ feedProblem url + "problem downloading some item(s) from feed"+ )+ debugfeedcontent tmpf msg = do+ feedcontent <- liftIO $ readFile tmpf fastDebug "Command.ImportFeed" $ unlines [ "start of feed content" , feedcontent@@ -161,22 +170,18 @@ mk i = case getItemEnclosure i of Just (enclosureurl, _, _) -> Just $ ToDownload f u i $ Enclosure $ - T.unpack enclosureurl+ decodeBS $ fromFeedText enclosureurl Nothing -> case getItemLink i of Just l -> Just $ ToDownload f u i $ - MediaLink $ T.unpack l+ MediaLink $ decodeBS $ fromFeedText l Nothing -> Nothing {- Feeds change, so a feed download cannot be resumed. -}-downloadFeed :: URLString -> Annex (Maybe String)-downloadFeed url+downloadFeed :: URLString -> FilePath -> Annex Bool+downloadFeed url f | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url"- | otherwise = withTmpFile "feed" $ \f h -> do- liftIO $ hClose h- ifM (Url.withUrlOptions $ Url.download nullMeterUpdate Nothing url f)- ( Just <$> liftIO (readFileStrict f)- , return Nothing- )+ | otherwise = Url.withUrlOptions $+ Url.download nullMeterUpdate Nothing url f performDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> ToDownload -> Annex Bool performDownload addunlockedmatcher opts cache todownload = case location todownload of@@ -185,7 +190,7 @@ let f' = fromRawFilePath f r <- Remote.claimingUrl url if Remote.uuid r == webUUID || rawOption (downloadOptions opts)- then checkRaw (downloadOptions opts) $ do+ then checkRaw Nothing (downloadOptions opts) $ do let dlopts = (downloadOptions opts) -- force using the filename -- chosen here@@ -243,7 +248,7 @@ knownitemid = case getItemId (item todownload) of Just (_, itemid) ->- S.member (T.unpack itemid) (knownitems cache)+ S.member (decodeBS $ fromFeedText itemid) (knownitems cache) _ -> False rundownload url extension getter = do@@ -326,7 +331,7 @@ , downloadlink ) where- downloadlink = checkRaw (downloadOptions opts) $+ downloadlink = checkRaw Nothing (downloadOptions opts) $ performDownload addunlockedmatcher opts cache todownload { location = Enclosure linkurl } @@ -370,7 +375,7 @@ Just pd -> Just $ formatTime defaultTimeLocale "%F" pd -- if date cannot be parsed, use the raw string- Nothing-> replace "/" "-" . T.unpack+ Nothing-> replace "/" "-" . decodeBS . fromFeedText <$> getItemPublishDateString itm (itempubyear, itempubmonth, itempubday) = case pubdate of@@ -401,7 +406,7 @@ minimalMetaData i = case getItemId (item i) of (Nothing) -> emptyMetaData (Just (_, itemid)) -> MetaData $ M.singleton itemIdField - (S.singleton $ toMetaValue $ encodeBS $ T.unpack itemid)+ (S.singleton $ toMetaValue $fromFeedText itemid) {- Extract fields from the feed and item, that are both used as metadata, - and to generate the filename. -}@@ -411,18 +416,18 @@ , ("itemtitle", [itemtitle]) , ("feedauthor", [feedauthor]) , ("itemauthor", [itemauthor])- , ("itemsummary", [T.unpack <$> getItemSummary (item i)])- , ("itemdescription", [T.unpack <$> getItemDescription (item i)])- , ("itemrights", [T.unpack <$> getItemRights (item i)])- , ("itemid", [T.unpack . snd <$> getItemId (item i)])+ , ("itemsummary", [decodeBS . fromFeedText <$> getItemSummary (item i)])+ , ("itemdescription", [decodeBS . fromFeedText <$> getItemDescription (item i)])+ , ("itemrights", [decodeBS . fromFeedText <$> getItemRights (item i)])+ , ("itemid", [decodeBS . fromFeedText . snd <$> getItemId (item i)]) , ("title", [itemtitle, feedtitle]) , ("author", [itemauthor, feedauthor]) ] where- feedtitle = Just $ T.unpack $ getFeedTitle $ feed i- itemtitle = T.unpack <$> getItemTitle (item i)- feedauthor = T.unpack <$> getFeedAuthor (feed i)- itemauthor = T.unpack <$> getItemAuthor (item i)+ feedtitle = Just $ decodeBS $ fromFeedText $ getFeedTitle $ feed i+ itemtitle = decodeBS . fromFeedText <$> getItemTitle (item i)+ feedauthor = decodeBS . fromFeedText <$> getFeedAuthor (feed i)+ itemauthor = decodeBS . fromFeedText <$> getItemAuthor (item i) itemIdField :: MetaField itemIdField = mkMetaFieldUnchecked "itemid"@@ -478,3 +483,17 @@ feedState :: URLString -> Annex RawFilePath feedState url = fromRepo $ gitAnnexFeedState $ fromUrl url Nothing++{- The feed library parses the feed to Text, and does not use the+ - filesystem encoding to do it, so when the locale is not unicode+ - capable, a Text value can still include unicode characters. + -+ - So, it's not safe to use T.unpack to convert that to a String,+ - because later use of that String by eg encodeBS will crash+ - with an encoding error. Use this instad.+ -+ - This should not be used on a Text that is read using the+ - filesystem encoding because it does not reverse that encoding.+ -}+fromFeedText :: T.Text -> B.ByteString+fromFeedText = TE.encodeUtf8
Command/MetaData.hs view
@@ -12,7 +12,7 @@ import Annex.VectorClock import Logs.MetaData import Annex.WorkTree-import Messages.JSON (JSONActionItem(..))+import Messages.JSON (JSONActionItem(..), AddJSONActionItemFields(..)) import Types.Messages import Utility.Aeson import Limit@@ -94,7 +94,7 @@ JSONOutput _ -> ifM limited ( giveup "combining --batch with file matching options is not currently supported" , batchInput fmt parseJSONInput - (commandAction . startBatch)+ (commandAction . batchCommandStart . startBatch) ) _ -> giveup "--batch is currently only supported in --json mode" @@ -125,7 +125,7 @@ cleanup :: Key -> CommandCleanup cleanup k = do m <- getCurrentMetaData k- case toJSON' (MetaDataFields m) of+ case toJSON' (AddJSONActionItemFields m) of Object o -> maybeShowJSON $ AesonObject o _ -> noop showLongNote $ unlines $ concatMap showmeta $@@ -135,32 +135,13 @@ unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v)) showmeta (f, vs) = map ((T.unpack f ++ "=") ++) (map decodeBS vs) --- Metadata serialized to JSON in the field named "fields" of--- a larger object.-newtype MetaDataFields = MetaDataFields MetaData- deriving (Show)--instance ToJSON' MetaDataFields where- toJSON' (MetaDataFields m) = object [ (fieldsField, toJSON' m) ]--instance FromJSON MetaDataFields where- parseJSON (Object v) = do- f <- v .: fieldsField- case f of- Nothing -> return (MetaDataFields emptyMetaData)- Just v' -> MetaDataFields <$> parseJSON v'- parseJSON _ = fail "expected an object"--fieldsField :: T.Text-fieldsField = T.pack "fields"- parseJSONInput :: String -> Annex (Either String (Either RawFilePath Key, MetaData)) parseJSONInput i = case eitherDecode (BU.fromString i) of Left e -> return (Left e) Right v -> do- let m = case itemAdded v of+ let m = case itemFields v of Nothing -> emptyMetaData- Just (MetaDataFields m') -> m'+ Just m' -> m' case (itemKey v, itemFile v) of (Just k, _) -> return $ Right (Right k, m)@@ -176,7 +157,7 @@ mk <- lookupKey f case mk of Just k -> go k (mkActionItem (k, AssociatedFile (Just f)))- Nothing -> giveup $ "not an annexed file: " ++ fromRawFilePath f+ Nothing -> return Nothing Right k -> go k (mkActionItem k) where go k ai = starting "metadata" ai si $ do
Command/Migrate.hs view
@@ -23,20 +23,33 @@ cmd = withGlobalOptions [annexedMatchingOptions] $ command "migrate" SectionUtility "switch data to different backend"- paramPaths (withParams seek)+ paramPaths (seek <$$> optParser) -seek :: CmdParams -> CommandSeek-seek = withFilesInGitAnnex ww seeker <=< workTreeItems ww+data MigrateOptions = MigrateOptions+ { migrateThese :: CmdParams+ , removeSize :: Bool+ }++optParser :: CmdParamsDesc -> Parser MigrateOptions+optParser desc = MigrateOptions+ <$> cmdParams desc+ <*> switch+ ( long "remove-size"+ <> help "remove size field from keys"+ )++seek :: MigrateOptions -> CommandSeek+seek o = withFilesInGitAnnex ww seeker =<< workTreeItems ww (migrateThese o) where ww = WarnUnmatchLsFiles seeker = AnnexedFileSeeker- { startAction = start+ { startAction = start o , checkContentPresent = Nothing , usesLocationLog = False } -start :: SeekInput -> RawFilePath -> Key -> CommandStart-start si file key = do+start :: MigrateOptions -> SeekInput -> RawFilePath -> Key -> CommandStart+start o si file key = do forced <- Annex.getState Annex.force v <- Backend.getBackend (fromRawFilePath file) key case v of@@ -46,9 +59,14 @@ newbackend <- maybe defaultBackend return =<< chooseBackend file if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists- then starting "migrate" (mkActionItem (key, file)) si $- perform file key oldbackend newbackend- else stop+ then go False oldbackend newbackend+ else if removeSize o && exists+ then go True oldbackend oldbackend+ else stop+ where+ go onlyremovesize oldbackend newbackend =+ starting "migrate" (mkActionItem (key, file)) si $+ perform onlyremovesize o file key oldbackend newbackend {- Checks if a key is upgradable to a newer representation. - @@ -70,13 +88,14 @@ - data cannot get corrupted after the fsck but before the new key is - generated. -}-perform :: RawFilePath -> Key -> Backend -> Backend -> CommandPerform-perform file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbackend)+perform :: Bool -> MigrateOptions -> RawFilePath -> Key -> Backend -> Backend -> CommandPerform+perform onlyremovesize o file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbackend) where go Nothing = stop go (Just (newkey, knowngoodcontent))- | knowngoodcontent = finish newkey- | otherwise = stopUnless checkcontent $ finish newkey+ | knowngoodcontent = finish (removesize newkey)+ | otherwise = stopUnless checkcontent $+ finish (removesize newkey) checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyPresent afile finish newkey = ifM (Command.ReKey.linkKey file oldkey newkey) ( do@@ -89,6 +108,7 @@ next $ Command.ReKey.cleanup file newkey , giveup "failed creating link from old to new key" )+ genkey _ | onlyremovesize = return $ Just (oldkey, False) genkey Nothing = do content <- calcRepo $ gitAnnexLocation oldkey let source = KeySource@@ -101,4 +121,7 @@ genkey (Just fm) = fm oldkey newbackend afile >>= \case Just newkey -> return (Just (newkey, True)) Nothing -> genkey Nothing+ removesize k+ | removeSize o = alterKey k $ \kd -> kd { keySize = Nothing } + | otherwise = k afile = AssociatedFile (Just file)
Command/Smudge.hs view
@@ -74,15 +74,19 @@ smudge :: FilePath -> CommandStart smudge file = do b <- liftIO $ L.hGetContents stdin- case parseLinkTargetOrPointerLazy b of- Nothing -> noop- Just k -> do- topfile <- inRepo (toTopFilePath (toRawFilePath file))- Database.Keys.addAssociatedFile k topfile- void $ smudgeLog k topfile+ smudge' file b liftIO $ L.putStr b stop +-- Handles everything except the IO of the file content.+smudge' :: FilePath -> L.ByteString -> Annex ()+smudge' file b = case parseLinkTargetOrPointerLazy b of+ Nothing -> noop+ Just k -> do+ topfile <- inRepo (toTopFilePath (toRawFilePath file))+ Database.Keys.addAssociatedFile k topfile+ void $ smudgeLog k topfile+ -- Clean filter is fed file content on stdin, decides if a file -- should be stored in the annex, and outputs a pointer to its -- injested content if so. Otherwise, the original content.@@ -90,50 +94,72 @@ clean file = do Annex.BranchState.disableUpdate -- optimisation b <- liftIO $ L.hGetContents stdin- ifM fileoutsiderepo- ( liftIO $ L.hPut stdout b- , do- -- Avoid a potential deadlock.- Annex.changeState $ \s -> s- { Annex.insmudgecleanfilter = True }- go b- )+ let passthrough = liftIO $ L.hPut stdout b+ -- Before git 2.5, failing to consume all stdin here would+ -- cause a SIGPIPE and crash it.+ -- Newer git catches the signal and stops sending, which is+ -- much faster. (Also, git seems to forget to free memory+ -- when sending the file, so the less we let it send, the+ -- less memory it will waste.)+ let discardreststdin = if Git.BuildVersion.older "2.5"+ then L.length b `seq` return ()+ else liftIO $ hClose stdin+ let emitpointer = liftIO . S.hPut stdout . formatPointer+ clean' file (parseLinkTargetOrPointerLazy b)+ passthrough+ discardreststdin+ emitpointer stop where- go b = case parseLinkTargetOrPointerLazy b of++-- Handles everything except the IO of the file content.+clean'+ :: RawFilePath+ -> Maybe Key+ -- ^ If the content provided by git is an annex pointer,+ -- this is the key it points to.+ -> Annex ()+ -- ^ passthrough: Feed the content provided by git back out to git.+ -> Annex ()+ -- ^ discardreststdin: Called when passthrough will not be called,+ -- this has to take care of reading the content provided by git, or+ -- otherwise dealing with it.+ -> (Key -> Annex ())+ -- ^ emitpointer: Emit a pointer file for the key.+ -> Annex ()+clean' file mk passthrough discardreststdin emitpointer =+ ifM (fileOutsideRepo file)+ ( passthrough+ , inSmudgeCleanFilter go+ )+ where++ go = case mk of Just k -> do addingExistingLink file k $ do getMoveRaceRecovery k file- liftIO $ L.hPut stdout b+ passthrough Nothing -> inRepo (Git.Ref.fileRef file) >>= \case Just fileref -> do indexmeta <- catObjectMetaData fileref oldkey <- case indexmeta of Just (_, sz, _) -> catKey' fileref sz Nothing -> return Nothing- go' b indexmeta oldkey- Nothing -> liftIO $ L.hPut stdout b- go' b indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey)+ go' indexmeta oldkey+ Nothing -> passthrough+ go' indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) ( do- -- Before git 2.5, failing to consume all stdin here- -- would cause a SIGPIPE and crash it.- -- Newer git catches the signal and stops sending,- -- which is much faster. (Also, git seems to forget- -- to free memory when sending the file, so the- -- less we let it send, the less memory it will waste.)- if Git.BuildVersion.older "2.5"- then L.length b `seq` return ()- else liftIO $ hClose stdin+ discardreststdin -- Optimization for the case when the file is already -- annexed and is unmodified. case oldkey of Nothing -> doingest Nothing Just ko -> ifM (isUnmodifiedCheap ko file)- ( liftIO $ emitPointer ko+ ( emitpointer ko , updateingest ko )- , liftIO $ L.hPut stdout b+ , passthrough ) -- Use the same backend that was used before, when possible.@@ -150,7 +176,7 @@ -- Can't restage associated files because git add -- runs this and has the index locked. let norestage = Restage False- liftIO . emitPointer+ emitpointer =<< postingest =<< (\ld -> ingest' preferredbackend nullMeterUpdate ld Nothing norestage) =<< lockDown cfg (fromRawFilePath file)@@ -166,13 +192,23 @@ , checkWritePerms = True } - -- git diff can run the clean filter on files outside the- -- repository; can't annex those- fileoutsiderepo = do- repopath <- liftIO . absPath =<< fromRepo Git.repoPath- filepath <- liftIO $ absPath file- return $ not $ dirContains repopath filepath+-- git diff can run the clean filter on files outside the+-- repository; can't annex those+fileOutsideRepo :: RawFilePath -> Annex Bool+fileOutsideRepo file = do+ repopath <- liftIO . absPath =<< fromRepo Git.repoPath+ filepath <- liftIO $ absPath file+ return $ not $ dirContains repopath filepath +-- Avoid a potential deadlock.+inSmudgeCleanFilter :: Annex a -> Annex a+inSmudgeCleanFilter = bracket setup cleanup . const+ where+ setup = Annex.changeState $ \s -> s+ { Annex.insmudgecleanfilter = True }+ cleanup () = Annex.changeState $ \s -> s+ { Annex.insmudgecleanfilter = False }+ -- If annex.largefiles is configured (and not disabled by annex.gitaddtoannex -- being set to false), matching files are added to the annex and the rest to -- git.@@ -244,9 +280,6 @@ else cont _ -> cont _ -> cont--emitPointer :: Key -> IO ()-emitPointer = S.putStr . formatPointer -- Recover from a previous race between eg git mv and git-annex get. -- That could result in the file remaining a pointer file, while
Command/Uninit.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2010 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -11,6 +11,7 @@ import qualified Annex import qualified Git import qualified Git.Command+import qualified Git.Ref import qualified Command.Unannex import qualified Annex.Branch import qualified Annex.Queue@@ -30,14 +31,18 @@ check :: Annex () check = do b <- current_branch- when (b == Annex.Branch.name) $ giveup $- "cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"+ when (b == Just Annex.Branch.name) $ giveup $+ "cannot uninit when the " ++ Git.fromRef Annex.Branch.name ++ " branch is checked out" top <- fromRepo Git.repoPath currdir <- liftIO R.getCurrentDirectory whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ giveup "can only run uninit from the top of the git repository" where- current_branch = Git.Ref . encodeBS . Prelude.head . lines . decodeBS <$> revhead+ current_branch = + ifM (inRepo Git.Ref.headExists)+ ( Just . Git.Ref . encodeBS . Prelude.head . lines . decodeBS <$> revhead+ , return Nothing+ ) revhead = inRepo $ Git.Command.pipeReadStrict [Param "rev-parse", Param "--abbrev-ref", Param "HEAD"] @@ -93,8 +98,9 @@ uninitialize -- avoid normal shutdown saveState False- inRepo $ Git.Command.run- [Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name]+ whenM (inRepo $ Git.Ref.exists Annex.Branch.fullname) $+ inRepo $ Git.Command.run+ [Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name] liftIO exitSuccess {- Turn on write bits in all remaining files in the annex directory, in
Config/Smudge.hs view
@@ -67,4 +67,5 @@ bypassSmudgeConfig = map Param [ "-c", "filter.annex.smudge=" , "-c", "filter.annex.clean="+ , "-c", "filter.annex.process=" ]
Git/Config.hs view
@@ -241,6 +241,14 @@ , Param "--list" ] ConfigList +{- Changes a git config setting in .git/config. -}+change :: ConfigKey -> S.ByteString -> Repo -> IO Bool+change (ConfigKey k) v = Git.Command.runBool+ [ Param "config"+ , Param (decodeBS k)+ , Param (decodeBS v)+ ]+ {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool
+ Git/FilterProcess.hs view
@@ -0,0 +1,168 @@+{- git long-running filter process+ -+ - As documented in git's gitattributes(5) and+ - Documentation/technical/long-running-process-protocol.txt+ -+ - Copyright 2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Git.FilterProcess (+ WelcomeMessage(..),+ Version(..),+ Capability(..),+ longRunningProcessHandshake,+ longRunningFilterProcessHandshake,+ FilterRequest(..),+ getFilterRequest,+ respondFilterRequest,+) where++import Common+import Git.PktLine++import qualified Data.ByteString as B++{- This is a message like "git-filter-client" or "git-filter-server" -}+data WelcomeMessage = WelcomeMessage PktLine+ deriving (Show)++{- Configuration message, eg "foo=bar" -}+data ConfigValue = ConfigValue String String+ deriving (Show, Eq)++encodeConfigValue :: ConfigValue -> PktLine+encodeConfigValue (ConfigValue k v) = stringPktLine (k <> "=" <> v)++decodeConfigValue :: PktLine -> Maybe ConfigValue+decodeConfigValue pktline =+ let t = pktLineToString pktline+ (k, v) = break (== '=') t+ in if null v+ then Nothing+ else Just $ ConfigValue k (drop 1 v)++extractConfigValue :: [ConfigValue] -> String -> Maybe String+extractConfigValue [] _ = Nothing+extractConfigValue (ConfigValue k v:cs) wantk+ | k == wantk = Just v+ | otherwise = extractConfigValue cs wantk++data Version = Version Int+ deriving (Show, Eq)++encodeVersion :: Version -> PktLine+encodeVersion (Version n) = encodeConfigValue $ ConfigValue "version" (show n)++decodeVersion :: PktLine -> Maybe Version+decodeVersion pktline = decodeConfigValue pktline >>= \case+ ConfigValue "version" v -> Version <$> readish v+ _ -> Nothing++data Capability = Capability String+ deriving (Show, Eq)++encodeCapability :: Capability -> PktLine+encodeCapability (Capability c) = encodeConfigValue $ + ConfigValue "capability" c++decodeCapability :: PktLine -> Maybe Capability+decodeCapability pktline = decodeConfigValue pktline >>= \case+ ConfigValue "capability" c -> Just $ Capability c+ _ -> Nothing++longRunningProcessHandshake+ :: (WelcomeMessage -> Maybe WelcomeMessage)+ -> ([Version] -> [Version])+ -> ([Capability] -> [Capability])+ -> IO (Either String ())+longRunningProcessHandshake respwelcomemessage filterversions filtercapabilities =+ readUntilFlushPkt >>= \case+ [] -> protoerr "no welcome message"+ (welcomemessage:versions) -> + checkwelcomemessage welcomemessage $+ checkversion versions $ do+ capabilities <- readUntilFlushPkt+ checkcapabilities capabilities success+ where+ protoerr msg = return $ Left $ "git protocol error: " ++ msg+ success = return (Right ())++ checkwelcomemessage welcomemessage cont =+ case respwelcomemessage (WelcomeMessage welcomemessage) of+ Nothing -> protoerr "unsupported welcome message"+ Just (WelcomeMessage welcomemessage') -> do+ writePktLine stdout welcomemessage'+ cont++ checkversion versions cont = do+ let versions' = filterversions (mapMaybe decodeVersion versions)+ if null versions'+ then protoerr "unsupported protocol version"+ else do+ forM_ versions' $ \v ->+ writePktLine stdout $ encodeVersion v+ writePktLine stdout flushPkt+ cont+ + checkcapabilities capabilities cont = do+ let capabilities' = filtercapabilities (mapMaybe decodeCapability capabilities)+ if null capabilities'+ then protoerr "unsupported protocol capabilities"+ else do+ forM_ capabilities' $ \c ->+ writePktLine stdout $ encodeCapability c+ writePktLine stdout flushPkt+ cont++longRunningFilterProcessHandshake :: IO (Either String ())+longRunningFilterProcessHandshake =+ longRunningProcessHandshake respwelcomemessage filterversions filtercapabilities+ where+ respwelcomemessage (WelcomeMessage w)+ | pktLineToString w == "git-filter-client" =+ Just $ WelcomeMessage $ stringPktLine "git-filter-server"+ | otherwise = Nothing+ filterversions = filter (== Version 2)+ -- Delay capability is not implemented, so filter it out.+ filtercapabilities = filter (`elem` [Capability "smudge", Capability "clean"])++data FilterRequest = Smudge FilePath | Clean FilePath+ deriving (Show, Eq)++{- Waits for the next FilterRequest to be received. Does not read+ - the content to be filtered, which is what gets sent subsequent to the+ - FilterRequest. Use eg readUntilFlushPkt to read it, before calling+ - respondFilterRequest. -}+getFilterRequest :: IO (Maybe FilterRequest)+getFilterRequest = do+ ps <- readUntilFlushPkt+ let cs = mapMaybe decodeConfigValue ps+ case (extractConfigValue cs "command", extractConfigValue cs "pathname") of+ (Just command, Just pathname)+ | command == "smudge" -> return $ Just $ Smudge pathname+ | command == "clean" -> return $ Just $ Clean pathname+ | otherwise -> return Nothing+ _ -> return Nothing++{- Send a response to a FilterRequest, consisting of the filtered content. -}+respondFilterRequest :: B.ByteString -> IO ()+respondFilterRequest b = do+ writePktLine stdout $ encodeConfigValue $ ConfigValue "status" "success"+ writePktLine stdout flushPkt+ send b+ -- The protocol allows for another list of ConfigValues to be sent+ -- here, but we don't use it. Send another flushPkt to terminate+ -- the empty list.+ writePktLine stdout flushPkt+ where+ send b' = + let (pktline, rest) = encodePktLine b'+ in do+ writePktLine stdout pktline+ case rest of+ Just b'' -> send b''+ Nothing -> writePktLine stdout flushPkt
+ Git/PktLine.hs view
@@ -0,0 +1,153 @@+{- git pkt-line communication format+ -+ - As documented in git's Documentation/technical/protocol-common.txt+ -+ - Copyright 2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Git.PktLine (+ PktLine,+ pktLineToByteString,+ pktLineToString,+ readPktLine,+ encodePktLine,+ stringPktLine,+ writePktLine,+ flushPkt,+ isFlushPkt,+ readUntilFlushPkt,+ readUntilFlushPktOrSize,+ discardUntilFlushPkt,+) where++import System.IO+import qualified Data.ByteString as B+import qualified Data.Attoparsec.ByteString.Char8 as A8+import Text.Printf++import Utility.PartialPrelude+import Utility.FileSystemEncoding++{- This is a variable length binary string, but its size is limited to+ - maxPktLineLength. Its serialization includes a 4 byte hexidecimal+ - prefix giving its total length, including that prefix. -}+newtype PktLine = PktLine B.ByteString+ deriving (Show)++{- Maximum allowed length of the string encoded in PktLine+ - is slightly shorter than the absolute maximum possible length.+ - Git does not accept anything longer than this. -}+maxPktLineLength :: Int+maxPktLineLength = 65520 - pktLineHeaderLength++pktLineHeaderLength :: Int+pktLineHeaderLength = 4++pktLineToByteString :: PktLine -> B.ByteString+pktLineToByteString (PktLine b) = b++{- When the pkt-line contains non-binary data, its serialization+ - may include a terminating newline. This removes that newline, if it was+ - present.+ -+ - Note that the pkt-line has no defined encoding, and could still+ - contain something non-ascii, eg a filename. -}+pktLineToString :: PktLine -> String+pktLineToString (PktLine b) = + let s = decodeBS b+ in case lastMaybe s of+ Just '\n' -> beginning s+ _ -> s++{- Reads the next PktLine from a Handle. Returns Nothing on EOF or when+ - there is a protocol error. -}+readPktLine :: Handle -> IO (Maybe PktLine)+readPktLine h = do+ lenb <- B.hGet h pktLineHeaderLength+ if B.length lenb < pktLineHeaderLength+ then return Nothing+ else case A8.parseOnly (A8.hexadecimal <* A8.endOfInput) lenb of+ Right len -> go (len - pktLineHeaderLength) mempty+ _ -> return Nothing+ where+ go n b+ | n <= 0 = return (Just (PktLine b))+ | otherwise = do+ b' <- B.hGet h n+ if B.length b' == 0+ then return Nothing -- EOF+ else go (n - B.length b') (b <> b')++{- Encodes the ByteString as a PktLine. But if the ByteString is too+ - long to fit in a single PktLine, returns the remainder of it. -}+encodePktLine :: B.ByteString -> (PktLine, Maybe B.ByteString)+encodePktLine b+ | B.length b > maxPktLineLength =+ let (b', rest) = B.splitAt maxPktLineLength b+ in (PktLine b', Just rest)+ | otherwise = (PktLine b, Nothing)++{- If the String is too long to fit in a single PktLine,+ - will throw an error. -}+stringPktLine :: String -> PktLine+stringPktLine s+ | length s > maxPktLineLength =+ error "textPktLine called with too-long value"+ | otherwise = PktLine (encodeBS s <> "\n")++{- Sends a PktLine to a Handle, and flushes it so that it will be+ - visible to the Handle's reader. -}+writePktLine :: Handle -> PktLine -> IO ()+writePktLine h (PktLine b)+ -- Special case for empty string; avoid encoding as "0004".+ | B.null b = do+ B.hPut h "0000"+ hFlush h+ | otherwise = do+ hPutStr h $ printf "%04x" (B.length b + pktLineHeaderLength)+ B.hPut h b+ hFlush h++flushPkt :: PktLine+flushPkt = PktLine mempty++isFlushPkt :: PktLine -> Bool+isFlushPkt (PktLine b) = b == mempty++{- Reads PktLines until a flushPkt (or EOF), + - and returns all except the flushPkt -}+readUntilFlushPkt :: IO [PktLine]+readUntilFlushPkt = go []+ where+ go l = readPktLine stdin >>= \case+ Just pktline | not (isFlushPkt pktline) -> go (pktline:l)+ _ -> return (reverse l)++{- Reads PktLines until at least the specified number of bytes have been+ - read, or until a flushPkt (or EOF). Returns Right if it did read a+ - flushPkt/EOF, and Left if there is still content leftover that needs to+ - be read. -}+readUntilFlushPktOrSize :: Int -> IO (Either [PktLine] [PktLine])+readUntilFlushPktOrSize = go []+ where+ go l n = readPktLine stdin >>= \case+ Just pktline+ | isFlushPkt pktline -> return (Right (reverse l))+ | otherwise -> + let len = B.length (pktLineToByteString pktline)+ n' = n - len+ in if n' <= 0+ then return (Left (reverse (pktline:l)))+ else go (pktline:l) n'+ Nothing -> return (Right (reverse l))++{- Reads PktLines until a flushPkt (or EOF), and throws them away. -}+discardUntilFlushPkt :: IO ()+discardUntilFlushPkt = readPktLine stdin >>= \case+ Just pktline | isFlushPkt pktline -> return ()+ Nothing -> return ()+ _ -> discardUntilFlushPkt
Git/Queue.hs view
@@ -49,11 +49,11 @@ - to as the queue grows. -} | InternalAction { getRunner :: InternalActionRunner m- , getInternalFiles :: [(RawFilePath, IO Bool)]+ , getInternalFiles :: [(RawFilePath, IO Bool, FileSize)] } {- The String must be unique for each internal action. -}-data InternalActionRunner m = InternalActionRunner String (Repo -> [(RawFilePath, IO Bool)] -> m ())+data InternalActionRunner m = InternalActionRunner String (Repo -> [(RawFilePath, IO Bool, FileSize)] -> m ()) instance Eq (InternalActionRunner m) where InternalActionRunner s1 _ == InternalActionRunner s2 _ = s1 == s2@@ -116,7 +116,7 @@ different _ = True {- Adds an internal action to the queue. -}-addInternalAction :: MonadIO m => InternalActionRunner m -> [(RawFilePath, IO Bool)] -> Queue m -> Repo -> m (Queue m)+addInternalAction :: MonadIO m => InternalActionRunner m -> [(RawFilePath, IO Bool, FileSize)] -> Queue m -> Repo -> m (Queue m) addInternalAction runner files q repo = updateQueue action different (length files) q repo where
Messages/JSON.hs view
@@ -1,6 +1,6 @@ {- git-annex command-line JSON output and input -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -26,6 +26,7 @@ DualDisp(..), ObjectMap(..), JSONActionItem(..),+ AddJSONActionItemFields(..), ) where import Control.Applicative@@ -78,7 +79,7 @@ { itemCommand = Just command , itemKey = key , itemFile = fromRawFilePath <$> file- , itemAdded = Nothing+ , itemFields = Nothing :: Maybe Bool , itemSeekInput = si } @@ -179,19 +180,21 @@ { itemCommand :: Maybe String , itemKey :: Maybe Key , itemFile :: Maybe FilePath- , itemAdded :: Maybe a -- for additional fields added by `add`+ , itemFields :: Maybe a , itemSeekInput :: SeekInput } deriving (Show) -instance ToJSON' (JSONActionItem a) where+instance ToJSON' a => ToJSON' (JSONActionItem a) where toJSON' i = object $ catMaybes [ Just $ "command" .= itemCommand i , case itemKey i of Just k -> Just $ "key" .= toJSON' k Nothing -> Nothing , Just $ "file" .= toJSON' (itemFile i)- -- itemAdded is not included; must be added later by 'add'+ , case itemFields i of+ Just f -> Just $ "fields" .= toJSON' f+ Nothing -> Nothing , Just $ "input" .= fromSeekInput (itemSeekInput i) ] @@ -200,8 +203,14 @@ <$> (v .:? "command") <*> (maybe (return Nothing) parseJSON =<< (v .:? "key")) <*> (v .:? "file")- <*> parseadded+ <*> (v .:? "fields") <*> pure (SeekInput [])- where- parseadded = (Just <$> parseJSON (Object v)) <|> return Nothing parseJSON _ = mempty++-- This can be used to populate the "fields" after a JSONActionItem+-- has already been started.+newtype AddJSONActionItemFields a = AddJSONActionItemFields a+ deriving (Show)++instance ToJSON' a => ToJSON' (AddJSONActionItemFields a) where+ toJSON' (AddJSONActionItemFields a) = object [ ("fields", toJSON' a) ]
P2P/Annex.hs view
@@ -178,7 +178,7 @@ then defaultChunkSize else fromIntegral n b <- S.hGet h c- updateIncremental iv b+ updateIncrementalVerifier iv b unless (b == S.empty) $ go iv (n - fromIntegral (S.length b)) @@ -192,7 +192,7 @@ Nothing -> \c -> S.hPut h c Just iv -> \c -> do S.hPut h c- updateIncremental iv c+ updateIncrementalVerifier iv c meteredWrite p' writechunk b indicatetransferred ti @@ -203,7 +203,7 @@ runner validitycheck >>= \case Right (Just Valid) -> case incrementalverifier of Just iv- | rightsize -> liftIO (finalizeIncremental iv) >>= \case+ | rightsize -> liftIO (finalizeIncrementalVerifier iv) >>= \case Nothing -> return (True, UnVerified) Just True -> return (True, Verified) Just False -> return (False, UnVerified)
Remote/GitLFS.hs view
@@ -457,7 +457,11 @@ (req, sha256, size) <- mkUploadRequest rs k src sendTransferRequest req endpoint >>= \case Right resp -> do- body <- liftIO $ httpBodyStorer src p+ let body (LFS.ServerSupportsChunks ssc) =+ if ssc+ then httpBodyStorerChunked src p+ else RequestBodyIO $+ httpBodyStorer src p forM_ (LFS.objects resp) $ send body sha256 size Left err -> giveup err
Remote/Helper/Chunked.hs view
@@ -372,7 +372,7 @@ finalize (Right Nothing) = return UnVerified finalize (Right (Just iv)) =- liftIO (finalizeIncremental iv) >>= \case+ liftIO (finalizeIncrementalVerifier iv) >>= \case Just True -> return Verified _ -> return UnVerified finalize (Left v) = return v@@ -426,7 +426,7 @@ Just p -> let writer = case miv of Just iv -> \s -> do- updateIncremental iv s+ updateIncrementalVerifier iv s S.hPut h s Nothing -> S.hPut h in meteredWrite p writer b
Remote/Helper/Http.hs view
@@ -37,6 +37,12 @@ let streamer sink = withMeteredFile src m $ \b -> byteStringPopper b sink return $ RequestBodyStream (fromInteger size) streamer +-- Like httpBodyStorer, but generates a chunked request body.+httpBodyStorerChunked :: FilePath -> MeterUpdate -> RequestBody+httpBodyStorerChunked src m =+ let streamer sink = withMeteredFile src m $ \b -> byteStringPopper b sink+ in RequestBodyStreamChunked streamer+ byteStringPopper :: L.ByteString -> NeedsPopper () -> IO () byteStringPopper b sink = do mvar <- newMVar $ L.toChunks b@@ -83,5 +89,5 @@ let sofar' = addBytesProcessed sofar $ S.length b S.hPut h b meterupdate sofar'- maybe noop (flip updateIncremental b) iv+ maybe noop (flip updateIncrementalVerifier b) iv go sofar' h
Remote/WebDAV.hs view
@@ -173,7 +173,7 @@ withDavHandle hv $ \dav -> case cc of LegacyChunks _ -> do -- Not doing incremental verification for chunks.- liftIO $ maybe noop unableIncremental iv+ liftIO $ maybe noop unableIncrementalVerifier iv retrieveLegacyChunked (fromRawFilePath d) k p dav _ -> liftIO $ goDAV dav $ retrieveHelper (keyLocation k) (fromRawFilePath d) p iv
Utility/GitLFS.hs view
@@ -45,6 +45,7 @@ -- * Making transfers downloadOperationRequest, uploadOperationRequests,+ ServerSupportsChunks(..), -- * Endpoint discovery Endpoint,@@ -402,10 +403,10 @@ -- | Builds a http request to perform a download. downloadOperationRequest :: DownloadOperation -> Maybe Request-downloadOperationRequest = operationParamsRequest . download+downloadOperationRequest = fmap fst . operationParamsRequest . download -- | Builds http request to perform an upload. The content to upload is--- provided in the RequestBody, along with its SHA256 and size.+-- provided, along with its SHA256 and size. -- -- When the LFS server requested verification, there will be a second -- Request that does that; it should be run only after the upload has@@ -413,8 +414,8 @@ -- -- When the LFS server already contains the object, an empty list may be -- returned.-uploadOperationRequests :: UploadOperation -> RequestBody -> SHA256 -> Integer -> Maybe [Request]-uploadOperationRequests op content oid size = +uploadOperationRequests :: UploadOperation -> (ServerSupportsChunks -> RequestBody) -> SHA256 -> Integer -> Maybe [Request]+uploadOperationRequests op mkcontent oid size = case (mkdlreq, mkverifyreq) of (Nothing, _) -> Nothing (Just dlreq, Nothing) -> Just [dlreq]@@ -422,25 +423,40 @@ where mkdlreq = mkdlreq' <$> operationParamsRequest (upload op)- mkdlreq' r = r+ mkdlreq' (r, ssc) = r { method = "PUT"- , requestBody = content+ , requestBody = mkcontent ssc } mkverifyreq = mkverifyreq' <$> (operationParamsRequest =<< verify op)- mkverifyreq' r = addLfsJsonHeaders $ r+ mkverifyreq' (r, _ssc) = addLfsJsonHeaders $ r { method = "POST" , requestBody = RequestBodyLBS $ encode $ Verification oid size } -operationParamsRequest :: OperationParams -> Maybe Request+-- | When the LFS server indicates that it supports Transfer-Encoding chunked,+-- this will contain a true value, and the RequestBody provided to+-- uploadOperationRequests may be created using RequestBodyStreamChunked.+-- Otherwise, that should be avoided as the server may not support the+-- chunked encoding.+newtype ServerSupportsChunks = ServerSupportsChunks Bool++operationParamsRequest :: OperationParams -> Maybe (Request, ServerSupportsChunks) operationParamsRequest ps = do r <- parseRequest (T.unpack (href ps)) let headers = map convheader $ maybe [] M.toList (header ps)- return $ r { requestHeaders = headers }+ let headers' = filter allowedheader headers+ let ssc = ServerSupportsChunks $+ any (== ("Transfer-Encoding", "chunked")) headers+ return (r { requestHeaders = headers' }, ssc) where convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)+ -- requestHeaders is not allowed to set Transfer-Encoding or + -- Content-Length; copying those over blindly could request in a+ -- malformed request.+ allowedheader (k, _) = k /= "Transfer-Encoding"+ && k /= "Content-Length" type Url = T.Text
Utility/Hash.hs view
@@ -64,6 +64,8 @@ Mac(..), calcMac, props_macs_stable,+ IncrementalHasher(..),+ mkIncrementalHasher, IncrementalVerifier(..), mkIncrementalVerifier, ) where@@ -280,44 +282,62 @@ key = T.encodeUtf8 $ T.pack "foo" msg = T.encodeUtf8 $ T.pack "bar" -data IncrementalVerifier = IncrementalVerifier- { updateIncremental :: S.ByteString -> IO ()+data IncrementalHasher = IncrementalHasher+ { updateIncrementalHasher :: S.ByteString -> IO () -- ^ Called repeatedly on each peice of the content.- , finalizeIncremental :: IO (Maybe Bool)- -- ^ Called once the full content has been sent, returns True- -- if the hash verified, False if it did not, and Nothing if- -- incremental verification was unable to be done.- , unableIncremental :: IO ()- -- ^ Call if the incremental verification is unable to be done.- , positionIncremental :: IO (Maybe Integer)+ , finalizeIncrementalHasher :: IO (Maybe String)+ -- ^ Called once the full content has been sent, returns+ -- the hash. (Nothing if unableIncremental was called.)+ , unableIncrementalHasher :: IO ()+ -- ^ Call if the incremental hashing is unable to be done.+ , positionIncrementalHasher :: IO (Maybe Integer) -- ^ Returns the number of bytes that have been fed to this- -- incremental verifier so far. (Nothing if unableIncremental was+ -- incremental hasher so far. (Nothing if unableIncremental was -- called.)- , descVerify :: String- -- ^ A description of what is done to verify the content.+ , descIncrementalHasher :: String } -mkIncrementalVerifier :: HashAlgorithm h => Context h -> String -> (String -> Bool) -> IO IncrementalVerifier-mkIncrementalVerifier ctx descverify samechecksum = do+mkIncrementalHasher :: HashAlgorithm h => Context h -> String -> IO IncrementalHasher+mkIncrementalHasher ctx desc = do v <- newIORef (Just (ctx, 0))- return $ IncrementalVerifier- { updateIncremental = \b ->+ return $ IncrementalHasher+ { updateIncrementalHasher = \b -> modifyIORef' v $ \case (Just (ctx', n)) -> let !ctx'' = hashUpdate ctx' b !n' = n + fromIntegral (S.length b) in (Just (ctx'', n')) Nothing -> Nothing- , finalizeIncremental =+ , finalizeIncrementalHasher = readIORef v >>= \case (Just (ctx', _)) -> do let digest = hashFinalize ctx'- return $ Just $ - samechecksum (show digest)+ return $ Just $ show digest Nothing -> return Nothing- , unableIncremental = writeIORef v Nothing- , positionIncremental = readIORef v >>= \case+ , unableIncrementalHasher = writeIORef v Nothing+ , positionIncrementalHasher = readIORef v >>= \case Just (_, n) -> return (Just n) Nothing -> return Nothing- , descVerify = descverify+ , descIncrementalHasher = desc+ }++data IncrementalVerifier = IncrementalVerifier+ { updateIncrementalVerifier :: S.ByteString -> IO ()+ , finalizeIncrementalVerifier :: IO (Maybe Bool)+ , unableIncrementalVerifier :: IO ()+ , positionIncrementalVerifier :: IO (Maybe Integer)+ , descIncrementalVerifier :: String+ }++mkIncrementalVerifier :: HashAlgorithm h => Context h -> String -> (String -> Bool) -> IO IncrementalVerifier+mkIncrementalVerifier ctx desc samechecksum = do+ hasher <- mkIncrementalHasher ctx desc+ return $ IncrementalVerifier+ { updateIncrementalVerifier = updateIncrementalHasher hasher+ , finalizeIncrementalVerifier = + maybe Nothing (Just . samechecksum)+ <$> finalizeIncrementalHasher hasher+ , unableIncrementalVerifier = unableIncrementalHasher hasher+ , positionIncrementalVerifier = positionIncrementalHasher hasher+ , descIncrementalVerifier = descIncrementalHasher hasher }
Utility/Url.hs view
@@ -451,7 +451,7 @@ Nothing -> throwIO ex followredir _ ex = throwIO ex - noverification = maybe noop unableIncremental iv+ noverification = maybe noop unableIncrementalVerifier iv {- Download a perhaps large file using conduit, with auto-resume - of incomplete downloads.@@ -554,7 +554,7 @@ () <- signalsuccess False throwM e - noverification = maybe noop unableIncremental iv+ noverification = maybe noop unableIncrementalVerifier iv {- Sinks a Response's body to a file. The file can either be appended to - (AppendMode), or written from the start of the response (WriteMode).@@ -575,9 +575,9 @@ sinkResponseFile meterupdate iv initialp file mode resp = do ui <- case (iv, mode) of (Just iv', AppendMode) -> do- liftIO $ unableIncremental iv'+ liftIO $ unableIncrementalVerifier iv' return (const noop)- (Just iv', _) -> return (updateIncremental iv')+ (Just iv', _) -> return (updateIncrementalVerifier iv') (Nothing, _) -> return (const noop) (fr, fh) <- allocate (openBinaryFile file mode) hClose runConduit $ responseBody resp .| go ui initialp fh
doc/git-annex-adjust.mdwn view
@@ -16,13 +16,18 @@ Since it's a regular git branch, you can use `git checkout` to switch back to the original branch at any time. +This allows changing how annexed files are handled, without making changes+to a public branch with commands like `git-annex unlock`.+ While in the adjusted branch, you can use git-annex and git commands as usual. Any commits that you make will initially only be made to the adjusted branch. To propagate commits from the adjusted branch back to the original branch, and to other repositories, as well as to merge in changes from other-repositories, run `git annex sync`.+repositories, run `git annex sync`. This will propagate changes that you've+made such as adding/deleting files, but will not propagate the adjustments+made by this command. When in an adjusted branch, using `git merge otherbranch` is often not ideal, because merging a non-adjusted branch may lead to unncessary@@ -116,6 +121,8 @@ [[git-annex]](1) [[git-annex-unlock]](1)++[[git-annex-lock]](1) [[git-annex-upgrade]](1)
doc/git-annex-metadata.mdwn view
@@ -133,7 +133,9 @@ enable `--json` along with `--batch`. In batch mode, git-annex reads lines from stdin, which contain- JSON objects. It replies to each input with an output JSON object.+ JSON objects. It replies to each input annexed file+ with an output JSON object. (But if the file is not an annexed file,+ an empty line will be output.) The format of the JSON sent to git-annex can be the same as the JSON that it outputs. Or, a simplified version. Only the "file" (or "key") field@@ -158,9 +160,6 @@ To remove the author of file foo: {"file":"foo","fields":{"author":[]}}-- Note that matching options do not affect the files that are- processed when in batch mode. * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-migrate.mdwn view
@@ -39,6 +39,18 @@ * Also the [[git-annex-common-options]](1) can be used. +* `--remove-size`++ Keys often include the size of their content, which is generally a useful+ thing. In fact, this command defaults to adding missing size information+ to keys. With this option, the size information is removed instead.++ One use of this option is to convert URL keys that were added+ by `git-annex addurl --fast` to ones that would have been added if+ that command was run with the `--relaxed` option. Eg:++ git-annex migrate --remove-size --backend=URL somefile+ # SEE ALSO [[git-annex]](1)
doc/git-annex-rekey.mdwn view
@@ -13,6 +13,9 @@ Multiple pairs of file and key can be given in a single command line. +Note that, unlike `git-annex migrate`, this does not copy over metadata,+urls, and other such information from the old to the new key+ # OPTIONS * `--force`@@ -36,6 +39,8 @@ # SEE ALSO [[git-annex]](1)++[[git-annex-migrate]](1) # AUTHOR
doc/git-annex-smudge.mdwn view
@@ -58,6 +58,7 @@ # SEE ALSO [[git-annex]](1)+[[git-annex-filter-process]](1) # AUTHOR
doc/git-annex.mdwn view
@@ -713,6 +713,13 @@ See [[git-annex-smudge]](1) for details. +* `filter-process`++ An alternative implementation of a git filter driver, that is faster+ in some situations and slower in others than `git-annex smudge`.++ See [[git-annex-filter-process]](1) for details.+ * `findref [ref]` Lists files in a git ref. (deprecated)
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20211028+Version: 8.20211117 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -419,7 +419,7 @@ Build-Depends: network (< 3.0.0.0), network (>= 2.6.3.0) if flag(GitLfs)- Build-Depends: git-lfs (>= 1.1.0)+ Build-Depends: git-lfs (>= 1.2.0) CPP-Options: -DWITH_GIT_LFS else Other-Modules: Utility.GitLFS@@ -745,6 +745,7 @@ Command.Expire Command.Export Command.FilterBranch+ Command.FilterProcess Command.Find Command.FindRef Command.Fix@@ -871,6 +872,7 @@ Git.FileMode Git.FilePath Git.Filename+ Git.FilterProcess Git.Fsck Git.GCrypt Git.HashObject@@ -882,6 +884,7 @@ Git.LsTree Git.Merge Git.Objects+ Git.PktLine Git.Queue Git.Ref Git.RefLog
stack.yaml view
@@ -19,7 +19,7 @@ - IfElse-0.85 - aws-0.22 - bloomfilter-2.0.1.0-- git-lfs-1.1.2+- git-lfs-1.2.0 - http-client-restricted-0.0.4 - network-multicast-0.3.2 - sandi-0.5