diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -43,7 +43,6 @@ import qualified Git.Config import qualified Git.Construct import Annex.Fixup -import Git.CatFile import Git.HashObject import Git.CheckAttr import Git.CheckIgnore @@ -67,9 +66,12 @@ import Types.CleanupActions import Types.AdjustedBranch import Types.WorkerPool +import Types.IndexFiles +import Types.CatFileHandles import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url +import Utility.ResourcePool import "mtl" Control.Monad.Reader import Control.Concurrent @@ -108,7 +110,6 @@ , gitremotes :: Maybe [Git.Repo] , backend :: Maybe (BackendA Annex) , remotes :: [Types.Remote.RemoteA Annex] - , remoteannexstate :: M.Map UUID AnnexState , output :: MessageState , concurrency :: Concurrency , force :: Bool @@ -116,10 +117,10 @@ , daemon :: Bool , branchstate :: BranchState , repoqueue :: Maybe (Git.Queue.Queue Annex) - , catfilehandles :: M.Map FilePath CatFileHandle + , catfilehandles :: CatFileHandles , hashobjecthandle :: Maybe HashObjectHandle - , checkattrhandle :: Maybe CheckAttrHandle - , checkignorehandle :: Maybe CheckIgnoreHandle + , checkattrhandle :: Maybe (ResourcePool CheckAttrHandle) + , checkignorehandle :: Maybe (ResourcePool CheckIgnoreHandle) , forcebackend :: Maybe String , globalnumcopies :: Maybe NumCopies , forcenumcopies :: Maybe NumCopies @@ -146,9 +147,9 @@ , workers :: Maybe (TMVar (WorkerPool AnnexState)) , activekeys :: TVar (M.Map Key ThreadId) , activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer) - , keysdbhandle :: Maybe Keys.DbHandle + , keysdbhandle :: Keys.DbHandle , cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment)) - , cachedgitenv :: Maybe (FilePath, [(String, String)]) + , cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) , urloptions :: Maybe UrlOptions } @@ -158,6 +159,7 @@ emptyactivekeys <- newTVarIO M.empty o <- newMessageState sc <- newTMVarIO False + kh <- Keys.newDbHandle return $ AnnexState { repo = r , repoadjustment = return @@ -166,7 +168,6 @@ , gitremotes = Nothing , backend = Nothing , remotes = [] - , remoteannexstate = M.empty , output = o , concurrency = NonConcurrent , force = False @@ -174,7 +175,7 @@ , daemon = False , branchstate = startBranchState , repoqueue = Nothing - , catfilehandles = M.empty + , catfilehandles = catFileHandlesNonConcurrent , hashobjecthandle = Nothing , checkattrhandle = Nothing , checkignorehandle = Nothing @@ -204,7 +205,7 @@ , workers = Nothing , activekeys = emptyactivekeys , activeremotes = emptyactiveremotes - , keysdbhandle = Nothing + , keysdbhandle = kh , cachedcurrentbranch = Nothing , cachedgitenv = Nothing , urloptions = Nothing @@ -232,7 +233,7 @@ flush s' return (r, s') where - flush = maybe noop Keys.flushDbQueue . keysdbhandle + flush = Keys.flushDbQueue . keysdbhandle {- Performs an action in the Annex monad from a starting state, - and throws away the new state. -} diff --git a/Annex/Action.hs b/Annex/Action.hs --- a/Annex/Action.hs +++ b/Annex/Action.hs @@ -23,7 +23,10 @@ import Annex.Common import qualified Annex import Annex.Content -import Annex.Concurrent +import Annex.CatFile +import Annex.CheckAttr +import Annex.HashObject +import Annex.CheckIgnore {- Actions to perform each time ran. -} startup :: Annex () @@ -36,6 +39,14 @@ sequence_ =<< M.elems <$> Annex.getState Annex.cleanup stopCoProcesses liftIO reapZombies -- zombies from long-running git processes + +{- Stops all long-running git query processes. -} +stopCoProcesses :: Annex () +stopCoProcesses = do + catFileStop + checkAttrStop + hashObjectStop + checkIgnoreStop {- Reaps any zombie processes that may be hanging around. - diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, OverloadedStrings #-} module Annex.AdjustedBranch ( Adjustment(..), @@ -61,6 +61,7 @@ import Config import qualified Data.Map as M +import qualified Data.ByteString as S -- How to perform various adjustments to a TreeItem. class AdjustTreeItem t where @@ -128,7 +129,7 @@ -- refs/basis/adjusted/master(unlocked). basisBranch :: AdjBranch -> BasisBranch basisBranch (AdjBranch adjbranch) = BasisBranch $ - Ref ("refs/basis/" ++ fromRef (Git.Ref.base adjbranch)) + Ref ("refs/basis/" <> fromRef' (Git.Ref.base adjbranch)) getAdjustment :: Branch -> Maybe Adjustment getAdjustment = fmap fst . adjustedToOriginal @@ -405,7 +406,8 @@ <||> (resolveMerge (Just updatedorig) tomerge True <&&> commitResolvedMerge commitmode) if merged then do - !mergecommit <- liftIO $ extractSha <$> readFile (tmpgit "HEAD") + !mergecommit <- liftIO $ extractSha + <$> S.readFile (tmpgit "HEAD") -- This is run after the commit lock is dropped. return $ postmerge mergecommit else return $ return False diff --git a/Annex/AdjustedBranch/Name.hs b/Annex/AdjustedBranch/Name.hs --- a/Annex/AdjustedBranch/Name.hs +++ b/Annex/AdjustedBranch/Name.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.AdjustedBranch.Name ( originalToAdjusted, adjustedToOriginal, @@ -18,14 +20,15 @@ import Utility.Misc import Control.Applicative -import Data.List +import Data.Char +import qualified Data.ByteString as S -adjustedBranchPrefix :: String +adjustedBranchPrefix :: S.ByteString adjustedBranchPrefix = "refs/heads/adjusted/" class SerializeAdjustment t where - serializeAdjustment :: t -> String - deserializeAdjustment :: String -> Maybe t + serializeAdjustment :: t -> S.ByteString + deserializeAdjustment :: S.ByteString -> Maybe t instance SerializeAdjustment Adjustment where serializeAdjustment (LinkAdjustment l) = @@ -33,7 +36,7 @@ serializeAdjustment (PresenceAdjustment p Nothing) = serializeAdjustment p serializeAdjustment (PresenceAdjustment p (Just l)) = - serializeAdjustment p ++ "-" ++ serializeAdjustment l + serializeAdjustment p <> "-" <> serializeAdjustment l deserializeAdjustment s = (LinkAdjustment <$> deserializeAdjustment s) <|> @@ -41,7 +44,7 @@ <|> (PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing) where - (s1, s2) = separate (== '-') s + (s1, s2) = separate' (== (fromIntegral (ord '-'))) s instance SerializeAdjustment LinkAdjustment where serializeAdjustment UnlockAdjustment = "unlocked" @@ -65,19 +68,21 @@ originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch originalToAdjusted orig adj = AdjBranch $ Ref $ - adjustedBranchPrefix ++ base ++ '(' : serializeAdjustment adj ++ ")" + adjustedBranchPrefix <> base <> "(" <> serializeAdjustment adj <> ")" where - base = fromRef (Git.Ref.base orig) + base = fromRef' (Git.Ref.base orig) type OrigBranch = Branch adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch) adjustedToOriginal b - | adjustedBranchPrefix `isPrefixOf` bs = do - let (base, as) = separate (== '(') (drop prefixlen bs) - adj <- deserializeAdjustment (takeWhile (/= ')') as) + | adjustedBranchPrefix `S.isPrefixOf` bs = do + let (base, as) = separate' (== openparen) (S.drop prefixlen bs) + adj <- deserializeAdjustment (S.takeWhile (/= closeparen) as) Just (adj, Git.Ref.branchRef (Ref base)) | otherwise = Nothing where - bs = fromRef b - prefixlen = length adjustedBranchPrefix + bs = fromRef' b + prefixlen = S.length adjustedBranchPrefix + openparen = fromIntegral (ord '(') + closeparen = fromIntegral (ord ')') diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -1,10 +1,12 @@ {- management of the git-annex branch - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Branch ( fullname, name, @@ -12,6 +14,7 @@ hasSibling, siblingBranches, create, + UpdateMade(..), update, forceUpdate, updateTo, @@ -29,7 +32,9 @@ withIndex, ) where +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Char8 as B8 import qualified Data.Set as S import qualified Data.Map as M import Data.Function @@ -38,6 +43,7 @@ import Control.Concurrent (threadDelay) import Annex.Common +import Types.BranchState import Annex.BranchState import Annex.Journal import Annex.GitOverlay @@ -55,7 +61,7 @@ import Git.LsTree (lsTreeParams) import qualified Git.HashObject import Annex.HashObject -import Git.Types (Ref(..), fromRef, RefDate, TreeItemType(..)) +import Git.Types (Ref(..), fromRef, fromRef', RefDate, TreeItemType(..)) import Git.FilePath import Annex.CatFile import Annex.Perms @@ -77,11 +83,11 @@ {- Fully qualified name of the branch. -} fullname :: Git.Ref -fullname = Git.Ref $ "refs/heads/" ++ fromRef name +fullname = Git.Ref $ "refs/heads/" <> fromRef' name {- Branch's name in origin. -} originname :: Git.Ref -originname = Git.Ref $ "origin/" ++ fromRef name +originname = Git.Ref $ "origin/" <> fromRef' name {- Does origin/git-annex exist? -} hasOrigin :: Annex Bool @@ -119,13 +125,18 @@ {- Ensures that the branch and index are up-to-date; should be - called before data is read from it. Runs only once per git-annex run. -} -update :: Annex () -update = runUpdateOnce $ void $ updateTo =<< siblingBranches +update :: Annex BranchState +update = runUpdateOnce $ journalClean <$$> updateTo =<< siblingBranches {- Forces an update even if one has already been run. -} -forceUpdate :: Annex Bool +forceUpdate :: Annex UpdateMade forceUpdate = updateTo =<< siblingBranches +data UpdateMade = UpdateMade + { refsWereMerged :: Bool + , journalClean :: Bool + } + {- Merges the specified Refs into the index, if they have any changes not - already in it. The Branch names are only used in the commit message; - it's even possible that the provided Branches have not been updated to @@ -144,13 +155,13 @@ - - Returns True if any refs were merged in, False otherwise. -} -updateTo :: [(Git.Sha, Git.Branch)] -> Annex Bool +updateTo :: [(Git.Sha, Git.Branch)] -> Annex UpdateMade updateTo pairs = ifM (annexMergeAnnexBranches <$> Annex.getGitConfig) ( updateTo' pairs - , return False + , return (UpdateMade False False) ) -updateTo' :: [(Git.Sha, Git.Branch)] -> Annex Bool +updateTo' :: [(Git.Sha, Git.Branch)] -> Annex UpdateMade updateTo' pairs = do -- ensure branch exists, and get its current ref branchref <- getBranch @@ -162,20 +173,35 @@ else do mergedrefs <- getMergedRefs filterM isnewer (excludeset mergedrefs unignoredrefs) - if null tomerge + journalclean <- if null tomerge {- Even when no refs need to be merged, the index - may still be updated if the branch has gotten ahead - - of the index. -} - then do - whenM (needUpdateIndex branchref) $ lockJournal $ \jl -> do + - of the index, or just if the journal is dirty. -} + then ifM (needUpdateIndex branchref) + ( lockJournal $ \jl -> do forceUpdateIndex jl branchref {- When there are journalled changes - as well as the branch being updated, - a commit needs to be done. -} when dirty $ - go branchref True [] jl - else lockJournal $ go branchref dirty tomerge - return $ not $ null tomerge + go branchref dirty [] jl + return True + , if dirty + then ifM (annexAlwaysCommit <$> Annex.getGitConfig) + ( do + lockJournal $ go branchref dirty [] + return True + , return False + ) + else return True + ) + else do + lockJournal $ go branchref dirty tomerge + return True + return $ UpdateMade + { refsWereMerged = not (null tomerge) + , journalClean = journalclean + } where excludeset s = filter (\(r, _) -> S.notMember r s) isnewer (r, _) = inRepo $ Git.Branch.changed fullname r @@ -217,8 +243,10 @@ - Returns an empty string if the file doesn't exist yet. -} get :: RawFilePath -> Annex L.ByteString get file = do - update - getLocal file + st <- update + if journalIgnorable st + then getRef fullname file + else getLocal file {- Like get, but does not merge the branch, so the info returned may not - reflect changes in remotes. @@ -270,7 +298,9 @@ {- Records new content of a file into the journal -} set :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex () -set = setJournalFile +set jl f c = do + journalChanged + setJournalFile jl f c {- Commit message used when making a commit of whatever data has changed - to the git-annex brach. -} @@ -327,9 +357,9 @@ where -- look for "parent ref" lines and return the refs commitparents = map (Git.Ref . snd) . filter isparent . - map (toassoc . decodeBL) . L.split newline + map (toassoc . L.toStrict) . L.split newline newline = fromIntegral (ord '\n') - toassoc = separate (== ' ') + toassoc = separate' (== (fromIntegral (ord ' '))) isparent (k,_) = k == "parent" {- The race can be detected by checking the commit's @@ -355,7 +385,7 @@ - that have not been committed yet. There may be duplicates in the list. -} files :: Annex [RawFilePath] files = do - update + _ <- update -- ++ forces the content of the first list to be buffered in memory, -- so use getJournalledFilesStale which should be much smaller most -- of the time. branchFiles will stream as the list is consumed. @@ -388,8 +418,8 @@ mergeIndex jl branches = do prepareModifyIndex jl hashhandle <- hashObjectHandle - ch <- catFileHandle - inRepo $ \g -> Git.UnionMerge.mergeIndex hashhandle ch g branches + withCatFileHandle $ \ch -> + inRepo $ \g -> Git.UnionMerge.mergeIndex hashhandle ch g branches {- Removes any stale git lock file, to avoid git falling over when - updating the index. @@ -410,14 +440,12 @@ withIndex :: Annex a -> Annex a withIndex = withIndex' False withIndex' :: Bool -> Annex a -> Annex a -withIndex' bootstrapping a = do - f <- fromRepo gitAnnexIndex - withIndexFile f $ do - checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do - unless bootstrapping create - createAnnexDirectory $ takeDirectory f - unless bootstrapping $ inRepo genIndex - a +withIndex' bootstrapping a = withIndexFile AnnexIndexFile $ \f -> do + checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do + unless bootstrapping create + createAnnexDirectory $ takeDirectory f + unless bootstrapping $ inRepo genIndex + a {- Updates the branch's index to reflect the current contents of the branch. - Any changes staged in the index will be preserved. @@ -438,8 +466,8 @@ needUpdateIndex :: Git.Ref -> Annex Bool needUpdateIndex branchref = do f <- fromRepo gitAnnexIndexStatus - committedref <- Git.Ref . firstLine <$> - liftIO (catchDefaultIO "" $ readFileStrict f) + committedref <- Git.Ref . firstLine' <$> + liftIO (catchDefaultIO mempty $ B.readFile f) return (committedref /= branchref) {- Record that the branch's index has been updated to correspond to a @@ -621,11 +649,12 @@ unlines $ map fromRef $ S.elems s getIgnoredRefs :: Annex (S.Set Git.Sha) -getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content +getIgnoredRefs = + S.fromList . mapMaybe Git.Sha.extractSha . B8.lines <$> content where content = do f <- fromRepo gitAnnexIgnoredRefs - liftIO $ catchDefaultIO "" $ readFile f + liftIO $ catchDefaultIO mempty $ B.readFile f addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex () addMergedRefs [] = return () @@ -643,11 +672,11 @@ getMergedRefs' :: Annex [(Git.Sha, Git.Branch)] getMergedRefs' = do f <- fromRepo gitAnnexMergedRefs - s <- liftIO $ catchDefaultIO "" $ readFile f - return $ map parse $ lines s + s <- liftIO $ catchDefaultIO mempty $ B.readFile f + return $ map parse $ B8.lines s where parse l = - let (s, b) = separate (== '\t') l + let (s, b) = separate' (== (fromIntegral (ord '\t'))) l in (Ref s, Ref b) {- Grafts a treeish into the branch at the specified location, diff --git a/Annex/BranchState.hs b/Annex/BranchState.hs --- a/Annex/BranchState.hs +++ b/Annex/BranchState.hs @@ -2,7 +2,7 @@ - - Runtime state about the git-annex branch. - - - Copyright 2011-2012 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -28,14 +28,55 @@ changeState $ \s -> s { indexChecked = True } {- Runs an action to update the branch, if it's not been updated before - - in this run of git-annex. -} -runUpdateOnce :: Annex () -> Annex () -runUpdateOnce a = unlessM (branchUpdated <$> getState) $ do - a - disableUpdate + - in this run of git-annex. + - + - The action should return True if anything that was in the journal + - before got staged (or if the journal was empty). That lets an opmisation + - be done: The journal then does not need to be checked going forward, + - until new information gets written to it. + -} +runUpdateOnce :: Annex Bool -> Annex BranchState +runUpdateOnce a = do + st <- getState + if branchUpdated st + then return st + else do + journalstaged <- a + let stf = \st' -> st' + { branchUpdated = True + , journalIgnorable = journalstaged + && not (journalNeverIgnorable st') + } + changeState stf + return (stf st) {- Avoids updating the branch. A useful optimisation when the branch - is known to have not changed, or git-annex won't be relying on info - from it. -} disableUpdate :: Annex () disableUpdate = changeState $ \s -> s { branchUpdated = True } + +{- Called when a change is made to the journal. -} +journalChanged :: Annex () +journalChanged = do + -- Optimisation: Typically journalIgnorable will already be True + -- (when one thing gets journalled, often other things do to), + -- so avoid an unnecessary write to the MVar that changeState + -- would do. + -- + -- This assumes that another thread is not changing journalIgnorable + -- at the same time, but since runUpdateOnce is the only + -- thing that changes it, and it only runs once, that + -- should not happen. + st <- getState + when (journalIgnorable st) $ + changeState $ \st' -> st' { journalIgnorable = False } + +{- When git-annex is somehow interactive, eg in --batch mode, + - and needs to always notice changes made to the journal by other + - processes, this disables optimisations that avoid normally reading the + - journal. + -} +enableInteractiveJournalAccess :: Annex () +enableInteractiveJournalAccess = changeState $ + \s -> s { journalNeverIgnorable = True } diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -1,10 +1,12 @@ {- git cat-file interface, with handle automatically stored in the Annex monad - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Annex.CatFile ( catFile, catFileDetails, @@ -12,7 +14,7 @@ catTree, catCommit, catObjectDetails, - catFileHandle, + withCatFileHandle, catObjectMetaData, catFileStop, catKey, @@ -27,6 +29,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import System.PosixCompat.Types +import Control.Concurrent.STM import Annex.Common import qualified Git @@ -39,64 +42,94 @@ import Annex.Link import Annex.CurrentBranch import Types.AdjustedBranch +import Types.CatFileHandles +import Utility.ResourcePool catFile :: Git.Branch -> RawFilePath -> Annex L.ByteString -catFile branch file = do - h <- catFileHandle +catFile branch file = withCatFileHandle $ \h -> liftIO $ Git.CatFile.catFile h branch file catFileDetails :: Git.Branch -> RawFilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType)) -catFileDetails branch file = do - h <- catFileHandle +catFileDetails branch file = withCatFileHandle $ \h -> liftIO $ Git.CatFile.catFileDetails h branch file catObject :: Git.Ref -> Annex L.ByteString -catObject ref = do - h <- catFileHandle +catObject ref = withCatFileHandle $ \h -> liftIO $ Git.CatFile.catObject h ref catObjectMetaData :: Git.Ref -> Annex (Maybe (Sha, Integer, ObjectType)) -catObjectMetaData ref = do - h <- catFileHandle +catObjectMetaData ref = withCatFileHandle $ \h -> liftIO $ Git.CatFile.catObjectMetaData h ref catTree :: Git.Ref -> Annex [(FilePath, FileMode)] -catTree ref = do - h <- catFileHandle +catTree ref = withCatFileHandle $ \h -> liftIO $ Git.CatFile.catTree h ref catCommit :: Git.Ref -> Annex (Maybe Commit) -catCommit ref = do - h <- catFileHandle +catCommit ref = withCatFileHandle $ \h -> liftIO $ Git.CatFile.catCommit h ref catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha, ObjectType)) -catObjectDetails ref = do - h <- catFileHandle +catObjectDetails ref = withCatFileHandle $ \h -> liftIO $ Git.CatFile.catObjectDetails h ref {- There can be multiple index files, and a different cat-file is needed - - for each. This is selected by setting GIT_INDEX_FILE in the gitEnv. -} -catFileHandle :: Annex Git.CatFile.CatFileHandle -catFileHandle = do - m <- Annex.getState Annex.catfilehandles + - for each. That is selected by setting GIT_INDEX_FILE in the gitEnv + - before running this. -} +withCatFileHandle :: (Git.CatFile.CatFileHandle -> Annex a) -> Annex a +withCatFileHandle a = do + cfh <- Annex.getState Annex.catfilehandles indexfile <- fromMaybe "" . maybe Nothing (lookup indexEnv) <$> fromRepo gitEnv - case M.lookup indexfile m of - Just h -> return h - Nothing -> do - h <- inRepo Git.CatFile.catFileStart - let m' = M.insert indexfile h m - Annex.changeState $ \s -> s { Annex.catfilehandles = m' } - return h + p <- case cfh of + CatFileHandlesNonConcurrent m -> case M.lookup indexfile m of + Just p -> return p + Nothing -> do + p <- mkResourcePoolNonConcurrent startcatfile + let !m' = M.insert indexfile p m + Annex.changeState $ \s -> s { Annex.catfilehandles = CatFileHandlesNonConcurrent m' } + return p + CatFileHandlesPool tm -> do + m <- liftIO $ atomically $ takeTMVar tm + case M.lookup indexfile m of + Just p -> do + liftIO $ atomically $ putTMVar tm m + return p + Nothing -> do + p <- mkResourcePool maxCatFiles + let !m' = M.insert indexfile p m + liftIO $ atomically $ putTMVar tm m' + return p + withResourcePool p startcatfile a + where + startcatfile = inRepo Git.CatFile.catFileStart +{- A lot of git cat-file processes are unlikely to improve concurrency, + - because a query to them takes only a little bit of CPU, and tends to be + - bottlenecked on disk. Also, they each open a number of files, so + - using too many might run out of file handles. So, only start a maximum + - of 2. + - + - Note that each different index file gets its own pool of cat-files; + - this is the size of each pool. In all, 4 times this many cat-files + - may end up running. + -} +maxCatFiles :: Int +maxCatFiles = 2 + {- Stops all running cat-files. Should only be run when it's known that - nothing is using the handles, eg at shutdown. -} catFileStop :: Annex () catFileStop = do - m <- Annex.withState $ pure . \s -> - (s { Annex.catfilehandles = M.empty }, Annex.catfilehandles s) - liftIO $ mapM_ Git.CatFile.catFileStop (M.elems m) + cfh <- Annex.getState Annex.catfilehandles + m <- case cfh of + CatFileHandlesNonConcurrent m -> do + Annex.changeState $ \s -> s { Annex.catfilehandles = CatFileHandlesNonConcurrent M.empty } + return m + CatFileHandlesPool tm -> + liftIO $ atomically $ swapTMVar tm M.empty + liftIO $ forM_ (M.elems m) $ \p -> + freeResourcePool p Git.CatFile.catFileStop {- From ref to a symlink or a pointer file, get the key. -} catKey :: Ref -> Annex (Maybe Key) diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs --- a/Annex/ChangedRefs.hs +++ b/Annex/ChangedRefs.hs @@ -1,6 +1,6 @@ {- Waiting for changed git refs - - - Copyright 2014-216 Joey Hess + - Copyright 2014-2016 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -24,13 +24,14 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Concurrent.STM.TBMChan +import qualified Data.ByteString as S newtype ChangedRefs = ChangedRefs [Git.Ref] deriving (Show) instance Proto.Serializable ChangedRefs where serialize (ChangedRefs l) = unwords $ map Git.fromRef l - deserialize = Just . ChangedRefs . map Git.Ref . words + deserialize = Just . ChangedRefs . map (Git.Ref . encodeBS) . words data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha) @@ -97,7 +98,7 @@ | ".lock" `isSuffixOf` reffile = noop | otherwise = void $ do sha <- catchDefaultIO Nothing $ - extractSha <$> readFile reffile + extractSha <$> S.readFile reffile -- When the channel is full, there is probably no reader -- running, or ref changes have been occuring very fast, -- so it's ok to not write the change to it. diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs --- a/Annex/CheckAttr.hs +++ b/Annex/CheckAttr.hs @@ -1,19 +1,22 @@ {- git check-attr interface, with handle automatically stored in the Annex monad - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Annex.CheckAttr ( checkAttr, - checkAttrHandle, checkAttrStop, + mkConcurrentCheckAttrHandle, ) where import Annex.Common import qualified Git.CheckAttr as Git import qualified Annex +import Utility.ResourcePool +import Types.Concurrency +import Annex.Concurrent.Utility {- All gitattributes used by git-annex. -} annexAttrs :: [Git.Attr] @@ -24,21 +27,38 @@ ] checkAttr :: Git.Attr -> FilePath -> Annex String -checkAttr attr file = do - h <- checkAttrHandle +checkAttr attr file = withCheckAttrHandle $ \h -> liftIO $ Git.checkAttr h attr file -checkAttrHandle :: Annex Git.CheckAttrHandle -checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle +withCheckAttrHandle :: (Git.CheckAttrHandle -> Annex a) -> Annex a +withCheckAttrHandle a = + maybe mkpool go =<< Annex.getState Annex.checkattrhandle where - startup = do - h <- inRepo $ Git.checkAttrStart annexAttrs - Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h } - return h + go p = withResourcePool p start a + start = inRepo $ Git.checkAttrStart annexAttrs + mkpool = do + -- This only runs in non-concurrent code paths; + -- a concurrent pool is set up earlier when needed. + p <- mkResourcePoolNonConcurrent start + Annex.changeState $ \s -> s { Annex.checkattrhandle = Just p } + go p +mkConcurrentCheckAttrHandle :: Concurrency -> Annex (ResourcePool Git.CheckAttrHandle) +mkConcurrentCheckAttrHandle c = + Annex.getState Annex.checkattrhandle >>= \case + Just p@(ResourcePool {}) -> return p + _ -> mkResourcePool =<< liftIO (maxCheckAttrs c) + +{- git check-attr is typically CPU bound, and is not likely to be the main + - bottleneck for any command. So limit to the number of CPU cores, maximum, + - while respecting the -Jn value. + -} +maxCheckAttrs :: Concurrency -> IO Int +maxCheckAttrs = concurrencyUpToCpus + checkAttrStop :: Annex () checkAttrStop = maybe noop stop =<< Annex.getState Annex.checkattrhandle where - stop h = do - liftIO $ Git.checkAttrStop h + stop p = do + liftIO $ freeResourcePool p Git.checkAttrStop Annex.changeState $ \s -> s { Annex.checkattrhandle = Nothing } diff --git a/Annex/CheckIgnore.hs b/Annex/CheckIgnore.hs --- a/Annex/CheckIgnore.hs +++ b/Annex/CheckIgnore.hs @@ -1,37 +1,57 @@ {- git check-ignore interface, with handle automatically stored in - the Annex monad - - - Copyright 2013 Joey Hess + - Copyright 2013-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Annex.CheckIgnore ( checkIgnored, - checkIgnoreHandle, - checkIgnoreStop + checkIgnoreStop, + mkConcurrentCheckIgnoreHandle, ) where import Annex.Common import qualified Git.CheckIgnore as Git import qualified Annex +import Utility.ResourcePool +import Types.Concurrency +import Annex.Concurrent.Utility checkIgnored :: FilePath -> Annex Bool -checkIgnored file = go =<< checkIgnoreHandle - where - go h = liftIO $ Git.checkIgnored h file +checkIgnored file = withCheckIgnoreHandle $ \h -> + liftIO $ Git.checkIgnored h file -checkIgnoreHandle :: Annex Git.CheckIgnoreHandle -checkIgnoreHandle = maybe startup return =<< Annex.getState Annex.checkignorehandle +withCheckIgnoreHandle :: (Git.CheckIgnoreHandle -> Annex a) -> Annex a +withCheckIgnoreHandle a = + maybe mkpool go =<< Annex.getState Annex.checkignorehandle where - startup = do - h <- inRepo Git.checkIgnoreStart - Annex.changeState $ \s -> s { Annex.checkignorehandle = Just h } - return h + go p = withResourcePool p start a + start = inRepo Git.checkIgnoreStart + mkpool = do + -- This only runs in non-concurrent code paths; + -- a concurrent pool is set up earlier when needed. + p <- mkResourcePoolNonConcurrent start + Annex.changeState $ \s -> s { Annex.checkignorehandle = Just p } + go p +mkConcurrentCheckIgnoreHandle :: Concurrency -> Annex (ResourcePool Git.CheckIgnoreHandle) +mkConcurrentCheckIgnoreHandle c = + Annex.getState Annex.checkignorehandle >>= \case + Just p@(ResourcePool {}) -> return p + _ -> mkResourcePool =<< liftIO (maxCheckIgnores c) + +{- git check-ignore is typically CPU bound, and is not likely to be the main + - bottleneck for any command. So limit to the number of CPU cores, maximum, + - while respecting the -Jn value. + -} +maxCheckIgnores :: Concurrency -> IO Int +maxCheckIgnores = concurrencyUpToCpus + checkIgnoreStop :: Annex () checkIgnoreStop = maybe noop stop =<< Annex.getState Annex.checkignorehandle where - stop h = do - liftIO $ Git.checkIgnoreStop h + stop p = do + liftIO $ freeResourcePool p Git.checkIgnoreStop Annex.changeState $ \s -> s { Annex.checkignorehandle = Nothing } diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -1,6 +1,6 @@ {- git-annex concurrent state - - - Copyright 2015-2019 Joey Hess + - Copyright 2015-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,16 +10,36 @@ import Annex import Annex.Common import qualified Annex.Queue -import Annex.CatFile +import Annex.Action +import Types.Concurrency +import Types.WorkerPool +import Types.CatFileHandles import Annex.CheckAttr -import Annex.HashObject import Annex.CheckIgnore -import Types.WorkerPool +import Remote.List import Control.Concurrent import Control.Concurrent.STM import qualified Data.Map as M +setConcurrency :: Concurrency -> Annex () +setConcurrency NonConcurrent = Annex.changeState $ \s -> s + { Annex.concurrency = NonConcurrent + } +setConcurrency c = do + cfh <- Annex.getState Annex.catfilehandles + cfh' <- case cfh of + CatFileHandlesNonConcurrent _ -> liftIO catFileHandlesPool + CatFileHandlesPool _ -> pure cfh + cah <- mkConcurrentCheckAttrHandle c + cih <- mkConcurrentCheckIgnoreHandle c + Annex.changeState $ \s -> s + { Annex.concurrency = c + , Annex.catfilehandles = cfh' + , Annex.checkattrhandle = Just cah + , Annex.checkignorehandle = Just cih + } + {- Allows forking off a thread that uses a copy of the current AnnexState - to run an Annex action. - @@ -46,14 +66,22 @@ -} dupState :: Annex AnnexState dupState = do + -- Make sure that some expensive actions have been done before + -- starting threads. This way the state has them already run, + -- and each thread won't try to do them. + _ <- remoteList + st <- Annex.getState id - return $ st + -- Make sure that concurrency is enabled, if it was not already, + -- so the concurrency-safe resource pools are set up. + st' <- case Annex.concurrency st of + NonConcurrent -> do + setConcurrency (Concurrent 1) + Annex.getState id + _ -> return st + return $ st' -- each thread has its own repoqueue { Annex.repoqueue = Nothing - -- avoid sharing eg, open file handles - , Annex.catfilehandles = M.empty - , Annex.checkattrhandle = Nothing - , Annex.checkignorehandle = Nothing } {- Merges the passed AnnexState into the current Annex state. @@ -65,14 +93,6 @@ uncurry addCleanup Annex.Queue.mergeFrom st' changeState $ \s -> s { errcounter = errcounter s + errcounter st' } - -{- Stops all long-running git query processes. -} -stopCoProcesses :: Annex () -stopCoProcesses = do - catFileStop - checkAttrStop - hashObjectStop - checkIgnoreStop {- Runs an action and makes the current thread have the specified stage - while doing so. If too many other threads are running in the specified diff --git a/Annex/Concurrent/Utility.hs b/Annex/Concurrent/Utility.hs new file mode 100644 --- /dev/null +++ b/Annex/Concurrent/Utility.hs @@ -0,0 +1,23 @@ +{- git-annex concurrency utilities + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.Concurrent.Utility where + +import Types.Concurrency + +import GHC.Conc + +{- Honor the requested level of concurrency, but only up to the number of + - CPU cores. Useful for things that are known to be CPU bound. -} +concurrencyUpToCpus :: Concurrency -> IO Int +concurrencyUpToCpus c = do + let cn = case c of + Concurrent n -> n + NonConcurrent -> 1 + ConcurrentPerCpu -> 1 + pn <- getNumProcessors + return (min cn pn) diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -74,6 +74,7 @@ import Annex.Perms import Annex.Link import Annex.LockPool +import Annex.WorkerPool import Messages.Progress import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..)) import qualified Types.Remote @@ -87,7 +88,6 @@ import Utility.InodeCache import Annex.Content.LowLevel import Annex.Content.PointerFile -import Annex.Concurrent import Types.WorkerPool import qualified Utility.RawFilePath as R diff --git a/Annex/Export.hs b/Annex/Export.hs --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -14,7 +14,6 @@ import qualified Git import qualified Types.Remote as Remote import Messages -import Utility.FileSystemEncoding import Control.Applicative import Data.Maybe @@ -34,7 +33,7 @@ where mk (Just k) = AnnexKey k mk Nothing = GitKey $ mkKey $ \k -> k - { keyName = encodeBS $ Git.fromRef sha + { keyName = Git.fromRef' sha , keyVariety = SHA1Key (HasExt False) , keySize = Nothing , keyMtime = Nothing diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -1,15 +1,19 @@ {- Temporarily changing the files git uses. - - - Copyright 2014-2016 Joey Hess + - Copyright 2014-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -module Annex.GitOverlay where +module Annex.GitOverlay ( + module Annex.GitOverlay, + AltIndexFile(..), +) where import qualified Control.Exception as E import Annex.Common +import Types.IndexFiles import Git import Git.Types import Git.Index @@ -18,13 +22,8 @@ import qualified Annex.Queue {- Runs an action using a different git index file. -} -withIndexFile :: FilePath -> Annex a -> Annex a -withIndexFile f a = do - f' <- liftIO $ indexEnvVal f - withAltRepo - (usecachedgitenv f' $ \g -> addGitEnv g indexEnv f') - (\g g' -> g' { gitEnv = gitEnv g }) - a +withIndexFile :: AltIndexFile -> (FilePath -> Annex a) -> Annex a +withIndexFile i = withAltRepo usecachedgitenv restoregitenv where -- This is an optimisation. Since withIndexFile is run repeatedly, -- typically with the same file, and addGitEnv uses the slow @@ -37,22 +36,40 @@ -- Git object in the first place, but it's more efficient to let -- the environment be inherited in all calls to git where it -- does not need to be modified.) - usecachedgitenv f' m g = case gitEnv g of - Just _ -> liftIO $ m g + -- + -- Also, the use of AltIndexFile avoids needing to construct + -- the FilePath each time, which saves enough time to be worth the + -- added complication. + usecachedgitenv g = case gitEnv g of Nothing -> Annex.withState $ \s -> case Annex.cachedgitenv s of - Just (cachedf, cachede) | f' == cachedf -> - return (s, g { gitEnv = Just cachede }) + Just (cachedi, cachedf, cachede) | i == cachedi -> + return (s, (g { gitEnv = Just cachede }, cachedf)) _ -> do - g' <- m g - return (s { Annex.cachedgitenv = (,) <$> Just f' <*> gitEnv g' }, g') + r@(g', f) <- addindex g + let cache = (,,) + <$> Just i + <*> Just f + <*> gitEnv g' + return (s { Annex.cachedgitenv = cache }, r) + Just _ -> liftIO $ addindex g + + addindex g = do + f <- indexEnvVal $ case i of + AnnexIndexFile -> gitAnnexIndex g + ViewIndexFile -> gitAnnexViewIndex g + g' <- addGitEnv g indexEnv f + return (g', f) + + restoregitenv g g' = g' { gitEnv = gitEnv g } {- Runs an action using a different git work tree. - - Smudge and clean filters are disabled in this work tree. -} withWorkTree :: FilePath -> Annex a -> Annex a -withWorkTree d = withAltRepo - (\g -> return $ g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig }) +withWorkTree d a = withAltRepo + (\g -> return $ (g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig }, ())) (\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g }) + (const a) where modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) } modlocation _ = error "withWorkTree of non-local git repo" @@ -70,29 +87,29 @@ - Needs git 2.2.0 or newer. -} withWorkTreeRelated :: FilePath -> Annex a -> Annex a -withWorkTreeRelated d = withAltRepo modrepo unmodrepo +withWorkTreeRelated d a = withAltRepo modrepo unmodrepo (const a) where modrepo g = liftIO $ do g' <- addGitEnv g "GIT_COMMON_DIR" =<< absPath (fromRawFilePath (localGitDir g)) g'' <- addGitEnv g' "GIT_DIR" d - return (g'' { gitEnvOverridesGitDir = True }) + return (g'' { gitEnvOverridesGitDir = True }, ()) unmodrepo g g' = g' { gitEnv = gitEnv g , gitEnvOverridesGitDir = gitEnvOverridesGitDir g } withAltRepo - :: (Repo -> Annex Repo) + :: (Repo -> Annex (Repo, t)) -- ^ modify Repo -> (Repo -> Repo -> Repo) -- ^ undo modifications; first Repo is the original and second -- is the one after running the action. - -> Annex a + -> (t -> Annex a) -> Annex a withAltRepo modrepo unmodrepo a = do g <- gitRepo - g' <- modrepo g + (g', t) <- modrepo g q <- Annex.Queue.get v <- tryNonAsync $ do Annex.changeState $ \s -> s @@ -101,7 +118,7 @@ -- with the modified repo. , Annex.repoqueue = Nothing } - a + a t void $ tryNonAsync Annex.Queue.flush Annex.changeState $ \s -> s { Annex.repo = unmodrepo g (Annex.repo s) diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -122,7 +122,9 @@ Nothing -> pure committedtree Just dir -> let subtreeref = Ref $ - fromRef committedtree ++ ":" ++ fromRawFilePath (getTopFilePath dir) + fromRef' committedtree + <> ":" + <> getTopFilePath dir in fromMaybe emptyTree <$> inRepo (Git.Ref.tree subtreeref) updateexportdb importedtree diff --git a/Annex/Multicast.hs b/Annex/Multicast.hs --- a/Annex/Multicast.hs +++ b/Annex/Multicast.hs @@ -7,7 +7,7 @@ module Annex.Multicast where -import Config.Files +import Annex.Path import Utility.Env import Utility.PartialPrelude @@ -22,7 +22,7 @@ multicastCallbackEnv :: IO (FilePath, [(String, String)], Handle) multicastCallbackEnv = do - gitannex <- readProgramFile + gitannex <- programPath -- This will even work on Windows (rfd, wfd) <- createPipeFd rh <- fdToHandle rfd diff --git a/Annex/Path.hs b/Annex/Path.hs --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -32,5 +32,16 @@ exe <- getExecutablePath p <- if isAbsolute exe then return exe - else readProgramFile + else fromMaybe exe <$> readProgramFile maybe cannotFindProgram return =<< searchPath p + +{- Returns the path for git-annex that is recorded in the programFile. -} +readProgramFile :: IO (Maybe FilePath) +readProgramFile = do + programfile <- programFile + headMaybe . lines <$> readFile programfile + +cannotFindProgram :: IO a +cannotFindProgram = do + f <- programFile + giveup $ "cannot find git-annex program in PATH or in " ++ f diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -22,7 +22,6 @@ import Remote.List import Logs.Remote import Logs.Trust -import qualified Git.Config import qualified Types.Remote as Remote import Git.Types (RemoteName) @@ -99,7 +98,7 @@ _ -> return () where configured rc = fromMaybe False $ - Git.Config.isTrueFalse . fromProposedAccepted + trueFalseParser' . fromProposedAccepted =<< M.lookup autoEnableField rc canenable u = (/= DeadTrusted) <$> lookupTrust u getenabledremotes = M.fromList diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -17,7 +17,6 @@ import Types.ProposedAccepted import Types.RemoteConfig import Types.GitConfig -import qualified Git.Config import qualified Data.Map as M import qualified Data.Set as S @@ -242,8 +241,16 @@ yesno _ = Nothing trueFalseParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser -trueFalseParser f v fd = genParser Git.Config.isTrueFalse f v fd +trueFalseParser f v fd = genParser trueFalseParser' f v fd (Just (ValueDesc "true or false")) + +-- Not using Git.Config.isTrueFalse because git supports +-- a lot of other values for true and false in its configs, +-- and this is not a git config and we want to avoid that mess. +trueFalseParser' :: String -> Maybe Bool +trueFalseParser' "true" = Just True +trueFalseParser' "false" = Just False +trueFalseParser' _ = Nothing genParser :: Typeable t diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs --- a/Annex/TaggedPush.hs +++ b/Annex/TaggedPush.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.TaggedPush where import Annex.Common @@ -16,6 +18,8 @@ import qualified Git.Branch import Utility.Base64 +import qualified Data.ByteString as S + {- Converts a git branch into a branch that is tagged with a UUID, typically - the UUID of the repo that will be pushing it, and possibly with other - information. @@ -31,11 +35,11 @@ - refs, per git-check-ref-format. -} toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Ref -toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes +toTaggedBranch u info b = Git.Ref $ S.intercalate "/" $ catMaybes [ Just "refs/synced" , Just $ fromUUID u - , toB64 <$> info - , Just $ Git.fromRef $ Git.Ref.base b + , toB64' . encodeBS <$> info + , Just $ Git.fromRef' $ Git.Ref.base b ] fromTaggedBranch :: Git.Ref -> Maybe (UUID, Maybe String) diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -30,9 +30,9 @@ import Annex.LockPool import Types.Key import qualified Types.Remote as Remote -import Annex.Concurrent import Types.Concurrency import Types.WorkerPool +import Annex.WorkerPool import Control.Concurrent import qualified Data.Map.Strict as M diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -111,7 +111,7 @@ setUUID :: Git.Repo -> UUID -> IO Git.Repo setUUID r u = do let s = encodeBS' $ show configkeyUUID ++ "=" ++ fromUUID u - Git.Config.store s r + Git.Config.store s Git.Config.ConfigList r -- Dummy uuid for the whole web. Do not alter. webUUID :: UUID diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -177,9 +177,5 @@ Right b -> return b Left err -> warning err >> return False -getUrlInfo :: U.URLString -> U.UrlOptions -> Annex U.UrlInfo -getUrlInfo url uo = liftIO (U.getUrlInfo url uo) >>= \case - Right i -> return i - Left err -> do - warning err - return $ U.UrlInfo False Nothing Nothing +getUrlInfo :: U.URLString -> U.UrlOptions -> Annex (Either String U.UrlInfo) +getUrlInfo url uo = liftIO (U.getUrlInfo url uo) diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -412,9 +412,7 @@ - Note that the file does not necessarily exist, or can contain - info staged for an old view. -} withViewIndex :: Annex a -> Annex a -withViewIndex a = do - f <- fromRepo gitAnnexViewIndex - withIndexFile f a +withViewIndex = withIndexFile ViewIndexFile . const {- Generates a branch for a view, using the view index file - to make a commit to the view branch. The view branch is not diff --git a/Annex/WorkerPool.hs b/Annex/WorkerPool.hs new file mode 100644 --- /dev/null +++ b/Annex/WorkerPool.hs @@ -0,0 +1,126 @@ +{- git-annex worker thread pool + - + - Copyright 2015-2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.WorkerPool where + +import Annex +import Annex.Common +import Types.WorkerPool + +import Control.Concurrent +import Control.Concurrent.STM + +{- Runs an action and makes the current thread have the specified stage + - while doing so. If too many other threads are running in the specified + - stage, waits for one of them to become idle. + - + - Noop if the current thread already has the requested stage, or if the + - current thread is not in the worker pool, or if concurrency is not + - enabled. + - + - Also a noop if the stage is not one of the stages that the worker pool + - uses. + -} +enteringStage :: WorkerStage -> Annex a -> Annex a +enteringStage newstage a = Annex.getState Annex.workers >>= \case + Nothing -> a + Just tv -> do + mytid <- liftIO myThreadId + let set = changeStageTo mytid tv (const newstage) + let restore = maybe noop (void . changeStageTo mytid tv . const) + bracket set restore (const a) + +{- Transition the current thread to the initial stage. + - This is done once the thread is ready to begin work. + -} +enteringInitialStage :: Annex () +enteringInitialStage = Annex.getState Annex.workers >>= \case + Nothing -> noop + Just tv -> do + mytid <- liftIO myThreadId + void $ changeStageTo mytid tv initialStage + +{- This needs to leave the WorkerPool with the same number of + - idle and active threads, and with the same number of threads for each + - WorkerStage. So, all it can do is swap the WorkerStage of our thread's + - ActiveWorker with an IdleWorker. + - + - Must avoid a deadlock if all worker threads end up here at the same + - time, or if there are no suitable IdleWorkers left. So if necessary + - we first replace our ActiveWorker with an IdleWorker in the pool, to allow + - some other thread to use it, before waiting for a suitable IdleWorker + - for us to use. + - + - Note that the spareVals in the WorkerPool does not get anything added to + - it when adding the IdleWorker, so there will for a while be more IdleWorkers + - in the pool than spareVals. That does not prevent other threads that call + - this from using them though, so it's fine. + -} +changeStageTo :: ThreadId -> TMVar (WorkerPool AnnexState) -> (UsedStages -> WorkerStage) -> Annex (Maybe WorkerStage) +changeStageTo mytid tv getnewstage = liftIO $ + replaceidle >>= maybe + (return Nothing) + (either waitidle (return . Just)) + where + replaceidle = atomically $ do + pool <- takeTMVar tv + let newstage = getnewstage (usedStages pool) + let notchanging = do + putTMVar tv pool + return Nothing + if memberStage newstage (usedStages pool) + then case removeThreadIdWorkerPool mytid pool of + Just ((myaid, oldstage), pool') + | oldstage /= newstage -> case getIdleWorkerSlot newstage pool' of + Nothing -> do + putTMVar tv $ + addWorkerPool (IdleWorker oldstage) pool' + return $ Just $ Left (myaid, newstage, oldstage) + Just pool'' -> do + -- optimisation + putTMVar tv $ + addWorkerPool (IdleWorker oldstage) $ + addWorkerPool (ActiveWorker myaid newstage) pool'' + return $ Just $ Right oldstage + | otherwise -> notchanging + _ -> notchanging + else notchanging + + waitidle (myaid, newstage, oldstage) = atomically $ do + pool <- waitIdleWorkerSlot newstage =<< takeTMVar tv + putTMVar tv $ addWorkerPool (ActiveWorker myaid newstage) pool + return (Just oldstage) + +-- | Waits until there's an idle StartStage worker in the worker pool, +-- removes it from the pool, and returns its state. +-- +-- If the worker pool is not already allocated, returns Nothing. +waitStartWorkerSlot :: TMVar (WorkerPool Annex.AnnexState) -> STM (Maybe (Annex.AnnexState, WorkerStage)) +waitStartWorkerSlot tv = do + pool <- takeTMVar tv + st <- go pool + return $ Just (st, StartStage) + where + go pool = case spareVals pool of + [] -> retry + (v:vs) -> do + let pool' = pool { spareVals = vs } + putTMVar tv =<< waitIdleWorkerSlot StartStage pool' + return v + +waitIdleWorkerSlot :: WorkerStage -> WorkerPool Annex.AnnexState -> STM (WorkerPool Annex.AnnexState) +waitIdleWorkerSlot wantstage = maybe retry return . getIdleWorkerSlot wantstage + +getIdleWorkerSlot :: WorkerStage -> WorkerPool Annex.AnnexState -> Maybe (WorkerPool Annex.AnnexState) +getIdleWorkerSlot wantstage pool = do + l <- findidle [] (workerList pool) + return $ pool { workerList = l } + where + findidle _ [] = Nothing + findidle c ((IdleWorker stage):rest) + | stage == wantstage = Just (c ++ rest) + findidle c (w:rest) = findidle (w:c) rest diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -50,6 +50,7 @@ import Utility.HumanTime import qualified BuildInfo import Annex.Perms +import Annex.BranchState import Utility.LogFile #ifdef mingw32_HOST_OS import Utility.Env @@ -70,8 +71,8 @@ - stdout and stderr descriptors. -} startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do - Annex.changeState $ \s -> s { Annex.daemon = True } + enableInteractiveJournalAccess pidfile <- fromRepo gitAnnexPidFile logfile <- fromRepo gitAnnexLogFile liftIO $ debugM desc $ "logging to " ++ logfile diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -216,7 +216,8 @@ , return $ Just r ) else return Nothing - haddiverged <- liftAnnex Annex.Branch.forceUpdate + haddiverged <- Annex.Branch.refsWereMerged + <$> liftAnnex Annex.Branch.forceUpdate forM_ remotes $ \r -> liftAnnex $ Command.Sync.mergeRemote r currentbranch Command.Sync.mergeConfig def diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -65,7 +65,8 @@ | ".lock" `isSuffixOf` file = noop | isAnnexBranch file = do branchChanged - diverged <- liftAnnex Annex.Branch.forceUpdate + diverged <- Annex.Branch.refsWereMerged + <$> liftAnnex Annex.Branch.forceUpdate when diverged $ do updateExportTreeFromLogAll queueDeferredDownloads "retrying deferred download" Later @@ -109,6 +110,6 @@ n = '/' : Git.fromRef Annex.Branch.name fileToBranch :: FilePath -> Git.Ref -fileToBranch f = Git.Ref $ "refs" base +fileToBranch f = Git.Ref $ encodeBS' $ "refs" base where base = Prelude.last $ split "/refs/" f diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -330,7 +330,7 @@ addLink file link mk = do debug ["add symlink", file] liftAnnex $ do - v <- catObjectDetails $ Ref $ ':':file + v <- catObjectDetails $ Ref $ encodeBS' $ ':':file case v of Just (currlink, sha, _type) | s2w8 link == L.unpack currlink -> diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -225,20 +225,22 @@ {- Finds where the old version was installed. -} oldVersionLocation :: IO FilePath -oldVersionLocation = do - pdir <- parentDir <$> readProgramFile +oldVersionLocation = readProgramFile >>= \case + Nothing -> error "Cannot find old distribution bundle; not upgrading." + Just pf -> do + let pdir = parentDir pf #ifdef darwin_HOST_OS - let dirs = splitDirectories pdir - {- It will probably be deep inside a git-annex.app directory. -} - let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of - Nothing -> pdir - Just i -> joinPath (take (i + 1) dirs) + let dirs = splitDirectories pdir + {- It will probably be deep inside a git-annex.app directory. -} + let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of + Nothing -> pdir + Just i -> joinPath (take (i + 1) dirs) #else - let olddir = pdir + let olddir = pdir #endif - when (null olddir) $ - error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")" - return olddir + when (null olddir) $ + error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")" + return olddir {- Finds a place to install the new version. - Generally, put it in the parent directory of where the old version was @@ -344,10 +346,9 @@ - trustedkeys.gpg, next to the git-annex program. -} verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool -verifyDistributionSig gpgcmd sig = do - p <- readProgramFile - if isAbsolute p - then withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do +verifyDistributionSig gpgcmd sig = readProgramFile >>= \case + Just p | isAbsolute p -> + withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do let trustedkeys = takeDirectory p "trustedkeys.gpg" boolGpgCmd gpgcmd [ Param "--no-default-keyring" @@ -360,4 +361,4 @@ , Param "--verify" , File sig ] - else return False + _ -> return False diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -33,7 +33,7 @@ import Command.P2P (unusedPeerRemoteName, PairingResult(..)) import P2P.Address import Git -import Config.Files +import Annex.Path import Utility.Process.Transcript import qualified Data.Map as M @@ -72,7 +72,7 @@ enableTor :: Handler () enableTor = do - gitannex <- liftIO readProgramFile + gitannex <- liftIO programPath (transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing if ok -- Reload remotedameon so it's serving the tor hidden diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -28,7 +28,7 @@ -- so skewing the runtime of the first action that will be -- benchmarked. Annex.Branch.commit "benchmarking" - Annex.Branch.update + _ <- Annex.Branch.update l <- mapM parsesubcommand $ split [";"] userinput return $ do forM_ l $ \(cmd, seek, st) -> diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,52 @@ +git-annex (8.20200501) upstream; urgency=medium + + * Improve git-annex's ability to find the path to its program, + especially when it needs to run itself in another repo to upgrade it. + * adb: Better messages when the adb command is not installed. + * Sped up query commands that read the git-annex branch by around 9%. + * Various speed improvements gained by using ByteStrings for git refs and + shas. + * Fix a potential failure to parse git config. + * Support boolean git configs that are represented by the name of the + setting with no value, eg "core.bare" is the same as "core.bare = true". + * When parsing git configs, support all the documented ways to write + true and false, including "yes", "on", "1", etc. + * Fix --batch commands (and git-annex info) to accept absolute filenames + for unlocked files, which already worked for locked files. + * Avoid repeatedly opening keys db when accessing a local git remote + and -J is used. + * Avoid running a large number of git cat-file child processes when run + with a large -J value. + * Avoid running with more git check-attr and check-ignore processes than + there are CPU cores when run with a large -J value. + * get --from, move --from: When used with a local git remote, these used + to silently skip files that the location log thought were present on the + remote, when the remote actually no longer contained them. Since that + behavior could be surprising, now instead display a warning. + * external special remotes: remote.name.annex-readonly=true no longer + disables running the external special remote program. Instead, it just + makes the remote operate in a readonly mode, same as any remote. + To disable running the external special remote program, now need to set + remote.name.annex-externaltype=readonly. That is done when + git-annex enableremote is passed readonly=true. + * Stop storing readonly=true in remote.log of external special remotes; + it is a local setting only. + * sync: When some remotes to sync with are specified, and --fast is too, + pick the lowest cost of the specified remotes, do not sync with a + faster remote that was not specified. + * addurl: When run with --fast on an url that + annex.security.allowed-ip-addresses prevents accessing, display + a more useful message. + * When the required content is set to "groupwanted", use whatever + expression has been set in groupwanted as the required content of the + repo, similar to how setting required content to "standard" already + worked. + * Avoid a test suite failure when the environment does not let gpg be + tested due to eg, too long a path to the agent socket. + * test: Include testremote tests, run on a directory special remote. + + -- Joey Hess Fri, 01 May 2020 13:09:24 -0400 + git-annex (8.20200330) upstream; urgency=medium * fsck: Fix reversion in 8.20200226 that made it incorrectly warn diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -17,7 +17,6 @@ import Messages.Concurrent import Types.Messages import Types.WorkerPool -import Remote.List import Control.Concurrent import Control.Concurrent.Async @@ -200,8 +199,7 @@ startConcurrency usedstages a = do fromcmdline <- Annex.getState Annex.concurrency fromgitcfg <- annexJobs <$> Annex.getGitConfig - let usegitcfg = Annex.changeState $ - \c -> c { Annex.concurrency = fromgitcfg } + let usegitcfg = setConcurrency fromgitcfg case (fromcmdline, fromgitcfg) of (NonConcurrent, NonConcurrent) -> a (Concurrent n, _) -> @@ -245,11 +243,6 @@ liftIO $ setNumCapabilities n initworkerpool n = do - -- Generate the remote list now, to avoid each thread - -- generating it, which would be more expensive and - -- could cause threads to contend over eg, calls to - -- setConfig. - _ <- remoteList tv <- liftIO newEmptyTMVarIO Annex.changeState $ \s -> s { Annex.workers = Just tv } st <- dupState diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -14,6 +14,7 @@ import Options.Applicative import Limit import Types.FileMatcher +import Annex.BranchState data BatchMode = Batch BatchFormat | NoBatch @@ -49,7 +50,7 @@ batchseeker (opts, NoBatch, params) = mapM_ (go NoBatch opts) params batchseeker (opts, batchmode@(Batch fmt), _) = - batchInput fmt Right (go batchmode opts) + batchInput fmt (pure . Right) (go batchmode opts) go batchmode opts p = unlessM (handler opts p) $ @@ -61,18 +62,26 @@ batchBadInput NoBatch = liftIO exitFailure batchBadInput (Batch _) = liftIO $ putStrLn "" --- Reads lines of batch mode input and passes to the action to handle. -batchInput :: BatchFormat -> (String -> Either String a) -> (a -> Annex ()) -> Annex () +-- Reads lines of batch mode input, runs a parser, and passes the result +-- to the action. +-- +-- Note that if the batch input includes a worktree filename, it should +-- be converted to relative. Normally, filename parameters are passed +-- through git ls-files, which makes them relative, but batch mode does +-- not use that, and absolute worktree files are likely to cause breakage. +batchInput :: BatchFormat -> (String -> Annex (Either String a)) -> (a -> Annex ()) -> Annex () batchInput fmt parser a = go =<< batchLines fmt where go [] = return () go (l:rest) = do - either parseerr a (parser l) + either parseerr a =<< parser l go rest parseerr s = giveup $ "Batch input parse failure: " ++ s batchLines :: BatchFormat -> Annex [String] -batchLines fmt = liftIO $ splitter <$> getContents +batchLines fmt = do + enableInteractiveJournalAccess + liftIO $ splitter <$> getContents where splitter = case fmt of BatchLine -> lines @@ -92,9 +101,12 @@ -- Reads lines of batch input and passes the filepaths to a CommandStart -- to handle them. -- +-- Absolute filepaths are converted to relative. +-- -- File matching options are not checked. -batchStart :: BatchFormat -> (String -> CommandStart) -> Annex () -batchStart fmt a = batchInput fmt Right $ batchCommandAction . a +batchStart :: BatchFormat -> (FilePath -> CommandStart) -> Annex () +batchStart fmt a = batchInput fmt (Right <$$> liftIO . relPathCwdToFile) $ + batchCommandAction . a -- Like batchStart, but checks the file matching options -- and skips non-matching files. diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -36,6 +36,7 @@ import qualified Backend import qualified Types.Backend as Backend import Utility.HumanTime +import Annex.Concurrent -- Global options that are accepted by all git-annex sub-commands, -- although not always used. @@ -96,7 +97,7 @@ setgitconfig v = Annex.adjustGitRepo $ \r -> if Param v `elem` gitGlobalOpts r then return r - else Git.Config.store (encodeBS' v) $ + else Git.Config.store (encodeBS' v) Git.Config.ConfigList $ r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] } setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } @@ -395,7 +396,7 @@ -- action in `allowConcurrentOutput`. jobsOption :: [GlobalOption] jobsOption = - [ globalSetter set $ + [ globalSetter setConcurrency $ option (maybeReader parseConcurrency) ( long "jobs" <> short 'J' <> metavar (paramNumber `paramOr` "cpus") @@ -403,8 +404,6 @@ <> hidden ) ] - where - set v = Annex.changeState $ \s -> s { Annex.concurrency = v } timeLimitOption :: [GlobalOption] timeLimitOption = diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -103,7 +103,7 @@ else checkUrl addunlockedmatcher r o' u forM_ (addUrls o) (\u -> go (o, u)) case batchOption o of - Batch fmt -> batchInput fmt (parseBatchInput o) go + Batch fmt -> batchInput fmt (pure . parseBatchInput o) go NoBatch -> noop parseBatchInput :: AddUrlOptions -> String -> Either String (AddUrlOptions, URLString) @@ -194,11 +194,16 @@ where bad = fromMaybe (giveup $ "bad url " ++ urlstring) $ Url.parseURIRelaxed $ urlstring - go url = startingAddUrl urlstring o $ do + go url = startingAddUrl urlstring o $ + if relaxedOption (downloadOptions o) + then go' url Url.assumeUrlExists + else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case + Right urlinfo -> go' url urlinfo + Left err -> do + warning err + next $ return False + go' url urlinfo = do pathmax <- liftIO $ fileNameLengthLimit "." - urlinfo <- if relaxedOption (downloadOptions o) - then pure Url.assumeUrlExists - else Url.withUrlOptions $ Url.getUrlInfo urlstring file <- adjustFile o <$> case fileOption (downloadOptions o) of Just f -> pure f Nothing -> case Url.urlSuggestedFile urlinfo of diff --git a/Command/CheckPresentKey.hs b/Command/CheckPresentKey.hs --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -38,7 +38,7 @@ (rn:[]) -> toRemote rn >>= \r -> return (flip check (Just r)) [] -> return (flip check Nothing) _ -> wrongnumparams - batchInput fmt Right $ checker >=> batchResult + batchInput fmt (pure . Right) $ checker >=> batchResult where wrongnumparams = giveup "Wrong number of parameters" diff --git a/Command/Config.hs b/Command/Config.hs --- a/Command/Config.hs +++ b/Command/Config.hs @@ -69,8 +69,9 @@ seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $ startingCustomOutput (ActionItemOther Nothing) $ do getGlobalConfig ck >>= \case - Nothing -> return () Just (ConfigValue v) -> liftIO $ S8.putStrLn v + Just NoConfigValue -> return () + Nothing -> return () next $ return True checkIsGlobalConfig :: ConfigKey -> Annex a -> Annex a diff --git a/Command/DropKey.hs b/Command/DropKey.hs --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -35,7 +35,8 @@ giveup "dropkey can cause data loss; use --force if you're sure you want to do this" withKeys (commandAction . start) (toDrop o) case batchOption o of - Batch fmt -> batchInput fmt parsekey $ batchCommandAction . start + Batch fmt -> batchInput fmt (pure . parsekey) $ + batchCommandAction . start NoBatch -> noop where parsekey = maybe (Left "bad key") Right . deserializeKey diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -16,7 +16,7 @@ import Utility.Tor import Annex.UUID #ifndef mingw32_HOST_OS -import Config.Files +import Annex.Path #endif import P2P.IO import qualified P2P.Protocol as P2P @@ -53,7 +53,7 @@ Nothing -> giveup "Need user-id parameter." Just userid -> go userid else starting "enable-tor" (ActionItemOther Nothing) $ do - gitannex <- liftIO readProgramFile + gitannex <- liftIO programPath let ps = [Param (cmdname cmd), Param (show curruserid)] sucommand <- liftIO $ mkSuCommand gitannex ps maybe noop showLongNote diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -37,6 +37,7 @@ import Utility.Metered import Utility.Matcher +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import Control.Concurrent @@ -112,7 +113,7 @@ return (fmap (tb, ) commitsha) | otherwise = return Nothing where - baseref = Ref $ takeWhile (/= ':') $ fromRef $ + baseref = Ref $ S8.takeWhile (/= ':') $ fromRef' $ Git.Ref.removeBase refsheads treeish refsheads = "refs/heads" diff --git a/Command/FindRef.hs b/Command/FindRef.hs --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -22,6 +22,6 @@ where o' = o { Find.keyOptions = Just $ WantBranchKeys $ - map Git.Ref (Find.findThese o) + map (Git.Ref . encodeBS') (Find.findThese o) , Find.findThese = [] } diff --git a/Command/Forget.hs b/Command/Forget.hs --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -45,7 +45,7 @@ perform ts True = do recordTransitions Branch.change ts -- get branch committed before contining with the transition - Branch.update + _ <- Branch.update void $ Branch.performTransitions ts True [] next $ return True perform _ False = do diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -47,11 +47,14 @@ seekBatch :: BatchFormat -> CommandSeek seekBatch fmt = batchInput fmt parse commandAction where - parse s = + parse s = do let (keyname, file) = separate (== ' ') s - in if not (null keyname) && not (null file) - then Right $ go file (keyOpt keyname) - else Left "Expected pairs of key and filename" + if not (null keyname) && not (null file) + then do + file' <- liftIO $ relPathCwdToFile file + return $ Right $ go file' (keyOpt keyname) + else return $ + Left "Expected pairs of key and filename" go file key = starting "fromkey" (mkActionItem (key, toRawFilePath file)) $ perform key file diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -66,7 +66,7 @@ [bs] -> let (branch, subdir) = separate (== ':') bs in RemoteImportOptions r - (Ref branch) + (Ref (encodeBS' branch)) (if null subdir then Nothing else Just subdir) _ -> giveup "expected BRANCH[:SUBDIR]" diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -162,10 +162,6 @@ r <- Remote.claimingUrl url if Remote.uuid r == webUUID || rawOption (downloadOptions opts) then do - urlinfo <- if relaxedOption (downloadOptions opts) - then pure Url.assumeUrlExists - else Url.withUrlOptions $ - Url.getUrlInfo url let dlopts = (downloadOptions opts) -- force using the filename -- chosen here @@ -173,7 +169,14 @@ -- don't use youtube-dl , rawOption = True } - maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f + let go urlinfo = maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f + if relaxedOption (downloadOptions opts) + then go Url.assumeUrlExists + else Url.withUrlOptions (Url.getUrlInfo url) >>= \case + Right urlinfo -> go urlinfo + Left err -> do + warning err + return [] else do res <- tryNonAsync $ maybe (error $ "unable to checkUrl of " ++ Remote.name r) diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -119,7 +119,7 @@ seek :: InfoOptions -> CommandSeek seek o = case batchOption o of NoBatch -> withWords (commandAction . start o) (infoFor o) - Batch fmt -> batchInput fmt Right (itemInfo o) + Batch fmt -> batchInput fmt (pure . Right) (itemInfo o) start :: InfoOptions -> [String] -> CommandStart start o [] = do @@ -152,9 +152,11 @@ v' <- Remote.nameToUUID' p case v' of Right u -> uuidInfo o u - Left _ -> ifAnnexed (toRawFilePath p) - (fileInfo o p) - (treeishInfo o p) + Left _ -> do + relp <- liftIO $ relPathCwdToFile p + ifAnnexed (toRawFilePath relp) + (fileInfo o relp) + (treeishInfo o p) ) where isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus) @@ -181,7 +183,7 @@ treeishInfo :: InfoOptions -> String -> Annex () treeishInfo o t = do - mi <- getTreeStatInfo o (Git.Ref t) + mi <- getTreeStatInfo o (Git.Ref (encodeBS' t)) case mi of Nothing -> noInfo t Just i -> showCustom (unwords ["info", t]) $ do diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -264,7 +264,8 @@ parseRawChangeLine :: String -> Maybe (Git.Ref, Git.Ref) parseRawChangeLine = go . words where - go (_:_:oldsha:newsha:_) = Just (Git.Ref oldsha, Git.Ref newsha) + go (_:_:oldsha:newsha:_) = + Just (Git.Ref (encodeBS oldsha), Git.Ref (encodeBS newsha)) go _ = Nothing parseTimeStamp :: String -> POSIXTime diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -222,18 +222,18 @@ Nothing -> return $ Just r | otherwise = liftIO $ safely $ Git.Config.read r where - pipedconfig pcmd params = liftIO $ safely $ + pipedconfig st pcmd params = liftIO $ safely $ withHandle StdoutHandle createProcessSuccess p $ - Git.Config.hRead r + Git.Config.hRead r st where p = proc pcmd $ toCommand params configlist = Ssh.onRemote NoConsumeStdin r - (pipedconfig, return Nothing) "configlist" [] [] + (pipedconfig Git.Config.ConfigList, return Nothing) "configlist" [] [] manualconfiglist = do gc <- Annex.getRemoteGitConfig r (sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r gc remotecmd - liftIO $ pipedconfig sshcmd sshparams + liftIO $ pipedconfig Git.Config.ConfigNullList sshcmd sshparams where remotecmd = "sh -c " ++ shellEscape (cddir ++ " && " ++ "git config --null --list") diff --git a/Command/Merge.hs b/Command/Merge.hs --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -26,11 +26,11 @@ commandAction mergeSyncedBranch seek bs = do prepMerge - forM_ bs (commandAction . mergeBranch . Git.Ref) + forM_ bs (commandAction . mergeBranch . Git.Ref . encodeBS') mergeAnnexBranch :: CommandStart mergeAnnexBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do - Annex.Branch.update + _ <- Annex.Branch.update -- commit explicitly, in case no remote branches were merged Annex.Branch.commit =<< Annex.Branch.commitMessage next $ return True diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -119,8 +119,9 @@ cleanup :: Key -> CommandCleanup cleanup k = do m <- getCurrentMetaData k - let Object o = toJSON' (MetaDataFields m) - maybeShowJSON $ AesonObject o + case toJSON' (MetaDataFields m) of + Object o -> maybeShowJSON $ AesonObject o + _ -> noop showLongNote $ unlines $ concatMap showmeta $ map unwrapmeta (fromMetaData m) return True @@ -147,16 +148,21 @@ fieldsField :: T.Text fieldsField = T.pack "fields" -parseJSONInput :: String -> Either String (Either RawFilePath Key, MetaData) -parseJSONInput i = do - v <- eitherDecode (BU.fromString i) - let m = case itemAdded v of - Nothing -> emptyMetaData - Just (MetaDataFields m') -> m' - case (itemKey v, itemFile v) of - (Just k, _) -> Right (Right k, m) - (Nothing, Just f) -> Right (Left (toRawFilePath f), m) - (Nothing, Nothing) -> Left "JSON input is missing either file or key" +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 + Nothing -> emptyMetaData + Just (MetaDataFields m') -> m' + case (itemKey v, itemFile v) of + (Just k, _) -> return $ + Right (Right k, m) + (Nothing, Just f) -> do + f' <- liftIO $ relPathCwdToFile f + return $ Right (Left (toRawFilePath f'), m) + (Nothing, Nothing) -> return $ + Left "JSON input is missing either file or key" startBatch :: (Either RawFilePath Key, MetaData) -> CommandStart startBatch (i, (MetaData m)) = case i of diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -187,16 +187,10 @@ fromPerform src removewhen key afile fromOk :: Remote -> Key -> Annex Bool -fromOk src key - | Remote.hasKeyCheap src = - either (const checklog) return =<< haskey - | otherwise = checklog - where - haskey = Remote.hasKey src key - checklog = do - u <- getUUID - remotes <- Remote.keyPossibilities key - return $ u /= Remote.uuid src && elem src remotes +fromOk src key = do + u <- getUUID + remotes <- Remote.keyPossibilities key + return $ u /= Remote.uuid src && elem src remotes fromPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform fromPerform src removewhen key afile = do diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -16,7 +16,6 @@ import Annex.Link import Annex.View import Annex.View.ViewedFile -import Annex.LockFile import Logs.View import Logs.MetaData import Types.View diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -39,17 +39,21 @@ -- Split on the last space, since a FilePath can contain whitespace, -- but a Key very rarely does. -batchParser :: String -> Either String (RawFilePath, Key) +batchParser :: String -> Annex (Either String (RawFilePath, Key)) batchParser s = case separate (== ' ') (reverse s) of (rk, rf) - | null rk || null rf -> Left "Expected: \"file key\"" + | null rk || null rf -> return $ Left "Expected: \"file key\"" | otherwise -> case deserializeKey (reverse rk) of - Nothing -> Left "bad key" - Just k -> Right (toRawFilePath (reverse rf), k) + Nothing -> return $ Left "bad key" + Just k -> do + let f = reverse rf + f' <- liftIO $ relPathCwdToFile f + return $ Right (toRawFilePath f', k) seek :: ReKeyOptions -> CommandSeek seek o = case batchOption o of - Batch fmt -> batchInput fmt batchParser (batchCommandAction . start) + Batch fmt -> batchInput fmt batchParser $ + batchCommandAction . start NoBatch -> withPairs (commandAction . start . parsekey) (reKeyThese o) where parsekey (file, skey) = diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -13,6 +13,8 @@ import qualified Git.Branch import Annex.AutoMerge +import qualified Data.ByteString as S + cmd :: Command cmd = command "resolvemerge" SectionPlumbing "resolve merge conflicts" @@ -27,7 +29,7 @@ d <- fromRawFilePath <$> fromRepo Git.localGitDir let merge_head = d "MERGE_HEAD" them <- fromMaybe (error nomergehead) . extractSha - <$> liftIO (readFile merge_head) + <$> liftIO (S.readFile merge_head) ifM (resolveMerge (Just us) them False) ( do void $ commitResolvedMerge Git.Branch.ManualCommit diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -30,16 +30,20 @@ seek :: RmUrlOptions -> CommandSeek seek o = case batchOption o of - Batch fmt -> batchInput fmt batchParser (batchCommandAction . start) + Batch fmt -> batchInput fmt batchParser + (batchCommandAction . start) NoBatch -> withPairs (commandAction . start) (rmThese o) -- Split on the last space, since a FilePath can contain whitespace, -- but a url should not. -batchParser :: String -> Either String (FilePath, URLString) +batchParser :: String -> Annex (Either String (FilePath, URLString)) batchParser s = case separate (== ' ') (reverse s) of (ru, rf) - | null ru || null rf -> Left "Expected: \"file url\"" - | otherwise -> Right (reverse rf, reverse ru) + | null ru || null rf -> return $ Left "Expected: \"file url\"" + | otherwise -> do + let f = reverse rf + f' <- liftIO $ relPathCwdToFile f + return $ Right (f', reverse ru) start :: (FilePath, URLString) -> CommandStart start (file, url) = flip whenAnnexed file' $ \_ key -> diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -31,7 +31,7 @@ seek :: SetPresentKeyOptions -> CommandSeek seek o = case batchOption o of Batch fmt -> batchInput fmt - (parseKeyStatus . words) + (pure . parseKeyStatus . words) (batchCommandAction . start) NoBatch -> either giveup (commandAction . start) (parseKeyStatus $ params o) diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -46,7 +46,7 @@ import Config.GitConfig import Annex.SpecialRemote.Config import Config.DynamicConfig -import Config.Files +import Annex.Path import Annex.Wanted import Annex.Content import Command.Get (getKey') @@ -72,6 +72,8 @@ import Control.Concurrent.MVar import qualified Data.Map as M +import qualified Data.ByteString as S +import Data.Char cmd :: Command cmd = withGlobalOptions [jobsOption] $ @@ -289,10 +291,8 @@ syncRemotes' :: [String] -> [Remote] -> Annex [Remote] syncRemotes' ps available = - ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) + ifM (Annex.getState Annex.fast) ( fastest <$> wanted , wanted ) where - pickfast = (++) <$> listed <*> (filterM good (fastest available)) - wanted | null ps = filterM good (concat $ Remote.byCost available) | otherwise = listed @@ -444,11 +444,11 @@ | otherwise = case remoteAnnexTrackingBranch (Remote.gitconfig remote) of Nothing -> noop Just tb -> do - let (b, s) = separate (== ':') (Git.fromRef tb) + let (b, p) = separate' (== (fromIntegral (ord ':'))) (Git.fromRef' tb) let branch = Git.Ref b - let subdir = if null s + let subdir = if S.null p then Nothing - else Just (asTopFilePath (toRawFilePath s)) + else Just (asTopFilePath p) Command.Import.seekRemote remote branch subdir void $ mergeRemote remote currbranch mergeconfig o where @@ -509,13 +509,13 @@ Nothing -> return True Just wt -> ifM needemulation ( liftIO $ do - p <- readProgramFile + p <- programPath boolSystem' p [Param "post-receive"] (\cp -> cp { cwd = Just (fromRawFilePath wt) }) , return True ) where - needemulation = Remote.Git.onLocal repo remote $ + needemulation = Remote.Git.onLocalRepo repo $ (annexCrippledFileSystem <$> Annex.getGitConfig) <&&> needUpdateInsteadEmulation diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} + module Command.TestRemote where import Command @@ -27,9 +29,8 @@ import Types.RemoteConfig import Types.ProposedAccepted import Annex.SpecialRemote.Config (exportTreeField) -import Remote.Helper.ExportImport import Remote.Helper.Chunked -import Remote.Helper.Encryptable (describeEncryption, encryptionField, highRandomQualityField) +import Remote.Helper.Encryptable (encryptionField, highRandomQualityField) import Git.Types import Test.Tasty @@ -39,6 +40,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as M +import Control.Concurrent.STM hiding (check) cmd :: Command cmd = command "testremote" SectionTesting @@ -83,58 +85,63 @@ let r' = if null (testReadonlyFile o) then r else r { Remote.readonly = True } - rs <- if Remote.readonly r' - then return [r'] - else do - rs <- catMaybes <$> mapM (adjustChunkSize r') (chunkSizes basesz fast) - concat <$> mapM encryptionVariants rs - unavailrs <- catMaybes <$> mapM Remote.mkUnavailable [r'] - exportr <- if Remote.readonly r' + let drs = if Remote.readonly r' + then [Described "remote" (pure (Just r'))] + else remoteVariants (Described "remote" (pure r')) basesz fast + unavailr <- Remote.mkUnavailable r' + let exportr = if Remote.readonly r' then return Nothing else exportTreeVariant r' - perform rs unavailrs exportr ks + perform drs unavailr exportr ks where basesz = fromInteger $ sizeOption o -perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform -perform rs unavailrs exportr ks = do - let ea = maybe exportUnsupported Remote.exportActions exportr - st <- Annex.getState id - let tests = testGroup "Remote Tests" $ concat - [ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ] - , [ testGroup (desc r k) (test st r k) | k <- ks, r <- rs ] - , [ testGroup (descexport k1 k2) (testExportTree st exportr ea k1 k2) | k1 <- take 2 ks, k2 <- take 2 (reverse ks) ] - ] +perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform +perform drs unavailr exportr ks = do + st <- liftIO . newTVarIO =<< Annex.getState id + let tests = testGroup "Remote Tests" $ mkTestTrees + (runTestCase st) + drs + (pure unavailr) + exportr + (map (\k -> Described (desck k) (pure k)) ks) ok <- case tryIngredients [consoleTestReporter] mempty tests of Nothing -> error "No tests found!?" Just act -> liftIO act + rs <- catMaybes <$> mapM getVal drs next $ cleanup rs ks ok where - desc r' k = intercalate "; " $ map unwords - [ [ "key size", show (fromKey keySize k) ] - , [ show (getChunkConfig (Remote.config r')) ] - , ["encryption", describeEncryption (Remote.config r')] - ] - descexport k1 k2 = intercalate "; " $ map unwords - [ [ "exporttree=yes" ] - , [ "key1 size", show (fromKey keySize k1) ] - , [ "key2 size", show (fromKey keySize k2) ] - ] + desck k = unwords [ "key size", show (fromKey keySize k) ] +remoteVariants :: Described (Annex Remote) -> Int -> Bool -> [Described (Annex (Maybe Remote))] +remoteVariants dr basesz fast = + concatMap encryptionVariants $ + map chunkvariant (chunkSizes basesz fast) + where + chunkvariant sz = Described (getDesc dr ++ " chunksize=" ++ show sz) $ do + r <- getVal dr + adjustChunkSize r sz + adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote) adjustChunkSize r chunksize = adjustRemoteConfig r $ M.insert chunkField (Proposed (show chunksize)) -- Variants of a remote with no encryption, and with simple shared -- encryption. Gpg key based encryption is not tested. -encryptionVariants :: Remote -> Annex [Remote] -encryptionVariants r = do - noenc <- adjustRemoteConfig r $ - M.insert encryptionField (Proposed "none") - sharedenc <- adjustRemoteConfig r $ - M.insert encryptionField (Proposed "shared") . - M.insert highRandomQualityField (Proposed "false") - return $ catMaybes [noenc, sharedenc] +encryptionVariants :: Described (Annex (Maybe Remote)) -> [Described (Annex (Maybe Remote))] +encryptionVariants dr = [noenc, sharedenc] + where + noenc = Described (getDesc dr ++ " encryption=none") $ + getVal dr >>= \case + Nothing -> return Nothing + Just r -> adjustRemoteConfig r $ + M.insert encryptionField (Proposed "none") + sharedenc = Described (getDesc dr ++ " encryption=shared") $ + getVal dr >>= \case + Nothing -> return Nothing + Just r -> adjustRemoteConfig r $ + M.insert encryptionField (Proposed "shared") . + M.insert highRandomQualityField (Proposed "false") -- Variant of a remote with exporttree disabled. disableExportTree :: Remote -> Annex Remote @@ -162,19 +169,65 @@ (Remote.gitconfig r) (Remote.remoteStateHandle r) -test :: Annex.AnnexState -> Remote -> Key -> [TestTree] -test st r k = catMaybes - [ whenwritable $ check "removeKey when not present" remove - , whenwritable $ present False - , whenwritable $ check "storeKey" store - , whenwritable $ present True - , whenwritable $ check "storeKey when already present" store - , Just $ present True - , Just $ check "retrieveKeyFile" $ do +data Described t = Described + { getDesc :: String + , getVal :: t + } + +type RunAnnex = forall a. Annex a -> IO a + +runTestCase :: TVar Annex.AnnexState -> RunAnnex +runTestCase stv a = do + st <- atomically $ readTVar stv + (r, st') <- Annex.run st $ do + Annex.setOutput QuietOutput + a + atomically $ writeTVar stv st' + return r + +-- Note that the same remotes and keys should be produced each time +-- the provided actions are called. +mkTestTrees + :: RunAnnex + -> [Described (Annex (Maybe Remote))] + -> Annex (Maybe Remote) + -> Annex (Maybe Remote) + -> [Described (Annex Key)] + -> [TestTree] +mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $ + [ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (Prelude.head mkks))) ] + , [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- mkks, mkr <- mkrs ] + , [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 mkks, mkk2 <- take 2 (reverse mkks) ] + ] + where + desc r k = intercalate "; " $ map unwords + [ [ getDesc k ] + , [ getDesc r ] + ] + descexport k1 k2 = intercalate "; " $ map unwords + [ [ "exporttree=yes" ] + , [ getDesc k1 ] + , [ getDesc k2 ] + ] + +test :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree] +test runannex mkr mkk = + [ check "removeKey when not present" $ \r k -> + whenwritable r $ remove r k + , check ("present " ++ show False) $ \r k -> + whenwritable r $ present r k False + , check "storeKey" $ \r k -> + whenwritable r $ store r k + , check ("present " ++ show True) $ \r k -> + whenwritable r $ present r k True + , check "storeKey when already present" $ \r k -> + whenwritable r $ store r k + , check ("present " ++ show True) $ \r k -> present r k True + , check "retrieveKeyFile" $ \r k -> do lockContentForRemoval k removeAnnex - get - , Just $ check "fsck downloaded object" fsck - , Just $ check "retrieveKeyFile resume from 33%" $ do + get r k + , check "fsck downloaded object" fsck + , check "retrieveKeyFile resume from 33%" $ \r k -> do loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do @@ -182,106 +235,133 @@ L.hGet h $ fromInteger $ sz `div` 3 liftIO $ L.writeFile tmp partial lockContentForRemoval k removeAnnex - get - , Just $ check "fsck downloaded object" fsck - , Just $ check "retrieveKeyFile resume from 0" $ do + get r k + , check "fsck downloaded object" fsck + , check "retrieveKeyFile resume from 0" $ \r k -> do tmp <- prepTmp k liftIO $ writeFile tmp "" lockContentForRemoval k removeAnnex - get - , Just $ check "fsck downloaded object" fsck - , Just $ check "retrieveKeyFile resume from end" $ do + get r k + , check "fsck downloaded object" fsck + , check "retrieveKeyFile resume from end" $ \r k -> do loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp lockContentForRemoval k removeAnnex - get - , Just $ check "fsck downloaded object" fsck - , whenwritable $ check "removeKey when present" remove - , whenwritable $ present False + get r k + , check "fsck downloaded object" fsck + , check "removeKey when present" $ \r k -> + whenwritable r $ remove r k + , check ("present " ++ show False) $ \r k -> + whenwritable r $ present r k False ] where - whenwritable a = if Remote.readonly r then Nothing else Just a - check desc a = testCase desc $ - Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" - present b = check ("present " ++ show b) $ - (== Right b) <$> Remote.hasKey r k - fsck = case maybeLookupBackendVariety (fromKey keyVariety k) of + whenwritable r a + | Remote.readonly r = return True + | otherwise = a + check desc a = testCase desc $ do + let a' = mkr >>= \case + Just r -> do + k <- mkk + a r k + Nothing -> return True + runannex a' @? "failed" + present r k b = (== Right b) <$> Remote.hasKey r k + fsck _ k = case maybeLookupBackendVariety (fromKey keyVariety k) of Nothing -> return True Just b -> case Backend.verifyKeyContent b of Nothing -> return True Just verifier -> verifier k (serializeKey k) - get = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> + get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate - store = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate - remove = Remote.removeKey r k + store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate + remove r k = Remote.removeKey r k -testExportTree :: Annex.AnnexState -> Maybe Remote -> Remote.ExportActions Annex -> Key -> Key -> [TestTree] -testExportTree _ Nothing _ _ _ = [] -testExportTree st (Just _) ea k1 k2 = - [ check "check present export when not present" $ - not <$> checkpresentexport k1 - , check "remove export when not present" (removeexport k1) - , check "store export" (storeexport k1) - , check "check present export after store" $ - checkpresentexport k1 - , check "store export when already present" (storeexport k1) - , check "retrieve export" (retrieveexport k1) - , check "store new content to export" (storeexport k2) - , check "check present export after store of new content" $ - checkpresentexport k2 - , check "retrieve export new content" (retrieveexport k2) - , check "remove export" (removeexport k2) - , check "check present export after remove" $ - not <$> checkpresentexport k2 - , check "retrieve export fails after removal" $ - not <$> retrieveexport k2 - , check "remove export directory" removeexportdirectory - , check "remove export directory that is already removed" removeexportdirectory +testExportTree :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree] +testExportTree runannex mkr mkk1 mkk2 = + [ check "check present export when not present" $ \ea k1 _k2 -> + not <$> checkpresentexport ea k1 + , check "remove export when not present" $ \ea k1 _k2 -> + removeexport ea k1 + , check "store export" $ \ea k1 _k2 -> + storeexport ea k1 + , check "check present export after store" $ \ea k1 _k2 -> + checkpresentexport ea k1 + , check "store export when already present" $ \ea k1 _k2 -> + storeexport ea k1 + , check "retrieve export" $ \ea k1 _k2 -> + retrieveexport ea k1 + , check "store new content to export" $ \ea _k1 k2 -> + storeexport ea k2 + , check "check present export after store of new content" $ \ea _k1 k2 -> + checkpresentexport ea k2 + , check "retrieve export new content" $ \ea _k1 k2 -> + retrieveexport ea k2 + , check "remove export" $ \ea _k1 k2 -> + removeexport ea k2 + , check "check present export after remove" $ \ea _k1 k2 -> + not <$> checkpresentexport ea k2 + , check "retrieve export fails after removal" $ \ea _k1 k2 -> + not <$> retrieveexport ea k2 + , check "remove export directory" $ \ea _k1 _k2 -> + removeexportdirectory ea + , check "remove export directory that is already removed" $ \ea _k1 _k2 -> + removeexportdirectory ea -- renames are not tested because remotes do not need to support them ] where testexportdirectory = "testremote-export" testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory "location")) - check desc a = testCase desc $ - Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" - storeexport k = do + check desc a = testCase desc $ do + let a' = mkr >>= \case + Just r -> do + let ea = Remote.exportActions r + k1 <- mkk1 + k2 <- mkk2 + a ea k1 k2 + Nothing -> return True + runannex a' @? "failed" + storeexport ea k = do loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) Remote.storeExport ea loc k testexportlocation nullMeterUpdate - retrieveexport k = withTmpFile "exported" $ \tmp h -> do + retrieveexport ea k = withTmpFile "exported" $ \tmp h -> do liftIO $ hClose h ifM (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) ( verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified k tmp , return False ) - checkpresentexport k = Remote.checkPresentExport ea k testexportlocation - removeexport k = Remote.removeExport ea k testexportlocation - removeexportdirectory = case Remote.removeExportDirectory ea of + checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation + removeexport ea k = Remote.removeExport ea k testexportlocation + removeexportdirectory ea = case Remote.removeExportDirectory ea of Nothing -> return True Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory)) -testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree] -testUnavailable st r k = - [ check (== Right False) "removeKey" $ +testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree] +testUnavailable runannex mkr mkk = + [ check (== Right False) "removeKey" $ \r k -> Remote.removeKey r k - , check (== Right False) "storeKey" $ + , check (== Right False) "storeKey" $ \r k -> Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate - , check (`notElem` [Right True, Right False]) "checkPresent" $ + , check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> Remote.checkPresent r k - , check (== Right False) "retrieveKeyFile" $ + , check (== Right False) "retrieveKeyFile" $ \r k -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate - , check (== Right False) "retrieveKeyFileCheap" $ + , check (== Right False) "retrieveKeyFileCheap" $ \r k -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> unVerified $ Remote.retrieveKeyFileCheap r k (AssociatedFile Nothing) dest ] where - check checkval desc a = testCase desc $ do - v <- Annex.eval st $ do - Annex.setOutput QuietOutput - either (Left . show) Right <$> tryNonAsync a - checkval v @? ("(got: " ++ show v ++ ")") + check checkval desc a = testCase desc $ + join $ runannex $ mkr >>= \case + Just r -> do + k <- mkk + v <- either (Left . show) Right + <$> tryNonAsync (a r k) + return $ checkval v + @? ("(got: " ++ show v ++ ")") + Nothing -> return noop cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup cleanup rs ks ok diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -17,6 +17,7 @@ import Utility.SimpleProtocol (dupIoHandles) import Git.Types (RemoteName) import qualified Database.Keys +import Annex.BranchState data TransferRequest = TransferRequest Direction Remote Key AssociatedFile @@ -29,6 +30,7 @@ start :: CommandStart start = do + enableInteractiveJournalAccess (readh, writeh) <- liftIO dupIoHandles runRequests readh writeh runner stop diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -35,7 +35,7 @@ whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ giveup "can only run uninit from the top of the git repository" where - current_branch = Git.Ref . Prelude.head . lines . decodeBS' <$> revhead + current_branch = Git.Ref . encodeBS' . Prelude.head . lines . decodeBS' <$> revhead revhead = inRepo $ Git.Command.pipeReadStrict [Param "rev-parse", Param "--abbrev-ref", Param "HEAD"] diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -5,12 +5,10 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, OverloadedStrings #-} module Command.Unused where -import qualified Data.Map as M - import Command import Logs.Unused import Annex.Content @@ -37,6 +35,11 @@ import qualified Database.Keys import Annex.InodeSentinal +import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.Char + cmd :: Command cmd = command "unused" SectionMaintenance "look for unused file content" paramNothing (seek <$$> optParser) @@ -221,8 +224,7 @@ withKeysReferencedDiffGitRefs :: RefSpec -> (Key -> Annex ()) -> Annex () withKeysReferencedDiffGitRefs refspec a = do - rs <- relevantrefs . decodeBS' - <$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"]) + rs <- relevantrefs <$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"]) shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha) =<< inRepo Git.Branch.currentUnsafe let haveHead = any (\(shaRef, _) -> Just shaRef == shaHead) rs @@ -233,12 +235,12 @@ where relevantrefs = map (\(r, h) -> (Git.Ref r, Git.Ref h)) . filter ourbranches . - map (separate (== ' ')) . - lines + map (separate' (== (fromIntegral (ord ' ')))) . + S8.lines nubRefs = nubBy (\(x, _) (y, _) -> x == y) - ourbranchend = '/' : Git.fromRef Annex.Branch.name - ourbranches (_, b) = not (ourbranchend `isSuffixOf` b) - && not ("refs/synced/" `isPrefixOf` b) + ourbranchend = S.cons (fromIntegral (ord '/')) (Git.fromRef' Annex.Branch.name) + ourbranches (_, b) = not (ourbranchend `S.isSuffixOf` b) + && not ("refs/synced/" `S.isPrefixOf` b) && not (is_branchView (Git.Ref b)) getreflog rs = inRepo $ Git.RefLog.getMulti rs diff --git a/Config/Cost.hs b/Config/Cost.hs --- a/Config/Cost.hs +++ b/Config/Cost.hs @@ -46,9 +46,9 @@ insertCostAfter l pos | pos < 0 = costBetween 0 (l !! 0) : l | nextpos > maxpos = l ++ [1 + l !! maxpos] - | item == nextitem = - let (_dup:new:l') = insertCostAfter lastsegment 0 - in firstsegment ++ [costBetween item new, new] ++ l' + | item == nextitem = case insertCostAfter lastsegment 0 of + (_dup:new:l') -> firstsegment ++ [costBetween item new, new] ++ l' + _ -> error "insertCostAfter internal error" | otherwise = firstsegment ++ [costBetween item nextitem ] ++ lastsegment where diff --git a/Config/Files.hs b/Config/Files.hs --- a/Config/Files.hs +++ b/Config/Files.hs @@ -61,27 +61,6 @@ programFile :: IO FilePath programFile = userConfigFile "program" -{- Returns a command to run for git-annex. -} -readProgramFile :: IO FilePath -readProgramFile = do - programfile <- programFile - p <- catchDefaultIO cmd $ - fromMaybe cmd . headMaybe . lines <$> readFile programfile - ifM (inPath p) - ( return p - , ifM (inPath cmd) - ( return cmd - , cannotFindProgram - ) - ) - where - cmd = "git-annex" - -cannotFindProgram :: IO a -cannotFindProgram = do - f <- programFile - giveup $ "cannot find git-annex program in PATH or in the location listed in " ++ f - {- A .noannex file in a git repository prevents git-annex from - initializing that repository.. The content of the file is returned. -} noAnnexFileContent :: Maybe FilePath -> IO (Maybe String) diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module Database.Keys ( DbHandle, @@ -44,6 +45,7 @@ import Git.Index import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified System.FilePath.ByteString as P {- Runs an action that reads from the database. @@ -59,7 +61,7 @@ -} runReader :: Monoid v => (SQL.ReadHandle -> Annex v) -> Annex v runReader a = do - h <- getDbHandle + h <- Annex.getState Annex.keysdbhandle withDbState h go where go DbUnavailable = return (mempty, DbUnavailable) @@ -83,7 +85,7 @@ - The database is created if it doesn't exist yet. -} runWriter :: (SQL.WriteHandle -> Annex ()) -> Annex () runWriter a = do - h <- getDbHandle + h <- Annex.getState Annex.keysdbhandle withDbState h go where go st@(DbOpen qh) = do @@ -99,17 +101,6 @@ runWriterIO :: (SQL.WriteHandle -> IO ()) -> Annex () runWriterIO a = runWriter (liftIO . a) -{- Gets the handle cached in Annex state; creates a new one if it's not yet - - available, but doesn't open the database. -} -getDbHandle :: Annex DbHandle -getDbHandle = go =<< Annex.getState Annex.keysdbhandle - where - go (Just h) = pure h - go Nothing = do - h <- liftIO newDbHandle - Annex.changeState $ \s -> s { Annex.keysdbhandle = Just h } - return h - {- Opens the database, perhaps creating it if it doesn't exist yet. - - Multiple readers and writers can have the database open at the same @@ -151,9 +142,7 @@ - data to it. -} closeDb :: Annex () -closeDb = Annex.getState Annex.keysdbhandle >>= \case - Nothing -> return () - Just h -> liftIO (closeDbHandle h) +closeDb = liftIO . closeDbHandle =<< Annex.getState Annex.keysdbhandle addAssociatedFile :: Key -> TopFilePath -> Annex () addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile k f @@ -237,8 +226,8 @@ Nothing -> noop where go cur indexcache = do - (l, cleanup) <- inRepo $ pipeNullSplit diff - changed <- procdiff (map decodeBL' l) False + (l, cleanup) <- inRepo $ pipeNullSplit' diff + changed <- procdiff l False void $ liftIO cleanup -- Flush database changes immediately -- so other processes can see them. @@ -278,15 +267,16 @@ , Param "--no-ext-diff" ] - procdiff (info:file:rest) changed = case words info of - ((':':_srcmode):dstmode:_srcsha:dstsha:_change:[]) - -- Only want files, not symlinks - | dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do - maybe noop (reconcile (asTopFilePath (toRawFilePath file))) - =<< catKey (Ref dstsha) - procdiff rest True - | otherwise -> procdiff rest changed - _ -> return changed -- parse failed + procdiff (info:file:rest) changed + | ":" `S.isPrefixOf` info = case S8.words info of + (_colonsrcmode:dstmode:_srcsha:dstsha:_change:[]) + -- Only want files, not symlinks + | dstmode /= fmtTreeItemType TreeSymlink -> do + maybe noop (reconcile (asTopFilePath file)) + =<< catKey (Ref dstsha) + procdiff rest True + | otherwise -> procdiff rest changed + _ -> return changed -- parse failed procdiff _ changed = return changed -- Note that database writes done in here will not necessarily diff --git a/Database/Types.hs b/Database/Types.hs --- a/Database/Types.hs +++ b/Database/Types.hs @@ -28,6 +28,7 @@ import Key import Utility.InodeCache import Utility.FileSize +import Utility.FileSystemEncoding import Git.Types import Types.UUID import Types.Import @@ -94,10 +95,10 @@ deriving (Eq, Show) toSSha :: Sha -> SSha -toSSha (Ref s) = SSha s +toSSha (Ref s) = SSha (decodeBS' s) fromSSha :: SSha -> Ref -fromSSha (SSha s) = Ref s +fromSSha (SSha s) = Ref (encodeBS' s) instance PersistField SSha where toPersistValue (SSha b) = toPersistValue b diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -14,6 +14,7 @@ Repo(..), Ref(..), fromRef, + fromRef', Branch, Sha, Tag, diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -18,6 +18,7 @@ import qualified Git.Ref import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 {- The currently checked out branch. - @@ -39,25 +40,27 @@ {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch) -currentUnsafe r = parse . firstLine' - <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r +currentUnsafe r = parse . firstLine' <$> pipeReadStrict + [ Param "symbolic-ref" + , Param "-q" + , Param $ fromRef Git.Ref.headRef + ] r where parse b | B.null b = Nothing - | otherwise = Just $ Git.Ref $ decodeBS b + | otherwise = Just $ Git.Ref b {- Checks if the second branch has any commits not present on the first - branch. -} changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False - | otherwise = not . null + | otherwise = not . B.null <$> changed' origbranch newbranch [Param "-n1"] repo where -changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String -changed' origbranch newbranch extraps repo = - decodeBS <$> pipeReadStrict ps repo +changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString +changed' origbranch newbranch extraps repo = pipeReadStrict ps repo where ps = [ Param "log" @@ -68,7 +71,7 @@ {- Lists commits that are in the second branch and not in the first branch. -} changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] changedCommits origbranch newbranch extraps repo = - catMaybes . map extractSha . lines + catMaybes . map extractSha . B8.lines <$> changed' origbranch newbranch extraps repo {- Check if it's possible to fast-forward from the old @@ -163,8 +166,7 @@ -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do - tree <- getSha "write-tree" $ - decodeBS' <$> pipeReadStrict [Param "write-tree"] repo + tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,10 +1,12 @@ {- git cat-file interface - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.CatFile ( CatFileHandle, catFileStart, @@ -22,7 +24,9 @@ import System.IO import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Map as M import Data.String import Data.Char @@ -69,11 +73,11 @@ {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $ - fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) + fromRef' branch <> ":" <> toInternalGitPath file catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $ - fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) + fromRef' branch <> ":" <> toInternalGitPath file {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -82,9 +86,9 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do - header <- hGetLine from + header <- S8.hGetLine from case parseResp object header of - Just (ParsedResp sha size objtype) -> do + Just (ParsedResp sha objtype size) -> do content <- S.hGet from (fromIntegral size) eatchar '\n' from return $ Just (L.fromChunks [content], sha, objtype) @@ -112,9 +116,9 @@ {- Gets the size and type of an object, without reading its content. -} catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do - resp <- hGetLine from + resp <- S8.hGetLine from case parseResp object resp of - Just (ParsedResp sha size objtype) -> + Just (ParsedResp sha objtype size) -> return $ Just (sha, size, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) @@ -126,36 +130,40 @@ objtype <- queryObjectType object (gitRepo h) return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE +data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE + deriving (Show) query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a query hdl object newlinefallback receive -- git cat-file --batch uses a line based protocol, so when the -- filename itself contains a newline, have to fall back to another -- method of getting the information. - | '\n' `elem` s = newlinefallback + | '\n' `S8.elem` s = newlinefallback -- git strips carriage return from the end of a line, out of some -- misplaced desire to support windows, so also use the newline -- fallback for those. - | "\r" `isSuffixOf` s = newlinefallback + | "\r" `S8.isSuffixOf` s = newlinefallback | otherwise = CoProcess.query hdl send receive where - send to = hPutStrLn to s - s = fromRef object + send to = S8.hPutStrLn to s + s = fromRef' object -parseResp :: Ref -> String -> Maybe ParsedResp -parseResp object l - | " missing" `isSuffixOf` l -- less expensive than full check - && l == fromRef object ++ " missing" = Just DNE - | otherwise = case words l of - [sha, objtype, size] -> case extractSha sha of - Just sha' -> case (readObjectType (encodeBS objtype), reads size) of - (Just t, [(bytes, "")]) -> - Just $ ParsedResp sha' bytes t - _ -> Nothing - Nothing -> Nothing - _ -> Nothing +parseResp :: Ref -> S.ByteString -> Maybe ParsedResp +parseResp object s + | " missing" `S.isSuffixOf` s -- less expensive than full check + && s == fromRef' object <> " missing" = Just DNE + | otherwise = eitherToMaybe $ A.parseOnly respParser s +respParser :: A.Parser ParsedResp +respParser = ParsedResp + <$> (maybe (fail "bad sha") return . extractSha =<< nextword) + <* A8.char ' ' + <*> (maybe (fail "bad object type") return . readObjectType =<< nextword) + <* A8.char ' ' + <*> A8.decimal + where + nextword = A8.takeTill (== ' ') + querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a) querySingle o r repo reader = assertLocal repo $ -- In non-batch mode, git cat-file warns on stderr when @@ -218,39 +226,39 @@ catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) catCommit h commitref = go <$> catObjectDetails h commitref where - go (Just (b, _, CommitObject)) = parseCommit b + go (Just (b, _, CommitObject)) = parseCommit (L.toStrict b) go _ = Nothing -parseCommit :: L.ByteString -> Maybe Commit +parseCommit :: S.ByteString -> Maybe Commit parseCommit b = Commit - <$> (extractSha . L8.unpack =<< field "tree") - <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent")) + <$> (extractSha =<< field "tree") + <*> Just (maybe [] (mapMaybe extractSha) (fields "parent")) <*> (parsemetadata <$> field "author") <*> (parsemetadata <$> field "committer") - <*> Just (L8.unpack $ L.intercalate (L.singleton nl) message) + <*> Just (decodeBS $ S.intercalate (S.singleton nl) message) where field n = headMaybe =<< fields n fields n = M.lookup (fromString n) fieldmap fieldmap = M.fromListWith (++) ((map breakfield) header) breakfield l = - let (k, sp_v) = L.break (== sp) l - in (k, [L.drop 1 sp_v]) - (header, message) = separate L.null ls - ls = L.split nl b + let (k, sp_v) = S.break (== sp) l + in (k, [S.drop 1 sp_v]) + (header, message) = separate S.null ls + ls = S.split nl b -- author and committer lines have the form: "name date" -- The email is always present, even if empty "<>" parsemetadata l = CommitMetaData - { commitName = whenset $ L.init name_sp + { commitName = whenset $ S.init name_sp , commitEmail = whenset email - , commitDate = whenset $ L.drop 2 gt_sp_date + , commitDate = whenset $ S.drop 2 gt_sp_date } where - (name_sp, rest) = L.break (== lt) l - (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest) + (name_sp, rest) = S.break (== lt) l + (email, gt_sp_date) = S.break (== gt) (S.drop 1 rest) whenset v - | L.null v = Nothing - | otherwise = Just (L8.unpack v) + | S.null v = Nothing + | otherwise = Just (decodeBS v) nl = fromIntegral (ord '\n') sp = fromIntegral (ord ' ') diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -81,11 +81,16 @@ {- Runs a git command, feeding it an input, and returning its output, - which is expected to be fairly small, since it's all read into memory - strictly. -} -pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String +pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO S.ByteString pipeWriteRead params writer repo = assertLocal repo $ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) - (gitEnv repo) writer (Just adjusthandle) + (gitEnv repo) writer' where + writer' = case writer of + Nothing -> Nothing + Just a -> Just $ \h -> do + adjusthandle h + a h adjusthandle h = hSetNewlineMode h noNewlineTranslation {- Runs a git command, feeding it input on a handle with an action. -} diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -59,7 +59,7 @@ go Repo { location = LocalUnknown d } = git_config d go _ = assertLocal repo $ error "internal" git_config d = withHandle StdoutHandle createProcessSuccess p $ - hRead repo + hRead repo ConfigNullList where params = ["config", "--null", "--list"] p = (proc "git" params) @@ -74,7 +74,7 @@ ifM (doesFileExist $ home ".gitconfig") ( do repo <- withHandle StdoutHandle createProcessSuccess p $ - hRead (Git.Construct.fromUnknown) + hRead (Git.Construct.fromUnknown) ConfigNullList return $ Just repo , return Nothing ) @@ -83,18 +83,18 @@ p = (proc "git" params) {- Reads git config from a handle and populates a repo with it. -} -hRead :: Repo -> Handle -> IO Repo -hRead repo h = do +hRead :: Repo -> ConfigStyle -> Handle -> IO Repo +hRead repo st h = do val <- S.hGetContents h - store val repo + store val st repo {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -} -store :: S.ByteString -> Repo -> IO Repo -store s repo = do - let c = parse s +store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo +store s st repo = do + let c = parse s st updateLocation $ repo { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo) @@ -135,27 +135,30 @@ top <- absPath $ fromRawFilePath (gitdir l) let p = absPathFrom top (fromRawFilePath d) return $ l { worktree = Just (toRawFilePath p) } + Just NoConfigValue -> return l return $ r { location = l' } +data ConfigStyle = ConfigList | ConfigNullList + {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: S.ByteString -> M.Map ConfigKey [ConfigValue] -parse s +parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue] +parse s st | S.null s = M.empty - -- --list output will have a '=' in the first line - -- (The first line of --null --list output is the name of a key, - -- which is assumed to never contain '='.) - | S.elem eq firstline = sep eq $ S.split nl s - -- --null --list output separates keys from values with newlines - | otherwise = sep nl $ S.split 0 s + | otherwise = case st of + ConfigList -> sep eq $ S.split nl s + ConfigNullList -> sep nl $ S.split 0 s where nl = fromIntegral (ord '\n') eq = fromIntegral (ord '=') - firstline = S.takeWhile (/= nl) s sep c = M.fromListWith (++) - . map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) + . map (\(k,v) -> (ConfigKey k, [mkval v])) . map (S.break (== c)) + + mkval v + | S.null v = NoConfigValue + | otherwise = ConfigValue (S.drop 1 v) {- Checks if a string from git config is a true/false value. -} isTrueFalse :: String -> Maybe Bool @@ -163,11 +166,21 @@ isTrueFalse' :: ConfigValue -> Maybe Bool isTrueFalse' (ConfigValue s) + | s' == "yes" = Just True + | s' == "on" = Just True | s' == "true" = Just True + | s' == "1" = Just True + + | s' == "no" = Just False + | s' == "off" = Just False | s' == "false" = Just False + | s' == "0" = Just False + | s' == "" = Just False + | otherwise = Nothing where s' = S8.map toLower s +isTrueFalse' NoConfigValue = Just True boolConfig :: Bool -> String boolConfig True = "true" @@ -186,14 +199,14 @@ {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - output and any standard output of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) -fromPipe r cmd params = try $ +fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) +fromPipe r cmd params st = try $ withOEHandles createProcessSuccess p $ \(hout, herr) -> do geterr <- async $ S.hGetContents herr getval <- async $ S.hGetContents hout val <- wait getval err <- wait geterr - r' <- store val r + r' <- store val st r return (r', val, err) where p = proc cmd $ toCommand params @@ -206,7 +219,7 @@ , Param "--file" , File f , Param "--list" - ] + ] ConfigList {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} diff --git a/Git/ConfigTypes.hs b/Git/ConfigTypes.hs --- a/Git/ConfigTypes.hs +++ b/Git/ConfigTypes.hs @@ -23,7 +23,6 @@ getSharedRepository :: Repo -> SharedRepository getSharedRepository r = case Git.Config.getMaybe "core.sharedrepository" r of - Nothing -> UnShared Just (ConfigValue v) -> case S8.map toLower v of "1" -> GroupShared "2" -> AllShared @@ -33,6 +32,8 @@ "world" -> AllShared "everybody" -> AllShared _ -> maybe UnShared UmaskShared (readish (decodeBS' v)) + Just NoConfigValue -> UnShared + Nothing -> UnShared data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush deriving (Eq) @@ -45,4 +46,5 @@ "warn" -> WarnPush "ignore" -> IgnorePush _ -> RefusePush + Just NoConfigValue -> RefusePush Nothing -> RefusePush diff --git a/Git/Credential.hs b/Git/Credential.hs --- a/Git/Credential.hs +++ b/Git/Credential.hs @@ -58,7 +58,7 @@ runCredential :: String -> Credential -> Repo -> IO Credential runCredential action input r = - parseCredential <$> pipeWriteRead + parseCredential . decodeBS <$> pipeWriteRead [ Param "credential" , Param action ] diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -1,6 +1,6 @@ {- git diff-tree interface - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -17,7 +17,9 @@ commitDiff, ) where -import Numeric +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 import Common import Git @@ -27,6 +29,7 @@ import Git.DiffTreeItem import qualified Git.Filename import qualified Git.Ref +import Utility.Attoparsec {- Checks if the DiffTreeItem modifies a file with a given name - or under a directory by that name. -} @@ -89,7 +92,7 @@ getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool) getdiff command params repo = do (diff, cleanup) <- pipeNullSplit ps repo - return (parseDiffRaw (map decodeBL diff), cleanup) + return (parseDiffRaw diff, cleanup) where ps = command : @@ -100,26 +103,28 @@ params {- Parses --raw output used by diff-tree and git-log. -} -parseDiffRaw :: [String] -> [DiffTreeItem] +parseDiffRaw :: [L.ByteString] -> [DiffTreeItem] parseDiffRaw l = go l where go [] = [] - go (info:f:rest) = mk info f : go rest - go (s:[]) = error $ "diff-tree parse error near \"" ++ s ++ "\"" - - mk info f = DiffTreeItem - { srcmode = readmode srcm - , dstmode = readmode dstm - , srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha - , dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha - , status = s - , file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f - } - where - readmode = fst . Prelude.head . readOct + go (info:f:rest) = case A.parse (parserDiffRaw (L.toStrict f)) info of + A.Done _ r -> r : go rest + A.Fail _ _ err -> error $ "diff-tree parse error: " ++ err + go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL' s ++ "\"" - -- info = : SP SP SP SP - (srcm, past_srcm) = splitAt 7 $ drop 1 info - (dstm, past_dstm) = splitAt 7 past_srcm - (ssha, past_ssha) = separate (== ' ') past_dstm - (dsha, s) = separate (== ' ') past_ssha +-- : SP SP SP SP +parserDiffRaw :: RawFilePath -> A.Parser DiffTreeItem +parserDiffRaw f = DiffTreeItem + <$ A8.char ':' + <*> octal + <* A8.char ' ' + <*> octal + <* A8.char ' ' + <*> (maybe (fail "bad srcsha") return . extractSha =<< nextword) + <* A8.char ' ' + <*> (maybe (fail "bad dstsha") return . extractSha =<< nextword) + <* A8.char ' ' + <*> A.takeByteString + <*> pure (asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f) + where + nextword = A8.takeTill (== ' ') diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs --- a/Git/DiffTreeItem.hs +++ b/Git/DiffTreeItem.hs @@ -10,6 +10,7 @@ ) where import System.Posix.Types +import qualified Data.ByteString as S import Git.FilePath import Git.Types @@ -19,6 +20,6 @@ , dstmode :: FileMode , srcsha :: Sha -- null sha if file was added , dstsha :: Sha -- null sha if file was deleted - , status :: String + , status :: S.ByteString , file :: TopFilePath } deriving Show diff --git a/Git/FilePath.hs b/Git/FilePath.hs --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -50,7 +50,7 @@ {- Git uses the branch:file form to refer to a BranchFilePath -} descBranchFilePath :: BranchFilePath -> S.ByteString descBranchFilePath (BranchFilePath b f) = - encodeBS' (fromRef b) <> ":" <> getTopFilePath f + fromRef' b <> ":" <> getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -139,7 +139,8 @@ ] r findShas :: [String] -> [Sha] -findShas = catMaybes . map extractSha . concat . map words . filter wanted +findShas = catMaybes . map (extractSha . encodeBS') + . concat . map words . filter wanted where wanted l = not ("dangling " `isPrefixOf` l) diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -98,6 +98,7 @@ defaultkey = "gcrypt.participants" parse (Just (ConfigValue "simple")) = [] parse (Just (ConfigValue b)) = words (decodeBS' b) + parse (Just NoConfigValue) = [] parse Nothing = [] remoteParticipantConfigKey :: RemoteName -> ConfigKey diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -18,6 +18,7 @@ import Utility.Tmp import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder @@ -39,7 +40,7 @@ hashFile h file = CoProcess.query h send receive where send to = hPutStrLn to =<< absPath file - receive from = getSha "hash-object" $ hGetLine from + receive from = getSha "hash-object" $ S8.hGetLine from class HashableBlob t where hashableBlobToHandle :: Handle -> t -> IO () diff --git a/Git/History.hs b/Git/History.hs --- a/Git/History.hs +++ b/Git/History.hs @@ -15,6 +15,9 @@ import Git.Sha import qualified Data.Set as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 data History t = History t (S.Set (History t)) deriving (Show, Eq, Ord) @@ -53,8 +56,9 @@ !h <- fmap (truncateHistoryToDepth n) . build Nothing . map parsehistorycommit - . lines - <$> hGetContents inh + . map L.toStrict + . L8.lines + <$> L.hGetContents inh hClose inh void $ waitForProcess pid return h @@ -93,7 +97,7 @@ , Param "--format=%T %H %P" ] - parsehistorycommit l = case map extractSha (splitc ' ' l) of + parsehistorycommit l = case map extractSha (B8.split ' ' l) of (Just t:Just c:ps) -> Just $ ( HistoryCommit { historyCommit = c diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -36,9 +36,10 @@ import Utility.TimeStamp import Numeric +import Data.Char import System.Posix.Types import qualified Data.Map as M -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S {- It's only safe to use git ls-files on the current repo, not on a remote. - @@ -81,7 +82,7 @@ {- Files that are checked into the index or have been committed to a - branch. -} inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] +inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef b] {- Scans for files at the specified locations that are not checked into git. -} notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) @@ -189,21 +190,21 @@ - contents. -} stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' ps l repo = guardSafeForLsFiles repo $ do - (ls, cleanup) <- pipeNullSplit params repo + (ls, cleanup) <- pipeNullSplit' params repo return (map parseStagedDetails ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l -parseStagedDetails :: L.ByteString -> StagedDetails +parseStagedDetails :: S.ByteString -> StagedDetails parseStagedDetails s - | null file = (L.toStrict s, Nothing, Nothing) - | otherwise = (toRawFilePath file, extractSha sha, readmode mode) + | S.null file = (s, Nothing, Nothing) + | otherwise = (file, extractSha sha, readmode mode) where - (metadata, file) = separate (== '\t') (decodeBL' s) - (mode, metadata') = separate (== ' ') metadata - (sha, _) = separate (== ' ') metadata' - readmode = fst <$$> headMaybe . readOct + (metadata, file) = separate' (== fromIntegral (ord '\t')) s + (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata + (sha, _) = separate' (== fromIntegral (ord ' ')) metadata' + readmode = fst <$$> headMaybe . readOct . decodeBS' {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} @@ -284,7 +285,7 @@ then Nothing else do treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) - sha <- extractSha rawsha + sha <- extractSha (encodeBS' rawsha) return $ InternalUnmerged (stage == 2) (toRawFilePath file) (Just treeitemtype) (Just sha) _ -> Nothing diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -96,7 +96,7 @@ <*> A8.takeTill (== ' ') <* A8.char ' ' -- sha - <*> (Ref . decodeBS' <$> A8.takeTill (== '\t')) + <*> (Ref <$> A8.takeTill (== '\t')) <* A8.char '\t' -- file <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString) diff --git a/Git/Objects.hs b/Git/Objects.hs --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -26,7 +26,7 @@ listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas r = catchDefaultIO [] $ - mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories) + mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) looseObjectFile :: Repo -> Sha -> FilePath diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -17,6 +17,7 @@ import Data.Char (chr, ord) import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 headRef :: Ref headRef = Ref "HEAD" @@ -25,7 +26,7 @@ headFile r = fromRawFilePath (localGitDir r) "HEAD" setHeadRef :: Ref -> Repo -> IO () -setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) +setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref) {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String @@ -41,10 +42,11 @@ {- Removes a directory such as "refs/heads/master" from a - fully qualified ref. Any ref not starting with it is left as-is. -} removeBase :: String -> Ref -> Ref -removeBase dir (Ref r) - | prefix `isPrefixOf` r = Ref (drop (length prefix) r) - | otherwise = Ref r +removeBase dir r + | prefix `isPrefixOf` rs = Ref $ encodeBS $ drop (length prefix) rs + | otherwise = r where + rs = fromRef r prefix = case end dir of ['/'] -> dir _ -> dir ++ "/" @@ -53,7 +55,7 @@ - refs/heads/master, yields a version of that ref under the directory, - such as refs/remotes/origin/master. -} underBase :: String -> Ref -> Ref -underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r) +underBase dir r = Ref $ encodeBS dir <> "/" <> fromRef' (base r) {- Convert a branch such as "master" into a fully qualified ref. -} branchRef :: Branch -> Ref @@ -66,21 +68,25 @@ - of a repo. -} fileRef :: RawFilePath -> Ref -fileRef f = Ref $ ":./" ++ fromRawFilePath f +fileRef f = Ref $ ":./" <> f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref -dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d +dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d {- A Ref that can be used to refer to a file in the repository as it - appears in a given Ref. -} fileFromRef :: Ref -> RawFilePath -> Ref -fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr) +fileFromRef r f = let (Ref fr) = fileRef f in Ref (fromRef' r <> fr) {- Checks if a ref exists. -} exists :: Ref -> Repo -> IO Bool exists ref = runBool - [Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref] + [ Param "show-ref" + , Param "--verify" + , Param "-q" + , Param $ fromRef ref + ] {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -} @@ -107,26 +113,26 @@ ] process s | S.null s = Nothing - | otherwise = Just $ Ref $ decodeBS' $ firstLine' s + | otherwise = Just $ Ref $ firstLine' s headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef {- List of (shas, branches) matching a given ref or refs. -} matching :: [Ref] -> Repo -> IO [(Sha, Branch)] -matching refs repo = matching' (map fromRef refs) repo +matching = matching' [] {- Includes HEAD in the output, if asked for it. -} matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)] -matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo +matchingWithHEAD = matching' [Param "--head"] -{- List of (shas, branches) matching a given ref spec. -} -matching' :: [String] -> Repo -> IO [(Sha, Branch)] -matching' ps repo = map gen . lines . decodeBS' <$> - pipeReadStrict (Param "show-ref" : map Param ps) repo +matching' :: [CommandParam] -> [Ref] -> Repo -> IO [(Sha, Branch)] +matching' ps rs repo = map gen . S8.lines <$> + pipeReadStrict (Param "show-ref" : ps ++ rps) repo where - gen l = let (r, b) = separate (== ' ') l + gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l in (Ref r, Ref b) + rps = map (Param . fromRef) rs {- List of (shas, branches) matching a given ref. - Duplicate shas are filtered out. -} @@ -137,7 +143,7 @@ {- List of all refs. -} list :: Repo -> IO [(Sha, Ref)] -list = matching' [] +list = matching' [] [] {- Deletes a ref. This can delete refs that are not branches, - which git branch --delete refuses to delete. -} @@ -154,13 +160,17 @@ - The ref may be something like a branch name, and it could contain - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict - [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] +tree (Ref ref) = extractSha <$$> pipeReadStrict + [ Param "rev-parse" + , Param "--verify" + , Param "--quiet" + , Param (decodeBS' ref') + ] where - ref' = if ":" `isInfixOf` ref + ref' = if ":" `S.isInfixOf` ref then ref -- de-reference commit objects to the tree - else ref ++ ":" + else ref <> ":" {- Checks if a String is a legal git ref name. - diff --git a/Git/RefLog.hs b/Git/RefLog.hs --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -12,6 +12,9 @@ import Git.Command import Git.Sha +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 + {- Gets the reflog for a given branch. -} get :: Branch -> Repo -> IO [Sha] get b = getMulti [b] @@ -21,7 +24,7 @@ getMulti bs = get' (map (Param . fromRef) bs) get' :: [CommandParam] -> Repo -> IO [Sha] -get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps' +get' ps = mapMaybe (extractSha . S.copy) . S8.lines <$$> pipeReadStrict ps' where ps' = catMaybes [ Just $ Param "log" diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -84,12 +84,17 @@ where replacement = decodeBS' $ S.drop (S.length prefix) $ S.take (S.length bestkey - S.length suffix) bestkey - (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs + (bestkey, bestvalue) = + case maximumBy longestvalue insteadofs of + (ConfigKey k, ConfigValue v) -> (k, v) + (ConfigKey k, NoConfigValue) -> (k, mempty) longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> - prefix `S.isPrefixOf` k && - suffix `S.isSuffixOf` k && - v `S.isPrefixOf` encodeBS l + insteadofs = filterconfig $ \case + (ConfigKey k, ConfigValue v) -> + prefix `S.isPrefixOf` k && + suffix `S.isSuffixOf` k && + v `S.isPrefixOf` encodeBS l + (_, NoConfigValue) -> False filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -232,7 +232,7 @@ getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . joinPath . drop topsegs . splitPath + let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO () @@ -257,8 +257,8 @@ parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of (sha:ref:[]) - | isJust (extractSha sha) && Ref.legal True ref -> - Just (Ref sha, Ref ref) + | isJust (extractSha (encodeBS' sha)) && Ref.legal True ref -> + Just (Ref (encodeBS' sha), Ref (encodeBS' ref)) _ -> Nothing {- git-branch -d cannot be used to remove a branch that is directly @@ -279,13 +279,13 @@ if ok then return (Just branch, goodcommits') else do - (ls, cleanup) <- pipeNullSplit + (ls, cleanup) <- pipeNullSplit' [ Param "log" , Param "-z" , Param "--format=%H" , Param (fromRef branch) ] r - let branchshas = catMaybes $ map (extractSha . decodeBL) ls + let branchshas = catMaybes $ map extractSha ls reflogshas <- RefLog.get branch r -- XXX Could try a bit harder here, and look -- for uncorrupted old commits in branches in the @@ -328,8 +328,8 @@ where parse l = case words l of (commitsha:treesha:[]) -> (,) - <$> extractSha commitsha - <*> extractSha treesha + <$> extractSha (encodeBS' commitsha) + <*> extractSha (encodeBS' treesha) _ -> Nothing check [] = return True check ((c, t):rest) @@ -448,7 +448,8 @@ void $ tryIO $ allowWrite f where headfile = fromRawFilePath (localGitDir g) "HEAD" - validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) + validhead s = "ref: refs/" `isPrefixOf` s + || isJust (extractSha (encodeBS' s)) {- Put it all together. -} runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) diff --git a/Git/Sha.hs b/Git/Sha.hs --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -5,31 +5,43 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Sha where import Common import Git.Types +import qualified Data.ByteString as S +import Data.Char + {- Runs an action that causes a git subcommand to emit a Sha, and strips - any trailing newline, returning the sha. -} -getSha :: String -> IO String -> IO Sha +getSha :: String -> IO S.ByteString -> IO Sha getSha subcommand a = maybe bad return =<< extractSha <$> a where bad = error $ "failed to read sha from git " ++ subcommand -{- Extracts the Sha from a string. There can be a trailing newline after - - it, but nothing else. -} -extractSha :: String -> Maybe Sha +{- Extracts the Sha from a ByteString. + - + - There can be a trailing newline after it, but nothing else. + -} +extractSha :: S.ByteString -> Maybe Sha extractSha s | len `elem` shaSizes = val s - | len - 1 `elem` shaSizes && length s' == len - 1 = val s' + | len - 1 `elem` shaSizes && S.length s' == len - 1 = val s' | otherwise = Nothing where - len = length s - s' = firstLine s + len = S.length s + s' = firstLine' s val v - | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v + | S.all validinsha v = Just $ Ref v | otherwise = Nothing + validinsha w = or + [ w >= 48 && w <= 57 -- 0-9 + , w >= 97 && w <= 102 -- a-f + , w >= 65 && w <= 70 -- A-F + ] {- Sizes of git shas. -} shaSizes :: [Int] @@ -41,7 +53,9 @@ {- Git plumbing often uses a all 0 sha to represent things like a - deleted file. -} nullShas :: [Sha] -nullShas = map (\n -> Ref (replicate n '0')) shaSizes +nullShas = map (\n -> Ref (S.replicate n zero)) shaSizes + where + zero = fromIntegral (ord '0') {- Sha to provide to git plumbing when deleting a file. - diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -38,6 +38,7 @@ import Control.Monad.IO.Class import qualified Data.Set as S import qualified Data.Map as M +import qualified Data.ByteString.Char8 as S8 newtype Tree = Tree [TreeContent] deriving (Show) @@ -106,7 +107,7 @@ NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree" TreeCommit f fm s -> mkTreeOutput fm CommitObject s f hPutStr h "\NUL" -- signal end of tree to --batch - receive h = getSha "mktree" (hGetLine h) + receive h = getSha "mktree" (S8.hGetLine h) treeMode :: FileMode treeMode = 0o040000 diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,12 +1,11 @@ {- git data types - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Git.Types where @@ -18,6 +17,8 @@ import System.Posix.Types import Utility.SafeCommand import Utility.FileSystemEncoding +import qualified Data.Semigroup as Sem +import Prelude {- Support repositories on local disk, and repositories accessed via an URL. - @@ -54,9 +55,21 @@ newtype ConfigKey = ConfigKey S.ByteString deriving (Ord, Eq) -newtype ConfigValue = ConfigValue S.ByteString - deriving (Ord, Eq, Semigroup, Monoid) +data ConfigValue + = ConfigValue S.ByteString + | NoConfigValue + -- ^ git treats a setting with no value as different than a setting + -- with an empty value + deriving (Ord, Eq) +instance Sem.Semigroup ConfigValue where + ConfigValue a <> ConfigValue b = ConfigValue (a <> b) + a <> NoConfigValue = a + NoConfigValue <> b = b + +instance Monoid ConfigValue where + mempty = ConfigValue mempty + instance Default ConfigValue where def = ConfigValue mempty @@ -68,6 +81,7 @@ fromConfigValue :: ConfigValue -> String fromConfigValue (ConfigValue s) = decodeBS' s +fromConfigValue NoConfigValue = mempty instance Show ConfigValue where show = fromConfigValue @@ -81,12 +95,15 @@ type RemoteName = String {- A git ref. Can be a sha1, or a branch or tag name. -} -newtype Ref = Ref String +newtype Ref = Ref S.ByteString deriving (Eq, Ord, Read, Show) fromRef :: Ref -> String -fromRef (Ref s) = s +fromRef = decodeBS' . fromRef' +fromRef' :: Ref -> S.ByteString +fromRef' (Ref s) = s + {- Aliases for Ref. -} type Branch = Ref type Sha = Ref @@ -98,6 +115,7 @@ {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject + deriving (Show) readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -10,8 +10,10 @@ mergeIndex ) where +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Char8 as S8 import qualified Data.Set as S import Common @@ -54,13 +56,13 @@ {- For merging two trees. -} mergeTrees :: Ref -> Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer -mergeTrees (Ref x) (Ref y) hashhandle ch = doMerge hashhandle ch - ("diff-tree":diffOpts ++ [x, y, "--"]) +mergeTrees x y hashhandle ch = doMerge hashhandle ch + ("diff-tree":diffOpts ++ [fromRef x, fromRef y, "--"]) {- For merging a single tree into the index. -} mergeTreeIndex :: Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer -mergeTreeIndex (Ref r) hashhandle ch = doMerge hashhandle ch $ - "diff-index" : diffOpts ++ ["--cached", r, "--"] +mergeTreeIndex r hashhandle ch = doMerge hashhandle ch $ + "diff-index" : diffOpts ++ ["--cached", fromRef r, "--"] diffOpts :: [String] diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"] @@ -69,27 +71,29 @@ - using git to get a raw diff. -} doMerge :: HashObjectHandle -> CatFileHandle -> [String] -> Repo -> Streamer doMerge hashhandle ch differ repo streamer = do - (diff, cleanup) <- pipeNullSplit (map Param differ) repo + (diff, cleanup) <- pipeNullSplit' (map Param differ) repo go diff void $ cleanup where go [] = noop - go (info:file:rest) = mergeFile (decodeBL' info) (L.toStrict file) hashhandle ch >>= + go (info:file:rest) = mergeFile info file hashhandle ch >>= maybe (go rest) (\l -> streamer l >> go rest) go (_:[]) = error $ "parse error " ++ show differ {- Given an info line from a git raw diff, and the filename, generates - a line suitable for update-index that union merges the two sides of the - diff. -} -mergeFile :: String -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) -mergeFile info file hashhandle h = case filter (`notElem` nullShas) [Ref asha, Ref bsha] of - [] -> return Nothing - (sha:[]) -> use sha - shas -> use - =<< either return (hashBlob hashhandle . L8.unlines) - =<< calcMerge . zip shas <$> mapM getcontents shas +mergeFile :: S.ByteString -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) +mergeFile info file hashhandle h = case S8.words info of + [_colonmode, _bmode, asha, bsha, _status] -> + case filter (`notElem` nullShas) [Ref asha, Ref bsha] of + [] -> return Nothing + (sha:[]) -> use sha + shas -> use + =<< either return (hashBlob hashhandle . L8.unlines) + =<< calcMerge . zip shas <$> mapM getcontents shas + _ -> return Nothing where - [_colonmode, _bmode, asha, bsha, _status] = words info use sha = return $ Just $ updateIndexLine sha TreeFile $ asTopFilePath file -- Get file and split into lines to union merge. diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -75,14 +75,14 @@ mapM_ streamer s void $ cleanup where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x] lsSubTree :: Ref -> FilePath -> Repo -> Streamer lsSubTree (Ref x) p repo streamer = do (s, cleanup) <- pipeNullSplit params repo mapM_ streamer s void $ cleanup where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x, p] {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} @@ -90,7 +90,7 @@ updateIndexLine sha treeitemtype file = L.fromStrict $ fmtTreeItemType treeitemtype <> " blob " - <> encodeBS (fromRef sha) + <> fromRef' sha <> "\t" <> indexPath file @@ -108,7 +108,7 @@ unstageFile' :: TopFilePath -> Streamer unstageFile' p = pureStreamer $ L.fromStrict $ "0 " - <> encodeBS' (fromRef deleteSha) + <> fromRef' deleteSha <> "\t" <> indexPath p diff --git a/Logs/Config.hs b/Logs/Config.hs --- a/Logs/Config.hs +++ b/Logs/Config.hs @@ -55,6 +55,7 @@ where configkeybuilder (ConfigKey k) = byteString k valuebuilder (ConfigValue v) = byteString v + valuebuilder NoConfigValue = mempty parseGlobalConfig :: L.ByteString -> MapLog ConfigKey ConfigValue parseGlobalConfig = parseMapLog configkeyparser valueparser @@ -63,7 +64,10 @@ valueparser = ConfigValue <$> A.takeByteString loadGlobalConfig :: Annex (M.Map ConfigKey ConfigValue) -loadGlobalConfig = M.filter (\(ConfigValue v) -> not (S.null v)) +loadGlobalConfig = M.filter nonempty . simpleMap . parseGlobalConfig <$> Annex.Branch.get configLog + where + nonempty (ConfigValue v) = not (S.null v) + nonempty NoConfigValue = True diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -158,12 +158,12 @@ where go [] = mempty go (r:rs) = rref r <> mconcat [ charUtf8 ' ' <> rref r' | r' <- rs ] - rref r = byteString (encodeBS' (Git.fromRef r)) + rref = byteString . Git.fromRef' exportedParser :: A.Parser Exported exportedParser = Exported <$> refparser <*> many refparser where - refparser = (Git.Ref . decodeBS <$> A8.takeWhile1 (/= ' ') ) + refparser = (Git.Ref <$> A8.takeWhile1 (/= ' ') ) <* ((const () <$> A8.char ' ') <|> A.endOfInput) logExportExcluded :: UUID -> ((Git.Tree.TreeItem -> IO ()) -> Annex a) -> Annex a diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs --- a/Logs/FsckResults.hs +++ b/Logs/FsckResults.hs @@ -43,7 +43,7 @@ deserialize ("truncated":ls) = deserialize' ls True deserialize ls = deserialize' ls False deserialize' ls t = - let s = S.fromList $ map Ref ls + let s = S.fromList $ map (Ref . encodeBS') ls in if S.null s then FsckFailed else FsckFoundMissing s t clearFsckResults :: UUID -> Annex () diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -92,8 +92,9 @@ in simpleMap . parseLogOldWithUUID (\u -> mk u . decodeBS <$> A.takeByteString) <$> Annex.Branch.get l - pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw - rc <- genmap requiredContentLog M.empty + gm <- groupPreferredContentMapRaw + pc <- genmap preferredContentLog gm + rc <- genmap requiredContentLog gm -- Required content is implicitly also preferred content, so combine. let pc' = M.unionWith combiner pc rc return (pc', rc) diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -143,12 +143,12 @@ transfers <- filter (wanted . transferKey) <$> mapMaybe parseTransferFile . concat <$> findfiles infos <- mapM checkTransfer transfers - return $ map (\(t, Just i) -> (t, i)) $ - filter running $ zip transfers infos + return $ mapMaybe running $ zip transfers infos where findfiles = liftIO . mapM dirContentsRecursive =<< mapM (fromRepo . transferDir) dirs - running (_, i) = isJust i + running (t, Just i) = Just (t, i) + running (_, Nothing) = Nothing {- Number of bytes remaining to download from matching downloads that are in - progress. -} diff --git a/Logs/View.hs b/Logs/View.hs --- a/Logs/View.hs +++ b/Logs/View.hs @@ -9,6 +9,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs.View ( currentView, setView, @@ -31,6 +33,7 @@ import qualified Data.Text as T import qualified Data.Set as S import Data.Char +import qualified Data.ByteString as B setView :: View -> Annex () setView v = do @@ -54,11 +57,11 @@ currentView :: Annex (Maybe View) currentView = go =<< inRepo Git.Branch.current where - go (Just b) | branchViewPrefix `isPrefixOf` fromRef b = + go (Just b) | branchViewPrefix `B.isPrefixOf` fromRef' b = headMaybe . filter (\v -> branchView v == b) <$> recentViews go _ = return Nothing -branchViewPrefix :: String +branchViewPrefix :: B.ByteString branchViewPrefix = "refs/heads/views" {- Generates a git branch name for a View. @@ -68,10 +71,11 @@ -} branchView :: View -> Git.Branch branchView view - | null name = Git.Ref branchViewPrefix - | otherwise = Git.Ref $ branchViewPrefix ++ "/" ++ name + | B.null name = Git.Ref branchViewPrefix + | otherwise = Git.Ref $ branchViewPrefix <> "/" <> name where - name = intercalate ";" $ map branchcomp (viewComponents view) + name = encodeBS' $ + intercalate ";" $ map branchcomp (viewComponents view) branchcomp c | viewVisible c = branchcomp' c | otherwise = "(" ++ branchcomp' c ++ ")" @@ -92,7 +96,7 @@ is_branchView :: Git.Branch -> Bool is_branchView (Ref b) | b == branchViewPrefix = True - | otherwise = (branchViewPrefix ++ "/") `isPrefixOf` b + | otherwise = (branchViewPrefix <> "/") `B.isPrefixOf` b prop_branchView_legal :: View -> Bool prop_branchView_legal = Git.Ref.legal False . fromRef . branchView diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -90,7 +90,7 @@ {- Ensure the git-annex branch's index file is up-to-date and - any journaled changes are reflected in it, since we're going - to query its index directly. -} - Annex.Branch.update + _ <- Annex.Branch.update Annex.Branch.commit =<< Annex.Branch.commitMessage Annex.Branch.withIndex $ do top <- fromRepo Git.repoPath diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -65,9 +65,11 @@ none = id start :: String -> Maybe RawFilePath -> Maybe Key -> JSONBuilder -start command file key _ = Just (o, False) +start command file key _ = case j of + Object o -> Just (o, False) + _ -> Nothing where - Object o = toJSON' $ JSONActionItem + j = toJSON' $ JSONActionItem { itemCommand = Just command , itemKey = key , itemFile = fromRawFilePath <$> file @@ -102,18 +104,22 @@ combinelines new _old = new info :: String -> JSONBuilder -info s _ = Just (o, True) +info s _ = case j of + Object o -> Just (o, True) + _ -> Nothing where - Object o = object ["info" .= toJSON' s] + j = object ["info" .= toJSON' s] data JSONChunk v where AesonObject :: Object -> JSONChunk Object JSONChunk :: ToJSON' v => [(String, v)] -> JSONChunk [(String, v)] add :: JSONChunk v -> JSONBuilder -add v (Just (o, e)) = Just (HM.union o' o, e) +add v (Just (o, e)) = case j of + Object o' -> Just (HM.union o' o, e) + _ -> Nothing where - Object o' = case v of + j = case v of AesonObject ao -> Object ao JSONChunk l -> object $ map mkPair l mkPair (s, d) = (packString s, toJSON' d) @@ -125,12 +131,15 @@ -- Show JSON formatted progress, including the current state of the JSON -- object for the action being performed. progress :: Maybe Object -> Maybe Integer -> BytesProcessed -> IO () -progress maction msize bytesprocessed = emit $ case maction of - Just action -> HM.insert "action" (Object action) o - Nothing -> o +progress maction msize bytesprocessed = + case j of + Object o -> emit $ case maction of + Just action -> HM.insert "action" (Object action) o + Nothing -> o + _ -> return () where n = fromBytesProcessed bytesprocessed :: Integer - Object o = case msize of + j = case msize of Just size -> object [ "byte-progress" .= n , "percent-progress" .= showPercentage 2 (percentage size n) diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -128,12 +128,12 @@ (giveup "Specify androiddirectory=") (pure . AndroidPath . fromProposedAccepted) (M.lookup androiddirectoryField c) - serial <- getserial =<< liftIO enumerateAdbConnected + serial <- getserial =<< enumerateAdbConnected let c' = M.insert androidserialField (Proposed (fromAndroidSerial serial)) c (c'', _encsetup) <- encryptionSetup c' gc - ok <- liftIO $ adbShellBool serial + ok <- adbShellBool serial [Param "mkdir", Param "-p", File (fromAndroidPath adir)] unless ok $ giveup "Creating directory on Android device failed." @@ -166,15 +166,15 @@ store' serial dest src = store'' serial dest src (return True) store'' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool -> Annex Bool -store'' serial dest src canoverwrite = do +store'' serial dest src canoverwrite = checkAdbInPath False $ do let destdir = takeDirectory $ fromAndroidPath dest - liftIO $ void $ adbShell serial [Param "mkdir", Param "-p", File destdir] + void $ adbShell serial [Param "mkdir", Param "-p", File destdir] showOutput -- make way for adb push output let tmpdest = fromAndroidPath dest ++ ".annextmp" ifM (liftIO $ boolSystem "adb" (mkAdbCommand serial [Param "push", File src, File tmpdest])) ( ifM canoverwrite -- move into place atomically - ( liftIO $ adbShellBool serial [Param "mv", File tmpdest, File (fromAndroidPath dest)] + ( adbShellBool serial [Param "mv", File tmpdest, File (fromAndroidPath dest)] , do void $ remove' serial (AndroidPath tmpdest) return False @@ -189,7 +189,7 @@ giveup "adb pull failed" retrieve' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool -retrieve' serial src dest = do +retrieve' serial src dest = checkAdbInPath False $ do showOutput -- make way for adb pull output liftIO $ boolSystem "adb" $ mkAdbCommand serial [ Param "pull" @@ -201,7 +201,7 @@ remove serial adir k = remove' serial (androidLocation adir k) remove' :: AndroidSerial -> AndroidPath -> Annex Bool -remove' serial aloc = liftIO $ adbShellBool serial +remove' serial aloc = adbShellBool serial [Param "rm", Param "-f", File (fromAndroidPath aloc)] checkKey :: Remote -> AndroidSerial -> AndroidPath -> CheckPresent @@ -210,7 +210,7 @@ checkKey' :: Remote -> AndroidSerial -> AndroidPath -> Annex Bool checkKey' r serial aloc = do showChecking r - out <- liftIO $ adbShellRaw serial $ unwords + out <- adbShellRaw serial $ unwords [ "if test -e ", shellEscape (fromAndroidPath aloc) , "; then echo y" , "; else echo n" @@ -247,7 +247,7 @@ aloc = androidExportLocation adir loc removeExportDirectoryM :: AndroidSerial -> AndroidPath -> ExportDirectory -> Annex Bool -removeExportDirectoryM serial abase dir = liftIO $ adbShellBool serial +removeExportDirectoryM serial abase dir = adbShellBool serial [Param "rm", Param "-rf", File (fromAndroidPath adir)] where adir = androidExportLocation abase (mkExportLocation (fromExportDirectory dir)) @@ -258,14 +258,19 @@ aloc = androidExportLocation adir loc renameExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) -renameExportM serial adir _k old new = liftIO $ Just <$> - adbShellBool serial [Param "mv", Param "-f", File oldloc, File newloc] +renameExportM serial adir _k old new = Just <$> adbShellBool serial ps where oldloc = fromAndroidPath $ androidExportLocation adir old newloc = fromAndroidPath $ androidExportLocation adir new + ps = + [ Param "mv" + , Param "-f" + , File oldloc + , File newloc + ] listImportableContentsM :: AndroidSerial -> AndroidPath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) -listImportableContentsM serial adir = liftIO $ +listImportableContentsM serial adir = process <$> adbShell serial [ Param "find" -- trailing slash is needed, or android's find command @@ -300,7 +305,7 @@ ifM (retrieve' serial src dest) ( do k <- mkkey - currcid <- liftIO $ getExportContentIdentifier serial adir loc + currcid <- getExportContentIdentifier serial adir loc return $ if currcid == Right (Just cid) then k else Nothing @@ -315,7 +320,7 @@ -- file is expensive and don't want to do it unncessarily. ifM checkcanoverwrite ( ifM (store'' serial dest src checkcanoverwrite) - ( liftIO $ getExportContentIdentifier serial adir loc >>= return . \case + ( getExportContentIdentifier serial adir loc >>= return . \case Right (Just cid) -> Right cid Right Nothing -> Left "adb failed to store file" Left _ -> Left "unable to get content identifier for file stored on adtb" @@ -325,7 +330,7 @@ ) where dest = androidExportLocation adir loc - checkcanoverwrite = liftIO $ + checkcanoverwrite = getExportContentIdentifier serial adir loc >>= return . \case Right (Just cid) | cid `elem` overwritablecids -> True Right Nothing -> True @@ -333,7 +338,7 @@ removeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool removeExportWithContentIdentifierM serial adir k loc removeablecids = catchBoolIO $ - liftIO (getExportContentIdentifier serial adir loc) >>= \case + getExportContentIdentifier serial adir loc >>= \case Right Nothing -> return True Right (Just cid) | cid `elem` removeablecids -> removeExportM serial adir k loc @@ -341,7 +346,7 @@ checkPresentExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierM serial adir _k loc knowncids = - liftIO $ getExportContentIdentifier serial adir loc >>= \case + getExportContentIdentifier serial adir loc >>= \case Right (Just cid) | cid `elem` knowncids -> return True Right _ -> return False Left _ -> giveup "unable to access Android device" @@ -351,8 +356,8 @@ fromAndroidPath adir ++ "/" ++ fromRawFilePath (fromExportLocation loc) -- | List all connected Android devices. -enumerateAdbConnected :: IO [AndroidSerial] -enumerateAdbConnected = +enumerateAdbConnected :: Annex [AndroidSerial] +enumerateAdbConnected = checkAdbInPath [] $ liftIO $ mapMaybe parse . lines <$> readProcess "adb" ["devices"] where parse l = @@ -364,11 +369,11 @@ -- | Runs a command on the android device with the given serial number. -- -- Any stdout from the command is returned, separated into lines. -adbShell :: AndroidSerial -> [CommandParam] -> IO (Maybe [String]) +adbShell :: AndroidSerial -> [CommandParam] -> Annex (Maybe [String]) adbShell serial cmd = adbShellRaw serial $ unwords $ map shellEscape (toCommand cmd) -adbShellBool :: AndroidSerial -> [CommandParam] -> IO Bool +adbShellBool :: AndroidSerial -> [CommandParam] -> Annex Bool adbShellBool serial cmd = adbShellRaw serial cmd' >>= return . \case Just l -> end l == ["y"] @@ -379,8 +384,8 @@ -- | Runs a raw shell command on the android device. -- Any necessary shellEscaping must be done by caller. -adbShellRaw :: AndroidSerial -> String -> IO (Maybe [String]) -adbShellRaw serial cmd = catchMaybeIO $ +adbShellRaw :: AndroidSerial -> String -> Annex (Maybe [String]) +adbShellRaw serial cmd = checkAdbInPath Nothing $ liftIO $ catchMaybeIO $ processoutput <$> readProcess "adb" [ "-s" , fromAndroidSerial serial @@ -393,13 +398,21 @@ -- despite both linux and android being unix systems. trimcr = takeWhile (/= '\r') +checkAdbInPath :: a -> Annex a -> Annex a +checkAdbInPath d a = ifM (isJust <$> liftIO (searchPath "adb")) + ( a + , do + warning "adb command not found in PATH. Install it to use this remote." + return d + ) + mkAdbCommand :: AndroidSerial -> [CommandParam] -> [CommandParam] mkAdbCommand serial cmd = [Param "-s", Param (fromAndroidSerial serial)] ++ cmd -- Gets the current content identifier for a file on the android device. -- If the file is not present, returns Right Nothing -getExportContentIdentifier :: AndroidSerial -> AndroidPath -> ExportLocation -> IO (Either ExitCode (Maybe ContentIdentifier)) -getExportContentIdentifier serial adir loc = liftIO $ do +getExportContentIdentifier :: AndroidSerial -> AndroidPath -> ExportLocation -> Annex (Either ExitCode (Maybe ContentIdentifier)) +getExportContentIdentifier serial adir loc = do ls <- adbShellRaw serial $ unwords [ "if test -e ", shellEscape aloc , "; then stat -c" diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -223,8 +223,10 @@ giveup "ssh failed" else liftIO $ do r' <- Git.Config.read r - let ConfigValue olduuid = Git.Config.get configkeyUUID mempty r' - when (S.null olduuid) $ + let noolduuid = case Git.Config.get configkeyUUID mempty r' of + ConfigValue olduuid -> S.null olduuid + NoConfigValue -> True + when noolduuid $ Git.Command.run [ Param "config" , Param "annex.uuid" diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -65,7 +65,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs -- readonly mode only downloads urls; does not use external program - | remoteAnnexReadOnly gc = do + | externaltype == "readonly" = do c <- parsedRemoteConfig remote rc cst <- remoteCost gc expensiveRemoteCost mk c cst GloballyAvailable @@ -165,15 +165,22 @@ externalSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu pc <- either giveup return $ parseRemoteConfig c lenientRemoteConfigParser - let externaltype = fromMaybe (giveup "Specify externaltype=") $ - getRemoteConfigValue externaltypeField pc + let readonlyconfig = getRemoteConfigValue readonlyField pc == Just True + let externaltype = if readonlyconfig + then "readonly" + else fromMaybe (giveup "Specify externaltype=") $ + getRemoteConfigValue externaltypeField pc (c', _encsetup) <- encryptionSetup c gc - c'' <- case getRemoteConfigValue readonlyField pc of - Just True -> do + c'' <- if readonlyconfig + then do + -- Setting annex-readonly is not really necessary + -- anymore, but older versions of git-annex used + -- this, not externaltype=readonly, so still set + -- it. setConfig (remoteAnnexConfig (fromJust (lookupName c)) "readonly") (boolConfig True) return c' - _ -> do + else do pc' <- either giveup return $ parseRemoteConfig c' lenientRemoteConfigParser external <- newExternal externaltype (Just u) pc' (Just gc) Nothing -- Now that we have an external, ask it to LISTCONFIGS, @@ -194,14 +201,16 @@ return (changes c') gitConfigSpecialRemote u c'' [("externaltype", externaltype)] - return (c'', u) + return (M.delete readonlyField c'', u) checkExportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool checkExportSupported c gc = do let externaltype = fromMaybe (giveup "Specify externaltype=") $ remoteAnnexExternalType gc <|> getRemoteConfigValue externaltypeField c - checkExportSupported' - =<< newExternal externaltype Nothing c (Just gc) Nothing + if externaltype == "readonly" + then return False + else checkExportSupported' + =<< newExternal externaltype Nothing c (Just gc) Nothing checkExportSupported' :: External -> Annex Bool checkExportSupported' external = go `catchNonAsync` (const (return False)) @@ -649,7 +658,16 @@ giveup $ "Cannot run " ++ cmd ++ " -- Make sure it's executable and that its dependencies are installed." runerr Nothing _ = do path <- intercalate ":" <$> getSearchPath - giveup $ "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")" + let err = "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")" + case (lookupName (unparsedRemoteConfig (externalDefaultConfig external)), remoteAnnexReadOnly <$> externalGitConfig external) of + (Just rname, Just True) -> giveup $ unlines + [ err + , "This remote has annex-readonly=true, and previous versions of" + , "git-annex would tried to download from it without" + , "installing " ++ basecmd ++ ". If you want that, you need to set:" + , "git config remote." ++ rname ++ ".annex-externaltype readonly" + ] + _ -> giveup err stopExternal :: External -> Annex () stopExternal external = liftIO $ do diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -474,7 +474,7 @@ | Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> liftIO (catchMaybeIO $ Git.Config.read r) | not fast = extract . liftM fst3 <$> getM (eitherToMaybe <$>) - [ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p), return (Left $ error "configlist failed")) "configlist" [] [] + [ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p Git.Config.ConfigList), return (Left $ error "configlist failed")) "configlist" [] [] , getConfigViaRsync r gc ] | otherwise = return (Nothing, r) diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -1,6 +1,6 @@ {- Standard git remotes. - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,7 +12,7 @@ remote, configRead, repoAvail, - onLocal, + onLocalRepo, ) where import Annex.Common @@ -249,7 +249,7 @@ | haveconfig r = return r -- already read | Git.repoIsSsh r = storeUpdatedRemote $ do v <- Ssh.onRemote NoConsumeStdin r - (pipedconfig autoinit (Git.repoDescribe r), return (Left $ giveup "configlist failed")) + (pipedconfig Git.Config.ConfigList autoinit (Git.repoDescribe r), return (Left $ giveup "configlist failed")) "configlist" [] configlistfields case v of Right r' @@ -264,8 +264,8 @@ where haveconfig = not . M.null . Git.config - pipedconfig mustincludeuuuid configloc cmd params = do - v <- liftIO $ Git.Config.fromPipe r cmd params + pipedconfig st mustincludeuuuid configloc cmd params = do + v <- liftIO $ Git.Config.fromPipe r cmd params st case v of Right (r', val, _err) -> do unless (isUUIDConfigured r' || S.null val || not mustincludeuuuid) $ do @@ -282,7 +282,7 @@ liftIO $ hClose h let url = Git.repoLocation r ++ "/config" ifM (liftIO $ Url.downloadQuiet nullMeterUpdate url tmpfile uo) - ( Just <$> pipedconfig False url "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] + ( Just <$> pipedconfig Git.Config.ConfigNullList False url "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] , return Nothing ) case v of @@ -375,7 +375,7 @@ inAnnex' repo rmt st key inAnnex' :: Git.Repo -> Remote -> State -> Key -> Annex Bool -inAnnex' repo rmt (State connpool duc _ _) key +inAnnex' repo rmt st@(State connpool duc _ _ _) key | Git.repoIsHttp repo = checkhttp | Git.repoIsUrl repo = checkremote | otherwise = checklocal @@ -393,7 +393,7 @@ checklocal = ifM duc ( guardUsable repo (cantCheck repo) $ maybe (cantCheck repo) return - =<< onLocalFast repo rmt (Annex.Content.inAnnexSafe key) + =<< onLocalFast st (Annex.Content.inAnnexSafe key) , cantCheck repo ) @@ -421,10 +421,10 @@ (\e -> warning (show e) >> return False) dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex Bool -dropKey' repo r (State connpool duc _ _) key +dropKey' repo r st@(State connpool duc _ _ _) key | not $ Git.repoIsUrl repo = ifM duc ( guardUsable repo (return False) $ - commitOnCleanup repo r $ onLocalFast repo r $ do + commitOnCleanup repo r st $ onLocalFast st $ do whenM (Annex.Content.inAnnex key) $ do Annex.Content.lockContentForRemoval key $ \lock -> do Annex.Content.removeAnnex lock @@ -436,7 +436,7 @@ | Git.repoIsHttp repo = do warning "dropping from http remote not supported" return False - | otherwise = commitOnCleanup repo r $ do + | otherwise = commitOnCleanup repo r st $ do let fallback = Ssh.dropKey repo key P2PHelper.remove (Ssh.runProto r connpool (return False) fallback) key @@ -446,14 +446,14 @@ lockKey' repo r st key callback lockKey' :: Git.Repo -> Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r -lockKey' repo r (State connpool duc _ _) key callback +lockKey' repo r st@(State connpool duc _ _ _) key callback | not $ Git.repoIsUrl repo = ifM duc ( guardUsable repo failedlock $ do inorigrepo <- Annex.makeRunner -- Lock content from perspective of remote, -- and then run the callback in the original -- annex monad, not the remote's. - onLocalFast repo r $ + onLocalFast st $ Annex.Content.lockContentShared key $ liftIO . inorigrepo . callback , failedlock @@ -514,7 +514,7 @@ copyFromRemote'' repo forcersync r st key file dest meterupdate copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -copyFromRemote'' repo forcersync r st@(State connpool _ _ _) key file dest meterupdate +copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate | Git.repoIsHttp repo = unVerified $ do gc <- Annex.getGitConfig Url.withUrlOptionsPromptingCreds $ @@ -524,10 +524,12 @@ u <- getUUID hardlink <- wantHardLink -- run copy from perspective of remote - onLocalFast repo r $ do + onLocalFast st $ do v <- Annex.Content.prepSendAnnex key case v of - Nothing -> return (False, UnVerified) + Nothing -> do + warning "content is not present in remote" + return (False, UnVerified) Just (object, checksuccess) -> do copier <- mkCopier hardlink st params runTransfer (Transfer Download u (fromKey id key)) @@ -643,13 +645,13 @@ copyToRemote' repo r st key file meterupdate copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool -copyToRemote' repo r st@(State connpool duc _ _) key file meterupdate +copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate | not $ Git.repoIsUrl repo = ifM duc - ( guardUsable repo (return False) $ commitOnCleanup repo r $ + ( guardUsable repo (return False) $ commitOnCleanup repo r st $ copylocal =<< Annex.Content.prepSendAnnex key , return False ) - | Git.repoIsSsh repo = commitOnCleanup repo r $ + | Git.repoIsSsh repo = commitOnCleanup repo r st $ P2PHelper.store (\p -> Ssh.runProto r connpool (return False) (copyremotefallback p)) key file meterupdate @@ -668,7 +670,7 @@ u <- getUUID hardlink <- wantHardLink -- run copy from perspective of remote - onLocalFast repo r $ ifM (Annex.Content.inAnnex key) + onLocalFast st $ ifM (Annex.Content.inAnnex key) ( return True , runTransfer (Transfer Download u (fromKey id key)) file stdRetry $ \p -> do copier <- mkCopier hardlink st params @@ -715,6 +717,13 @@ ensureInitialized a `finally` stopCoProcesses +data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar (Maybe Annex.AnnexState)) + +{- This can safely be called on a Repo that is not local, but of course + - onLocal will not work if used with the result. -} +mkLocalRemoteAnnex :: Git.Repo -> Annex (LocalRemoteAnnex) +mkLocalRemoteAnnex repo = LocalRemoteAnnex repo <$> liftIO (newMVar Nothing) + {- Runs an action from the perspective of a local remote. - - The AnnexState is cached for speed and to avoid resource leaks. @@ -724,23 +733,29 @@ - The remote will be automatically initialized/upgraded first, - when possible. -} -onLocal :: Git.Repo -> Remote -> Annex a -> Annex a -onLocal repo r a = do - m <- Annex.getState Annex.remoteannexstate - case M.lookup (uuid r) m of - Nothing -> do - st <- liftIO $ Annex.new repo - go (st, ensureInitialized >> a) - Just st -> go (st, a) +onLocal :: State -> Annex a -> Annex a +onLocal (State _ _ _ _ lra) = onLocal' lra + +onLocalRepo :: Git.Repo -> Annex a -> Annex a +onLocalRepo repo a = do + lra <- mkLocalRemoteAnnex repo + onLocal' lra a + +onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a +onLocal' (LocalRemoteAnnex repo v) a = liftIO (takeMVar v) >>= \case + Nothing -> do + st <- liftIO $ Annex.new repo + go (st, ensureInitialized >> a) + Just st -> go (st, a) where - cache st = Annex.changeState $ \s -> s - { Annex.remoteannexstate = M.insert (uuid r) st (Annex.remoteannexstate s) } go (st, a') = do curro <- Annex.getState Annex.output - (ret, st') <- liftIO $ Annex.run (st { Annex.output = curro }) $ + let act = Annex.run (st { Annex.output = curro }) $ a' `finally` stopCoProcesses - cache st' + (ret, st') <- liftIO $ act `onException` cache st + liftIO $ cache st' return ret + cache st = putMVar v (Just st) {- Faster variant of onLocal. - @@ -749,8 +764,8 @@ - it gets the most current value. Caller of onLocalFast can make changes - to the branch, however. -} -onLocalFast :: Git.Repo -> Remote -> Annex a -> Annex a -onLocalFast repo r a = onLocal repo r $ Annex.BranchState.disableUpdate >> a +onLocalFast :: State -> Annex a -> Annex a +onLocalFast st a = onLocal st $ Annex.BranchState.disableUpdate >> a -- To avoid the overhead of trying copy-on-write every time, it's tried -- once and if it fails, is not tried again. @@ -784,7 +799,7 @@ ) where copycowtried = case st of - State _ _ (CopyCoWTried v) _ -> v + State _ _ (CopyCoWTried v) _ _ -> v dorsync = do -- dest may already exist, so make sure rsync can write to it void $ liftIO $ tryIO $ allowWrite dest @@ -796,12 +811,12 @@ docopywith a = liftIO $ watchFileSize dest p $ a CopyTimeStamps src dest -commitOnCleanup :: Git.Repo -> Remote -> Annex a -> Annex a -commitOnCleanup repo r a = go `after` a +commitOnCleanup :: Git.Repo -> Remote -> State -> Annex a -> Annex a +commitOnCleanup repo r st a = go `after` a where go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup cleanup - | not $ Git.repoIsUrl repo = onLocalFast repo r $ + | not $ Git.repoIsUrl repo = onLocalFast st $ doQuietSideAction $ Annex.Branch.commit =<< Annex.Branch.commitMessage | otherwise = void $ do @@ -857,23 +872,24 @@ - This returns False when the repository UUID is not as expected. -} type DeferredUUIDCheck = Annex Bool -data State = State Ssh.P2PSshConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig)) +data State = State Ssh.P2PSshConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex getRepoFromState :: State -> Annex Git.Repo -getRepoFromState (State _ _ _ a) = fst <$> a +getRepoFromState (State _ _ _ a _) = fst <$> a #ifndef mingw32_HOST_OS {- The config of the remote git repository, cached for speed. -} getGitConfigFromState :: State -> Annex GitConfig -getGitConfigFromState (State _ _ _ a) = snd <$> a +getGitConfigFromState (State _ _ _ a _) = snd <$> a #endif mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State mkState r u gc = do pool <- Ssh.mkP2PSshConnectionPool copycowtried <- liftIO newCopyCoWTried + lra <- mkLocalRemoteAnnex r (duc, getrepo) <- go - return $ State pool duc copycowtried getrepo + return $ State pool duc copycowtried getrepo lra where go | remoteAnnexCheckUUID gc = return diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -22,6 +22,7 @@ import Utility.ThreadScheduler import Config import Annex.Ssh +import Annex.BranchState import Types.Messages import Control.Concurrent @@ -163,7 +164,9 @@ annexstate <- newMVar =<< Annex.new =<< Git.CurrentRepo.get g <- Annex.repo <$> readMVar annexstate let h = TransportHandle (LocalRepo g) annexstate - liftAnnex h $ Annex.setOutput QuietOutput + liftAnnex h $ do + Annex.setOutput QuietOutput + enableInteractiveJournalAccess return h updateTransportHandle :: TransportHandle -> IO TransportHandle diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -24,6 +24,7 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy.UTF8 as BU8 import System.Environment +import Control.Concurrent.STM hiding (check) import Common import CmdLine.GitAnnex.Options @@ -65,6 +66,7 @@ import qualified Annex.View import qualified Annex.View.ViewedFile import qualified Logs.View +import qualified Command.TestRemote import qualified Utility.Path import qualified Utility.FileMode import qualified BuildInfo @@ -145,14 +147,16 @@ tests :: Bool -> Bool -> TestOptions -> TestTree tests crippledfilesystem adjustedbranchok opts = - testGroup "Tests" $ properties : - map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes + testGroup "Tests" $ properties + : withTestMode remotetestmode Nothing testRemotes + : map (\(d, te) -> withTestMode te (Just initTests) (unitTests d)) testmodes where testmodes = catMaybes [ canadjust ("v8 adjusted unlocked branch", (testMode opts (RepoVersion 8)) { adjustedUnlockedBranch = True }) , unlesscrippled ("v8 unlocked", (testMode opts (RepoVersion 8)) { unlockedFiles = True }) , unlesscrippled ("v8 locked", testMode opts (RepoVersion 8)) ] + remotetestmode = testMode opts (RepoVersion 8) unlesscrippled v | crippledfilesystem = Nothing | otherwise = Just v @@ -203,6 +207,62 @@ , Utility.Hash.props_macs_stable ] +testRemotes :: TestTree +testRemotes = testGroup "Remote Tests" + [ testRemote "directory" + [ "directory=remotedir" + , "encryption=none" + ] + (createDirectory "remotedir") + ] + +testRemote :: String -> [String] -> IO () -> TestTree +testRemote remotetype config preinitremote = + withResource newEmptyTMVarIO (const noop) $ \getv -> + testGroup ("remote type " ++ remotetype) $ concat + [ [testCase "init" (prep getv)] + , go getv + ] + where + reponame = "test repo" + remotename = "testremote" + basesz = 1024 * 1024 + keysizes = Command.TestRemote.keySizes basesz False + prep getv = do + d <- newmainrepodir + setmainrepodir d + innewrepo $ do + git_annex "init" [reponame, "--quiet"] + @? "init failed" + preinitremote + git_annex "initremote" + ([ remotename + , "type=" ++ remotetype + , "--quiet" + ] ++ config) + @? "init failed" + r <- annexeval $ either error return + =<< Remote.byName' remotename + unavailr <- annexeval $ Types.Remote.mkUnavailable r + exportr <- annexeval $ Command.TestRemote.exportTreeVariant r + ks <- annexeval $ mapM Command.TestRemote.randKey keysizes + v <- getv + liftIO $ atomically $ putTMVar v + (r, (unavailr, (exportr, ks))) + go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks + where + runannex = inmainrepo . annexeval + mkrs = Command.TestRemote.remoteVariants mkr basesz False + mkr = descas (remotetype ++ " remote") (fst <$> v) + mkunavailr = fst . snd <$> v + mkexportr = fst . snd . snd <$> v + mkks = map (\(sz, n) -> desckeysize sz (getk n)) + (zip keysizes [0..]) + getk n = fmap (!! n) (snd . snd . snd <$> v) + v = liftIO $ atomically . readTMVar =<< getv + descas = Command.TestRemote.Described + desckeysize sz = descas ("key size " ++ show sz) + {- These tests set up the test environment, but also test some basic parts - of git-annex. They are always run before the unitTests. -} initTests :: TestTree @@ -281,7 +341,7 @@ , testCase "addurl" test_addurl ] --- this test case create the main repo +-- this test case creates the main repo test_init :: Assertion test_init = innewrepo $ do ver <- annexVersion <$> getTestMode @@ -1576,14 +1636,12 @@ testscheme scheme = do abstmp <- absPath tmpdir testscheme' scheme abstmp - testscheme' scheme abstmp = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do - -- Use a relative path to avoid too long path to gpg's - -- agent socket. + testscheme' scheme abstmp = intmpclonerepo $ do gpgtmp <- ( "gpgtmp") <$> relPathCwdToFile abstmp createDirectoryIfMissing False gpgtmp - Utility.Gpg.testTestHarness gpgtmp gpgcmd + Utility.Gpg.testTestHarness gpgtmp gpgcmd @? "test harness self-test failed" - Utility.Gpg.testHarness gpgtmp gpgcmd $ do + void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ do createDirectory "dir" let a cmd = git_annex cmd $ [ "foo" @@ -1664,7 +1722,7 @@ unlessM (hasUnlockedFiles <$> getTestMode) $ do git_annex "sync" [] @? "sync failed" l <- annexeval $ Utility.FileSystemEncoding.decodeBL - <$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo") + <$> Annex.CatFile.catObject (Git.Types.Ref (encodeBS "HEAD:dir/foo")) "../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l) createDirectory "dir2" diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -79,10 +79,10 @@ Annex.setOutput Types.Messages.QuietOutput a `finally` Annex.Action.stopCoProcesses -innewrepo :: Assertion -> Assertion +innewrepo :: IO () -> IO () innewrepo a = withgitrepo $ \r -> indir r a -inmainrepo :: Assertion -> Assertion +inmainrepo :: IO a -> IO a inmainrepo a = do d <- mainrepodir indir d a @@ -417,17 +417,19 @@ hasUnlockedFiles :: TestMode -> Bool hasUnlockedFiles m = unlockedFiles m || adjustedUnlockedBranch m -withTestMode :: TestMode -> TestTree -> TestTree -> TestTree -withTestMode testmode inittests = withResource prepare release . const +withTestMode :: TestMode -> Maybe TestTree -> TestTree -> TestTree +withTestMode testmode minittests = withResource prepare release . const where prepare = do setTestMode testmode setmainrepodir =<< newmainrepodir - case tryIngredients [consoleTestReporter] mempty inittests of - Nothing -> error "No tests found!?" - Just act -> unlessM act $ - error "init tests failed! cannot continue" - return () + case minittests of + Just inittests -> + case tryIngredients [consoleTestReporter] mempty inittests of + Nothing -> error "No tests found!?" + Just act -> unlessM act $ + error "init tests failed! cannot continue" + Nothing -> return () release _ = noop setTestMode :: TestMode -> IO () diff --git a/Types/BranchState.hs b/Types/BranchState.hs --- a/Types/BranchState.hs +++ b/Types/BranchState.hs @@ -8,9 +8,17 @@ module Types.BranchState where data BranchState = BranchState - { branchUpdated :: Bool -- has the branch been updated this run? - , indexChecked :: Bool -- has the index file been checked to exist? + { branchUpdated :: Bool + -- ^ has the branch been updated this run? + , indexChecked :: Bool + -- ^ has the index file been checked to exist? + , journalIgnorable :: Bool + -- ^ can reading the journal be skipped, while still getting + -- sufficiently up-to-date information from the branch? + , journalNeverIgnorable :: Bool + -- ^ should the journal always be read even if it would normally + -- be safe to skip it? } startBranchState :: BranchState -startBranchState = BranchState False False +startBranchState = BranchState False False False False diff --git a/Types/CatFileHandles.hs b/Types/CatFileHandles.hs new file mode 100644 --- /dev/null +++ b/Types/CatFileHandles.hs @@ -0,0 +1,30 @@ +{- git-cat file handles pools + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.CatFileHandles ( + CatFileHandles(..), + catFileHandlesNonConcurrent, + catFileHandlesPool, +) where + +import Control.Concurrent.STM +import qualified Data.Map as M + +import Utility.ResourcePool +import Git.CatFile (CatFileHandle) + +data CatFileHandles + = CatFileHandlesNonConcurrent CatMap + | CatFileHandlesPool (TMVar CatMap) + +type CatMap = M.Map FilePath (ResourcePool CatFileHandle) + +catFileHandlesNonConcurrent :: CatFileHandles +catFileHandlesNonConcurrent = CatFileHandlesNonConcurrent M.empty + +catFileHandlesPool :: IO CatFileHandles +catFileHandlesPool = CatFileHandlesPool <$> newTMVarIO M.empty diff --git a/Types/Concurrency.hs b/Types/Concurrency.hs --- a/Types/Concurrency.hs +++ b/Types/Concurrency.hs @@ -11,6 +11,7 @@ -- the former specifies 1 job of each particular kind, but there can be -- more than one kind of job running concurrently. data Concurrency = NonConcurrent | Concurrent Int | ConcurrentPerCpu + deriving (Eq) parseConcurrency :: String -> Maybe Concurrency parseConcurrency "cpus" = Just ConcurrentPerCpu diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -343,7 +343,7 @@ , remoteAnnexReadOnly = getbool "readonly" False , remoteAnnexCheckUUID = getbool "checkuuid" True , remoteAnnexVerify = getbool "verify" True - , remoteAnnexTrackingBranch = Git.Ref <$> + , remoteAnnexTrackingBranch = Git.Ref . encodeBS <$> ( notempty (getmaybe "tracking-branch") <|> notempty (getmaybe "export-tracking") -- old name ) diff --git a/Types/IndexFiles.hs b/Types/IndexFiles.hs new file mode 100644 --- /dev/null +++ b/Types/IndexFiles.hs @@ -0,0 +1,11 @@ +{- Alternative git index files + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.IndexFiles where + +data AltIndexFile = AnnexIndexFile | ViewIndexFile + deriving (Eq, Show) diff --git a/Types/RefSpec.hs b/Types/RefSpec.hs --- a/Types/RefSpec.hs +++ b/Types/RefSpec.hs @@ -32,7 +32,7 @@ mk ('+':s) | any (`elem` s) "*?" = Right $ AddMatching $ compileGlob s CaseSensative - | otherwise = Right $ AddRef $ Ref s + | otherwise = Right $ AddRef $ Ref $ encodeBS s mk ('-':s) = Right $ RemoveMatching $ compileGlob s CaseSensative mk "reflog" = Right AddRefLog mk s = Left $ "bad refspec item \"" ++ s ++ "\" (expected + or - prefix)" diff --git a/Types/UUID.hs b/Types/UUID.hs --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -58,6 +58,7 @@ instance ToUUID ConfigValue where toUUID (ConfigValue v) = toUUID v + toUUID NoConfigValue = NoUUID -- There is no matching FromUUID U.UUID because a git-annex UUID may -- be NoUUID or perhaps contain something not allowed in a canonical UUID. diff --git a/Types/View.hs b/Types/View.hs --- a/Types/View.hs +++ b/Types/View.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Types.View where import Annex.Common diff --git a/Upgrade.hs b/Upgrade.hs --- a/Upgrade.hs +++ b/Upgrade.hs @@ -13,7 +13,7 @@ import qualified Annex import qualified Git import Config -import Config.Files +import Annex.Path import Annex.Version import Types.RepoVersion #ifndef mingw32_HOST_OS @@ -103,7 +103,7 @@ -- upgrading a git repo other than the current repo. upgraderemote = do rp <- fromRawFilePath <$> fromRepo Git.repoPath - cmd <- liftIO readProgramFile + cmd <- liftIO programPath liftIO $ boolSystem' cmd [ Param "upgrade" , Param "--quiet" diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -92,7 +92,8 @@ push :: Annex () push = do - origin_master <- inRepo $ Git.Ref.exists $ Git.Ref "origin/master" + origin_master <- inRepo $ Git.Ref.exists $ + Git.Ref $ encodeBS' "origin/master" origin_gitannex <- Annex.Branch.hasOrigin case (origin_master, origin_gitannex) of (_, True) -> do @@ -101,12 +102,12 @@ -- will immediately work. Not pushed here, -- because it's less obnoxious to let the user -- push. - Annex.Branch.update + void Annex.Branch.update (True, False) -> do -- push git-annex to origin, so that -- "git push" will from then on -- automatically push it - Annex.Branch.update -- just in case + void Annex.Branch.update -- just in case showAction "pushing new git-annex branch to origin" showOutput inRepo $ Git.Command.run @@ -117,7 +118,7 @@ _ -> do -- no origin exists, so just let the user -- know about the new branch - Annex.Branch.update + void Annex.Branch.update showLongNote $ "git-annex branch created\n" ++ "Be sure to push this branch when pushing to remotes.\n" diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -59,7 +59,7 @@ fromDirectBranch :: Ref -> Ref fromDirectBranch directhead = case splitc '/' $ fromRef directhead of ("refs":"heads":"annex":"direct":rest) -> - Ref $ "refs/heads/" ++ intercalate "/" rest + Ref $ encodeBS' $ "refs/heads/" ++ intercalate "/" rest _ -> directhead switchHEADBack :: Annex () diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -9,7 +9,8 @@ {-# LANGUAGE CPP #-} module Utility.CoProcess ( - CoProcessHandle, + CoProcessHandle(..), + CoProcessState(..), start, stop, query, diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -376,9 +376,18 @@ #ifndef mingw32_HOST_OS {- Runs an action using gpg in a test harness, in which gpg does - not use ~/.gpg/, but sets up the test key in a subdirectory of - - the passed directory and uses it. -} -testHarness :: FilePath -> GpgCmd -> IO a -> IO a -testHarness tmpdir cmd a = bracket setup cleanup (const a) + - the passed directory and uses it. + - + - If the test harness is not able to be set up (eg, because gpg is not + - installed or because there is some problem importing the test key, + - perhaps related to the agent socket), the action is not run, and Nothing + - is returned. + -} +testHarness :: FilePath -> GpgCmd -> IO a -> IO (Maybe a) +testHarness tmpdir cmd a = ifM (inPath (unGpgCmd cmd)) + ( bracket (eitherToMaybe <$> tryNonAsync setup) cleanup go + , return Nothing + ) where var = "GNUPGHOME" @@ -395,9 +404,13 @@ [testSecretKey, testKey] return orig - cleanup (Just v) = setEnv var v True - cleanup Nothing = unsetEnv var + cleanup (Just (Just v)) = setEnv var v True + cleanup (Just Nothing) = unsetEnv var + cleanup Nothing = return () + go (Just _) = Just <$> a + go Nothing = return Nothing + makenewdir n = do let subdir = tmpdir show n catchIOErrorType AlreadyExists (const $ makenewdir $ n + 1) $ do @@ -406,9 +419,12 @@ {- Tests the test harness. -} testTestHarness :: FilePath -> GpgCmd -> IO Bool -testTestHarness tmpdir cmd = do - keys <- testHarness tmpdir cmd $ findPubKeys cmd testKeyId - return $ KeyIds [testKeyId] == keys +testTestHarness tmpdir cmd = + testHarness tmpdir cmd (findPubKeys cmd testKeyId) >>= \case + Nothing -> do + hPutStrLn stderr "unable to test gpg, setting up the test harness did not succeed" + return True + Just keys -> return $ KeyIds [testKeyId] == keys checkEncryptionFile :: GpgCmd -> FilePath -> Maybe KeyIds -> IO Bool checkEncryptionFile cmd filename keys = diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -11,6 +11,7 @@ hGetContentsStrict, readFileStrict, separate, + separate', firstLine, firstLine', segment, @@ -53,6 +54,13 @@ unbreak r@(a, b) | null b = r | otherwise = (a, tail b) + +separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) +separate' c l = unbreak $ S.break c l + where + unbreak r@(a, b) + | S.null b = r + | otherwise = (a, S.tail b) {- Breaks out the first line. -} firstLine :: String -> String diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -1,7 +1,7 @@ {- System.Process enhancements, including additional ways of running - processes, and logging. - - - Copyright 2012-2015 Joey Hess + - Copyright 2012-2020 Joey Hess - - License: BSD-2-clause -} @@ -53,6 +53,7 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad +import qualified Data.ByteString as S type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -85,25 +86,20 @@ -> [String] -> Maybe [(String, String)] -> (Maybe (Handle -> IO ())) - -> (Maybe (Handle -> IO ())) - -> IO String -writeReadProcessEnv cmd args environ writestdin adjusthandle = do + -> IO S.ByteString +writeReadProcessEnv cmd args environ writestdin = do (Just inh, Just outh, _, pid) <- createProcess p - maybe (return ()) (\a -> a inh) adjusthandle - maybe (return ()) (\a -> a outh) adjusthandle - -- fork off a thread to start consuming the output - output <- hGetContents outh outMVar <- newEmptyMVar - _ <- forkIO $ E.evaluate (length output) >> putMVar outMVar () + _ <- forkIO $ putMVar outMVar =<< S.hGetContents outh -- now write and flush any input maybe (return ()) (\a -> a inh >> hFlush inh) writestdin hClose inh -- done with stdin -- wait on the output - takeMVar outMVar + output <- takeMVar outMVar hClose outh -- wait on the process diff --git a/Utility/ResourcePool.hs b/Utility/ResourcePool.hs new file mode 100644 --- /dev/null +++ b/Utility/ResourcePool.hs @@ -0,0 +1,94 @@ +{- Resource pools. + - + - Copyright 2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE BangPatterns #-} + +module Utility.ResourcePool ( + ResourcePool(..), + mkResourcePool, + mkResourcePoolNonConcurrent, + withResourcePool, + freeResourcePool, +) where + +import Common + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Data.Either + +data ResourcePool r + = ResourcePool Int (TVar Int) (TVar [r]) + | ResourcePoolNonConcurrent r + +{- Make a new resource pool, that can grow to contain the specified number + - of resources. -} +mkResourcePool :: MonadIO m => Int -> m (ResourcePool r) +mkResourcePool maxsz = liftIO $ + ResourcePool maxsz + <$> newTVarIO 0 + <*> newTVarIO [] + +{- When there will not be multiple threads that may + - may concurrently try to use it, using this is more + - efficient than mkResourcePool. + -} +mkResourcePoolNonConcurrent :: (MonadMask m, MonadIO m) => m r -> m (ResourcePool r) +mkResourcePoolNonConcurrent allocresource = + ResourcePoolNonConcurrent <$> allocresource + +{- Runs an action with a resource. + - + - If no free resource is available in the pool, + - will run the action the allocate a new resource if the pool's size + - allows. Or will block a resource becomes available to use. + - + - The resource is returned to the pool at the end. + -} +withResourcePool :: (MonadMask m, MonadIO m) => ResourcePool r -> m r -> (r -> m a) -> m a +withResourcePool (ResourcePoolNonConcurrent r) _ a = a r +withResourcePool (ResourcePool maxsz currsz p) allocresource a = + bracket setup cleanup a + where + setup = do + mr <- liftIO $ atomically $ do + l <- readTVar p + case l of + (r:rs) -> do + writeTVar p rs + return (Just r) + [] -> do + n <- readTVar currsz + if n < maxsz + then do + let !n' = succ n + writeTVar currsz n' + return Nothing + else retry + case mr of + Just r -> return r + Nothing -> allocresource + cleanup r = liftIO $ atomically $ modifyTVar' p (r:) + +{- Frees all resources in use in the pool, running the supplied action on + - each. (If any of the actions throw an exception, it will be rethrown + - after all the actions have completed.) + - + - The pool should not have any resources in use when this is called, + - and the pool should not be used again after calling this. + -} +freeResourcePool :: (MonadMask m, MonadIO m) => ResourcePool r -> (r -> m ()) -> m () +freeResourcePool (ResourcePoolNonConcurrent r) freeresource = freeresource r +freeResourcePool (ResourcePool _ currsz p) freeresource = do + rs <- liftIO $ atomically $ do + writeTVar currsz 0 + swapTVar p [] + res <- forM rs $ tryNonAsync . freeresource + case lefts res of + [] -> return () + (e:_) -> throwM e + diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -162,8 +162,8 @@ {- Checks that an url exists and could be successfully downloaded, - also checking that its size, if available, matches a specified size. - - - The Left error is returned if policy does not allow accessing the url - - or the url scheme is not supported. + - The Left error is returned if policy or the restricted http manager + - does not allow accessing the url or the url scheme is not supported. -} checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO (Either String Bool) checkBoth url expected_size uo = fmap go <$> check url expected_size uo @@ -195,8 +195,8 @@ {- Checks that an url exists and could be successfully downloaded, - also returning its size and suggested filename if available. - - - The Left error is returned if policy does not allow accessing the url - - or the url scheme is not supported. + - The Left error is returned if policy or the restricted http manages + - does not allow accessing the url or the url scheme is not supported. -} getUrlInfo :: URLString -> UrlOptions -> IO (Either String UrlInfo) getUrlInfo url uo = case parseURIRelaxed url of @@ -205,15 +205,8 @@ where go :: URI -> IO (Either String UrlInfo) go u = case (urlDownloader uo, parseRequest (show u)) of - (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust - -- When http redirects to a protocol which - -- conduit does not support, it will throw - -- a StatusCodeException with found302 - -- and a Response with the redir Location. - (matchStatusCodeException (== found302)) - (Right <$> existsconduit req uo) - (followredir r) - `catchNonAsync` (const $ return $ Right dne) + (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> + existsconduit r req (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) | isfileurl u -> Right <$> existsfile u | isftpurl u -> (Right <$> existscurlrestricted r u url ftpport) @@ -250,7 +243,23 @@ extractfilename = contentDispositionFilename . B8.toString <=< lookup hContentDisposition . responseHeaders - existsconduit req uo' = do + existsconduit r req = + let go = catchcrossprotoredir r (existsconduit' req uo) + in catchJust matchconnectionrestricted go retconnectionrestricted + + matchconnectionrestricted he@(HttpExceptionRequest _ (InternalException ie)) = + case fromException ie of + Just (ConnectionRestricted why) -> Just he + _ -> Nothing + matchconnectionrestricted _ = Nothing + + retconnectionrestricted he@(HttpExceptionRequest _ (InternalException ie)) = + case fromException ie of + Just (ConnectionRestricted why) -> return (Left why) + _ -> throwM he + retconnectionrestricted he = throwM he + + existsconduit' req uo' = do let req' = headRequest (applyRequest uo req) debugM "url" (show req') join $ runResourceT $ do @@ -266,7 +275,7 @@ then return $ getBasicAuth uo' (show (getUri req)) >>= \case Nothing -> return dne Just (ba, signalsuccess) -> do - ui <- existsconduit + ui <- existsconduit' (applyBasicAuth' ba req) (uo' { getBasicAuth = noBasicAuth }) signalsuccess (urlExists ui) @@ -301,6 +310,14 @@ sz <- getFileSize' f stat found (Just sz) Nothing Nothing -> return dne + + -- When http server redirects to a protocol which conduit does not + -- support, it will throw a StatusCodeException with found302 + -- and a Response with the redir Location. + catchcrossprotoredir r a = + catchJust (matchStatusCodeException (== found302)) + (Right <$> a) + (followredir r) followredir r (HttpExceptionRequest _ (StatusCodeException resp _)) = case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of diff --git a/doc/git-annex-copy.mdwn b/doc/git-annex-copy.mdwn --- a/doc/git-annex-copy.mdwn +++ b/doc/git-annex-copy.mdwn @@ -10,6 +10,9 @@ Copies the content of files from or to another remote. +With no parameters, operates on all annexed files in the current directory. +Paths of files or directories to operate on can be specified. + # OPTIONS * `--from=remote` @@ -38,7 +41,7 @@ * `--auto` - Rather than copying all files, only copy files that don't yet have + Rather than copying all specified files, only copy those that don't yet have the desired number of copies, or that are preferred content of the destination repository. See [[git-annex-preferred-content]](1) diff --git a/doc/git-annex-drop.mdwn b/doc/git-annex-drop.mdwn --- a/doc/git-annex-drop.mdwn +++ b/doc/git-annex-drop.mdwn @@ -18,6 +18,9 @@ Content that is required to be stored in the repository will not be dropped even if enough copies exist elsewhere. See [[git-annex-required]](1). +With no parameters, tries to drop all annexed files in the current directory. +Paths of files or directories to drop can be specified. + # OPTIONS * `--from=remote` @@ -28,7 +31,7 @@ * `--auto` - Rather than trying to drop all specified files, drop only files that + Rather than trying to drop all specified files, drop only those that are not preferred content of the repository. See [[git-annex-preferred-content]](1) @@ -44,7 +47,8 @@ Rather than specifying a filename or path to drop, this option can be used to drop all available versions of all files. - This is the default behavior when running git-annex drop in a bare repository. + This is the default behavior when running git-annex drop in a bare + repository. Note that this bypasses checking the .gitattributes annex.numcopies setting and required content settings. diff --git a/doc/git-annex-fsck.mdwn b/doc/git-annex-fsck.mdwn --- a/doc/git-annex-fsck.mdwn +++ b/doc/git-annex-fsck.mdwn @@ -8,11 +8,16 @@ # DESCRIPTION -With no parameters, this command checks the whole annex for consistency, -and warns about or fixes any problems found. This is a good complement to -`git fsck`. +This command checks annexed files for consistency, and warns about or +fixes any problems found. This is a good complement to `git fsck`. -With parameters, only the specified files are checked. +The default is to check all annexed files in the current directory and +subdirectories. With parameters, only the specified files are checked. + +The problems fsck finds include files that have gotten corrupted, +files whose content has somehow become lost, files that do not have the +configured number of copies yet made, and keys that can be upgraded to a +better format. # OPTIONS diff --git a/doc/git-annex-get.mdwn b/doc/git-annex-get.mdwn --- a/doc/git-annex-get.mdwn +++ b/doc/git-annex-get.mdwn @@ -12,12 +12,16 @@ will involve copying them from a remote repository, or downloading them, or transferring them from some kind of key-value store. +With no parameters, gets all annexed files in the current directory whose +content was not already present. Paths of files or directories to get can +be specified. + # OPTIONS * `--auto` - Rather than getting all files, get only files that don't yet have - the desired number of copies, or that are preferred content of the + Rather than getting all the specified files, get only those that don't yet + have the desired number of copies, or that are preferred content of the repository. See [[git-annex-preferred-content]](1) * `--from=remote` diff --git a/doc/git-annex-move.mdwn b/doc/git-annex-move.mdwn --- a/doc/git-annex-move.mdwn +++ b/doc/git-annex-move.mdwn @@ -10,6 +10,9 @@ Moves the content of files from or to another remote. +With no parameters, operates on all annexed files in the current directory. +Paths of files or directories to operate on can be specified. + # OPTIONS * `--from=remote` diff --git a/doc/git-annex-preferred-content.mdwn b/doc/git-annex-preferred-content.mdwn --- a/doc/git-annex-preferred-content.mdwn +++ b/doc/git-annex-preferred-content.mdwn @@ -48,6 +48,10 @@ [[git-annex-export]](1)) and [[git-annex-import]](1), these match relative to the top of the subdirectory. + Note that, when a command is run with the `--all` option, or in a bare + repository, there is no filename associated with an annexed object, + and so "include=" and "exclude=" will not match. + * `copies=number` Matches only files that git-annex believes to have the specified number @@ -159,6 +163,10 @@ `git annex enableremote $remote preferreddir=$dirname` (If no directory name is configured, it uses "public" by default.) + + Note that, when a command is run with the `--all` option, or in a bare + repository, there is no filename associated with an annexed object, + and so "inpreferreddir" will not match. * `standard` diff --git a/doc/git-annex-sync.mdwn b/doc/git-annex-sync.mdwn --- a/doc/git-annex-sync.mdwn +++ b/doc/git-annex-sync.mdwn @@ -46,6 +46,9 @@ Only sync with the remotes with the lowest annex-cost value configured. + When a list of remotes (or remote groups) is provided, it picks from + amoung those, otherwise it picks from amoung all remotes. + * `--only-annex` `-a`, `--not-only-annex` Only sync the git-annex branch and annexed content with remotes, @@ -99,9 +102,9 @@ The `annex.synccontent` configuration can be set to true to make content be synced by default. - Normally this tries to get each annexed file that the local repository - does not yet have, and then copies each file to every remote that it - is syncing with. + Normally this tries to get each annexed file that is in the working tree + and whose content the local repository does not yet have, and then copies + each file to every remote that it is syncing with. This behavior can be overridden by configuring the preferred content of a repository. See [[git-annex-preferred-content]](1). diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1039,10 +1039,6 @@ commit the data by running `git annex merge` (or by automatic merges) or `git annex sync`. - You should beware running `git gc` when using this configuration, - since it could garbage collect objects that are staged in git-annex's - index but not yet committed. - * `annex.commitmessage` When git-annex updates the git-annex branch, it usually makes up @@ -1531,10 +1527,21 @@ It is set to "true" if this is a git-lfs remote. -* `remote..annex-hooktype`, `remote..annex-externaltype` +* `remote..annex-externaltype` - Used by hook special remotes and external special remotes to record - the type of the remote. + Used external special remotes to record the type of the remote. + + Eg, if this is set to "foo", git-annex will run a "git-annex-remote-foo" + program to communicate with the external special remote. + + If this is set to "readonly", then git-annex will not run any external + special remote program, but will try to access things stored in the + remote using http. That only works for some external special remotes, + so consult the documentation of the one you are using. + +* `remote..annex-hooktype` + + Used by hook special remotes to record the type of the remote. * `annex.web-options` diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 8.20200330 +Version: 8.20200501 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess @@ -371,7 +371,7 @@ tasty-quickcheck, tasty-rerun CC-Options: -Wall - GHC-Options: -Wall -fno-warn-tabs + GHC-Options: -Wall -fno-warn-tabs -Wincomplete-uni-patterns Extensions: PackageImports, LambdaCase -- Some things don't work with the non-threaded RTS. GHC-Options: -threaded @@ -619,6 +619,7 @@ Annex.CheckIgnore Annex.Common Annex.Concurrent + Annex.Concurrent.Utility Annex.Content Annex.Content.LowLevel Annex.Content.PointerFile @@ -668,6 +669,7 @@ Annex.View Annex.View.ViewedFile Annex.Wanted + Annex.WorkerPool Annex.WorkTree Annex.YoutubeDl Backend @@ -974,6 +976,7 @@ Types.Backend Types.Benchmark Types.BranchState + Types.CatFileHandles Types.CleanupActions Types.Command Types.Concurrency @@ -988,6 +991,7 @@ Types.GitConfig Types.Group Types.Import + Types.IndexFiles Types.Key Types.KeySource Types.LockCache @@ -1087,6 +1091,7 @@ Utility.Process.Transcript Utility.QuickCheck Utility.RawFilePath + Utility.ResourcePool Utility.Rsync Utility.SafeCommand Utility.Scheduled