diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -74,6 +74,7 @@ import Types.RemoteConfig import Types.TransferrerPool import Types.VectorClock +import Types.Cluster import Annex.VectorClock.Utility import Annex.Debug.Utility import qualified Database.Keys.Handle as Keys @@ -194,6 +195,7 @@ , preferredcontentmap :: Maybe (FileMatcherMap Annex) , requiredcontentmap :: Maybe (FileMatcherMap Annex) , remoteconfigmap :: Maybe (M.Map UUID RemoteConfig) + , clusters :: Maybe Clusters , forcetrust :: TrustMap , trustmap :: Maybe TrustMap , groupmap :: Maybe GroupMap @@ -213,6 +215,7 @@ , urloptions :: Maybe UrlOptions , insmudgecleanfilter :: Bool , getvectorclock :: IO CandidateVectorClock + , proxyremote :: Maybe (Either ClusterUUID (Types.Remote.RemoteA Annex)) } newAnnexState :: GitConfig -> Git.Repo -> IO AnnexState @@ -247,6 +250,7 @@ , preferredcontentmap = Nothing , requiredcontentmap = Nothing , remoteconfigmap = Nothing + , clusters = Nothing , forcetrust = M.empty , trustmap = Nothing , groupmap = Nothing @@ -266,6 +270,7 @@ , urloptions = Nothing , insmudgecleanfilter = False , getvectorclock = vc + , proxyremote = Nothing } {- Makes an Annex state object for the specified git repo. @@ -423,6 +428,7 @@ { repo = r' , gitconfig = gitconfigadjuster $ extractGitConfig FromGitConfig r' + , gitremotes = Nothing } {- Gets the RemoteGitConfig from a remote, given the Git.Repo for that diff --git a/Annex/Action.hs b/Annex/Action.hs --- a/Annex/Action.hs +++ b/Annex/Action.hs @@ -5,12 +5,9 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Annex.Action ( action, verifiedAction, - startup, quiesce, stopCoProcesses, ) where @@ -27,11 +24,6 @@ import Annex.TransferrerPool import qualified Database.Keys -#ifndef mingw32_HOST_OS -import Control.Concurrent.STM -import System.Posix.Signals -#endif - {- Runs an action that may throw exceptions, catching and displaying them. -} action :: Annex () -> Annex Bool action a = tryNonAsync a >>= \case @@ -46,34 +38,6 @@ Left e -> do warning (UnquotedString (show e)) return (False, UnVerified) - - -{- Actions to perform each time ran. -} -startup :: Annex () -startup = do -#ifndef mingw32_HOST_OS - av <- Annex.getRead Annex.signalactions - let propagate sig = liftIO $ installhandleronce sig av - propagate sigINT - propagate sigQUIT - propagate sigTERM - propagate sigTSTP - propagate sigCONT - propagate sigHUP - -- sigWINCH is not propagated; it should not be needed, - -- and the concurrent-output library installs its own signal - -- handler for it. - -- sigSTOP and sigKILL cannot be caught, so will not be propagated. - where - installhandleronce sig av = void $ - installHandler sig (CatchOnce (gotsignal sig av)) Nothing - gotsignal sig av = do - mapM_ (\a -> a (fromIntegral sig)) =<< atomically (readTVar av) - raiseSignal sig - installhandleronce sig av -#else - return () -#endif {- Rn all cleanup actions, save all state, stop all long-running child - processes. diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -818,12 +818,18 @@ if neednewlocalbranch then do cmode <- annexCommitMode <$> Annex.getGitConfig - committedref <- inRepo $ Git.Branch.commitAlways cmode message fullname transitionedrefs - setIndexSha committedref + -- Creating a new empty branch must happen + -- atomically, so if this is interrupted, + -- it will not leave the new branch created + -- but without exports grafted in. + c <- inRepo $ Git.Branch.commitShaAlways + cmode message transitionedrefs + void $ regraftexports c else do ref <- getBranch - commitIndex jl ref message (nub $ fullname:transitionedrefs) - regraftexports + ref' <- regraftexports ref + commitIndex jl ref' message + (nub $ fullname:transitionedrefs) where message | neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc @@ -872,13 +878,25 @@ apply rest file content' -- Trees mentioned in export.log were grafted into the old - -- git-annex branch to make sure they remain available. Re-graft - -- the trees into the new branch. - regraftexports = do + -- git-annex branch to make sure they remain available. + -- Re-graft the trees. + regraftexports parent = do l <- exportedTreeishes . M.elems . parseExportLogMap <$> getStaged exportLog - forM_ l $ \t -> - rememberTreeishLocked t (asTopFilePath exportTreeGraftPoint) jl + c <- regraft l parent + inRepo $ Git.Branch.update' fullname c + setIndexSha c + return c + where + regraft [] c = pure c + regraft (et:ets) c = + -- Verify that the tree object exists. + catObjectDetails et >>= \case + Just _ -> + prepRememberTreeish et graftpoint c + >>= regraft ets + Nothing -> regraft ets c + graftpoint = asTopFilePath exportTreeGraftPoint checkBranchDifferences :: Git.Ref -> Annex () checkBranchDifferences ref = do @@ -935,26 +953,29 @@ - Returns the sha of the git commit made to the git-annex branch. -} rememberTreeish :: Git.Ref -> TopFilePath -> Annex Git.Sha -rememberTreeish treeish graftpoint = lockJournal $ - rememberTreeishLocked treeish graftpoint -rememberTreeishLocked :: Git.Ref -> TopFilePath -> JournalLocked -> Annex Git.Sha -rememberTreeishLocked treeish graftpoint jl = do +rememberTreeish treeish graftpoint = lockJournal $ \jl -> do branchref <- getBranch updateIndex jl branchref + c <- prepRememberTreeish treeish graftpoint branchref + inRepo $ Git.Branch.update' fullname c + -- The tree in c is the same as the tree in branchref, + -- and the index was updated to that above, so it's safe to + -- say that the index contains c. + setIndexSha c + return c + +{- Create a series of commits that graft a tree onto the parent commit, + - and then remove it. -} +prepRememberTreeish :: Git.Ref -> TopFilePath -> Git.Ref -> Annex Git.Sha +prepRememberTreeish treeish graftpoint parent = do origtree <- fromMaybe (giveup "unable to determine git-annex branch tree") <$> - inRepo (Git.Ref.tree branchref) + inRepo (Git.Ref.tree parent) addedt <- inRepo $ Git.Tree.graftTree treeish graftpoint origtree cmode <- annexCommitMode <$> Annex.getGitConfig c <- inRepo $ Git.Branch.commitTree cmode - ["graft"] [branchref] addedt - c' <- inRepo $ Git.Branch.commitTree cmode + ["graft"] [parent] addedt + inRepo $ Git.Branch.commitTree cmode ["graft cleanup"] [c] origtree - inRepo $ Git.Branch.update' fullname c' - -- The tree in c' is the same as the tree in branchref, - -- and the index was updated to that above, so it's safe to - -- say that the index contains c'. - setIndexSha c' - return c' {- Runs an action on the content of selected files from the branch. - This is much faster than reading the content of each file in turn, diff --git a/Annex/Cluster.hs b/Annex/Cluster.hs new file mode 100644 --- /dev/null +++ b/Annex/Cluster.hs @@ -0,0 +1,170 @@ +{- clusters + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes, OverloadedStrings #-} + +module Annex.Cluster where + +import Annex.Common +import qualified Annex +import Types.Cluster +import Logs.Cluster +import P2P.Proxy +import P2P.Protocol +import P2P.IO +import Annex.Proxy +import Annex.UUID +import Logs.Location +import Logs.PreferredContent +import Types.Command +import Remote.List +import qualified Remote +import qualified Types.Remote as Remote + +import qualified Data.Map as M +import qualified Data.Set as S +import System.Random + +{- Proxy to a cluster. -} +proxyCluster + :: ClusterUUID + -> CommandPerform + -> ServerMode + -> ClientSide + -> (forall a. Annex () -> ((a -> CommandPerform) -> Annex (Either ProtoFailure a) -> CommandPerform)) + -> CommandPerform +proxyCluster clusteruuid proxydone servermode clientside protoerrhandler = do + getClientProtocolVersion (fromClusterUUID clusteruuid) clientside + withclientversion (protoerrhandler noop) + where + proxymethods = ProxyMethods + { removedContent = \u k -> logChange k u InfoMissing + , addedContent = \u k -> logChange k u InfoPresent + } + + withclientversion (Just (clientmaxversion, othermsg)) = do + -- The protocol versions supported by the nodes are not + -- known at this point, and would be too expensive to + -- determine. Instead, pick the newest protocol version + -- that we and the client both speak. The proxy code + -- checks protocol versions when operating on multiple + -- nodes, and allows nodes to have different protocol + -- versions. + let protocolversion = min maxProtocolVersion clientmaxversion + sendClientProtocolVersion clientside othermsg protocolversion + (getclientbypass protocolversion) (protoerrhandler noop) + withclientversion Nothing = proxydone + + getclientbypass protocolversion othermsg = + getClientBypass clientside protocolversion othermsg + (withclientbypass protocolversion) (protoerrhandler noop) + + withclientbypass protocolversion (bypassuuids, othermsg) = do + (selectnode, closenodes) <- clusterProxySelector clusteruuid + protocolversion bypassuuids + concurrencyconfig <- getConcurrencyConfig + proxy proxydone proxymethods servermode clientside + (fromClusterUUID clusteruuid) + selectnode concurrencyconfig protocolversion + othermsg (protoerrhandler closenodes) + +clusterProxySelector :: ClusterUUID -> ProtocolVersion -> Bypass -> Annex (ProxySelector, Annex ()) +clusterProxySelector clusteruuid protocolversion (Bypass bypass) = do + nodeuuids <- (fromMaybe S.empty . M.lookup clusteruuid . clusterUUIDs) + <$> getClusters + myclusters <- annexClusters <$> Annex.getGitConfig + allremotes <- concat . Remote.byCost <$> remoteList + hereu <- getUUID + let bypass' = S.insert hereu bypass + let clusterremotes = filter (isnode bypass' allremotes nodeuuids myclusters) allremotes + fastDebug "Annex.Cluster" $ unwords + [ "cluster gateway at", fromUUID hereu + , "connecting to", show (map Remote.name clusterremotes) + , "bypass", show (S.toList bypass) + ] + nodes <- mapM (proxyRemoteSide protocolversion (Bypass bypass')) clusterremotes + let closenodes = mapM_ closeRemoteSide nodes + let proxyselector = ProxySelector + { proxyCHECKPRESENT = nodecontaining nodes + , proxyGET = nodecontaining nodes + -- The key is sent to multiple nodes at the same time, + -- skipping nodes where it's known/expected to already be + -- present to avoid needing to connect to those, and + -- skipping nodes where it's not preferred content. + , proxyPUT = \af k -> do + locs <- S.fromList <$> loggedLocations k + let l = filter (flip S.notMember locs . Remote.uuid . remote) nodes + l' <- filterM (\n -> isPreferredContent (Just (Remote.uuid (remote n))) mempty (Just k) af True) l + -- PUT to no nodes doesn't work, so fall + -- back to all nodes. + return $ nonempty [l', l] nodes + -- Remove the key from every node that contains it. + -- But, since it's possible the location log for some nodes + -- could be out of date, actually try to remove from every + -- node. + , proxyREMOVE = const (pure nodes) + -- Content is not locked on the cluster as a whole, + -- instead it can be locked on individual nodes that are + -- proxied to the client. + , proxyLOCKCONTENT = const (pure Nothing) + , proxyUNLOCKCONTENT = pure Nothing + } + return (proxyselector, closenodes) + where + -- Nodes of the cluster have remote.name.annex-cluster-node + -- containing its name. + -- + -- Or, a node can be the cluster proxied by another gateway. + isnode bypass' rs nodeuuids myclusters r = + case remoteAnnexClusterNode (Remote.gitconfig r) of + Just names + | any (isclustername myclusters) names -> + flip S.member nodeuuids $ + ClusterNodeUUID $ Remote.uuid r + | otherwise -> False + Nothing -> isclusterviagateway bypass' rs r + + -- Is this remote the same cluster, proxied via another gateway? + -- + -- Must avoid bypassed gateways to prevent cycles. + isclusterviagateway bypass' rs r = + case mkClusterUUID (Remote.uuid r) of + Just cu | cu == clusteruuid -> + case remoteAnnexProxiedBy (Remote.gitconfig r) of + Just proxyuuid | proxyuuid `S.notMember` bypass' -> + not $ null $ + filter isclustergateway $ + filter (\p -> Remote.uuid p == proxyuuid) rs + _ -> False + _ -> False + + isclustergateway r = any (== clusteruuid) $ + remoteAnnexClusterGateway $ Remote.gitconfig r + + isclustername myclusters name = + M.lookup name myclusters == Just clusteruuid + + nodecontaining nodes k = do + locs <- S.fromList <$> loggedLocations k + case filter (flip S.member locs . Remote.uuid . remote) nodes of + [] -> return Nothing + (node:[]) -> return (Just node) + (node:rest) -> + -- The list of nodes is ordered by cost. + -- Use any of the ones with equally low + -- cost. + let lowestcost = Remote.cost (remote node) + samecost = node : takeWhile (\n -> Remote.cost (remote n) == lowestcost) rest + in do + n <- liftIO $ getStdRandom $ + randomR (0, length samecost - 1) + return (Just (samecost !! n)) + + nonempty (l:ls) fallback + | null l = nonempty ls fallback + | otherwise = l + nonempty [] fallback = fallback diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -552,8 +552,8 @@ - If this happens, runs the rollback action and throws an exception. - The rollback action should remove the data that was transferred. -} -sendAnnex :: Key -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a -sendAnnex key rollback sendobject = go =<< prepSendAnnex' key +sendAnnex :: Key -> Maybe FilePath -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a +sendAnnex key o rollback sendobject = go =<< prepSendAnnex' key o where go (Just (f, sz, check)) = do r <- sendobject f sz @@ -575,10 +575,10 @@ - Annex monad of the remote that is receiving the object, rather than - the sender. So it cannot rely on Annex state. -} -prepSendAnnex :: Key -> Annex (Maybe (FilePath, FileSize, Annex Bool)) -prepSendAnnex key = withObjectLoc key $ \f -> do +prepSendAnnex :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex Bool)) +prepSendAnnex key Nothing = withObjectLoc key $ \f -> do let retval c cs = return $ Just - (fromRawFilePath f + ( fromRawFilePath f , inodeCacheFileSize c , sameInodeCache f cs ) @@ -601,9 +601,22 @@ , return Nothing ) Nothing -> return Nothing +-- If the provided object file is the annex object file, handle as above. +prepSendAnnex key (Just o) = withObjectLoc key $ \aof -> + let o' = toRawFilePath o + in if aof == o' + then prepSendAnnex key Nothing + else do + withTSDelta (liftIO . genInodeCache o') >>= \case + Nothing -> return Nothing + Just c -> return $ Just + ( o + , inodeCacheFileSize c + , sameInodeCache o' [c] + ) -prepSendAnnex' :: Key -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String))) -prepSendAnnex' key = prepSendAnnex key >>= \case +prepSendAnnex' :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String))) +prepSendAnnex' key o = prepSendAnnex key o >>= \case Just (f, sz, checksuccess) -> let checksuccess' = ifM checksuccess ( return Nothing diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -58,7 +58,7 @@ getcopies fs = do (untrusted, have) <- trustPartition UnTrusted locs (numcopies, mincopies) <- getSafestNumMinCopies' afile key fs - return (length have, numcopies, mincopies, S.fromList untrusted) + return (numCopiesCount have, numcopies, mincopies, S.fromList untrusted) {- Check that we have enough copies still to drop the content. - When the remote being dropped from is untrusted, it was not diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -103,8 +103,8 @@ Right username -> [username, at, hostname, ":", reldir] Left _ -> [hostname, ":", reldir] -initialize :: Maybe String -> Maybe RepoVersion -> Annex () -initialize mdescription mversion = checkInitializeAllowed $ \initallowed -> do +initialize :: Annex () -> Maybe String -> Maybe RepoVersion -> Annex () +initialize startupannex mdescription mversion = checkInitializeAllowed $ \initallowed -> do {- Has to come before any commits are made as the shared - clone heuristic expects no local objects. -} sharedclone <- checkSharedClone @@ -114,14 +114,14 @@ ensureCommit $ Annex.Branch.create prepUUID - initialize' mversion initallowed + initialize' startupannex mversion initallowed initSharedClone sharedclone u <- getUUID when (u == NoUUID) $ giveup "Failed to read annex.uuid from git config after setting it. This should never happen. Please file a bug report." - + {- Avoid overwriting existing description with a default - description. -} whenM (pure (isJust mdescription) <||> not . M.member u <$> uuidDescMapRaw) $ @@ -129,8 +129,8 @@ -- Everything except for uuid setup, shared clone setup, and initial -- description. -initialize' :: Maybe RepoVersion -> InitializeAllowed -> Annex () -initialize' mversion _initallowed = do +initialize' :: Annex () -> Maybe RepoVersion -> InitializeAllowed -> Annex () +initialize' startupannex mversion _initallowed = do checkLockSupport checkFifoSupport checkCrippledFileSystem @@ -162,6 +162,10 @@ createInodeSentinalFile False fixupUnusualReposAfterInit + -- This is usually run at Annex startup, but when git-annex was + -- not already initialized, it will not yet have run. + startupannex + uninitialize :: Annex () uninitialize = do -- Remove hooks that are written when initializing. @@ -203,12 +207,12 @@ - - Checks repository version and handles upgrades too. -} -ensureInitialized :: Annex [Remote] -> Annex () -ensureInitialized remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade +ensureInitialized :: Annex () -> Annex [Remote] -> Annex () +ensureInitialized startupannex remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade where needsinit = ifM autoInitializeAllowed ( do - tryNonAsync (initialize Nothing Nothing) >>= \case + tryNonAsync (initialize startupannex Nothing Nothing) >>= \case Right () -> noop Left e -> giveup $ show e ++ "\n" ++ "git-annex: automatic initialization failed due to above problems" @@ -256,15 +260,16 @@ - - Checks repository version and handles upgrades too. -} -autoInitialize :: Annex [Remote] -> Annex () +autoInitialize :: Annex () -> Annex [Remote] -> Annex () autoInitialize = autoInitialize' autoInitializeAllowed -autoInitialize' :: Annex Bool -> Annex [Remote] -> Annex () -autoInitialize' check remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade +autoInitialize' :: Annex Bool -> Annex () -> Annex [Remote] -> Annex () +autoInitialize' check startupannex remotelist = + getInitializedVersion >>= maybe needsinit checkUpgrade where needsinit = whenM (initializeAllowed <&&> check) $ do - initialize Nothing Nothing + initialize startupannex Nothing Nothing autoEnableSpecialRemotes remotelist {- Checks if a repository is initialized. Does not check version for upgrade. -} diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -1,6 +1,6 @@ {- git-annex numcopies configuration and checking - - - Copyright 2014-2021 Joey Hess + - Copyright 2014-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,6 +20,8 @@ defaultNumCopies, numCopiesCheck, numCopiesCheck', + numCopiesCheck'', + numCopiesCount, verifyEnoughCopiesToDrop, verifiableCopies, UnVerifiedCopy(..), @@ -30,6 +32,7 @@ import Types.NumCopies import Logs.NumCopies import Logs.Trust +import Logs.Cluster import Annex.CheckAttr import qualified Remote import qualified Types.Remote as Remote @@ -39,8 +42,10 @@ import qualified Database.Keys import Control.Exception -import qualified Control.Monad.Catch as M +import qualified Control.Monad.Catch as MC import Data.Typeable +import qualified Data.Set as S +import qualified Data.Map as M defaultNumCopies :: NumCopies defaultNumCopies = configuredNumCopies 1 @@ -197,13 +202,25 @@ numCopiesCheck' :: RawFilePath -> (Int -> Int -> v) -> [UUID] -> Annex v numCopiesCheck' file vs have = do - needed <- fromNumCopies . fst <$> getFileNumMinCopies file - let nhave = length have + needed <- fst <$> getFileNumMinCopies file + let nhave = numCopiesCount have explain (ActionItemTreeFile file) $ Just $ UnquotedString $ "has " ++ show nhave ++ " " ++ pluralCopies nhave ++ ", and the configured annex.numcopies is " ++ show needed - return $ nhave `vs` needed + return $ numCopiesCheck'' have vs needed +numCopiesCheck'' :: [UUID] -> (Int -> Int -> v) -> NumCopies -> v +numCopiesCheck'' have vs needed = + let nhave = numCopiesCount have + in nhave `vs` fromNumCopies needed + +{- When a key is logged as present in a node of the cluster, + - the cluster's UUID will also be in the list, but is not a + - distinct copy. + -} +numCopiesCount :: [UUID] -> Int +numCopiesCount = length . filter (not . isClusterUUID) + data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere deriving (Ord, Eq) @@ -214,6 +231,7 @@ verifyEnoughCopiesToDrop :: String -- message to print when there are no known locations -> Key + -> Maybe UUID -- repo dropping from -> Maybe ContentRemovalLock -> NumCopies -> MinCopies @@ -223,14 +241,14 @@ -> (SafeDropProof -> Annex a) -- action to perform the drop -> Annex a -- action to perform when unable to drop -> Annex a -verifyEnoughCopiesToDrop nolocmsg key removallock neednum needmin skip preverified tocheck dropaction nodropaction = +verifyEnoughCopiesToDrop nolocmsg key dropfrom removallock neednum needmin skip preverified tocheck dropaction nodropaction = helper [] [] preverified (nub tocheck) [] where helper bad missing have [] lockunsupported = liftIO (mkSafeDropProof neednum needmin have removallock) >>= \case Right proof -> dropaction proof Left stillhave -> do - notEnoughCopies key neednum needmin stillhave (skip++missing) bad nolocmsg lockunsupported + notEnoughCopies key dropfrom neednum needmin stillhave (skip++missing) bad nolocmsg lockunsupported nodropaction helper bad missing have (c:cs) lockunsupported | isSafeDrop neednum needmin have removallock = @@ -239,12 +257,17 @@ Left stillhave -> helper bad missing stillhave (c:cs) lockunsupported | otherwise = case c of UnVerifiedHere -> lockContentShared key contverified - UnVerifiedRemote r -> checkremote r contverified $ - let lockunsupported' = r : lockunsupported - in Remote.hasKey r key >>= \case - Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs lockunsupported' - Left _ -> helper (r:bad) missing have cs lockunsupported' - Right False -> helper bad (Remote.uuid r:missing) have cs lockunsupported' + UnVerifiedRemote r + -- Skip cluster uuids because locking is + -- not supported with them, instead will + -- lock individual nodes. + | isClusterUUID (Remote.uuid r) -> helper bad missing have cs lockunsupported + | otherwise -> checkremote r contverified $ + let lockunsupported' = r : lockunsupported + in Remote.hasKey r key >>= \case + Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs lockunsupported' + Left _ -> helper (r:bad) missing have cs lockunsupported' + Right False -> helper bad (Remote.uuid r:missing) have cs lockunsupported' where contverified vc = helper bad missing (vc : have) cs lockunsupported @@ -264,11 +287,11 @@ -- of exceptions by using DropException. let a = lockcontent key $ \v -> cont v `catchNonAsync` (throw . DropException) - a `M.catches` - [ M.Handler (\ (e :: AsyncException) -> throwM e) - , M.Handler (\ (e :: SomeAsyncException) -> throwM e) - , M.Handler (\ (DropException e') -> throwM e') - , M.Handler (\ (_e :: SomeException) -> fallback) + a `MC.catches` + [ MC.Handler (\ (e :: AsyncException) -> throwM e) + , MC.Handler (\ (e :: SomeAsyncException) -> throwM e) + , MC.Handler (\ (DropException e') -> throwM e') + , MC.Handler (\ (_e :: SomeException) -> fallback) ] Nothing -> fallback @@ -277,8 +300,8 @@ instance Exception DropException -notEnoughCopies :: Key -> NumCopies -> MinCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> [Remote] -> Annex () -notEnoughCopies key neednum needmin have skip bad nolocmsg lockunsupported = do +notEnoughCopies :: Key -> Maybe UUID -> NumCopies -> MinCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> [Remote] -> Annex () +notEnoughCopies key dropfrom neednum needmin have skip bad nolocmsg lockunsupported = do showNote "unsafe" if length have < fromNumCopies neednum then showLongNote $ UnquotedString $ @@ -297,7 +320,29 @@ ++ Remote.listRemoteNames lockunsupported Remote.showTriedRemotes bad - Remote.showLocations True key (map toUUID have++skip) nolocmsg + -- When dropping from a cluster, don't suggest making the nodes of + -- the cluster available + clusternodes <- case mkClusterUUID =<< dropfrom of + Nothing -> pure [] + Just cu -> do + clusters <- getClusters + pure $ maybe [] (map fromClusterNodeUUID . S.toList) $ + M.lookup cu (clusterUUIDs clusters) + let excludeset = S.fromList $ map toUUID have++skip++clusternodes + -- Don't suggest making a cluster available when dropping from its + -- node. + let exclude u + | u `S.member` excludeset = pure True + | otherwise = case (dropfrom, mkClusterUUID u) of + (Just dropfrom', Just cu) -> do + clusters <- getClusters + pure $ case M.lookup cu (clusterUUIDs clusters) of + Just nodes -> + ClusterNodeUUID dropfrom' + `S.member` nodes + Nothing -> False + _ -> pure False + Remote.showLocations True key exclude nolocmsg pluralCopies :: Int -> String pluralCopies 1 = "copy" @@ -312,17 +357,27 @@ - The return lists also exclude any repositories that are untrusted, - since those should not be used for verification. - + - When dropping from a cluster UUID, its nodes are excluded. + - + - Cluster UUIDs are also excluded since locking a key on a cluster + - is done by locking on individual nodes. + - - The UnVerifiedCopy list is cost ordered. - The VerifiedCopy list contains repositories that are trusted to - contain the key. -} verifiableCopies :: Key -> [UUID] -> Annex ([UnVerifiedCopy], [VerifiedCopy]) verifiableCopies key exclude = do - locs <- Remote.keyLocations key + locs <- filter (not . isClusterUUID) <$> Remote.keyLocations key (remotes, trusteduuids) <- Remote.remoteLocations (Remote.IncludeIgnored False) locs =<< trustGet Trusted + clusternodes <- if any isClusterUUID exclude + then do + clusters <- getClusters + pure $ concatMap (getclusternodes clusters) exclude + else pure [] untrusteduuids <- trustGet UnTrusted - let exclude' = exclude ++ untrusteduuids + let exclude' = exclude ++ untrusteduuids ++ clusternodes let remotes' = Remote.remotesWithoutUUID remotes (exclude' ++ trusteduuids) let verified = map (mkVerifiedCopy TrustedCopy) $ filter (`notElem` exclude') trusteduuids @@ -331,3 +386,8 @@ then [UnVerifiedHere] else [] return (herec ++ map UnVerifiedRemote remotes', verified) + where + getclusternodes clusters u = case mkClusterUUID u of + Just cu -> maybe [] (map fromClusterNodeUUID . S.toList) $ + M.lookup cu (clusterUUIDs clusters) + Nothing -> [] diff --git a/Annex/Proxy.hs b/Annex/Proxy.hs new file mode 100644 --- /dev/null +++ b/Annex/Proxy.hs @@ -0,0 +1,211 @@ +{- proxying + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.Proxy where + +import Annex.Common +import P2P.Proxy +import P2P.Protocol +import P2P.IO +import qualified Remote +import qualified Types.Remote as Remote +import qualified Remote.Git +import Remote.Helper.Ssh (openP2PShellConnection', closeP2PShellConnection) +import Annex.Content +import Annex.Concurrent +import Annex.Tmp +import Utility.Tmp.Dir +import Utility.Metered + +import Control.Concurrent.STM +import Control.Concurrent.Async +import qualified Data.ByteString.Lazy as L +import qualified System.FilePath.ByteString as P + +proxyRemoteSide :: ProtocolVersion -> Bypass -> Remote -> Annex RemoteSide +proxyRemoteSide clientmaxversion bypass r + | Remote.remotetype r == Remote.Git.remote = + proxyGitRemoteSide clientmaxversion bypass r + | otherwise = + proxySpecialRemoteSide clientmaxversion r + +proxyGitRemoteSide :: ProtocolVersion -> Bypass -> Remote -> Annex RemoteSide +proxyGitRemoteSide clientmaxversion bypass r = mkRemoteSide r $ + openP2PShellConnection' r clientmaxversion bypass >>= \case + Just conn@(OpenConnection (remoterunst, remoteconn, _)) -> + return $ Just + ( remoterunst + , remoteconn + , void $ liftIO $ closeP2PShellConnection conn + ) + _ -> return Nothing + +proxySpecialRemoteSide :: ProtocolVersion -> Remote -> Annex RemoteSide +proxySpecialRemoteSide clientmaxversion r = mkRemoteSide r $ do + let protoversion = min clientmaxversion maxProtocolVersion + remoterunst <- Serving (Remote.uuid r) Nothing <$> + liftIO (newTVarIO protoversion) + ihdl <- liftIO newEmptyTMVarIO + ohdl <- liftIO newEmptyTMVarIO + iwaitv <- liftIO newEmptyTMVarIO + owaitv <- liftIO newEmptyTMVarIO + endv <- liftIO newEmptyTMVarIO + worker <- liftIO . async =<< forkState + (proxySpecialRemote protoversion r ihdl ohdl owaitv endv) + let remoteconn = P2PConnection + { connRepo = Nothing + , connCheckAuth = const False + , connIhdl = P2PHandleTMVar ihdl iwaitv + , connOhdl = P2PHandleTMVar ohdl owaitv + , connIdent = ConnIdent (Just (Remote.name r)) + } + let closeremoteconn = do + liftIO $ atomically $ putTMVar endv () + join $ liftIO (wait worker) + return $ Just + ( remoterunst + , remoteconn + , closeremoteconn + ) + +-- Proxy for the special remote, speaking the P2P protocol. +proxySpecialRemote + :: ProtocolVersion + -> Remote + -> TMVar (Either L.ByteString Message) + -> TMVar (Either L.ByteString Message) + -> TMVar () + -> TMVar () + -> Annex () +proxySpecialRemote protoversion r ihdl ohdl owaitv endv = go + where + go :: Annex () + go = liftIO receivemessage >>= \case + Just (CHECKPRESENT k) -> do + tryNonAsync (Remote.checkPresent r k) >>= \case + Right True -> liftIO $ sendmessage SUCCESS + Right False -> liftIO $ sendmessage FAILURE + Left err -> liftIO $ propagateerror err + go + Just (LOCKCONTENT _) -> do + -- Special remotes do not support locking content. + liftIO $ sendmessage FAILURE + go + Just (REMOVE k) -> do + tryNonAsync (Remote.removeKey r k) >>= \case + Right () -> liftIO $ sendmessage SUCCESS + Left err -> liftIO $ propagateerror err + go + Just (PUT (ProtoAssociatedFile af) k) -> do + proxyput af k + go + Just (GET offset (ProtoAssociatedFile af) k) -> do + proxyget offset af k + go + Just (BYPASS _) -> go + Just (CONNECT _) -> + -- Not supported and the protocol ends here. + liftIO $ sendmessage $ CONNECTDONE (ExitFailure 1) + Just NOTIFYCHANGE -> do + liftIO $ sendmessage $ + ERROR "NOTIFYCHANGE unsupported for a special remote" + go + Just _ -> giveup "protocol error M" + Nothing -> return () + + getnextmessageorend = + liftIO $ atomically $ + (Right <$> takeTMVar ohdl) + `orElse` + (Left <$> readTMVar endv) + + receivemessage = getnextmessageorend >>= \case + Right (Right m) -> return (Just m) + Right (Left _b) -> giveup "unexpected ByteString received from P2P MVar" + Left () -> return Nothing + + receivebytestring = atomically (takeTMVar ohdl) >>= \case + Left b -> return b + Right _m -> giveup "did not receive ByteString from P2P MVar" + + sendmessage m = atomically $ putTMVar ihdl (Right m) + + sendbytestring b = atomically $ putTMVar ihdl (Left b) + + propagateerror err = sendmessage $ ERROR $ + "proxied special remote reports: " ++ show err + + -- Not using gitAnnexTmpObjectLocation because there might be + -- several concurrent GET and PUTs of the same key being proxied + -- from this special remote or others, and each needs to happen + -- independently. Also, this key is not getting added into the + -- local annex objects. + withproxytmpfile k a = withOtherTmp $ \othertmpdir -> + withTmpDirIn (fromRawFilePath othertmpdir) "proxy" $ \tmpdir -> + a (toRawFilePath tmpdir P. keyFile k) + + proxyput af k = do + liftIO $ sendmessage $ PUT_FROM (Offset 0) + withproxytmpfile k $ \tmpfile -> do + let store = tryNonAsync (Remote.storeKey r k af (Just (decodeBS tmpfile)) nullMeterUpdate) >>= \case + Right () -> liftIO $ sendmessage SUCCESS + Left err -> liftIO $ propagateerror err + liftIO receivemessage >>= \case + Just (DATA (Len _)) -> do + b <- liftIO receivebytestring + liftIO $ L.writeFile (fromRawFilePath tmpfile) b + -- Signal that the whole bytestring + -- has been received. + liftIO $ atomically $ putTMVar owaitv () + if protoversion > ProtocolVersion 1 + then liftIO receivemessage >>= \case + Just (VALIDITY Valid) -> + store + Just (VALIDITY Invalid) -> + return () + _ -> giveup "protocol error N" + else store + _ -> giveup "protocol error O" + + proxyget offset af k = withproxytmpfile k $ \tmpfile -> do + -- Don't verify the content from the remote, + -- because the client will do its own verification. + let vc = Remote.NoVerify + tryNonAsync (Remote.retrieveKeyFile r k af (fromRawFilePath tmpfile) nullMeterUpdate vc) >>= \case + Right v -> + ifM (verifyKeyContentPostRetrieval Remote.RetrievalVerifiableKeysSecure vc v k tmpfile) + ( liftIO $ senddata offset tmpfile + , liftIO $ sendmessage $ + ERROR "verification of content failed" + ) + Left err -> liftIO $ propagateerror err + + senddata (Offset offset) f = do + size <- fromIntegral <$> getFileSize f + let n = max 0 (size - offset) + sendmessage $ DATA (Len n) + withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do + hSeek h AbsoluteSeek offset + sendbs =<< L.hGetContents h + -- Important to keep the handle open until + -- the client responds. The bytestring + -- could still be lazily streaming out to + -- the client. + waitclientresponse + where + sendbs bs = do + sendbytestring bs + when (protoversion > ProtocolVersion 0) $ + sendmessage (VALIDITY Valid) + + waitclientresponse = + receivemessage >>= \case + Just SUCCESS -> return () + Just FAILURE -> return () + Just _ -> giveup "protocol error P" + Nothing -> return () + diff --git a/Annex/Startup.hs b/Annex/Startup.hs new file mode 100644 --- /dev/null +++ b/Annex/Startup.hs @@ -0,0 +1,67 @@ +{- git-annex startup + - + - Copyright 2010-2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Startup where + +import Annex.Common +import qualified Annex +import Logs.Cluster + +#ifndef mingw32_HOST_OS +import Control.Concurrent.STM +import System.Posix.Signals +#endif + +{- Run when starting up the main git-annex program. -} +startup :: Annex () +startup = do + startupSignals + gc <- Annex.getGitConfig + when (isinitialized gc) + startupAnnex + where + isinitialized gc = annexUUID gc /= NoUUID + && isJust (annexVersion gc) + +{- Run when starting up the main git-annex program when + - git-annex has already been initialized. + - Alternatively, run after initialization. + -} +startupAnnex :: Annex () +startupAnnex = doQuietAction $ + -- Logs.Location needs clusters to be loaded before it is used, + -- in order for a cluster to be treated as the location of keys + -- that are located in any of its nodes. + void loadClusters + +startupSignals :: Annex () +startupSignals = do +#ifndef mingw32_HOST_OS + av <- Annex.getRead Annex.signalactions + let propagate sig = liftIO $ installhandleronce sig av + propagate sigINT + propagate sigQUIT + propagate sigTERM + propagate sigTSTP + propagate sigCONT + propagate sigHUP + -- sigWINCH is not propagated; it should not be needed, + -- and the concurrent-output library installs its own signal + -- handler for it. + -- sigSTOP and sigKILL cannot be caught, so will not be propagated. + where + installhandleronce sig av = void $ + installHandler sig (CatchOnce (gotsignal sig av)) Nothing + gotsignal sig av = do + mapM_ (\a -> a (fromIntegral sig)) =<< atomically (readTVar av) + raiseSignal sig + installhandleronce sig av +#else + return () +#endif diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -55,13 +55,13 @@ -- Upload, supporting canceling detected stalls. upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool -upload r key f d witness = +upload r key af d witness = case getStallDetection Upload r of Nothing -> go (Just ProbeStallDetection) Just StallDetectionDisabled -> go Nothing - Just sd -> runTransferrer sd r key f d Upload witness + Just sd -> runTransferrer sd r key af d Upload witness where - go sd = upload' (Remote.uuid r) key f sd d (action . Remote.storeKey r key f) witness + go sd = upload' (Remote.uuid r) key af sd d (action . Remote.storeKey r key af Nothing) witness -- Upload, not supporting canceling detected stalls upload' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -6,7 +6,7 @@ - UUIDs of remotes are cached in git config, using keys named - remote..annex-uuid - - - Copyright 2010-2016 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -15,6 +15,7 @@ module Annex.UUID ( configkeyUUID, + configRepoUUID, getUUID, getRepoUUID, getUncachedUUID, @@ -47,6 +48,9 @@ configkeyUUID :: ConfigKey configkeyUUID = annexConfig "uuid" +configRepoUUID :: Git.Repo -> ConfigKey +configRepoUUID r = remoteAnnexConfig r "uuid" + {- Generates a random UUID, that does not include the MAC address. -} genUUID :: IO UUID genUUID = toUUID <$> U4.nextRandom @@ -82,7 +86,7 @@ updatecache u = do g <- gitRepo when (g /= r) $ storeUUIDIn cachekey u - cachekey = remoteAnnexConfig r "uuid" + cachekey = configRepoUUID r removeRepoUUID :: Annex () removeRepoUUID = do diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -19,6 +19,7 @@ import Annex.UUID import Annex.AdjustedBranch import Annex.Action +import Annex.Startup import Types.StandardGroups import Logs.PreferredContent import qualified Annex.Branch @@ -85,7 +86,7 @@ initRepo' :: Maybe String -> Maybe StandardGroup -> Annex () initRepo' desc mgroup = unlessM isInitialized $ do - initialize desc Nothing + initialize startupAnnex desc Nothing u <- getUUID maybe noop (defaultStandardGroup u) mgroup {- Ensure branch gets committed right away so it is diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -19,7 +19,6 @@ import Types.Distribution import Types.Transfer import Logs.Web -import Logs.Presence import Logs.Location import Annex.Content import Annex.UUID diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,27 @@ +git-annex (10.20240701) upstream; urgency=medium + + * git-annex remotes can now act as proxies that provide access to + their remotes. Configure this with remote.name.annex-proxy + and the git-annex update proxy command. + * Clusters are now supported. These are collections of nodes that can + be accessed as a single entity, accessed by one or more gateway + repositories. + * Added git-annex initcluster, updatecluster, and extendcluster commands. + * Fix a bug where interrupting git-annex while it is updating the + git-annex branch for an export could later lead to git fsck + complaining about missing tree objects. + * Tab completion of options like --from now includes special remotes, + as well as proxied remotes and clusters. + * Tab completion of many commands like info and trust now includes + remotes. + * P2P protocol version 2. + * Fix Windows build with Win32 2.13.4+ + Thanks, Oleg Tolmatcev + * When --debugfilter or annex.debugfilter is set, avoid propigating + debug output from git-annex-shell, since it cannot be filtered. + + -- Joey Hess Mon, 01 Jul 2024 15:11:48 -0400 + git-annex (10.20240531) upstream; urgency=medium * git-remote-annex: New program which allows pushing a git repo to a diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -23,6 +23,7 @@ import qualified Git import qualified Git.AutoCorrect import qualified Git.Config +import Annex.Startup import Annex.Action import Annex.Environment import Command diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -149,7 +149,7 @@ showEndMessage startmsg False return False -{- Waits for all worker threads to finish and merges their AnnexStates +{- Waits for all worker thrneads to finish and merges their AnnexStates - back into the current Annex's state. -} finishCommandActions :: Annex () diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -124,6 +124,10 @@ import qualified Command.FilterProcess import qualified Command.Restage import qualified Command.Undo +import qualified Command.InitCluster +import qualified Command.UpdateCluster +import qualified Command.ExtendCluster +import qualified Command.UpdateProxy import qualified Command.Version import qualified Command.RemoteDaemon #ifdef WITH_ASSISTANT @@ -247,6 +251,10 @@ , Command.FilterProcess.cmd , Command.Restage.cmd , Command.Undo.cmd + , Command.InitCluster.cmd + , Command.UpdateCluster.cmd + , Command.ExtendCluster.cmd + , Command.UpdateProxy.cmd , Command.Version.cmd , Command.RemoteDaemon.cmd #ifdef WITH_ASSISTANT diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -1,6 +1,6 @@ {- git-annex command-line option parsing - - - Copyright 2010-2023 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -40,6 +40,7 @@ import Utility.HumanTime import Utility.DataUnits import Annex.Concurrent +import Remote.List -- Options that are accepted by all git-annex sub-commands, -- although not always used. @@ -108,9 +109,12 @@ {- Parser that accepts all non-option params. -} cmdParams :: CmdParamsDesc -> Parser CmdParams -cmdParams paramdesc = many $ argument str +cmdParams paramdesc = cmdParamsWithCompleter paramdesc completeFiles + +cmdParamsWithCompleter :: String -> Mod ArgumentFields String -> Parser CmdParams +cmdParamsWithCompleter paramdesc completers = many $ argument str ( metavar paramdesc - <> action "file" + <> completers ) parseAutoOption :: Parser Bool @@ -569,14 +573,34 @@ ) completeRemotes :: HasCompleter f => Mod f a -completeRemotes = completer $ mkCompleter $ \input -> do - r <- maybe (pure Nothing) (Just <$$> Git.Config.read) - =<< Git.Construct.fromCwd - return $ filter (input `isPrefixOf`) $ - mapMaybe remoteKeyToRemoteName $ - filter isRemoteUrlKey $ - maybe [] (M.keys . config) r - +completeRemotes = completer $ mkCompleter $ \input -> + Git.Construct.fromCwd >>= \case + Nothing -> return [] + Just g -> completeRemotes' g input + +completeRemotes' :: Repo -> [Char] -> IO [[Char]] +completeRemotes' g input = do + g' <- Git.Config.read g + state <- Annex.new g' + Annex.eval state $ do + Annex.setOutput QuietOutput + gc <- Annex.getGitConfig + if isinitialized gc + then do + rs <- remoteList + matches $ map Remote.name rs + else matches $ + mapMaybe remoteKeyToRemoteName $ + filter isRemoteUrlKey $ + M.keys $ config g + where + isinitialized gc = annexUUID gc /= NoUUID && isJust (annexVersion gc) + matches = return . filter (input `isPrefixOf`) + completeBackends :: HasCompleter f => Mod f a completeBackends = completeWith $ map (decodeBS . formatKeyVariety . Backend.backendVariety) Backend.builtinList + +completeFiles :: HasCompleter f => Mod f a +completeFiles = action "file" + diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -1,6 +1,6 @@ {- git-annex-shell main program - - - Copyright 2010-2023 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -8,6 +8,7 @@ module CmdLine.GitAnnexShell where import Annex.Common +import qualified Annex import qualified Git.Construct import qualified Git.Config import CmdLine @@ -19,6 +20,11 @@ import Remote.GCrypt (getGCryptUUID) import P2P.Protocol (ServerMode(..)) import Git.Types +import qualified Types.Remote as R +import Logs.Proxy +import Logs.Cluster +import Logs.UUID +import Remote import qualified Command.ConfigList import qualified Command.NotifyChanges @@ -30,6 +36,7 @@ import qualified Command.DropKey import qualified Data.Map as M +import qualified Data.Set as S cmdsMap :: M.Map ServerMode [Command] cmdsMap = M.fromList $ map mk @@ -39,20 +46,22 @@ ] where readonlycmds = map addAnnexOptions - [ Command.ConfigList.cmd + [ notProxyable Command.ConfigList.cmd , gitAnnexShellCheck Command.NotifyChanges.cmd -- p2pstdio checks the environment variables to - -- determine the security policy to use + -- determine the security policy to use, so is safe to + -- include in the readonly list even though it is not + -- always readonly , gitAnnexShellCheck Command.P2PStdIO.cmd - , gitAnnexShellCheck Command.InAnnex.cmd - , gitAnnexShellCheck Command.SendKey.cmd + , notProxyable (gitAnnexShellCheck Command.InAnnex.cmd) + , notProxyable (gitAnnexShellCheck Command.SendKey.cmd) ] appendcmds = readonlycmds ++ map addAnnexOptions - [ gitAnnexShellCheck Command.RecvKey.cmd + [ notProxyable (gitAnnexShellCheck Command.RecvKey.cmd) ] allcmds = appendcmds ++ map addAnnexOptions - [ gitAnnexShellCheck Command.DropKey.cmd - , Command.GCryptSetup.cmd + [ notProxyable (gitAnnexShellCheck Command.DropKey.cmd) + , notProxyable Command.GCryptSetup.cmd ] mk (s, l) = (s, map (adddirparam . noMessages) l) @@ -77,17 +86,23 @@ where checkUUID expected = getUUID >>= check where - check u | u == toUUID expected = noop check NoUUID = checkGCryptUUID expected - check u = unexpectedUUID expected u + check u + | u == toUUID expected = noop + | otherwise = + unlessM (checkProxy (toUUID expected) u) $ + unexpectedUUID expected u + checkGCryptUUID expected = check =<< getGCryptUUID True =<< gitRepo where check (Just u) | u == toUUID expected = noop check Nothing = unexpected expected "uninitialized repository" check (Just u) = unexpectedUUID expected u + unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u unexpected expected s = giveup $ "expected repository UUID " ++ expected ++ " but found " ++ s + run :: [String] -> IO () run [] = failure @@ -104,6 +119,11 @@ | cmd `elem` builtins = failure | otherwise = external c +failure :: IO () +failure = giveup $ "bad parameters\n\n" ++ usage h cmdsList + where + h = "git-annex-shell [-c] command [parameters ...] [option ...]" + builtins :: [String] builtins = map cmdname cmdsList @@ -165,7 +185,60 @@ | field == fieldName autoInit = fieldCheck autoInit val | otherwise = False -failure :: IO () -failure = giveup $ "bad parameters\n\n" ++ usage h cmdsList +{- Check if this repository can proxy for a specified remote uuid, + - and if so enable proxying for it. -} +checkProxy :: UUID -> UUID -> Annex Bool +checkProxy remoteuuid ouruuid = M.lookup ouruuid <$> getProxies >>= \case + Nothing -> return False + -- This repository has (or had) proxying enabled. So it's + -- ok to display error messages that talk about proxies. + Just proxies -> + case filter (\p -> proxyRemoteUUID p == remoteuuid) (S.toList proxies) of + [] -> notconfigured + ps -> case mkClusterUUID remoteuuid of + Just cu -> proxyforcluster cu + Nothing -> proxyfor ps where - h = "git-annex-shell [-c] command [parameters ...] [option ...]" + -- This repository may have multiple remotes that access the same + -- repository. Proxy for the lowest cost one that is configured to + -- be used as a proxy. + proxyfor ps = do + rs <- concat . byCost <$> remoteList + myclusters <- annexClusters <$> Annex.getGitConfig + let sameuuid r = uuid r == remoteuuid + let samename r p = name r == proxyRemoteName p + case headMaybe (filter (\r -> sameuuid r && proxyisconfigured rs myclusters r && any (samename r) ps) rs) of + Nothing -> notconfigured + Just r -> do + Annex.changeState $ \st -> + st { Annex.proxyremote = Just (Right r) } + return True + + -- Only proxy for a remote when the git configuration + -- allows it. This is important to prevent changes to + -- the git-annex branch making git-annex-shell unexpectedly + -- proxy for remotes. + proxyisconfigured rs myclusters r + | remoteAnnexProxy (R.gitconfig r) = True + -- Proxy for remotes that are configured as cluster nodes. + | any (`M.member` myclusters) (fromMaybe [] $ remoteAnnexClusterNode $ R.gitconfig r) = True + -- Proxy for a remote when it is proxied by another remote + -- which is itself configured as a cluster gateway. + | otherwise = case remoteAnnexProxiedBy (R.gitconfig r) of + Just proxyuuid -> not $ null $ + concatMap (remoteAnnexClusterGateway . R.gitconfig) $ + filter (\p -> R.uuid p == proxyuuid) rs + Nothing -> False + + proxyforcluster cu = do + clusters <- getClusters + if M.member cu (clusterUUIDs clusters) + then do + Annex.changeState $ \st -> + st { Annex.proxyremote = Just (Left cu) } + return True + else notconfigured + + notconfigured = M.lookup remoteuuid <$> uuidDescMap >>= \case + Just desc -> giveup $ "not configured to proxy for repository " ++ fromUUIDDesc desc + Nothing -> return False diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs --- a/CmdLine/GitAnnexShell/Checks.hs +++ b/CmdLine/GitAnnexShell/Checks.hs @@ -1,6 +1,6 @@ {- git-annex-shell checks - - - Copyright 2012 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -82,3 +82,12 @@ where okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $ giveup "Not a git-annex or gcrypt repository." + +{- Used for Commands that don't support proxying. -} +notProxyable :: Command -> Command +notProxyable c = addCheck GitAnnexShellNotProxyable checkok c + where + checkok = Annex.getState Annex.proxyremote >>= \case + Nothing -> return () + Just _ -> giveup $ "Cannot proxy " ++ cmdname c ++ " command." + diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -30,6 +30,7 @@ import qualified Remote.External import Remote.Helper.Encryptable (parseEncryptionMethod) import Annex.Transfer +import Annex.Startup import Backend.GitRemoteAnnex import Config import Types.Key @@ -1173,7 +1174,7 @@ inRepo $ Git.Branch.delete Annex.Branch.fullname ifM (Annex.Branch.hasSibling <&&> nonbuggygitversion) ( do - autoInitialize' (pure True) remoteList + autoInitialize' (pure True) startupAnnex remoteList differences <- allDifferences <$> recordedDifferences when (differences /= mempty) $ deletebundleobjects diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -58,7 +58,7 @@ <$> loadP2PRemoteAuthToken (TorAnnex address port) myuuid <- getUUID g <- Annex.gitRepo - conn <- liftIO $ connectPeer g (TorAnnex address port) + conn <- liftIO $ connectPeer (Just g) (TorAnnex address port) runst <- liftIO $ mkRunState Client r <- liftIO $ runNetProto runst conn $ auth myuuid authtoken noop >>= \case Just _theiruuid -> connect service stdin stdout diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -23,6 +23,7 @@ import Options.Applicative as ReExported hiding (command) import qualified Git import Annex.Init +import Annex.Startup import Utility.Daemon import Types.Transfer import Types.ActionItem as ReExported @@ -39,6 +40,10 @@ withParams :: (CmdParams -> v) -> CmdParamsDesc -> Parser v withParams mkseek paramdesc = mkseek <$> cmdParams paramdesc +withParams' :: (CmdParams -> v) -> Mod ArgumentFields String -> String -> Parser v +withParams' mkseek completers paramdesc = mkseek + <$> cmdParamsWithCompleter paramdesc completers + {- Uses the supplied option parser, which yields a deferred parse, - and calls finishParse on the result before passing it to the - CommandSeek constructor. -} @@ -125,7 +130,7 @@ commonChecks = [repoExists] repoExists :: CommandCheck -repoExists = CommandCheck RepoExists (ensureInitialized remoteList) +repoExists = CommandCheck RepoExists (ensureInitialized startupAnnex remoteList) notBareRepo :: Command -> Command notBareRepo = addCheck CheckNotBareRepo checkNotBareRepo diff --git a/Command/Assistant.hs b/Command/Assistant.hs --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -17,6 +17,7 @@ import Utility.HumanTime import Assistant.Install import Remote.List +import Annex.Startup import Control.Concurrent.Async @@ -63,7 +64,7 @@ stop | otherwise = do liftIO ensureInstalled - ensureInitialized remoteList + ensureInitialized startupAnnex remoteList Command.Watch.start True (daemonOptions o) (startDelayOption o) startNoRepo :: AssistantOptions -> IO () diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -16,6 +16,7 @@ import Remote.GCrypt (coreGCryptId) import qualified CmdLine.GitAnnexShell.Fields as Fields import CmdLine.GitAnnexShell.Checks +import Annex.Startup cmd :: Command cmd = noCommit $ dontCheck repoExists $ @@ -47,7 +48,7 @@ else ifM (Annex.Branch.hasSibling <||> (isJust <$> Fields.getField Fields.autoInit)) ( do liftIO checkNotReadOnly - initialize Nothing Nothing + initialize startupAnnex Nothing Nothing getUUID , return NoUUID ) diff --git a/Command/Dead.hs b/Command/Dead.hs --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -22,7 +22,7 @@ data DeadOptions = DeadRemotes [RemoteName] | DeadKeys [Key] optParser :: CmdParamsDesc -> Parser DeadOptions -optParser desc = (DeadRemotes <$> cmdParams desc) +optParser desc = (DeadRemotes <$> cmdParamsWithCompleter desc completeRemotes) <|> (DeadKeys <$> many (option (str >>= parseKey) ( long "key" <> metavar paramKey <> help "keys whose content has been irretrievably lost" diff --git a/Command/Describe.hs b/Command/Describe.hs --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -14,8 +14,8 @@ cmd :: Command cmd = command "describe" SectionSetup "change description of a repository" - (paramPair paramRemote paramDesc) - (withParams seek) + (paramPair paramRepository paramDesc) + (withParams' seek completeRemotes) seek :: CmdParams -> CommandSeek seek = withWords (commandAction . start) diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -205,7 +205,7 @@ ifM (Annex.getRead Annex.force) ( dropaction Nothing , ifM (checkRequiredContent pcc dropfrom key afile) - ( verifyEnoughCopiesToDrop nolocmsg key + ( verifyEnoughCopiesToDrop nolocmsg key (Just dropfrom) contentlock numcopies mincopies skip preverified check (dropaction . Just) @@ -253,7 +253,7 @@ uuid <- getUUID let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote locs' <- trustExclude UnTrusted $ filter (/= remoteuuid) locs - if length locs' >= fromNumCopies numcopies + if numCopiesCheck'' locs' (>=) numcopies then a numcopies mincopies else stop | otherwise = a numcopies mincopies diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -105,11 +105,10 @@ check 0 _ = giveup "Still unable to connect to hidden service. It might not yet be usable by others. Please check Tor's logs for details." check _ [] = giveup "Somehow didn't get an onion address." - check n addrs@(addr:_) = do - g <- Annex.gitRepo + check n addrs@(addr:_) = -- Connect but don't bother trying to auth, -- we just want to know if the tor circuit works. - liftIO (tryNonAsync $ connectPeer g addr) >>= \case + liftIO (tryNonAsync $ connectPeer Nothing addr) >>= \case Left e -> do warning $ UnquotedString $ "Unable to connect to hidden service. It may not yet have propagated to the Tor network. (" ++ show e ++ ") Will retry.." liftIO $ threadDelaySeconds (Seconds 2) @@ -123,22 +122,21 @@ -- service's socket, start a listener. This is only run during the -- check, and it refuses all auth attempts. startlistener = do - r <- Annex.gitRepo u <- getUUID msock <- torSocketFile case msock of Just sockfile -> ifM (liftIO $ haslistener sockfile) ( liftIO $ async $ return () - , liftIO $ async $ runlistener sockfile u r + , liftIO $ async $ runlistener sockfile u ) Nothing -> giveup "Could not find socket file in Tor configuration!" - runlistener sockfile u r = serveUnixSocket sockfile $ \h -> do + runlistener sockfile u = serveUnixSocket sockfile $ \h -> do let conn = P2PConnection - { connRepo = r + { connRepo = Nothing , connCheckAuth = const False - , connIhdl = h - , connOhdl = h + , connIhdl = P2PHandle h + , connOhdl = P2PHandle h , connIdent = ConnIdent Nothing } runst <- mkRunState Client diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -304,7 +304,7 @@ alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do let rollback = void $ performUnexport r db [ek] loc - sendAnnex ek rollback $ \f _sz -> + sendAnnex ek Nothing rollback $ \f _sz -> Remote.action $ storer f ek loc pm , do diff --git a/Command/ExtendCluster.hs b/Command/ExtendCluster.hs new file mode 100644 --- /dev/null +++ b/Command/ExtendCluster.hs @@ -0,0 +1,58 @@ +{- git-annex command + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Command.ExtendCluster where + +import Command +import qualified Annex +import Types.Cluster +import Config +import Types.GitConfig +import qualified Remote +import qualified Command.UpdateCluster + +import qualified Data.Map as M + +cmd :: Command +cmd = command "extendcluster" SectionSetup "add an gateway to a cluster" + (paramPair paramRemote paramName) (withParams seek) + +seek :: CmdParams -> CommandSeek +seek (remotename:clustername:[]) = Remote.byName (Just clusterremotename) >>= \case + Just clusterremote -> Remote.byName (Just remotename) >>= \case + Just gatewayremote -> + case mkClusterUUID (Remote.uuid clusterremote) of + Just cu -> do + commandAction $ start cu clustername gatewayremote + Command.UpdateCluster.seek [] + Nothing -> giveup $ clusterremotename + ++ " is not a cluster remote." + Nothing -> giveup $ "No remote named " ++ remotename ++ " exists." + Nothing -> giveup $ "Expected to find a cluster remote named " + ++ clusterremotename + ++ " that is accessed via " ++ remotename + ++ ", but there is no such remote. Perhaps you need to" + ++ "git fetch from " ++ remotename + ++ ", or git-annex updatecluster needs to be run there?" + where + clusterremotename = remotename ++ "-" ++ clustername +seek _ = giveup "Expected two parameters, gateway and clustername." + +start :: ClusterUUID -> String -> Remote -> CommandStart +start cu clustername gatewayremote = starting "extendcluster" ai si $ do + myclusters <- annexClusters <$> Annex.getGitConfig + let setcus f = setConfig f (fromUUID (fromClusterUUID cu)) + unless (M.member clustername myclusters) $ do + setcus $ annexConfig ("cluster." <> encodeBS clustername) + setcus $ remoteAnnexConfig gatewayremote $ + remoteGitConfigKey ClusterGatewayField + next $ return True + where + ai = ActionItemOther (Just (UnquotedString clustername)) + si = SeekInput [clustername] diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -573,7 +573,7 @@ locs <- loggedLocations key (untrustedlocations, otherlocations) <- trustPartition UnTrusted locs (deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations - let present = length safelocations + let present = numCopiesCount safelocations if present < fromNumCopies numcopies then ifM (checkDead key) ( do diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -108,7 +108,8 @@ Remote.showTriedRemotes remotes showlocs (map Remote.uuid remotes) return False - showlocs exclude = Remote.showLocations False key exclude + showlocs exclude = Remote.showLocations False key + (\u -> pure (u `elem` exclude)) "No other repository is known to contain the file." -- This check is to avoid an ugly message if a remote is a -- drive that is not mounted. diff --git a/Command/Group.hs b/Command/Group.hs --- a/Command/Group.hs +++ b/Command/Group.hs @@ -20,7 +20,7 @@ cmd :: Command cmd = noMessages $ command "group" SectionSetup "add a repository to a group" - (paramPair paramRemote paramDesc) (seek <$$> optParser) + (paramPair paramRepository paramDesc) (seek <$$> optParser) data GroupOptions = GroupOptions { cmdparams :: CmdParams @@ -29,7 +29,7 @@ optParser :: CmdParamsDesc -> Parser GroupOptions optParser desc = GroupOptions - <$> cmdParams desc + <$> cmdParamsWithCompleter desc completeRemotes <*> switch ( long "list" <> help "list all currently defined groups" diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -319,7 +319,7 @@ (needcopies, mincopies) <- getFileNumMinCopies destfile (tocheck, preverified) <- verifiableCopies key [] - verifyEnoughCopiesToDrop [] key Nothing needcopies mincopies [] preverified tocheck + verifyEnoughCopiesToDrop [] key Nothing Nothing needcopies mincopies [] preverified tocheck (const yes) no seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CheckGitIgnore -> [String] -> CommandSeek diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -116,7 +116,7 @@ optParser :: CmdParamsDesc -> Parser InfoOptions optParser desc = InfoOptions - <$> cmdParams desc + <$> cmdParamsWithCompleter desc (completeFiles <> completeRemotes) <*> switch ( long "bytes" <> help "display file sizes in bytes" diff --git a/Command/Init.hs b/Command/Init.hs --- a/Command/Init.hs +++ b/Command/Init.hs @@ -12,6 +12,7 @@ import Command import Annex.Init import Annex.Version +import Annex.Startup import Types.RepoVersion import qualified Annex.SpecialRemote @@ -77,7 +78,7 @@ Just v | v /= wantversion -> giveup $ "This repository is already a initialized with version " ++ show (fromRepoVersion v) ++ ", not changing to requested version." _ -> noop - initialize + initialize startupAnnex (if null (initDesc os) then Nothing else Just (initDesc os)) (initVersion os) unless (noAutoEnable os) diff --git a/Command/InitCluster.hs b/Command/InitCluster.hs new file mode 100644 --- /dev/null +++ b/Command/InitCluster.hs @@ -0,0 +1,50 @@ +{- git-annex command + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Command.InitCluster where + +import Command +import qualified Annex +import Types.Cluster +import Logs.UUID +import Config +import Annex.UUID +import Git.Types +import Git.Remote (isLegalName) + +import qualified Data.Map as M + +cmd :: Command +cmd = command "initcluster" SectionSetup "initialize a new cluster" + (paramPair paramName paramDesc) (withParams seek) + +seek :: CmdParams -> CommandSeek +seek (clustername:desc:[]) = commandAction $ + start clustername (toUUIDDesc desc) +seek (clustername:[]) = commandAction $ + start clustername $ toUUIDDesc ("cluster " ++ clustername) +seek _ = giveup "Expected two parameters, name and description." + +start :: RemoteName -> UUIDDesc -> CommandStart +start clustername desc = starting "initcluster" ai si $ do + unless (isLegalName clustername) $ + giveup "That cluster name is not a valid git remote name." + + myclusters <- annexClusters <$> Annex.getGitConfig + unless (M.member clustername myclusters) $ do + cu <- fromMaybe (giveup "unable to generate a cluster UUID") + <$> genClusterUUID <$> liftIO genUUID + setConfig (annexConfig ("cluster." <> encodeBS clustername)) + (fromUUID (fromClusterUUID cu)) + describeUUID (fromClusterUUID cu) desc + + next $ return True + where + ai = ActionItemOther (Just (UnquotedString clustername)) + si = SeekInput [clustername] diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2023 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -16,11 +16,11 @@ import qualified Remote import Annex.UUID import Annex.Transfer -import Logs.Presence import Logs.Trust import Logs.File import Logs.Location import Annex.NumCopies +import Types.Cluster import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L @@ -194,7 +194,7 @@ DropCheckNumCopies -> do (numcopies, mincopies) <- getSafestNumMinCopies afile key (tocheck, verified) <- verifiableCopies key [srcuuid] - verifyEnoughCopiesToDrop "" key (Just contentlock) + verifyEnoughCopiesToDrop "" key (Just srcuuid) (Just contentlock) numcopies mincopies [srcuuid] verified (UnVerifiedRemote dest : tocheck) (drophere setpresentremote contentlock . showproof) @@ -300,7 +300,7 @@ DropCheckNumCopies -> do (numcopies, mincopies) <- getSafestNumMinCopies afile key (tocheck, verified) <- verifiableCopies key [Remote.uuid src] - verifyEnoughCopiesToDrop "" key Nothing numcopies mincopies [Remote.uuid src] verified + verifyEnoughCopiesToDrop "" key (Just (Remote.uuid src)) Nothing numcopies mincopies [Remote.uuid src] verified (adjusttocheck tocheck) (dropremote . showproof) faileddropremote DropWorse -> faileddropremote where @@ -503,7 +503,8 @@ - On the other hand, when the destination repository did not start - with a copy of a file, it can be dropped from the source without - making numcopies worse, so the move is allowed even if numcopies - - is not met. + - is not met. (However, when the source is a cluster, dropping from it + - drops from all nodes, and so numcopies must be checked.) - - Similarly, a file can move from an untrusted repository to another - untrusted repository, even if that is the only copy of the file. @@ -520,7 +521,7 @@ willDropMakeItWorse :: UUID -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> Annex DropCheck willDropMakeItWorse srcuuid destuuid (DestStartedWithCopy deststartedwithcopy _) key afile = ifM (Command.Drop.checkRequiredContent (Command.Drop.PreferredContentChecked False) srcuuid key afile) - ( if deststartedwithcopy + ( if deststartedwithcopy || isClusterUUID srcuuid then unlessforced DropCheckNumCopies else ifM checktrustlevel ( return DropAllowed diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -291,7 +291,7 @@ setupLink :: RemoteName -> P2PAddressAuth -> Annex LinkResult setupLink remotename (P2PAddressAuth addr authtoken) = do g <- Annex.gitRepo - cv <- liftIO $ tryNonAsync $ connectPeer g addr + cv <- liftIO $ tryNonAsync $ connectPeer (Just g) addr case cv of Left e -> return $ ConnectionError $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. (" ++ show e ++ ")" Right conn -> do diff --git a/Command/P2PStdIO.hs b/Command/P2PStdIO.hs --- a/Command/P2PStdIO.hs +++ b/Command/P2PStdIO.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2018 Joey Hess + - Copyright 2018-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,10 +10,16 @@ import Command import P2P.IO import P2P.Annex +import P2P.Proxy import qualified P2P.Protocol as P2P import qualified Annex +import Annex.Proxy import Annex.UUID import qualified CmdLine.GitAnnexShell.Checks as Checks +import Logs.Location +import Logs.Cluster +import Annex.Cluster +import qualified Remote import System.IO.Error @@ -35,16 +41,76 @@ (True, _) -> P2P.ServeReadOnly (False, True) -> P2P.ServeAppendOnly (False, False) -> P2P.ServeReadWrite + Annex.getState Annex.proxyremote >>= \case + Nothing -> + performLocal theiruuid servermode + Just (Right r) -> + performProxy theiruuid servermode r + Just (Left clusteruuid) -> + performProxyCluster theiruuid clusteruuid servermode + +performLocal :: UUID -> P2P.ServerMode -> CommandPerform +performLocal theiruuid servermode = do myuuid <- getUUID - conn <- stdioP2PConnection <$> Annex.gitRepo + let conn = stdioP2PConnection Nothing let server = do P2P.net $ P2P.sendMessage (P2P.AUTH_SUCCESS myuuid) P2P.serveAuthed servermode myuuid runst <- liftIO $ mkRunState $ Serving theiruuid Nothing - runFullProto runst conn server >>= \case - Right () -> done - -- Avoid displaying an error when the client hung up on us. - Left (ProtoFailureIOError e) | isEOFError e -> done - Left e -> giveup (describeProtoFailure e) + p2pErrHandler noop (const p2pDone) (runFullProto runst conn server) + +performProxy :: UUID -> P2P.ServerMode -> Remote -> CommandPerform +performProxy clientuuid servermode r = do + clientside <- proxyClientSide clientuuid + getClientProtocolVersion (Remote.uuid r) clientside + (withclientversion clientside) + (p2pErrHandler noop) where - done = next $ return True + withclientversion clientside (Just (clientmaxversion, othermsg)) = do + remoteside <- proxyRemoteSide clientmaxversion mempty r + protocolversion <- either (const (min P2P.maxProtocolVersion clientmaxversion)) id + <$> runRemoteSide remoteside + (P2P.net P2P.getProtocolVersion) + concurrencyconfig <- noConcurrencyConfig + let closer = do + closeRemoteSide remoteside + p2pDone + let errhandler = p2pErrHandler (closeRemoteSide remoteside) + let runproxy othermsg' = proxy closer proxymethods + servermode clientside + (Remote.uuid r) + (singleProxySelector remoteside) + concurrencyconfig + protocolversion othermsg' errhandler + sendClientProtocolVersion clientside othermsg protocolversion + runproxy errhandler + withclientversion _ Nothing = p2pDone + + proxymethods = ProxyMethods + { removedContent = \u k -> logChange k u InfoMissing + , addedContent = \u k -> logChange k u InfoPresent + } + +performProxyCluster :: UUID -> ClusterUUID -> P2P.ServerMode -> CommandPerform +performProxyCluster clientuuid clusteruuid servermode = do + clientside <- proxyClientSide clientuuid + proxyCluster clusteruuid p2pDone servermode clientside p2pErrHandler + +proxyClientSide :: UUID -> Annex ClientSide +proxyClientSide clientuuid = do + clientrunst <- liftIO (mkRunState $ Serving clientuuid Nothing) + ClientSide clientrunst <$> liftIO (stdioP2PConnectionDupped Nothing) + +p2pErrHandler :: Annex () -> (a -> CommandPerform) -> Annex (Either ProtoFailure a) -> CommandPerform +p2pErrHandler closeconn cont a = a >>= \case + -- Avoid displaying an error when the client hung up on us. + Left (ProtoFailureIOError e) | isEOFError e -> do + closeconn + p2pDone + Left e -> do + closeconn + giveup (describeProtoFailure e) + Right v -> cont v + +p2pDone :: CommandPerform +p2pDone = next $ return True diff --git a/Command/Reinit.hs b/Command/Reinit.hs --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -10,6 +10,7 @@ import Command import Annex.Init import Annex.UUID +import Annex.Startup import qualified Remote import qualified Annex.SpecialRemote @@ -36,6 +37,6 @@ then return $ toUUID s else Remote.nameToUUID s storeUUID u - checkInitializeAllowed $ initialize' Nothing + checkInitializeAllowed $ initialize' startupAnnex Nothing Annex.SpecialRemote.autoEnable next $ return True diff --git a/Command/Semitrust.hs b/Command/Semitrust.hs --- a/Command/Semitrust.hs +++ b/Command/Semitrust.hs @@ -15,7 +15,8 @@ cmd = withAnnexOptions [jsonOptions] $ command "semitrust" SectionSetup "return repository to default trust level" - (paramRepeating paramRepository) (withParams seek) + (paramRepeating paramRepository) + (withParams' seek completeRemotes) seek :: CmdParams -> CommandSeek seek = trustCommand "semitrust" SemiTrusted diff --git a/Command/SendKey.hs b/Command/SendKey.hs --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -32,7 +32,7 @@ <$> getField "RsyncOptions" ifM (inAnnex key) ( fieldTransfer Upload key $ \_p -> - sendAnnex key rollback $ \f _sz -> + sendAnnex key Nothing rollback $ \f _sz -> liftIO $ rsyncServerSend (map Param opts) f , do warning "requested key is not present" diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -302,7 +302,7 @@ tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) - store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate + store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate remove r k = Remote.removeKey r k testExportTree :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree] @@ -368,7 +368,7 @@ [ check isLeft "removeKey" $ \r k -> Remote.removeKey r k , check isLeft "storeKey" $ \r k -> - Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate + Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate , check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -50,9 +50,9 @@ FromRemote src -> fromPerform key (fileOption o) =<< getParsed src toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform -toPerform key file remote = go Upload file $ - upload' (uuid remote) key file Nothing stdRetry $ \p -> do - tryNonAsync (Remote.storeKey remote key file p) >>= \case +toPerform key af remote = go Upload af $ + upload' (uuid remote) key af Nothing stdRetry $ \p -> do + tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case Right () -> do Remote.logStatus remote key InfoPresent return True @@ -61,10 +61,10 @@ return False fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform -fromPerform key file remote = go Upload file $ - download' (uuid remote) key file Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file Nothing $ \t -> - tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case +fromPerform key af remote = go Upload af $ + download' (uuid remote) key af Nothing stdRetry $ \p -> + logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t -> + tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p vc) >>= \case Right v -> return (True, v) Left e -> do warning (UnquotedString (show e)) diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -38,20 +38,20 @@ runRequests readh writeh runner stop where - runner (TransferRequest direction remote key file) - | direction == Upload = notifyTransfer direction file $ - upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do - tryNonAsync (Remote.storeKey remote key file p) >>= \case + runner (TransferRequest direction remote key af) + | direction == Upload = notifyTransfer direction af $ + upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do + tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case Left e -> do warning (UnquotedString (show e)) return False Right () -> do Remote.logStatus remote key InfoPresent return True - | otherwise = notifyTransfer direction file $ - download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do - r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case + | otherwise = notifyTransfer direction af $ + download' (Remote.uuid remote) key af Nothing stdRetry $ \p -> + logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do + r <- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) >>= \case Left e -> do warning (UnquotedString (show e)) return (False, UnVerified) diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs --- a/Command/Transferrer.hs +++ b/Command/Transferrer.hs @@ -42,27 +42,27 @@ runRequests readh writeh runner stop where - runner (UploadRequest _ key (TransferAssociatedFile file)) remote = + runner (UploadRequest _ key (TransferAssociatedFile af)) remote = -- This is called by eg, Annex.Transfer.upload, -- so caller is responsible for doing notification, -- and for retrying, and updating location log, -- and stall canceling. - upload' (Remote.uuid remote) key file Nothing noRetry - (Remote.action . Remote.storeKey remote key file) + upload' (Remote.uuid remote) key af Nothing noRetry + (Remote.action . Remote.storeKey remote key af Nothing) noNotification - runner (DownloadRequest _ key (TransferAssociatedFile file)) remote = + runner (DownloadRequest _ key (TransferAssociatedFile af)) remote = -- This is called by eg, Annex.Transfer.download -- so caller is responsible for doing notification -- and for retrying, and updating location log, -- and stall canceling. - let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do - Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) - in download' (Remote.uuid remote) key file Nothing noRetry go + let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do + Remote.verifiedAction (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) + in download' (Remote.uuid remote) key af Nothing noRetry go noNotification - runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote = - notifyTransfer Upload file $ - upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do - tryNonAsync (Remote.storeKey remote key file p) >>= \case + runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote = + notifyTransfer Upload af $ + upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do + tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case Left e -> do warning (UnquotedString (show e)) return False diff --git a/Command/Trust.hs b/Command/Trust.hs --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -19,7 +19,8 @@ cmd :: Command cmd = withAnnexOptions [jsonOptions] $ command "trust" SectionSetup "trust a repository" - (paramRepeating paramRepository) (withParams seek) + (paramRepeating paramRepository) + (withParams' seek completeRemotes) seek :: CmdParams -> CommandSeek seek = trustCommand "trust" Trusted diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -16,7 +16,8 @@ cmd :: Command cmd = command "ungroup" SectionSetup "remove a repository from a group" - (paramPair paramRemote paramDesc) (withParams seek) + (paramPair paramRemote paramDesc) + (withParams' seek completeRemotes) seek :: CmdParams -> CommandSeek seek = withWords (commandAction . start) diff --git a/Command/Untrust.hs b/Command/Untrust.hs --- a/Command/Untrust.hs +++ b/Command/Untrust.hs @@ -14,7 +14,8 @@ cmd :: Command cmd = withAnnexOptions [jsonOptions] $ command "untrust" SectionSetup "do not trust a repository" - (paramRepeating paramRepository) (withParams seek) + (paramRepeating paramRepository) + (withParams' seek completeRemotes) seek :: CmdParams -> CommandSeek seek = trustCommand "untrust" UnTrusted diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -56,6 +56,7 @@ optParser _ = UnusedOptions <$> optional (strOption ( long "from" <> short 'f' <> metavar paramRemote + <> completeRemotes <> help "remote to check for unused content" )) <*> optional (option (eitherReader parseRefSpec) diff --git a/Command/UpdateCluster.hs b/Command/UpdateCluster.hs new file mode 100644 --- /dev/null +++ b/Command/UpdateCluster.hs @@ -0,0 +1,84 @@ +{- git-annex command + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Command.UpdateCluster where + +import Command +import qualified Annex +import Types.Cluster +import Logs.Cluster +import qualified Remote as R +import qualified Types.Remote as R +import qualified Command.UpdateProxy +import Utility.SafeOutput + +import qualified Data.Map as M +import qualified Data.Set as S + +cmd :: Command +cmd = noMessages $ command "updatecluster" SectionSetup + "update records of cluster nodes" + paramNothing (withParams seek) + +seek :: CmdParams -> CommandSeek +seek = withNothing $ do + commandAction start + commandAction Command.UpdateProxy.start + +start :: CommandStart +start = startingCustomOutput (ActionItemOther Nothing) $ do + rs <- R.remoteList + let getnode r = do + clusternames <- remoteAnnexClusterNode (R.gitconfig r) + return $ M.fromList $ zip clusternames (repeat (S.singleton r)) + let myclusternodes = M.unionsWith S.union (mapMaybe getnode rs) + myclusters <- annexClusters <$> Annex.getGitConfig + recordedclusters <- getClusters + descs <- R.uuidDescriptions + + -- Update the cluster log to list the currently configured nodes + -- of each configured cluster. + forM_ (M.toList myclusters) $ \(clustername, cu) -> do + let mynodesremotes = fromMaybe mempty $ + M.lookup clustername myclusternodes + let mynodes = S.map (ClusterNodeUUID . R.uuid) mynodesremotes + let recordednodes = fromMaybe mempty $ M.lookup cu $ + clusterUUIDs recordedclusters + proxiednodes <- findProxiedClusterNodes recordednodes + let allnodes = S.union mynodes proxiednodes + if recordednodes == allnodes + then liftIO $ putStrLn $ safeOutput $ + "No cluster node changes for cluster: " ++ clustername + else do + describechanges descs clustername recordednodes allnodes mynodesremotes + recordCluster cu allnodes + + next $ return True + where + describechanges descs clustername oldnodes allnodes mynodesremotes = do + forM_ (S.toList mynodesremotes) $ \r -> + unless (S.member (ClusterNodeUUID (R.uuid r)) oldnodes) $ + liftIO $ putStrLn $ safeOutput $ + "Added node " ++ R.name r ++ " to cluster: " ++ clustername + forM_ (S.toList oldnodes) $ \n -> + unless (S.member n allnodes) $ do + let desc = maybe (fromUUID (fromClusterNodeUUID n)) fromUUIDDesc $ + M.lookup (fromClusterNodeUUID n) descs + liftIO $ putStrLn $ safeOutput $ + "Removed node " ++ desc ++ " from cluster: " ++ clustername + +-- Finds nodes that are proxied by other cluster gateways. +findProxiedClusterNodes :: S.Set ClusterNodeUUID -> Annex (S.Set ClusterNodeUUID) +findProxiedClusterNodes recordednodes = + (S.fromList . map asclusternode . filter isproxynode) <$> R.remoteList + where + isproxynode r = + asclusternode r `S.member` recordednodes + && isJust (remoteAnnexProxiedBy (R.gitconfig r)) + asclusternode = ClusterNodeUUID . R.uuid diff --git a/Command/UpdateProxy.hs b/Command/UpdateProxy.hs new file mode 100644 --- /dev/null +++ b/Command/UpdateProxy.hs @@ -0,0 +1,96 @@ +{- git-annex command + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Command.UpdateProxy where + +import Command +import qualified Annex +import Logs.Proxy +import Logs.Cluster +import Annex.UUID +import qualified Remote as R +import qualified Types.Remote as R +import Utility.SafeOutput + +import qualified Data.Map as M +import qualified Data.Set as S + +cmd :: Command +cmd = noMessages $ command "updateproxy" SectionSetup + "update records with proxy configuration" + paramNothing (withParams seek) + +seek :: CmdParams -> CommandSeek +seek = withNothing (commandAction start) + +start :: CommandStart +start = startingCustomOutput (ActionItemOther Nothing) $ do + rs <- R.remoteList + let remoteproxies = S.fromList $ map mkproxy $ + filter (isproxy . R.gitconfig) rs + clusterproxies <- getClusterProxies remoteproxies + let proxies = S.union remoteproxies clusterproxies + u <- getUUID + oldproxies <- fromMaybe mempty . M.lookup u <$> getProxies + if oldproxies == proxies + then liftIO $ putStrLn "No proxy changes to record." + else do + describechanges oldproxies proxies + recordProxies proxies + next $ return True + where + describechanges oldproxies proxies = + forM_ (S.toList $ S.union oldproxies proxies) $ \p -> + case (S.member p oldproxies, S.member p proxies) of + (False, True) -> liftIO $ + putStrLn $ safeOutput $ + "Started proxying for " ++ proxyRemoteName p + (True, False) -> liftIO $ + putStrLn $ safeOutput $ + "Stopped proxying for " ++ proxyRemoteName p + _ -> noop + + isproxy c = remoteAnnexProxy c || not (null (remoteAnnexClusterNode c)) + + mkproxy r = Proxy (R.uuid r) (R.name r) + +-- Automatically proxy nodes of any cluster this repository is configured +-- to serve as a gateway for. Also proxy other cluster nodes that are +-- themselves proxied via other remotes. +getClusterProxies :: S.Set Proxy -> Annex (S.Set Proxy) +getClusterProxies remoteproxies = do + myclusters <- (map mkclusterproxy . M.toList . annexClusters) + <$> Annex.getGitConfig + remoteproxiednodes <- findRemoteProxiedClusterNodes + let myproxieduuids = S.map proxyRemoteUUID remoteproxies + <> S.fromList (map proxyRemoteUUID myclusters) + -- filter out nodes we proxy for from the remote proxied nodes + -- to avoid cycles + let remoteproxiednodes' = filter + (\n -> proxyRemoteUUID n `S.notMember` myproxieduuids) + remoteproxiednodes + return (S.fromList (myclusters ++ remoteproxiednodes')) + where + mkclusterproxy (remotename, cu) = + Proxy (fromClusterUUID cu) remotename + +findRemoteProxiedClusterNodes :: Annex [Proxy] +findRemoteProxiedClusterNodes = do + myclusters <- (S.fromList . M.elems . annexClusters) + <$> Annex.getGitConfig + clusternodes <- clusterNodeUUIDs <$> getClusters + let isproxiedclusternode r + | isJust (remoteAnnexProxiedBy (R.gitconfig r)) = + case M.lookup (ClusterNodeUUID (R.uuid r)) clusternodes of + Nothing -> False + Just s -> not $ S.null $ + S.intersection s myclusters + | otherwise = False + (map asproxy . filter isproxiedclusternode) + <$> R.remoteList + where + asproxy r = Proxy (R.uuid r) (R.name r) diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -11,6 +11,7 @@ import Upgrade import Annex.Version import Annex.Init +import Annex.Startup cmd :: Command cmd = dontCheck @@ -46,6 +47,6 @@ start _ = starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do whenM (isNothing <$> getVersion) $ do - initialize Nothing Nothing + initialize startupAnnex Nothing Nothing r <- upgrade False latestVersion next $ return r diff --git a/Command/Wanted.hs b/Command/Wanted.hs --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -27,7 +27,8 @@ -> (UUID -> PreferredContentExpression -> Annex ()) -> Command cmd' name desc getter setter = noMessages $ - command name SectionSetup desc pdesc (withParams seek) + command name SectionSetup desc pdesc + (withParams' seek completeRemotes) where pdesc = paramPair paramRemote (paramOptional paramExpression) diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -15,6 +15,7 @@ import Logs.Web import Remote.Web (getWebUrls) import Annex.UUID +import Annex.NumCopies import qualified Utility.Format import qualified Command.Find @@ -86,7 +87,7 @@ (untrustedlocations, safelocations) <- trustPartition UnTrusted locations case formatOption o of Nothing -> do - let num = length safelocations + let num = numCopiesCount safelocations showNote $ UnquotedString $ show num ++ " " ++ copiesplural num pp <- ppwhereis "whereis" safelocations urls unless (null safelocations) $ diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -178,13 +178,19 @@ - in any way, or output a summary. -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) -commit commitmode allowempty message branch parentrefs repo = do - tree <- writeTree repo - ifM (cancommit tree) - ( do - sha <- commitTree commitmode [message] parentrefs tree repo +commit commitmode allowempty message branch parentrefs repo = + commitSha commitmode allowempty message parentrefs repo >>= \case + Just sha -> do update' branch sha repo return $ Just sha + Nothing -> return Nothing + +{- Same as commit but without updating any branch. -} +commitSha :: CommitMode -> Bool -> String -> [Ref] -> Repo -> IO (Maybe Sha) +commitSha commitmode allowempty message parentrefs repo = do + tree <- writeTree repo + ifM (cancommit tree) + ( Just <$> commitTree commitmode [message] parentrefs tree repo , return Nothing ) where @@ -197,6 +203,10 @@ commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha commitAlways commitmode message branch parentrefs repo = fromJust <$> commit commitmode True message branch parentrefs repo + +commitShaAlways :: CommitMode -> String -> [Ref] -> Repo -> IO Sha +commitShaAlways commitmode message parentrefs repo = fromJust + <$> commitSha commitmode True message parentrefs repo -- Throws exception if the index is locked, with an error message output by -- git on stderr. diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -65,9 +65,13 @@ {- Only alphanumerics, and a few common bits of punctuation common - in hostnames. -} legal '_' = True + legal '-' = True legal '.' = True legal c = isAlphaNum c - + +isLegalName :: String -> Bool +isLegalName s = s == makeLegalName s + data RemoteLocation = RemoteUrl String | RemotePath FilePath deriving (Eq, Show) diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -84,6 +84,9 @@ fromConfigKey :: ConfigKey -> String fromConfigKey (ConfigKey s) = decodeBS s +fromConfigKey' :: ConfigKey -> S.ByteString +fromConfigKey' (ConfigKey s) = s + instance Show ConfigKey where show = fromConfigKey diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -408,7 +408,7 @@ go' n good notpresent key = do us <- filter (`S.notMember` notpresent) <$> (filterM good =<< Remote.keyLocations key) - return $ length us >= n + return $ numCopiesCount us >= n checktrust checker u = checker <$> lookupTrust u checkgroup g u = S.member g <$> lookupGroups u parsetrustspec s @@ -442,7 +442,8 @@ MatchingUserInfo {} -> approxNumCopies us <- filter (`S.notMember` notpresent) <$> (trustExclude UnTrusted =<< Remote.keyLocations key) - return $ fromNumCopies numcopies - length us >= needed + let vs nhave numcopies' = numcopies' - nhave >= needed + return $ numCopiesCheck'' us vs numcopies approxNumCopies = fromMaybe defaultNumCopies <$> getGlobalNumCopies {- Match keys that are unused. diff --git a/Logs.hs b/Logs.hs --- a/Logs.hs +++ b/Logs.hs @@ -98,6 +98,8 @@ topLevelNewUUIDBasedLogs :: [RawFilePath] topLevelNewUUIDBasedLogs = [ exportLog + , proxyLog + , clusterLog ] {- Other top-level logs. -} @@ -153,6 +155,12 @@ exportLog :: RawFilePath exportLog = "export.log" + +proxyLog :: RawFilePath +proxyLog = "proxy.log" + +clusterLog :: RawFilePath +clusterLog = "cluster.log" {- This is not a log file, it's where exported treeishes get grafted into - the git-annex branch. -} diff --git a/Logs/Cluster.hs b/Logs/Cluster.hs new file mode 100644 --- /dev/null +++ b/Logs/Cluster.hs @@ -0,0 +1,41 @@ +{- git-annex cluster log + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, TupleSections #-} + +module Logs.Cluster ( + module Types.Cluster, + getClusters, + loadClusters, + recordCluster, +) where + +import qualified Annex +import Annex.Common +import Types.Cluster +import Logs.Cluster.Basic +import Logs.Trust + +import qualified Data.Map as M +import qualified Data.Set as S + +getClusters :: Annex Clusters +getClusters = maybe loadClusters return =<< Annex.getState Annex.clusters + +{- Loads the clusters and caches it for later. + - + - This takes care of removing dead nodes from clusters, + - to avoid inserting the cluster uuid into the location + - log when only dead nodes contain the content of a key. + -} +loadClusters :: Annex Clusters +loadClusters = do + dead <- (S.fromList . map ClusterNodeUUID) + <$> trustGet DeadTrusted + clusters <- getClustersWith (M.map (`S.difference` dead)) + Annex.changeState $ \s -> s { Annex.clusters = Just clusters } + return clusters diff --git a/Logs/Cluster/Basic.hs b/Logs/Cluster/Basic.hs new file mode 100644 --- /dev/null +++ b/Logs/Cluster/Basic.hs @@ -0,0 +1,91 @@ +{- git-annex cluster log, basics + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, TupleSections #-} + +module Logs.Cluster.Basic ( + module Types.Cluster, + getClustersWith, + recordCluster, +) where + +import qualified Annex +import Annex.Common +import qualified Annex.Branch +import Types.Cluster +import Logs +import Logs.UUIDBased +import Logs.MapLog + +import qualified Data.Set as S +import qualified Data.Map as M +import Data.ByteString.Builder +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified Data.ByteString.Lazy as L + +{- Gets the clusters. Note that this includes any dead nodes, + - unless a function is provided to remove them. + -} +getClustersWith + :: (M.Map ClusterUUID (S.Set ClusterNodeUUID) + -> M.Map ClusterUUID (S.Set ClusterNodeUUID)) + -> Annex Clusters +getClustersWith removedeadnodes = do + m <- removedeadnodes + . convclusteruuids + . M.map value + . fromMapLog + . parseClusterLog + <$> Annex.Branch.get clusterLog + return $ Clusters + { clusterUUIDs = m + , clusterNodeUUIDs = M.foldlWithKey inverter mempty m + } + where + convclusteruuids :: M.Map UUID (S.Set ClusterNodeUUID) -> M.Map ClusterUUID (S.Set ClusterNodeUUID) + convclusteruuids = M.fromList + . mapMaybe (\(mk, v) -> (, v) <$> mk) + . M.toList . M.mapKeys mkClusterUUID + inverter m k v = M.unionWith (<>) m + (M.fromList (map (, S.singleton k) (S.toList v))) + +recordCluster :: ClusterUUID -> S.Set ClusterNodeUUID -> Annex () +recordCluster clusteruuid nodeuuids = do + -- If a private UUID has been configured as a cluster node, + -- avoid leaking it into the git-annex log. + privateuuids <- annexPrivateRepos <$> Annex.getGitConfig + let nodeuuids' = S.filter + (\(ClusterNodeUUID n) -> S.notMember n privateuuids) + nodeuuids + + c <- currentVectorClock + Annex.Branch.change (Annex.Branch.RegardingUUID [fromClusterUUID clusteruuid]) clusterLog $ + (buildLogNew buildClusterNodeList) + . changeLog c (fromClusterUUID clusteruuid) nodeuuids' + . parseClusterLog + +buildClusterNodeList :: S.Set ClusterNodeUUID -> Builder +buildClusterNodeList = assemble + . map (buildUUID . fromClusterNodeUUID) + . S.toList + where + assemble [] = mempty + assemble (x:[]) = x + assemble (x:y:l) = x <> " " <> assemble (y:l) + +parseClusterLog :: L.ByteString -> Log (S.Set ClusterNodeUUID) +parseClusterLog = parseLogNew parseClusterNodeList + +parseClusterNodeList :: A.Parser (S.Set ClusterNodeUUID) +parseClusterNodeList = S.fromList <$> many parseword + where + parseword = parsenode + <* ((const () <$> A8.char ' ') <|> A.endOfInput) + parsenode = ClusterNodeUUID + <$> (toUUID <$> A8.takeWhile1 (/= ' ')) + diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -22,9 +22,6 @@ getExportExcluded, ) where -import qualified Data.Map as M -import qualified Data.ByteString as B - import Annex.Common import qualified Annex.Branch import qualified Git @@ -38,6 +35,8 @@ import qualified Git.Tree import Annex.UUID +import qualified Data.Map as M +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Either import Data.Char @@ -66,19 +65,19 @@ . parseExportLogMap <$> Annex.Branch.get exportLog let new = updateIncompleteExportedTreeish old (nub (newtree:incompleteExportedTreeishes [old])) + rememberExportTreeish newtree Annex.Branch.change (Annex.Branch.RegardingUUID [remoteuuid, u]) exportLog (buildExportLog . changeMapLog c ep new . parseExportLog) - recordExportTreeish newtree -- Graft a tree ref into the git-annex branch. This is done -- to ensure that it's available later, when getting exported files -- from the remote. Since that could happen in another clone of the -- repository, the tree has to be kept available, even if it -- doesn't end up being merged into the master branch. -recordExportTreeish :: Git.Ref -> Annex () -recordExportTreeish t = void $ +rememberExportTreeish :: Git.Ref -> Annex () +rememberExportTreeish t = void $ Annex.Branch.rememberTreeish t (asTopFilePath exportTreeGraftPoint) -- | Record that an export to a special remote is under way. @@ -112,7 +111,7 @@ recordExport :: UUID -> Git.Ref -> ExportChange -> Annex () recordExport remoteuuid tree ec = do when (oldTreeish ec /= [tree]) $ - recordExportTreeish tree + rememberExportTreeish tree recordExportUnderway remoteuuid ec logExportExcluded :: UUID -> ((Git.Tree.TreeItem -> IO ()) -> Annex a) -> Annex a diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -8,7 +8,7 @@ - Repositories record their UUID and the date when they --get or --drop - a value. - - - Copyright 2010-2023 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -41,6 +41,7 @@ import qualified Annex.Branch import Logs import Logs.Presence +import Types.Cluster import Annex.UUID import Annex.CatFile import Annex.VectorClock @@ -49,6 +50,8 @@ import Data.Time.Clock import qualified Data.ByteString.Lazy as L +import qualified Data.Map as M +import qualified Data.Set as S {- Log a change in the presence of a key's value in current repository. -} logStatus :: Key -> LogStatus -> Annex () @@ -66,15 +69,22 @@ , return False ) -{- Log a change in the presence of a key's value in a repository. -} +{- Log a change in the presence of a key's value in a repository. + - + - Cluster UUIDs are not logged. Instead, when a node of a cluster is + - logged to contain a key, loading the log will include the cluster's + - UUID. + -} logChange :: Key -> UUID -> LogStatus -> Annex () -logChange key u@(UUID _) s = do - config <- Annex.getGitConfig - maybeAddLog - (Annex.Branch.RegardingUUID [u]) - (locationLogFile config key) - s - (LogInfo (fromUUID u)) +logChange key u@(UUID _) s + | isClusterUUID u = noop + | otherwise = do + config <- Annex.getGitConfig + maybeAddLog + (Annex.Branch.RegardingUUID [u]) + (locationLogFile config key) + s + (LogInfo (fromUUID u)) logChange _ NoUUID _ = noop {- Returns a list of repository UUIDs that, according to the log, have @@ -97,15 +107,30 @@ loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref {- Parses the content of a log file and gets the locations in it. -} -parseLoggedLocations :: L.ByteString -> [UUID] -parseLoggedLocations l = map (toUUID . fromLogInfo . info) - (filterPresent (parseLog l)) +parseLoggedLocations :: Clusters -> L.ByteString -> [UUID] +parseLoggedLocations clusters l = addClusterUUIDs clusters $ + map (toUUID . fromLogInfo . info) + (filterPresent (parseLog l)) getLoggedLocations :: (RawFilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] getLoggedLocations getter key = do config <- Annex.getGitConfig - map (toUUID . fromLogInfo) <$> getter (locationLogFile config key) + locs <- map (toUUID . fromLogInfo) <$> getter (locationLogFile config key) + clusters <- getClusters + return $ addClusterUUIDs clusters locs +-- Add UUIDs of any clusters whose nodes are in the list. +addClusterUUIDs :: Clusters -> [UUID] -> [UUID] +addClusterUUIDs clusters locs + | M.null clustermap = locs + -- ^ optimisation for common case of no clusters + | otherwise = clusterlocs ++ locs + where + clustermap = clusterNodeUUIDs clusters + clusterlocs = map fromClusterUUID $ S.toList $ + S.unions $ mapMaybe findclusters locs + findclusters u = M.lookup (ClusterNodeUUID u) clustermap + {- Is there a location log for the key? True even for keys with no - remaining locations. -} isKnownKey :: Key -> Annex Bool @@ -204,6 +229,7 @@ -> Annex v overLocationLogs' iv discarder keyaction = do config <- Annex.getGitConfig + clusters <- getClusters let getk = locationLogFileKey config let go v reader = reader >>= \case @@ -214,11 +240,16 @@ ifM (checkDead k) ( go v reader , do - !v' <- keyaction k (maybe [] parseLoggedLocations content) v + !v' <- keyaction k (maybe [] (parseLoggedLocations clusters) content) v go v' reader ) Nothing -> return v Annex.Branch.overBranchFileContents getk (go iv) >>= \case Just r -> return r - Nothing -> giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents operating on all keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)" + Nothing -> giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents operating on allu keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)" + +-- Cannot import Logs.Cluster due to a cycle. +-- Annex.clusters gets populated when starting up git-annex. +getClusters :: Annex Clusters +getClusters = fromMaybe noClusters <$> Annex.getState Annex.clusters diff --git a/Logs/Proxy.hs b/Logs/Proxy.hs new file mode 100644 --- /dev/null +++ b/Logs/Proxy.hs @@ -0,0 +1,88 @@ +{- git-annex proxy log + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Logs.Proxy ( + Proxy(..), + getProxies, + recordProxies, +) where + +import qualified Annex +import Annex.Common +import qualified Annex.Branch +import qualified Git.Remote +import Git.Types +import Logs +import Logs.UUIDBased +import Logs.MapLog +import Annex.UUID + +import qualified Data.Set as S +import qualified Data.Map as M +import Data.ByteString.Builder +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified Data.ByteString.Lazy as L + +data Proxy = Proxy + { proxyRemoteUUID :: UUID + , proxyRemoteName :: RemoteName + } deriving (Show, Eq, Ord) + +getProxies :: Annex (M.Map UUID (S.Set Proxy)) +getProxies = M.map (validateProxies . value) . fromMapLog . parseProxyLog + <$> Annex.Branch.get proxyLog + +recordProxies :: S.Set Proxy -> Annex () +recordProxies proxies = do + -- If a private UUID has been configured as a proxy, avoid leaking + -- it into the git-annex log. + privateuuids <- annexPrivateRepos <$> Annex.getGitConfig + let proxies' = S.filter + (\p -> S.notMember (proxyRemoteUUID p) privateuuids) proxies + + c <- currentVectorClock + u <- getUUID + Annex.Branch.change (Annex.Branch.RegardingUUID [u]) proxyLog $ + (buildLogNew buildProxyList) + . changeLog c u proxies' + . parseProxyLog + +buildProxyList :: S.Set Proxy -> Builder +buildProxyList = assemble . map fmt . S.toList + where + fmt p = buildUUID (proxyRemoteUUID p) + <> colon + <> byteString (encodeBS (proxyRemoteName p)) + colon = charUtf8 ':' + + assemble [] = mempty + assemble (x:[]) = x + assemble (x:y:l) = x <> " " <> assemble (y:l) + +parseProxyLog :: L.ByteString -> Log (S.Set Proxy) +parseProxyLog = parseLogNew parseProxyList + +parseProxyList :: A.Parser (S.Set Proxy) +parseProxyList = S.fromList <$> many parseword + where + parseword = parseproxy + <* ((const () <$> A8.char ' ') <|> A.endOfInput) + parseproxy = Proxy + <$> (toUUID <$> A8.takeWhile1 (/= colon)) + <* (const () <$> A8.char colon) + <*> (decodeBS <$> A8.takeWhile1 (/= ' ')) + colon = ':' + +-- Filter out any proxies that have a name that is not allowed as a git +-- remote name. This avoids any security problems with eg escape +-- characters in names, and ensures the name can be used anywhere a usual +-- git remote name can be used without causing issues. +validateProxies :: S.Set Proxy -> S.Set Proxy +validateProxies = S.filter $ Git.Remote.isLegalName . proxyRemoteName diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -51,7 +51,7 @@ let getsize = liftIO . catchMaybeIO . getFileSize size <- inAnnex' isJust Nothing getsize k runner (next (Len <$> size)) - ReadContent k af o sender next -> do + ReadContent k af o offset sender next -> do let proceed c = do r <- tryNonAsync c case r of @@ -62,12 +62,12 @@ -- run for any other reason, the sender action still must -- be run, so is given empty and Invalid data. let fallback = runner (sender mempty (return Invalid)) - v <- tryNonAsync $ prepSendAnnex k + v <- tryNonAsync $ prepSendAnnex k o case v of Right (Just (f, _sz, checkchanged)) -> proceed $ do -- alwaysUpload to allow multiple uploads of the same key. let runtransfer ti = transfer alwaysUpload k af Nothing $ \p -> - sinkfile f o checkchanged sender p ti + sinkfile f offset checkchanged sender p ti checktransfer runtransfer fallback Right Nothing -> proceed fallback Left e -> return $ Left $ ProtoFailureException e diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -1,6 +1,6 @@ {- P2P protocol, IO implementation - - - Copyright 2016-2018 Joey Hess + - Copyright 2016-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -11,10 +11,12 @@ ( RunProto , RunState(..) , mkRunState + , P2PHandle(..) , P2PConnection(..) , ConnIdent(..) , ClosableConnection(..) , stdioP2PConnection + , stdioP2PConnectionDupped , connectPeer , closeConnection , serveUnixSocket @@ -74,11 +76,15 @@ tvar <- newTVarIO defaultProtocolVersion return (mk tvar) +data P2PHandle + = P2PHandle Handle + | P2PHandleTMVar (TMVar (Either L.ByteString Message)) (TMVar ()) + data P2PConnection = P2PConnection - { connRepo :: Repo + { connRepo :: Maybe Repo , connCheckAuth :: (AuthToken -> Bool) - , connIhdl :: Handle - , connOhdl :: Handle + , connIhdl :: P2PHandle + , connOhdl :: P2PHandle , connIdent :: ConnIdent } @@ -90,31 +96,48 @@ | ClosedConnection -- P2PConnection using stdio. -stdioP2PConnection :: Git.Repo -> P2PConnection +stdioP2PConnection :: Maybe Git.Repo -> P2PConnection stdioP2PConnection g = P2PConnection { connRepo = g , connCheckAuth = const False - , connIhdl = stdin - , connOhdl = stdout + , connIhdl = P2PHandle stdin + , connOhdl = P2PHandle stdout , connIdent = ConnIdent Nothing } +-- P2PConnection using stdio, but with the handles first duplicated, +-- to avoid anything that might output to stdio (eg a program run by a +-- special remote) from interfering with the connection. +stdioP2PConnectionDupped :: Maybe Git.Repo -> IO P2PConnection +stdioP2PConnectionDupped g = do + (readh, writeh) <- dupIoHandles + return $ P2PConnection + { connRepo = g + , connCheckAuth = const False + , connIhdl = P2PHandle readh + , connOhdl = P2PHandle writeh + , connIdent = ConnIdent Nothing + } + -- Opens a connection to a peer. Does not authenticate with it. -connectPeer :: Git.Repo -> P2PAddress -> IO P2PConnection +connectPeer :: Maybe Git.Repo -> P2PAddress -> IO P2PConnection connectPeer g (TorAnnex onionaddress onionport) = do h <- setupHandle =<< connectHiddenService onionaddress onionport return $ P2PConnection { connRepo = g , connCheckAuth = const False - , connIhdl = h - , connOhdl = h + , connIhdl = P2PHandle h + , connOhdl = P2PHandle h , connIdent = ConnIdent Nothing } closeConnection :: P2PConnection -> IO () closeConnection conn = do - hClose (connIhdl conn) - hClose (connOhdl conn) + closehandle (connIhdl conn) + closehandle (connOhdl conn) + where + closehandle (P2PHandle h) = hClose h + closehandle (P2PHandleTMVar _ _) = return () -- Serves the protocol on a unix socket. -- @@ -154,8 +177,7 @@ -- Purposefully incomplete interpreter of Proto. -- -- This only runs Net actions. No Local actions will be run --- (those need the Annex monad) -- if the interpreter reaches any, --- it returns Nothing. +-- (those need the Annex monad). runNetProto :: RunState -> P2PConnection -> Proto a -> IO (Either ProtoFailure a) runNetProto runst conn = go where @@ -165,6 +187,11 @@ go (Free (Local _)) = return $ Left $ ProtoFailureMessage "unexpected annex operation attempted" +data P2PTMVarException = P2PTMVarException String + deriving (Show) + +instance Exception P2PTMVarException + -- Interpreter of the Net part of Proto. -- -- An interpreter of Proto has to be provided, to handle the rest of Proto @@ -172,40 +199,71 @@ runNet :: (MonadIO m, MonadMask m) => RunState -> P2PConnection -> RunProto m -> NetF (Proto a) -> m (Either ProtoFailure a) runNet runst conn runner f = case f of SendMessage m next -> do - v <- liftIO $ tryNonAsync $ do - let l = unwords (formatMessage m) + v <- liftIO $ do debugMessage conn "P2P >" m - hPutStrLn (connOhdl conn) l - hFlush (connOhdl conn) + case connOhdl conn of + P2PHandle h -> tryNonAsync $ do + hPutStrLn h $ unwords (formatMessage m) + hFlush h + P2PHandleTMVar mv _ -> + ifM (atomically (tryPutTMVar mv (Right m))) + ( return $ Right () + , return $ Left $ toException $ + P2PTMVarException "TMVar left full" + ) case v of Left e -> return $ Left $ ProtoFailureException e Right () -> runner next - ReceiveMessage next -> do - v <- liftIO $ tryIOError $ getProtocolLine (connIhdl conn) - case v of - Left e -> return $ Left $ ProtoFailureIOError e - Right Nothing -> return $ Left $ - ProtoFailureMessage "protocol error" - Right (Just l) -> case parseMessage l of - Just m -> do - liftIO $ debugMessage conn "P2P <" m - runner (next (Just m)) - Nothing -> runner (next Nothing) - SendBytes len b p next -> do - v <- liftIO $ tryNonAsync $ do - ok <- sendExactly len b (connOhdl conn) p - hFlush (connOhdl conn) - return ok - case v of - Right True -> runner next - Right False -> return $ Left $ - ProtoFailureMessage "short data write" - Left e -> return $ Left $ ProtoFailureException e - ReceiveBytes len p next -> do - v <- liftIO $ tryNonAsync $ receiveExactly len (connIhdl conn) p - case v of - Left e -> return $ Left $ ProtoFailureException e - Right b -> runner (next b) + ReceiveMessage next -> + let protoerr = return $ Left $ + ProtoFailureMessage "protocol error 1" + gotmessage m = do + liftIO $ debugMessage conn "P2P <" m + runner (next (Just m)) + in case connIhdl conn of + P2PHandle h -> do + v <- liftIO $ tryIOError $ getProtocolLine h + case v of + Left e -> return $ Left $ ProtoFailureIOError e + Right Nothing -> protoerr + Right (Just l) -> case parseMessage l of + Just m -> gotmessage m + Nothing -> runner (next Nothing) + P2PHandleTMVar mv _ -> + liftIO (atomically (takeTMVar mv)) >>= \case + Right m -> gotmessage m + Left _b -> protoerr + SendBytes len b p next -> + case connOhdl conn of + P2PHandle h -> do + v <- liftIO $ tryNonAsync $ do + ok <- sendExactly len b h p + hFlush h + return ok + case v of + Right True -> runner next + Right False -> return $ Left $ + ProtoFailureMessage "short data write" + Left e -> return $ Left $ ProtoFailureException e + P2PHandleTMVar mv waitv -> do + liftIO $ atomically $ putTMVar mv (Left b) + -- Wait for the whole bytestring to be + -- processed. Necessary due to lazyiness. + liftIO $ atomically $ takeTMVar waitv + runner next + ReceiveBytes len p next -> + case connIhdl conn of + P2PHandle h -> do + v <- liftIO $ tryNonAsync $ receiveExactly len h p + case v of + Right b -> runner (next b) + Left e -> return $ Left $ + ProtoFailureException e + P2PHandleTMVar mv _ -> + liftIO (atomically (takeTMVar mv)) >>= \case + Left b -> runner (next b) + Right _ -> return $ Left $ + ProtoFailureMessage "protocol error 2" CheckAuthToken _u t next -> do let authed = connCheckAuth conn t runner (next authed) @@ -286,19 +344,21 @@ go (v, _, _) = relayHelper runner v runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Either ProtoFailure ()) -runRelayService conn runner service = - withCreateProcess serviceproc' go +runRelayService conn runner service = case connRepo conn of + Just repo -> withCreateProcess (serviceproc' repo) go `catchNonAsync` (return . Left . ProtoFailureException) + Nothing -> return $ Left $ ProtoFailureMessage + "relaying to git not supported on this connection" where cmd = case service of UploadPack -> "upload-pack" ReceivePack -> "receive-pack" - serviceproc = gitCreateProcess + serviceproc repo = gitCreateProcess [ Param cmd - , File (fromRawFilePath (repoPath (connRepo conn))) - ] (connRepo conn) - serviceproc' = serviceproc + , File (fromRawFilePath (repoPath repo)) + ] repo + serviceproc' repo = (serviceproc repo) { std_out = CreatePipe , std_in = CreatePipe } diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -2,13 +2,14 @@ - - See doc/design/p2p_protocol.mdwn - - - Copyright 2016-2021 Joey Hess + - Copyright 2016-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module P2P.Protocol where @@ -37,6 +38,7 @@ import qualified System.FilePath.ByteString as P import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import qualified Data.Set as S import Data.Char import Control.Applicative import Prelude @@ -54,7 +56,7 @@ defaultProtocolVersion = ProtocolVersion 0 maxProtocolVersion :: ProtocolVersion -maxProtocolVersion = ProtocolVersion 1 +maxProtocolVersion = ProtocolVersion 2 newtype ProtoAssociatedFile = ProtoAssociatedFile AssociatedFile deriving (Show) @@ -65,6 +67,9 @@ data Validity = Valid | Invalid deriving (Show) + +newtype Bypass = Bypass (S.Set UUID) + deriving (Show, Monoid, Semigroup) -- | Messages in the protocol. The peer that makes the connection -- always initiates requests, and the other peer makes responses to them. @@ -85,8 +90,12 @@ | PUT ProtoAssociatedFile Key | PUT_FROM Offset | ALREADY_HAVE + | ALREADY_HAVE_PLUS [UUID] | SUCCESS + | SUCCESS_PLUS [UUID] | FAILURE + | FAILURE_PLUS [UUID] + | BYPASS Bypass | DATA Len -- followed by bytes of data | VALIDITY Validity | ERROR String @@ -109,8 +118,12 @@ formatMessage (PUT af key) = ["PUT", Proto.serialize af, Proto.serialize key] formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset] formatMessage ALREADY_HAVE = ["ALREADY-HAVE"] + formatMessage (ALREADY_HAVE_PLUS uuids) = ("ALREADY-HAVE-PLUS":map Proto.serialize uuids) formatMessage SUCCESS = ["SUCCESS"] + formatMessage (SUCCESS_PLUS uuids) = ("SUCCESS-PLUS":map Proto.serialize uuids) formatMessage FAILURE = ["FAILURE"] + formatMessage (FAILURE_PLUS uuids) = ("FAILURE-PLUS":map Proto.serialize uuids) + formatMessage (BYPASS (Bypass uuids)) = ("BYPASS":map Proto.serialize (S.toList uuids)) formatMessage (VALIDITY Valid) = ["VALID"] formatMessage (VALIDITY Invalid) = ["INVALID"] formatMessage (DATA len) = ["DATA", Proto.serialize len] @@ -133,8 +146,12 @@ parseCommand "PUT" = Proto.parse2 PUT parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM parseCommand "ALREADY-HAVE" = Proto.parse0 ALREADY_HAVE + parseCommand "ALREADY-HAVE-PLUS" = Proto.parseList ALREADY_HAVE_PLUS parseCommand "SUCCESS" = Proto.parse0 SUCCESS + parseCommand "SUCCESS-PLUS" = Proto.parseList SUCCESS_PLUS parseCommand "FAILURE" = Proto.parse0 FAILURE + parseCommand "FAILURE-PLUS" = Proto.parseList FAILURE_PLUS + parseCommand "BYPASS" = Proto.parseList (BYPASS . Bypass . S.fromList) parseCommand "DATA" = Proto.parse1 DATA parseCommand "ERROR" = Proto.parse1 ERROR parseCommand "VALID" = Proto.parse0 (VALIDITY Valid) @@ -164,12 +181,15 @@ -- its serialization cannot contain any whitespace. This is handled -- by replacing whitespace with '%' (and '%' with '%%') -- --- When deserializing an AssociatedFile from a peer, it's sanitized, --- to avoid any unusual characters that might cause problems when it's --- displayed to the user. +-- When deserializing an AssociatedFile from a peer, that escaping is +-- reversed. Unfortunately, an input tab will be deescaped to a space +-- though. And it's sanitized, to avoid any control characters that might +-- cause problems when it's displayed to the user. -- --- These mungings are ok, because a ProtoAssociatedFile is only ever displayed --- to the user and does not need to match a file on disk. +-- These mungings are ok, because a ProtoAssociatedFile is normally +-- only displayed to the user and so does not need to match a file on disk. +-- It may also be used in checking preferred content, which is very +-- unlikely to care about spaces vs tabs or control characters. instance Proto.Serializable ProtoAssociatedFile where serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = "" serialize (ProtoAssociatedFile (AssociatedFile (Just af))) = @@ -244,7 +264,7 @@ | ContentSize Key (Maybe Len -> c) -- ^ Gets size of the content of a key, when the full content is -- present. - | ReadContent Key AssociatedFile Offset (L.ByteString -> Proto Validity -> Proto Bool) (Bool -> c) + | ReadContent Key AssociatedFile (Maybe FilePath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c) -- ^ Reads the content of a key and sends it to the callback. -- Must run the callback, or terminate the protocol connection. -- @@ -324,10 +344,19 @@ Just (ERROR _) -> return () _ -> net $ sendMessage (ERROR "expected VERSION") -checkPresent :: Key -> Proto Bool +sendBypass :: Bypass -> Proto () +sendBypass bypass@(Bypass s) + | S.null s = return () + | otherwise = do + ver <- net getProtocolVersion + if ver >= ProtocolVersion 2 + then net $ sendMessage (BYPASS bypass) + else return () + +checkPresent :: Key -> Proto (Either String Bool) checkPresent key = do net $ sendMessage (CHECKPRESENT key) - checkSuccess + checkSuccess' {- Locks content to prevent it from being dropped, while running an action. - @@ -349,10 +378,10 @@ cleanup True = runproto () $ net $ sendMessage UNLOCKCONTENT cleanup False = return () -remove :: Key -> Proto Bool +remove :: Key -> Proto (Either String Bool, Maybe [UUID]) remove key = do net $ sendMessage (REMOVE key) - checkSuccess + checkSuccessFailurePlus get :: FilePath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification) get dest key iv af m p = @@ -362,16 +391,17 @@ sizer = fileSize dest storer = storeContentTo dest iv -put :: Key -> AssociatedFile -> MeterUpdate -> Proto Bool +put :: Key -> AssociatedFile -> MeterUpdate -> Proto (Maybe [UUID]) put key af p = do net $ sendMessage (PUT (ProtoAssociatedFile af) key) r <- net receiveMessage case r of - Just (PUT_FROM offset) -> sendContent key af offset p - Just ALREADY_HAVE -> return True + Just (PUT_FROM offset) -> sendContent key af Nothing offset p + Just ALREADY_HAVE -> return (Just []) + Just (ALREADY_HAVE_PLUS uuids) -> return (Just uuids) _ -> do net $ sendMessage (ERROR "expected PUT_FROM or ALREADY_HAVE") - return False + return Nothing data ServerHandler a = ServerGot a @@ -440,8 +470,6 @@ serveAuthed :: ServerMode -> UUID -> Proto () serveAuthed servermode myuuid = void $ serverLoop handler where - readonlyerror = net $ sendMessage (ERROR "this repository is read-only; write access denied") - appendonlyerror = net $ sendMessage (ERROR "this repository is append-only; removal denied") handler (VERSION theirversion) = do let v = min theirversion maxProtocolVersion net $ setProtocolVersion v @@ -459,45 +487,42 @@ handler (CHECKPRESENT key) = do sendSuccess =<< local (checkContentPresent key) return ServerContinue - handler (REMOVE key) = case servermode of - ServeReadWrite -> do - sendSuccess =<< local (removeContent key) - return ServerContinue - ServeAppendOnly -> do - appendonlyerror - return ServerContinue - ServeReadOnly -> do - readonlyerror - return ServerContinue - handler (PUT (ProtoAssociatedFile af) key) = case servermode of - ServeReadWrite -> handleput af key - ServeAppendOnly -> handleput af key - ServeReadOnly -> do - readonlyerror - return ServerContinue + handler (REMOVE key) = + checkREMOVEServerMode servermode $ \case + Nothing -> do + sendSuccess =<< local (removeContent key) + return ServerContinue + Just notallowed -> do + notallowed + return ServerContinue + handler (PUT (ProtoAssociatedFile af) key) = + checkPUTServerMode servermode $ \case + Nothing -> handleput af key + Just notallowed -> do + notallowed + return ServerContinue handler (GET offset (ProtoAssociatedFile af) key) = do - void $ sendContent key af offset nullMeterUpdate + void $ sendContent key af Nothing offset nullMeterUpdate -- setPresent not called because the peer may have -- requested the data but not permanently stored it. return ServerContinue handler (CONNECT service) = do - let goahead = net $ relayService service - case (servermode, service) of - (ServeReadWrite, _) -> goahead - (ServeAppendOnly, UploadPack) -> goahead - -- git protocol could be used to overwrite - -- refs or something, so don't allow - (ServeAppendOnly, ReceivePack) -> readonlyerror - (ServeReadOnly, UploadPack) -> goahead - (ServeReadOnly, ReceivePack) -> readonlyerror -- After connecting to git, there may be unconsumed data -- from the git processes hanging around (even if they -- exited successfully), so stop serving this connection. - return $ ServerGot () + let endit = return $ ServerGot () + checkCONNECTServerMode service servermode $ \case + Nothing -> do + net $ relayService service + endit + Just notallowed -> do + notallowed + endit handler NOTIFYCHANGE = do refs <- local waitRefChange net $ sendMessage (CHANGED refs) return ServerContinue + handler (BYPASS _) = return ServerContinue handler _ = return ServerUnexpected handleput af key = do @@ -512,14 +537,47 @@ local $ setPresent key myuuid return ServerContinue -sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool -sendContent key af offset@(Offset n) p = go =<< local (contentSize key) +sendReadOnlyError :: Proto () +sendReadOnlyError = net $ sendMessage $ + ERROR "this repository is read-only; write access denied" + +sendAppendOnlyError :: Proto () +sendAppendOnlyError = net $ sendMessage $ + ERROR "this repository is append-only; removal denied" + +checkPUTServerMode :: Monad m => ServerMode -> (Maybe (Proto ()) -> m a) -> m a +checkPUTServerMode servermode a = + case servermode of + ServeReadWrite -> a Nothing + ServeAppendOnly -> a Nothing + ServeReadOnly -> a (Just sendReadOnlyError) + +checkREMOVEServerMode :: Monad m => ServerMode -> (Maybe (Proto ()) -> m a) -> m a +checkREMOVEServerMode servermode a = + case servermode of + ServeReadWrite -> a Nothing + ServeAppendOnly -> a (Just sendAppendOnlyError) + ServeReadOnly -> a (Just sendReadOnlyError) + +checkCONNECTServerMode :: Monad m => Service -> ServerMode -> (Maybe (Proto ()) -> m a) -> m a +checkCONNECTServerMode service servermode a = + case (servermode, service) of + (ServeReadWrite, _) -> a Nothing + (ServeAppendOnly, UploadPack) -> a Nothing + -- git protocol could be used to overwrite + -- refs or something, so don't allow + (ServeAppendOnly, ReceivePack) -> a (Just sendReadOnlyError) + (ServeReadOnly, UploadPack) -> a Nothing + (ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError) + +sendContent :: Key -> AssociatedFile -> Maybe FilePath -> Offset -> MeterUpdate -> Proto (Maybe [UUID]) +sendContent key af o offset@(Offset n) p = go =<< local (contentSize key) where go (Just (Len totallen)) = do let len = totallen - n if len <= 0 then sender (Len 0) L.empty (return Valid) - else local $ readContent key af offset $ + else local $ readContent key af o offset $ sender (Len len) -- Content not available to send. Indicate this by sending -- empty data and indlicate it's invalid. @@ -531,7 +589,7 @@ ver <- net getProtocolVersion when (ver >= ProtocolVersion 1) $ net . sendMessage . VALIDITY =<< validitycheck - checkSuccess + checkSuccessPlus receiveContent :: Observable t @@ -565,20 +623,54 @@ validitycheck sendSuccess (observeBool v) return v + Just (ERROR _err) -> + return observeFailure _ -> do net $ sendMessage (ERROR "expected DATA") return observeFailure checkSuccess :: Proto Bool -checkSuccess = do +checkSuccess = either (const False) id <$> checkSuccess' + +checkSuccess' :: Proto (Either String Bool) +checkSuccess' = do ack <- net receiveMessage case ack of - Just SUCCESS -> return True - Just FAILURE -> return False + Just SUCCESS -> return (Right True) + Just FAILURE -> return (Right False) + Just (ERROR err) -> return (Left err) _ -> do net $ sendMessage (ERROR "expected SUCCESS or FAILURE") - return False + return (Right False) +checkSuccessPlus :: Proto (Maybe [UUID]) +checkSuccessPlus = + checkSuccessFailurePlus >>= return . \case + (Right True, v) -> v + (Right False, _) -> Nothing + (Left _, _) -> Nothing + +checkSuccessFailurePlus :: Proto (Either String Bool, Maybe [UUID]) +checkSuccessFailurePlus = do + ver <- net getProtocolVersion + if ver >= ProtocolVersion 2 + then do + ack <- net receiveMessage + case ack of + Just SUCCESS -> return (Right True, Just []) + Just (SUCCESS_PLUS l) -> return (Right True, Just l) + Just FAILURE -> return (Right False, Nothing) + Just (FAILURE_PLUS l) -> return (Right False, Just l) + Just (ERROR err) -> return (Left err, Nothing) + _ -> do + net $ sendMessage (ERROR "expected SUCCESS or SUCCESS-PLUS or FAILURE or FAILURE-PLUS") + return (Right False, Nothing) + else do + ok <- checkSuccess + if ok + then return (Right True, Just []) + else return (Right False, Nothing) + sendSuccess :: Bool -> Proto () sendSuccess True = net $ sendMessage SUCCESS sendSuccess False = net $ sendMessage FAILURE @@ -621,3 +713,4 @@ sendMessage (DATA len) sendBytes len b nullMeterUpdate relayToPeer (RelayFromPeer _) = return () + diff --git a/P2P/Proxy.hs b/P2P/Proxy.hs new file mode 100644 --- /dev/null +++ b/P2P/Proxy.hs @@ -0,0 +1,586 @@ +{- P2P protocol proxying + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} + +module P2P.Proxy where + +import Annex.Common +import qualified Annex +import P2P.Protocol +import P2P.IO +import Utility.Metered +import Git.FilePath +import Types.Concurrency +import Annex.Concurrent +import qualified Remote + +import Data.Either +import Control.Concurrent.STM +import Control.Concurrent.Async +import qualified Control.Concurrent.MSem as MSem +import qualified Data.ByteString.Lazy as L +import qualified Data.Set as S +import GHC.Conc + +type ProtoCloser = Annex () + +data ClientSide = ClientSide RunState P2PConnection + +data RemoteSide = RemoteSide + { remote :: Remote + , remoteConnect :: Annex (Maybe (RunState, P2PConnection, ProtoCloser)) + , remoteTMVar :: TMVar (RunState, P2PConnection, ProtoCloser) + } + +mkRemoteSide :: Remote -> Annex (Maybe (RunState, P2PConnection, ProtoCloser)) -> Annex RemoteSide +mkRemoteSide r remoteconnect = RemoteSide + <$> pure r + <*> pure remoteconnect + <*> liftIO (atomically newEmptyTMVar) + +runRemoteSide :: RemoteSide -> Proto a -> Annex (Either ProtoFailure a) +runRemoteSide remoteside a = + liftIO (atomically $ tryReadTMVar $ remoteTMVar remoteside) >>= \case + Just (runst, conn, _closer) -> liftIO $ runNetProto runst conn a + Nothing -> remoteConnect remoteside >>= \case + Just (runst, conn, closer) -> do + liftIO $ atomically $ putTMVar + (remoteTMVar remoteside) + (runst, conn, closer) + liftIO $ runNetProto runst conn a + Nothing -> giveup "Unable to connect to remote." + +closeRemoteSide :: RemoteSide -> Annex () +closeRemoteSide remoteside = + liftIO (atomically $ tryTakeTMVar $ remoteTMVar remoteside) >>= \case + Just (_, _, closer) -> closer + Nothing -> return () + +{- Selects what remotes to proxy to for top-level P2P protocol + - actions. + - -} +data ProxySelector = ProxySelector + { proxyCHECKPRESENT :: Key -> Annex (Maybe RemoteSide) + , proxyLOCKCONTENT :: Key -> Annex (Maybe RemoteSide) + , proxyUNLOCKCONTENT :: Annex (Maybe RemoteSide) + , proxyREMOVE :: Key -> Annex [RemoteSide] + -- ^ remove from all of these remotes + , proxyGET :: Key -> Annex (Maybe RemoteSide) + , proxyPUT :: AssociatedFile -> Key -> Annex [RemoteSide] + -- ^ put to some/all of these remotes + } + +singleProxySelector :: RemoteSide -> ProxySelector +singleProxySelector r = ProxySelector + { proxyCHECKPRESENT = const (pure (Just r)) + , proxyLOCKCONTENT = const (pure (Just r)) + , proxyUNLOCKCONTENT = pure (Just r) + , proxyREMOVE = const (pure [r]) + , proxyGET = const (pure (Just r)) + , proxyPUT = const (const (pure [r])) + } + +{- To keep this module limited to P2P protocol actions, + - all other actions that a proxy needs to do are provided + - here. -} +data ProxyMethods = ProxyMethods + { removedContent :: UUID -> Key -> Annex () + -- ^ called when content is removed from a repository + , addedContent :: UUID -> Key -> Annex () + -- ^ called when content is added to a repository + } + +{- Type of function that takes a error handler, which is + - used to handle a ProtoFailure when receiving a message + - from the client or remote. + -} +type ProtoErrorHandled r = + (forall t. ((t -> Annex r) -> Annex (Either ProtoFailure t) -> Annex r)) -> Annex r + +{- This is the first thing run when proxying with a client. + - The client has already authenticated. Most clients will send a + - VERSION message, although version 0 clients will not and will send + - some other message, which is returned to handle later. + - + - But before the client will send VERSION, it needs to see AUTH_SUCCESS. + - So send that, although the connection with the remote is not actually + - brought up yet. + -} +getClientProtocolVersion + :: UUID + -> ClientSide + -> (Maybe (ProtocolVersion, Maybe Message) -> Annex r) + -> ProtoErrorHandled r +getClientProtocolVersion remoteuuid (ClientSide clientrunst clientconn) cont protoerrhandler = + protoerrhandler cont $ client $ getClientProtocolVersion' remoteuuid + where + client = liftIO . runNetProto clientrunst clientconn + +getClientProtocolVersion' + :: UUID + -> Proto (Maybe (ProtocolVersion, Maybe Message)) +getClientProtocolVersion' remoteuuid = do + net $ sendMessage (AUTH_SUCCESS remoteuuid) + msg <- net receiveMessage + case msg of + Nothing -> return Nothing + Just (VERSION v) -> + -- If the client sends a newer version than we + -- understand, reduce it; we need to parse the + -- protocol too. + let v' = min v maxProtocolVersion + in return (Just (v', Nothing)) + Just othermsg -> return + (Just (defaultProtocolVersion, Just othermsg)) + +{- Send negotiated protocol version to the client. + - With a version 0 client, preserves the other protocol message + - received in getClientProtocolVersion. -} +sendClientProtocolVersion + :: ClientSide + -> Maybe Message + -> ProtocolVersion + -> (Maybe Message -> Annex r) + -> ProtoErrorHandled r +sendClientProtocolVersion (ClientSide clientrunst clientconn) othermsg protocolversion cont protoerrhandler = + case othermsg of + Nothing -> protoerrhandler (\() -> cont Nothing) $ + client $ net $ sendMessage $ VERSION protocolversion + Just _ -> cont othermsg + where + client = liftIO . runNetProto clientrunst clientconn + +{- When speaking to a version 2 client, get the BYPASS message which may be + - sent immediately after VERSION. Returns any other message to be handled + - later. -} +getClientBypass + :: ClientSide + -> ProtocolVersion + -> Maybe Message + -> ((Bypass, Maybe Message) -> Annex r) + -> ProtoErrorHandled r +getClientBypass (ClientSide clientrunst clientconn) (ProtocolVersion protocolversion) Nothing cont protoerrhandler + | protocolversion < 2 = cont (Bypass S.empty, Nothing) + | otherwise = protoerrhandler cont $ + client $ net receiveMessage >>= return . \case + Just (BYPASS bypass) -> (bypass, Nothing) + Just othermsg -> (Bypass S.empty, Just othermsg) + Nothing -> (Bypass S.empty, Nothing) + where + client = liftIO . runNetProto clientrunst clientconn +getClientBypass _ _ (Just othermsg) cont _ = + -- Pass along non-BYPASS message from version 0 client. + cont (Bypass S.empty, (Just othermsg)) + +{- Proxy between the client and the remote. This picks up after + - sendClientProtocolVersion. + -} +proxy + :: Annex r + -> ProxyMethods + -> ServerMode + -> ClientSide + -> UUID + -> ProxySelector + -> ConcurrencyConfig + -> ProtocolVersion + -- ^ Protocol version being spoken between the proxy and the + -- client. When there are multiple remotes, some may speak an + -- earlier version. + -> Maybe Message + -- ^ non-VERSION message that was received from the client when + -- negotiating protocol version, and has not been responded to yet + -> ProtoErrorHandled r +proxy proxydone proxymethods servermode (ClientSide clientrunst clientconn) remoteuuid proxyselector concurrencyconfig (ProtocolVersion protocolversion) othermsg protoerrhandler = do + case othermsg of + Nothing -> proxynextclientmessage () + Just message -> proxyclientmessage (Just message) + where + client = liftIO . runNetProto clientrunst clientconn + + proxynextclientmessage () = protoerrhandler proxyclientmessage $ + client (net receiveMessage) + + servermodechecker c a = c servermode $ \case + Nothing -> a + Just notallowed -> + protoerrhandler proxynextclientmessage $ + client notallowed + + proxyclientmessage Nothing = proxydone + proxyclientmessage (Just message) = case message of + CHECKPRESENT k -> proxyCHECKPRESENT proxyselector k >>= \case + Just remoteside -> + proxyresponse remoteside message + (const proxynextclientmessage) + Nothing -> + protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage FAILURE + LOCKCONTENT k -> proxyLOCKCONTENT proxyselector k >>= \case + Just remoteside -> + proxyresponse remoteside message + (const proxynextclientmessage) + Nothing -> + protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage FAILURE + UNLOCKCONTENT -> proxyUNLOCKCONTENT proxyselector >>= \case + Just remoteside -> + proxynoresponse remoteside message + proxynextclientmessage + Nothing -> proxynextclientmessage () + REMOVE k -> do + remotesides <- proxyREMOVE proxyselector k + servermodechecker checkREMOVEServerMode $ + handleREMOVE remotesides k message + GET _ _ k -> proxyGET proxyselector k >>= \case + Just remoteside -> handleGET remoteside message + Nothing -> + protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage $ + ERROR "content not present" + PUT paf k -> do + af <- getassociatedfile paf + remotesides <- proxyPUT proxyselector af k + servermodechecker checkPUTServerMode $ + handlePUT remotesides k message + BYPASS _ -> proxynextclientmessage () + -- These messages involve the git repository, not the + -- annex. So they affect the git repository of the proxy, + -- not the remote. + CONNECT service -> + servermodechecker (checkCONNECTServerMode service) $ + -- P2P protocol does not continue after + -- relaying from git. + protoerrhandler (\() -> proxydone) $ + client $ net $ relayService service + NOTIFYCHANGE -> protoerr + -- Messages that the client should only send after one of + -- the messages above. + SUCCESS -> protoerr + SUCCESS_PLUS _ -> protoerr + FAILURE -> protoerr + FAILURE_PLUS _ -> protoerr + DATA _ -> protoerr + VALIDITY _ -> protoerr + -- If the client errors out, give up. + ERROR msg -> giveup $ "client error: " ++ msg + -- Messages that only the server should send. + CONNECTDONE _ -> protoerr + CHANGED _ -> protoerr + AUTH_SUCCESS _ -> protoerr + AUTH_FAILURE -> protoerr + PUT_FROM _ -> protoerr + ALREADY_HAVE -> protoerr + ALREADY_HAVE_PLUS _ -> protoerr + -- Early messages that the client should not send now. + AUTH _ _ -> protoerr + VERSION _ -> protoerr + + -- Send a message to the remote, send its response back to the + -- client, and pass it to the continuation. + proxyresponse remoteside message a = + getresponse (runRemoteSide remoteside) message $ \resp -> + protoerrhandler (a resp) $ + client $ net $ sendMessage resp + + -- Send a message to the remote, that it will not respond to. + proxynoresponse remoteside message a = + protoerrhandler a $ + runRemoteSide remoteside $ net $ sendMessage message + + -- Send a message to the endpoint and get back its response. + getresponse endpoint message handleresp = + protoerrhandler (withresp handleresp) $ + endpoint $ net $ do + sendMessage message + receiveMessage + + withresp a (Just resp) = a resp + -- Whichever of the remote or client the message was read from + -- hung up. + withresp _ Nothing = proxydone + + -- Read a message from one party, send it to the other, + -- and then pass the message to the continuation. + relayonemessage from to cont = + flip protoerrhandler (from $ net $ receiveMessage) $ + withresp $ \message -> + protoerrhandler (cont message) $ + to $ net $ sendMessage message + + protoerr = do + _ <- client $ net $ sendMessage (ERROR "protocol error X") + giveup "protocol error M" + + handleREMOVE [] _ _ = + -- When no places are provided to remove from, + -- don't report a successful remote. + protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage FAILURE + handleREMOVE remotesides k message = do + v <- forMC concurrencyconfig remotesides $ \r -> + runRemoteSideOrSkipFailed r $ do + net $ sendMessage message + net receiveMessage >>= return . \case + Just SUCCESS -> + Just ((True, Nothing), [Remote.uuid (remote r)]) + Just (SUCCESS_PLUS us) -> + Just ((True, Nothing), Remote.uuid (remote r):us) + Just FAILURE -> + Just ((False, Nothing), []) + Just (FAILURE_PLUS us) -> + Just ((False, Nothing), us) + Just (ERROR err) -> + Just ((False, Just err), []) + _ -> Nothing + let v' = map join v + let us = concatMap snd $ catMaybes v' + mapM_ (\u -> removedContent proxymethods u k) us + protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage $ + let nonplussed = all (== remoteuuid) us + || protocolversion < 2 + in if all (maybe False (fst . fst)) v' + then if nonplussed + then SUCCESS + else SUCCESS_PLUS us + else if nonplussed + then case mapMaybe (snd . fst) (catMaybes v') of + [] -> FAILURE + (err:_) -> ERROR err + else FAILURE_PLUS us + + handleGET remoteside message = getresponse (runRemoteSide remoteside) message $ + withDATA (relayGET remoteside) $ \case + ERROR err -> protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage (ERROR err) + _ -> protoerr + + handlePUT (remoteside:[]) k message + | Remote.uuid (remote remoteside) == remoteuuid = + getresponse (runRemoteSide remoteside) message $ \resp -> case resp of + ALREADY_HAVE -> protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage resp + ALREADY_HAVE_PLUS _ -> protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage resp + PUT_FROM _ -> + getresponse client resp $ + withDATA + (relayPUT remoteside k) + (const protoerr) + _ -> protoerr + handlePUT [] _ _ = + protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage ALREADY_HAVE + handlePUT remotesides k message = + handlePutMulti remotesides k message + + withDATA a _ message@(DATA len) = a len message + withDATA _ a message = a message + + relayGET remoteside len = relayDATAStart client $ + relayDATACore len (runRemoteSide remoteside) client $ + relayDATAFinish (runRemoteSide remoteside) client $ + relayonemessage client (runRemoteSide remoteside) $ + const proxynextclientmessage + + relayPUT remoteside k len = relayDATAStart (runRemoteSide remoteside) $ + relayDATACore len client (runRemoteSide remoteside) $ + relayDATAFinish client (runRemoteSide remoteside) $ + relayonemessage (runRemoteSide remoteside) client finished + where + finished resp () = do + void $ relayPUTRecord k remoteside resp + proxynextclientmessage () + + relayPUTRecord k remoteside SUCCESS = do + addedContent proxymethods (Remote.uuid (remote remoteside)) k + return $ Just [Remote.uuid (remote remoteside)] + relayPUTRecord k remoteside (SUCCESS_PLUS us) = do + let us' = (Remote.uuid (remote remoteside)) : us + forM_ us' $ \u -> + addedContent proxymethods u k + return $ Just us' + relayPUTRecord _ _ _ = + return Nothing + + handlePutMulti remotesides k message = do + let initiate remoteside = do + resp <- runRemoteSideOrSkipFailed remoteside $ net $ do + sendMessage message + receiveMessage + case resp of + Just (Just (PUT_FROM (Offset offset))) -> + return $ Right $ + Right (remoteside, offset) + Just (Just ALREADY_HAVE) -> + return $ Right $ Left remoteside + Just (Just _) -> protoerr + Just Nothing -> return (Left ()) + Nothing -> return (Left ()) + let alreadyhave = \case + Right (Left _) -> True + _ -> False + l <- forMC concurrencyconfig remotesides initiate + if all alreadyhave l + then if protocolversion < 2 + then protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage ALREADY_HAVE + else protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage $ ALREADY_HAVE_PLUS $ + filter (/= remoteuuid) $ + map (Remote.uuid . remote) (lefts (rights l)) + else if null (rights l) + -- no response from any remote + then proxydone + else do + let l' = rights (rights l) + let minoffset = minimum (map snd l') + getresponse client (PUT_FROM (Offset minoffset)) $ + withDATA (relayPUTMulti minoffset l' k) + (const protoerr) + + relayPUTMulti minoffset remotes k (Len datalen) _ = do + let totallen = datalen + minoffset + -- Tell each remote how much data to expect, depending + -- on the remote's offset. + rs <- forMC concurrencyconfig remotes $ \r@(remoteside, remoteoffset) -> + runRemoteSideOrSkipFailed remoteside $ do + net $ sendMessage $ DATA $ Len $ + totallen - remoteoffset + return r + protoerrhandler (send (catMaybes rs) minoffset) $ + client $ net $ receiveBytes (Len datalen) nullMeterUpdate + where + chunksize = fromIntegral defaultChunkSize + + -- Stream the lazy bytestring out to the remotes in chunks. + -- Only start sending to a remote once past its desired + -- offset. + send rs n b = do + let (chunk, b') = L.splitAt chunksize b + let chunklen = fromIntegral (L.length chunk) + let !n' = n + chunklen + rs' <- forMC concurrencyconfig rs $ \r@(remoteside, remoteoffset) -> + if n >= remoteoffset + then runRemoteSideOrSkipFailed remoteside $ do + net $ sendBytes (Len chunklen) chunk nullMeterUpdate + return r + else if (n' > remoteoffset) + then do + let chunkoffset = remoteoffset - n + let subchunklen = chunklen - chunkoffset + let subchunk = L.drop (fromIntegral chunkoffset) chunk + runRemoteSideOrSkipFailed remoteside $ do + net $ sendBytes (Len subchunklen) subchunk nullMeterUpdate + return r + else return (Just r) + if L.null b' + then sent (catMaybes rs') + else send (catMaybes rs') n' b' + + sent [] = proxydone + sent rs = relayDATAFinishMulti k (map fst rs) + + runRemoteSideOrSkipFailed remoteside a = + runRemoteSide remoteside a >>= \case + Right v -> return (Just v) + Left _ -> do + -- This connection to the remote is + -- unrecoverable at this point, so close it. + closeRemoteSide remoteside + return Nothing + + relayDATAStart x receive message = + protoerrhandler (\() -> receive) $ + x $ net $ sendMessage message + + relayDATACore len x y a = protoerrhandler send $ + x $ net $ receiveBytes len nullMeterUpdate + where + send b = protoerrhandler a $ + y $ net $ sendBytes len b nullMeterUpdate + + relayDATAFinish x y sendsuccessfailure () + | protocolversion == 0 = sendsuccessfailure + -- Protocol version 1 has a VALID or + -- INVALID message after the data. + | otherwise = relayonemessage x y (\_ () -> sendsuccessfailure) + + relayDATAFinishMulti k rs + | protocolversion == 0 = + finish $ net receiveMessage + | otherwise = + flip protoerrhandler (client $ net $ receiveMessage) $ + withresp $ \message -> + finish $ do + -- Relay VALID or INVALID message + -- only to remotes that support + -- protocol version 1. + net getProtocolVersion >>= \case + ProtocolVersion 0 -> return () + _ -> net $ sendMessage message + net receiveMessage + where + finish a = do + storeduuids <- forMC concurrencyconfig rs $ \r -> + runRemoteSideOrSkipFailed r a >>= \case + Just (Just resp) -> + relayPUTRecord k r resp + _ -> return Nothing + protoerrhandler proxynextclientmessage $ + client $ net $ sendMessage $ + case concat (catMaybes storeduuids) of + [] -> FAILURE + us + | protocolversion < 2 -> SUCCESS + | otherwise -> SUCCESS_PLUS us + + -- The associated file received from the P2P protocol + -- is relative to the top of the git repository. But this process + -- may be running with a different cwd. + getassociatedfile (ProtoAssociatedFile (AssociatedFile (Just f))) = + AssociatedFile . Just + <$> fromRepo (fromTopFilePath (asTopFilePath f)) + getassociatedfile (ProtoAssociatedFile (AssociatedFile Nothing)) = + return $ AssociatedFile Nothing + +data ConcurrencyConfig = ConcurrencyConfig Int (MSem.MSem Int) + +noConcurrencyConfig :: Annex ConcurrencyConfig +noConcurrencyConfig = liftIO $ ConcurrencyConfig 1 <$> MSem.new 1 + +getConcurrencyConfig :: Annex ConcurrencyConfig +getConcurrencyConfig = (annexJobs <$> Annex.getGitConfig) >>= \case + NonConcurrent -> noConcurrencyConfig + Concurrent n -> go n + ConcurrentPerCpu -> go =<< liftIO getNumProcessors + where + go n = do + c <- liftIO getNumCapabilities + when (n > c) $ + liftIO $ setNumCapabilities n + setConcurrency (ConcurrencyGitConfig (Concurrent n)) + msem <- liftIO $ MSem.new n + return (ConcurrencyConfig n msem) + +forMC :: ConcurrencyConfig -> [a] -> (a -> Annex b) -> Annex [b] +forMC _ (x:[]) a = do + r <- a x + return [r] +forMC (ConcurrencyConfig n msem) xs a + | n < 2 = forM xs a + | otherwise = do + runners <- forM xs $ \x -> + forkState $ bracketIO + (MSem.wait msem) + (const $ MSem.signal msem) + (const $ a x) + mapM id =<< liftIO (forConcurrently runners id) + diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -342,11 +342,12 @@ {- Displays known locations of a key and helps the user take action - to make them accessible. -} -showLocations :: Bool -> Key -> [UUID] -> String -> Annex () -showLocations separateuntrusted key exclude nolocmsg = do +showLocations :: Bool -> Key -> (UUID -> Annex Bool) -> String -> Annex () +showLocations separateuntrusted key checkexclude nolocmsg = do u <- getUUID remotes <- remoteList uuids <- keyLocations key + exclude <- filterM checkexclude uuids untrusteduuids <- if separateuntrusted then trustGet UnTrusted else pure [] @@ -447,11 +448,14 @@ where checkclaim = maybe (pure False) (`id` url) . claimUrl -{- Is this a remote of a type we can sync with, or a special remote - - with an annex:: url configured? -} +{- Is this a remote of a type that git pull and push work with? + - That includes special remotes with an annex:: url configured. + - It does not include proxied remotes. -} gitSyncableRemote :: Remote -> Bool gitSyncableRemote r - | gitSyncableRemoteType (remotetype r) = True + | gitSyncableRemoteType (remotetype r) + && isJust (remoteUrl (gitconfig r)) = + not (isJust (remoteAnnexProxiedBy (gitconfig r))) | otherwise = case remoteUrl (gitconfig r) of Just u | "annex::" `isPrefixOf` u -> True _ -> False diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -118,8 +118,8 @@ unless ok $ get [] -uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () -uploadKey _ _ _ = giveup "upload to bittorrent not supported" +uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +uploadKey _ _ _ _ = giveup "upload to bittorrent not supported" dropKey :: Key -> Annex () dropKey k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k 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-2023 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -25,7 +25,6 @@ import qualified Git.GCrypt import qualified Git.Types as Git import qualified Annex -import Logs.Presence import Annex.Transfer import Annex.CopyFile import Annex.Verify @@ -45,6 +44,8 @@ import Types.CleanupActions import qualified CmdLine.GitAnnexShell.Fields as Fields import Logs.Location +import Logs.Proxy +import Logs.Cluster.Basic import Utility.Metered import Utility.Env import Utility.Batch @@ -66,7 +67,8 @@ import Control.Concurrent import qualified Data.Map as M -import qualified Data.ByteString as S +import qualified Data.Set as S +import qualified Data.ByteString as B import qualified Utility.RawFilePath as R import Network.URI @@ -92,7 +94,13 @@ list autoinit = do c <- fromRepo Git.config rs <- mapM (tweakurl c) =<< Annex.getGitRemotes - mapM (configRead autoinit) (filter (not . isGitRemoteAnnex) rs) + rs' <- mapM (configRead autoinit) (filter (not . isGitRemoteAnnex) rs) + proxies <- doQuietAction getProxies + if proxies == mempty + then return rs' + else do + proxied <- listProxied proxies rs' + return (proxied++rs') where annexurl r = remoteConfig r "annexurl" tweakurl c r = do @@ -168,6 +176,7 @@ Just r' -> return r' _ -> return r + gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs -- Remote.GitLFS may be used with a repo that is also encrypted @@ -178,10 +187,9 @@ Nothing -> do st <- mkState r u gc c <- parsedRemoteConfig remote rc - go st c <$> remoteCost gc c defcst + go st c <$> remoteCost gc c (defaultRepoCost r) Just addr -> Remote.P2P.chainGen addr r u rc gc rs where - defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost go st c cst = Just new where new = Remote @@ -221,6 +229,11 @@ , remoteStateHandle = rs } +defaultRepoCost :: Git.Repo -> Cost +defaultRepoCost r + | repoCheap r = cheapRemoteCost + | otherwise = expensiveRemoteCost + unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) unavailable r = gen r' where @@ -265,7 +278,7 @@ 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 + unless (isUUIDConfigured r' || val == mempty || not mustincludeuuuid) $ do warning $ UnquotedString $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r warning $ UnquotedString $ "Instead, got: " ++ show val warning "This is unexpected; please check the network transport!" @@ -338,7 +351,7 @@ readlocalannexconfig = do let check = do Annex.BranchState.disableUpdate - catchNonAsync (autoInitialize (pure [])) $ \e -> + catchNonAsync (autoInitialize noop (pure [])) $ \e -> warning $ UnquotedString $ "Remote " ++ Git.repoDescribe r ++ ": " ++ show e Annex.getState Annex.repo @@ -442,7 +455,8 @@ , giveup "remote does not have expected annex.uuid value" ) | Git.repoIsHttp repo = giveup "dropping from http remote not supported" - | otherwise = P2PHelper.remove (Ssh.runProto r connpool (return False)) key + | otherwise = P2PHelper.remove (uuid r) + (Ssh.runProto r connpool (return (Right False, Nothing))) key lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r lockKey r st key callback = do @@ -464,7 +478,7 @@ ) | Git.repoIsSsh repo = do showLocking r - let withconn = Ssh.withP2PSshConnection r connpool failedlock + let withconn = Ssh.withP2PShellConnection r connpool failedlock P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback | otherwise = failedlock where @@ -490,7 +504,7 @@ let bwlimit = remoteAnnexBwLimitDownload (gitconfig r) <|> remoteAnnexBwLimit (gitconfig r) -- run copy from perspective of remote - onLocalFast st $ Annex.Content.prepSendAnnex' key >>= \case + onLocalFast st $ Annex.Content.prepSendAnnex' key Nothing >>= \case Just (object, _sz, check) -> do let checksuccess = check >>= \case Just err -> giveup err @@ -529,22 +543,22 @@ #endif {- Tries to copy a key's content to a remote's annex. -} -copyToRemote :: Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex () -copyToRemote r st key file meterupdate = do +copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +copyToRemote r st key af o meterupdate = do repo <- getRepo r - copyToRemote' repo r st key file meterupdate + copyToRemote' repo r st key af o meterupdate -copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex () -copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate +copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate | not $ Git.repoIsUrl repo = ifM duc ( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $ - copylocal =<< Annex.Content.prepSendAnnex' key + copylocal =<< Annex.Content.prepSendAnnex' key o , giveup "remote does not have expected annex.uuid value" ) | Git.repoIsSsh repo = - P2PHelper.store (gitconfig r) - (Ssh.runProto r connpool (return False)) - key file meterupdate + P2PHelper.store (uuid r) (gitconfig r) + (Ssh.runProto r connpool (return Nothing)) + key af o meterupdate | otherwise = giveup "copying to non-ssh repo not supported" where @@ -561,14 +575,14 @@ -- run copy from perspective of remote res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) ( return True - , runTransfer (Transfer Download u (fromKey id key)) Nothing file Nothing stdRetry $ \p -> do + , runTransfer (Transfer Download u (fromKey id key)) Nothing af Nothing stdRetry $ \p -> do let verify = RemoteVerify r copier <- mkFileCopier hardlink st let rsp = RetrievalAllKeysSecure let checksuccess = liftIO checkio >>= \case Just err -> giveup err Nothing -> return True - logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file (Just sz) $ \dest -> + logStatusAfter key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest -> metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' -> copier object (fromRawFilePath dest) key p' checksuccess verify ) @@ -594,7 +608,7 @@ s <- Annex.new r Annex.eval s $ do Annex.BranchState.disableUpdate - ensureInitialized (pure []) + ensureInitialized noop (pure []) a `finally` quiesce True data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar [(Annex.AnnexState, Annex.AnnexRead)]) @@ -638,7 +652,7 @@ [] -> do liftIO $ putMVar mv [] v <- newLocal repo - go (v, ensureInitialized (pure []) >> a) + go (v, ensureInitialized noop (pure []) >> a) (v:rest) -> do liftIO $ putMVar mv rest go (v, a) @@ -725,7 +739,7 @@ - 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)) LocalRemoteAnnex +data State = State Ssh.P2PShellConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex getRepoFromState :: State -> Annex Git.Repo getRepoFromState (State _ _ _ a _) = fst <$> a @@ -738,7 +752,7 @@ mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State mkState r u gc = do - pool <- Ssh.mkP2PSshConnectionPool + pool <- Ssh.mkP2PShellConnectionPool copycowtried <- liftIO newCopyCoWTried lra <- mkLocalRemoteAnnex r (duc, getrepo) <- go @@ -772,3 +786,122 @@ ) return (duc, getrepo) + +listProxied :: M.Map UUID (S.Set Proxy) -> [Git.Repo] -> Annex [Git.Repo] +listProxied proxies rs = concat <$> mapM go rs + where + go r = do + g <- Annex.gitRepo + u <- getRepoUUID r + gc <- Annex.getRemoteGitConfig r + let cu = fromMaybe u $ remoteAnnexConfigUUID gc + if not (canproxy gc r) || cu == NoUUID + then pure [] + else case M.lookup cu proxies of + Nothing -> pure [] + Just proxied -> catMaybes + <$> mapM (mkproxied g r gc proxied) + (S.toList proxied) + + proxiedremotename r p = do + n <- Git.remoteName r + pure $ n ++ "-" ++ proxyRemoteName p + + mkproxied g r gc proxied p = case proxiedremotename r p of + Nothing -> pure Nothing + Just proxyname -> mkproxied' g r gc proxied p proxyname + + -- The proxied remote is constructed by renaming the proxy remote, + -- changing its uuid, and setting the proxied remote's inherited + -- configs and uuid in Annex state. + mkproxied' g r gc proxied p proxyname + | any isconfig (M.keys (Git.config g)) = pure Nothing + | otherwise = do + clusters <- getClustersWith id + -- Not using addGitConfigOverride for inherited + -- configs, because child git processes do not + -- need them to be provided with -c. + Annex.adjustGitRepo (pure . annexconfigadjuster clusters) + return $ Just $ renamedr + where + renamedr = + let c = adduuid configkeyUUID $ + Git.fullconfig r + in r + { Git.remoteName = Just proxyname + , Git.config = M.map Prelude.head c + , Git.fullconfig = c + } + + annexconfigadjuster clusters r' = + let c = adduuid (configRepoUUID renamedr) $ + addurl $ + addproxiedby $ + adjustclusternode clusters $ + inheritconfigs $ Git.fullconfig r' + in r' + { Git.config = M.map Prelude.head c + , Git.fullconfig = c + } + + adduuid ck = M.insert ck + [Git.ConfigValue $ fromUUID $ proxyRemoteUUID p] + + addurl = M.insert (remoteConfig renamedr (remoteGitConfigKey UrlField)) + [Git.ConfigValue $ encodeBS $ Git.repoLocation r] + + addproxiedby = case remoteAnnexUUID gc of + Just u -> addremoteannexfield ProxiedByField + [Git.ConfigValue $ fromUUID u] + Nothing -> id + + -- A node of a cluster that is being proxied along with + -- that cluster does not need to be synced with + -- by default, because syncing with the cluster will + -- effectively sync with all of its nodes. + -- + -- Also, give it a slightly higher cost than the + -- cluster by default, to encourage using the cluster. + adjustclusternode clusters = + case M.lookup (ClusterNodeUUID (proxyRemoteUUID p)) (clusterNodeUUIDs clusters) of + Just cs + | any (\c -> S.member (fromClusterUUID c) proxieduuids) (S.toList cs) -> + addremoteannexfield SyncField + [Git.ConfigValue $ Git.Config.boolConfig' False] + . addremoteannexfield CostField + [Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1] + _ -> id + + proxieduuids = S.map proxyRemoteUUID proxied + + addremoteannexfield f = M.insert + (remoteAnnexConfig renamedr (remoteGitConfigKey f)) + + inheritconfigs c = foldl' inheritconfig c proxyInheritedFields + + inheritconfig c k = case (M.lookup dest c, M.lookup src c) of + (Nothing, Just v) -> M.insert dest v c + _ -> c + where + src = remoteAnnexConfig r k + dest = remoteAnnexConfig renamedr k + + -- When the git config has anything set for a remote, + -- avoid making a proxied remote with the same name. + -- It is possible to set git configs of proxies, but it + -- needs both the url and uuid config to be manually set. + isconfig (Git.ConfigKey configkey) = + proxyconfigprefix `B.isPrefixOf` configkey + where + Git.ConfigKey proxyconfigprefix = remoteConfig proxyname mempty + + -- Git remotes that are gcrypt or git-lfs special remotes cannot + -- proxy. Local git remotes cannot proxy either because + -- git-annex-shell is not used to access a local git url. + -- Proxing is also yet supported for remotes using P2P + -- addresses. + canproxy gc r + | remoteAnnexGitLFS gc = False + | Git.GCrypt.isEncrypted r = False + | Git.repoIsLocal r || Git.repoIsLocalUnknown r = False + | otherwise = isNothing (repoP2PAddress r) diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -1,6 +1,6 @@ {- Utilities for git remotes. - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,9 +14,13 @@ import qualified Types.Remote as Remote import qualified Utility.RawFilePath as R import qualified Git.Config +import Logs.Proxy +import Types.Cluster import Data.Time.Clock.POSIX import System.PosixCompat.Files (modificationTime) +import qualified Data.Map as M +import qualified Data.Set as S repoCheap :: Git.Repo -> Bool repoCheap = not . Git.repoIsUrl @@ -62,7 +66,26 @@ [] -> "never" _ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes repo <- Remote.getRepo r - return - [ ("repository location", Git.repoLocation repo) - , ("last synced", lastsynctime) + let proxied = Git.Config.boolConfig $ isJust $ + remoteAnnexProxiedBy (Remote.gitconfig r) + proxies <- getProxies + let proxying = S.toList $ fromMaybe mempty $ + M.lookup (Remote.uuid r) proxies + let iscluster = isClusterUUID . proxyRemoteUUID + let proxyname p = Remote.name r ++ "-" ++ proxyRemoteName p + let proxynames = map proxyname $ filter (not . iscluster) proxying + let clusternames = map proxyname $ filter iscluster proxying + return $ catMaybes + [ Just ("repository location", Git.repoLocation repo) + , Just ("last synced", lastsynctime) + , Just ("proxied", proxied) + , if isClusterUUID (Remote.uuid r) + then Just ("cluster", Git.Config.boolConfig True) + else Nothing + , if null clusternames + then Nothing + else Just ("gateway to cluster", unwords clusternames) + , if null proxynames + then Nothing + else Just ("proxying", unwords proxynames) ] diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -34,8 +34,8 @@ addHooks' r starthook stophook = r' where r' = r - { storeKey = \k f p -> - wrapper $ storeKey r k f p + { storeKey = \k af o p -> + wrapper $ storeKey r k af o p , retrieveKeyFile = \k f d p vc -> wrapper $ retrieveKeyFile r k f d p vc , retrieveKeyFileCheap = case retrieveKeyFileCheap r of diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -1,6 +1,6 @@ {- Helpers for remotes using the git-annex P2P protocol. - - - Copyright 2016-2021 Joey Hess + - Copyright 2016-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -19,6 +19,8 @@ import Utility.Tuple import Types.NumCopies import Annex.Verify +import Logs.Location +import Utility.SafeOutput import Control.Concurrent @@ -32,14 +34,20 @@ -- the pool when done. type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a -store :: RemoteGitConfig -> ProtoRunner Bool -> Key -> AssociatedFile -> MeterUpdate -> Annex () -store gc runner k af p = do - let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k) +store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +store remoteuuid gc runner k af o p = do + let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k o) let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc metered (Just p) sizer bwlimit $ \_ p' -> runner (P2P.put k af p') >>= \case - Just True -> return () - Just False -> giveup "Transfer failed" + Just (Just fanoutuuids) -> do + -- Storing on the remote can cause it + -- to be stored on additional UUIDs, + -- so record those. + forM_ fanoutuuids $ \u -> + when (u /= remoteuuid) $ + logChange k u InfoPresent + Just Nothing -> giveup "Transfer failed" Nothing -> remoteUnavail retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification @@ -52,14 +60,30 @@ Just (False, _) -> giveup "Transfer failed" Nothing -> remoteUnavail -remove :: ProtoRunner Bool -> Key -> Annex () -remove runner k = runner (P2P.remove k) >>= \case - Just True -> return () - Just False -> giveup "removing content from remote failed" +remove :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Key -> Annex () +remove remoteuuid runner k = runner (P2P.remove k) >>= \case + Just (Right True, alsoremoveduuids) -> note alsoremoveduuids + Just (Right False, alsoremoveduuids) -> do + note alsoremoveduuids + giveup "removing content from remote failed" + Just (Left err, _) -> do + giveup (safeOutput err) Nothing -> remoteUnavail + where + -- The remote reports removal from other UUIDs than its own, + -- so record those. + note alsoremoveduuids = + forM_ (fromMaybe [] alsoremoveduuids) $ \u -> + when (u /= remoteuuid) $ + logChange k u InfoMissing -checkpresent :: ProtoRunner Bool -> Key -> Annex Bool -checkpresent runner k = maybe remoteUnavail return =<< runner (P2P.checkPresent k) +checkpresent :: ProtoRunner (Either String Bool) -> Key -> Annex Bool +checkpresent runner k = + runner (P2P.checkPresent k) + >>= \case + Nothing -> remoteUnavail + Just (Right b) -> return b + Just (Left err) -> giveup (safeOutput err) lock :: WithConn a c -> ProtoConnRunner c -> UUID -> Key -> (VerifiedCopy -> Annex a) -> Annex a lock withconn connrunner u k callback = withconn $ \conn -> do diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -44,8 +44,8 @@ } | otherwise = r -readonlyStoreKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () -readonlyStoreKey _ _ _ = readonlyFail +readonlyStoreKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +readonlyStoreKey _ _ _ _ = readonlyFail readonlyRemoveKey :: Key -> Annex () readonlyRemoveKey _ = readonlyFail diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -134,8 +134,8 @@ - but they are never actually used (since specialRemote replaces them). - Here are some dummy ones. -} -storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex () -storeKeyDummy _ _ _ = error "missing storeKey implementation" +storeKeyDummy :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +storeKeyDummy _ _ _ _ = error "missing storeKey implementation" retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation" removeKeyDummy :: Key -> Annex () @@ -181,7 +181,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr where encr = baser - { storeKey = \k _f p -> cip >>= storeKeyGen k p + { storeKey = \k _af o p -> cip >>= storeKeyGen k o p , retrieveKeyFile = \k _f d p vc -> cip >>= retrieveKeyFileGen k d p vc , retrieveKeyFileCheap = case retrieveKeyFileCheap baser of Nothing -> Nothing @@ -222,7 +222,7 @@ isencrypted = isEncrypted c -- chunk, then encrypt, then feed to the storer - storeKeyGen k p enc = sendAnnex k rollback $ \src _sz -> + storeKeyGen k o p enc = sendAnnex k o rollback $ \src _sz -> displayprogress uploadbwlimit p k (Just src) $ \p' -> storeChunks (uuid baser) chunkconfig enck k src p' enc encr storer checkpresent diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -1,6 +1,6 @@ {- git-annex remote access with ssh and git-annex-shell - - - Copyright 2011-2022 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,6 +21,7 @@ import Utility.Metered import Utility.Rsync import Utility.SshHost +import Utility.Debug import Types.Remote import Types.Transfer import Config @@ -61,9 +62,10 @@ shellcmd = "git-annex-shell" getshellopts = do debugenabled <- Annex.getRead Annex.debugenabled - let params' = if debugenabled - then Param "--debug" : params - else params + debugselector <- Annex.getRead Annex.debugselector + let params' = case (debugenabled, debugselector) of + (True, NoDebugSelector) -> Param "--debug" : params + _ -> params return (Param command : File (fromRawFilePath dir) : params') uuidcheck NoUUID = [] uuidcheck u@(UUID _) = ["--uuid", fromUUID u] @@ -178,70 +180,81 @@ | otherwise = remoteAnnexRsyncUploadOptions gc gc = gitconfig r --- A connection over ssh to git-annex shell speaking the P2P protocol. -type P2PSshConnection = P2P.ClosableConnection +-- A connection over ssh or locally to git-annex shell, +-- speaking the P2P protocol. +type P2PShellConnection = P2P.ClosableConnection (P2P.RunState, P2P.P2PConnection, ProcessHandle) -closeP2PSshConnection :: P2PSshConnection -> IO (P2PSshConnection, Maybe ExitCode) -closeP2PSshConnection P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing) -closeP2PSshConnection (P2P.OpenConnection (_st, conn, pid)) = +closeP2PShellConnection :: P2PShellConnection -> IO (P2PShellConnection, Maybe ExitCode) +closeP2PShellConnection P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing) +closeP2PShellConnection (P2P.OpenConnection (_st, conn, pid)) = -- mask async exceptions, avoid cleanup being interrupted uninterruptibleMask_ $ do P2P.closeConnection conn exitcode <- waitForProcess pid return (P2P.ClosedConnection, Just exitcode) --- Pool of connections over ssh to git-annex-shell p2pstdio. -type P2PSshConnectionPool = TVar (Maybe P2PSshConnectionPoolState) +-- Pool of connections to git-annex-shell p2pstdio. +type P2PShellConnectionPool = TVar (Maybe P2PShellConnectionPoolState) -data P2PSshConnectionPoolState - = P2PSshConnections [P2PSshConnection] +data P2PShellConnectionPoolState + = P2PShellConnections [P2PShellConnection] -- Remotes using an old version of git-annex-shell don't support P2P - | P2PSshUnsupported + | P2PShellUnsupported -mkP2PSshConnectionPool :: Annex P2PSshConnectionPool -mkP2PSshConnectionPool = liftIO $ newTVarIO Nothing +mkP2PShellConnectionPool :: Annex P2PShellConnectionPool +mkP2PShellConnectionPool = liftIO $ newTVarIO Nothing -- Takes a connection from the pool, if any are available, otherwise -- tries to open a new one. -getP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection) -getP2PSshConnection r connpool = getexistingconn >>= \case +getP2PShellConnection :: Remote -> P2PShellConnectionPool -> Annex (Maybe P2PShellConnection) +getP2PShellConnection r connpool = getexistingconn >>= \case Nothing -> return Nothing - Just Nothing -> openP2PSshConnection r connpool + Just Nothing -> openP2PShellConnection r connpool Just (Just c) -> return (Just c) where getexistingconn = liftIO $ atomically $ readTVar connpool >>= \case - Just P2PSshUnsupported -> return Nothing - Just (P2PSshConnections (c:cs)) -> do - writeTVar connpool (Just (P2PSshConnections cs)) + Just P2PShellUnsupported -> return Nothing + Just (P2PShellConnections (c:cs)) -> do + writeTVar connpool (Just (P2PShellConnections cs)) return (Just (Just c)) - Just (P2PSshConnections []) -> return (Just Nothing) + Just (P2PShellConnections []) -> return (Just Nothing) Nothing -> return (Just Nothing) -- Add a connection to the pool, unless it's closed. -storeP2PSshConnection :: P2PSshConnectionPool -> P2PSshConnection -> IO () -storeP2PSshConnection _ P2P.ClosedConnection = return () -storeP2PSshConnection connpool conn = atomically $ modifyTVar' connpool $ \case - Just (P2PSshConnections cs) -> Just (P2PSshConnections (conn:cs)) - _ -> Just (P2PSshConnections [conn]) +storeP2PShellConnection :: P2PShellConnectionPool -> P2PShellConnection -> IO () +storeP2PShellConnection _ P2P.ClosedConnection = return () +storeP2PShellConnection connpool conn = atomically $ modifyTVar' connpool $ \case + Just (P2PShellConnections cs) -> Just (P2PShellConnections (conn:cs)) + _ -> Just (P2PShellConnections [conn]) --- Try to open a P2PSshConnection. +-- Try to open a P2PShellConnection. -- The new connection is not added to the pool, so it's available -- for the caller to use. -- If the remote does not support the P2P protocol, that's remembered in -- the connection pool. -openP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection) -openP2PSshConnection r connpool = do +openP2PShellConnection :: Remote -> P2PShellConnectionPool -> Annex (Maybe P2PShellConnection) +openP2PShellConnection r connpool = + openP2PShellConnection' r P2P.maxProtocolVersion mempty >>= \case + Just conn -> return (Just conn) + Nothing -> do + liftIO $ rememberunsupported + return Nothing + where + rememberunsupported = atomically $ + modifyTVar' connpool $ + maybe (Just P2PShellUnsupported) Just + +openP2PShellConnection' :: Remote -> P2P.ProtocolVersion -> P2P.Bypass -> Annex (Maybe P2PShellConnection) +openP2PShellConnection' r maxprotoversion bypass = do u <- getUUID let ps = [Param (fromUUID u)] repo <- getRepo r git_annex_shell ConsumeStdin repo "p2pstdio" ps [] >>= \case - Nothing -> do - liftIO $ rememberunsupported - return Nothing - Just (cmd, params) -> start cmd params =<< getRepo r + Nothing -> return Nothing + Just (cmd, params) -> start cmd params where - start cmd params repo = liftIO $ do + start cmd params = liftIO $ do (Just from, Just to, Nothing, pid) <- createProcess $ (proc cmd (toCommand params)) { std_in = CreatePipe @@ -249,50 +262,46 @@ } pidnum <- getPid pid let conn = P2P.P2PConnection - { P2P.connRepo = repo + { P2P.connRepo = Nothing , P2P.connCheckAuth = const False - , P2P.connIhdl = to - , P2P.connOhdl = from + , P2P.connIhdl = P2P.P2PHandle to + , P2P.connOhdl = P2P.P2PHandle from , P2P.connIdent = P2P.ConnIdent $ - Just $ "ssh connection " ++ show pidnum + Just $ "git-annex-shell connection " ++ show pidnum } runst <- P2P.mkRunState P2P.Client let c = P2P.OpenConnection (runst, conn, pid) -- When the connection is successful, the remote -- will send an AUTH_SUCCESS with its uuid. - let proto = P2P.postAuth $ - P2P.negotiateProtocolVersion P2P.maxProtocolVersion + let proto = P2P.postAuth $ do + P2P.negotiateProtocolVersion maxprotoversion + P2P.sendBypass bypass tryNonAsync (P2P.runNetProto runst conn proto) >>= \case Right (Right (Just theiruuid)) | theiruuid == uuid r -> return $ Just c _ -> do - (cclosed, exitcode) <- closeP2PSshConnection c + (cclosed, exitcode) <- closeP2PShellConnection c -- ssh exits 255 when unable to connect to -- server. if exitcode == Just (ExitFailure 255) then return (Just cclosed) - else do - rememberunsupported - return Nothing - rememberunsupported = atomically $ - modifyTVar' connpool $ - maybe (Just P2PSshUnsupported) Just + else return Nothing -- Runs a P2P Proto action on a remote when it supports that, -- otherwise the fallback action. -runProto :: Remote -> P2PSshConnectionPool -> Annex a -> P2P.Proto a -> Annex (Maybe a) +runProto :: Remote -> P2PShellConnectionPool -> Annex a -> P2P.Proto a -> Annex (Maybe a) runProto r connpool onerr proto = Just <$> - (getP2PSshConnection r connpool >>= maybe onerr go) + (getP2PShellConnection r connpool >>= maybe onerr go) where go c = do (c', v) <- runProtoConn proto c case v of Just res -> do - liftIO $ storeP2PSshConnection connpool c' + liftIO $ storeP2PShellConnection connpool c' return res Nothing -> onerr -runProtoConn :: P2P.Proto a -> P2PSshConnection -> Annex (P2PSshConnection, Maybe a) +runProtoConn :: P2P.Proto a -> P2PShellConnection -> Annex (P2PShellConnection, Maybe a) runProtoConn _ P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing) runProtoConn a conn@(P2P.OpenConnection (runst, c, _)) = do P2P.runFullProto runst c a >>= \case @@ -301,24 +310,24 @@ -- usable, so close it. Left e -> do warning $ UnquotedString $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")" - conn' <- fst <$> liftIO (closeP2PSshConnection conn) + conn' <- fst <$> liftIO (closeP2PShellConnection conn) return (conn', Nothing) --- Allocates a P2P ssh connection from the pool, and runs the action with it, --- returning the connection to the pool once the action is done. +-- Allocates a P2P shell connection from the pool, and runs the action with +-- it, returning the connection to the pool once the action is done. -- -- If the remote does not support the P2P protocol, runs the fallback -- action instead. -withP2PSshConnection +withP2PShellConnection :: Remote - -> P2PSshConnectionPool + -> P2PShellConnectionPool -> Annex a - -> (P2PSshConnection -> Annex (P2PSshConnection, a)) + -> (P2PShellConnection -> Annex (P2PShellConnection, a)) -> Annex a -withP2PSshConnection r connpool fallback a = bracketOnError get cache go +withP2PShellConnection r connpool fallback a = bracketOnError get cache go where - get = getP2PSshConnection r connpool - cache (Just conn) = liftIO $ storeP2PSshConnection connpool conn + get = getP2PShellConnection r connpool + cache (Just conn) = liftIO $ storeP2PShellConnection connpool conn cache Nothing = return () go (Just conn) = do (conn', res) <- a conn diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -65,7 +65,7 @@ , Remote.External.remote ] -{- Builds a list of all available Remotes. +{- Builds a list of all Remotes. - Since doing so can be expensive, the list is cached. -} remoteList :: Annex [Remote] remoteList = do diff --git a/Remote/P2P.hs b/Remote/P2P.hs --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -57,11 +57,11 @@ { uuid = u , cost = cst , name = Git.repoDescribe r - , storeKey = store gc protorunner + , storeKey = store u gc protorunner , retrieveKeyFile = retrieve gc protorunner , retrieveKeyFileCheap = Nothing , retrievalSecurityPolicy = RetrievalAllKeysSecure - , removeKey = remove protorunner + , removeKey = remove u protorunner , lockContent = Just $ lock withconn runProtoConn u , checkPresent = checkpresent protorunner , checkPresentCheap = False @@ -143,7 +143,7 @@ openConnection :: UUID -> P2PAddress -> Annex Connection openConnection u addr = do g <- Annex.gitRepo - v <- liftIO $ tryNonAsync $ connectPeer g addr + v <- liftIO $ tryNonAsync $ connectPeer (Just g) addr case v of Right conn -> do myuuid <- getUUID diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -138,8 +138,8 @@ where missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." -store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex () -store rs hdl k _f _p = sendAnnex k noop $ \src _sz -> +store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +store rs hdl k _af o _p = sendAnnex k o noop $ \src _sz -> parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe (giveup "tahoe failed to store content") (\cap -> storeCapability rs k cap) diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -181,8 +181,8 @@ setEquivilantKey key ek return (Just Verified) -uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () -uploadKey _ _ _ = giveup "upload to web not supported" +uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +uploadKey _ _ _ _ = giveup "upload to web not supported" dropKey :: UrlIncludeExclude -> Key -> Annex () dropKey urlincludeexclude k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -111,10 +111,10 @@ -- when the allowed set is changed. allowed <- loadP2PAuthTokens let conn = P2PConnection - { connRepo = r + { connRepo = Just r , connCheckAuth = (`isAllowedAuthToken` allowed) - , connIhdl = h - , connOhdl = h + , connIhdl = P2PHandle h + , connOhdl = P2PHandle h , connIdent = ConnIdent $ Just "tor remotedaemon" } -- not really Client, but we don't know their uuid yet @@ -146,7 +146,7 @@ Nothing -> return () Just addr -> robustConnection 1 $ do g <- liftAnnex th Annex.gitRepo - bracket (connectPeer g addr) closeConnection (go addr) + bracket (connectPeer (Just g) addr) closeConnection (go addr) where go addr conn = do myuuid <- liftAnnex th getUUID diff --git a/Types/Cluster.hs b/Types/Cluster.hs new file mode 100644 --- /dev/null +++ b/Types/Cluster.hs @@ -0,0 +1,84 @@ +{- git-annex cluster types + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP, OverloadedStrings #-} + +module Types.Cluster ( + ClusterUUID, + mkClusterUUID, + genClusterUUID, + fromClusterUUID, + isClusterUUID, + ClusterNodeUUID(..), + Clusters(..), + noClusters, +) where + +import Types.UUID + +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.ByteString as B +import Data.Char + +-- The UUID of a cluster as a whole. +-- +-- Cluster UUIDs are specially constructed so that regular repository UUIDs +-- can never be used as a cluster UUID. This is ncessary for security. +-- They are a version 8 UUID with the first octet set to 'a' and the second +-- to 'c'. +newtype ClusterUUID = ClusterUUID UUID + deriving (Show, Eq, Ord) + +-- Smart constructor for a ClusterUUID. Only allows valid cluster UUIDs. +mkClusterUUID :: UUID -> Maybe ClusterUUID +mkClusterUUID u + | isClusterUUID u = Just (ClusterUUID u) + | otherwise = Nothing + +-- Check if it is a valid cluster UUID. +isClusterUUID :: UUID -> Bool +isClusterUUID (UUID b) + | B.take 2 b == "ac" = +#if MIN_VERSION_bytestring(0,11,0) + B.indexMaybe b 14 == Just eight +#else + B.length b > 14 && B.head (B.drop 14 b) == eight +#endif + where + eight = fromIntegral (ord '8') +isClusterUUID _ = False + +{-# INLINE isClusterUUID #-} + +-- Generates a ClusterUUID from any regular UUID (eg V4). +-- It is converted to a valid cluster UUID. +genClusterUUID :: UUID -> Maybe ClusterUUID +genClusterUUID (UUID b) + | B.length b > 14 = Just $ ClusterUUID $ UUID $ + "ac" <> B.drop 2 (B.take 14 b) <> "8" <> B.drop 15 b + | otherwise = Nothing +genClusterUUID NoUUID = Nothing + +fromClusterUUID :: ClusterUUID -> UUID +fromClusterUUID (ClusterUUID u) = u + +-- The UUID of a node in a cluster. The UUID can be either the UUID of a +-- repository, or of another cluster. +newtype ClusterNodeUUID = ClusterNodeUUID { fromClusterNodeUUID :: UUID } + deriving (Show, Eq, Ord) + +-- The same information is indexed two ways to allow fast lookups in either +-- direction. +data Clusters = Clusters + { clusterUUIDs :: M.Map ClusterUUID (S.Set ClusterNodeUUID) + , clusterNodeUUIDs :: M.Map ClusterNodeUUID (S.Set ClusterUUID) + } + deriving (Show) + +noClusters :: Clusters +noClusters = Clusters mempty mempty diff --git a/Types/Command.hs b/Types/Command.hs --- a/Types/Command.hs +++ b/Types/Command.hs @@ -142,4 +142,5 @@ | RepoExists | NoDaemonRunning | GitAnnexShellOk + | GitAnnexShellNotProxyable deriving (Show, Ord, Eq) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -22,6 +22,9 @@ RemoteNameable(..), remoteAnnexConfig, remoteConfig, + RemoteGitConfigField(..), + remoteGitConfigKey, + proxyInheritedFields, ) where import Common @@ -30,7 +33,7 @@ import qualified Git.Construct import Git.Types import Git.ConfigTypes -import Git.Remote (isRemoteKey, remoteKeyToRemoteName) +import Git.Remote (isRemoteKey, isLegalName, remoteKeyToRemoteName) import Git.Branch (CommitMode(..)) import Git.Quote (QuotePath(..)) import Utility.DataUnits @@ -44,6 +47,7 @@ import Types.RepoVersion import Types.StallDetection import Types.View +import Types.Cluster import Config.DynamicConfig import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd) @@ -154,6 +158,7 @@ , annexPrivateRepos :: S.Set UUID , annexAdviceNoSshCaching :: Bool , annexViewUnsetDirectory :: ViewUnset + , annexClusters :: M.Map RemoteName ClusterUUID } extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig @@ -282,6 +287,10 @@ , annexAdviceNoSshCaching = getbool (annexConfig "advicenosshcaching") True , annexViewUnsetDirectory = ViewUnset $ fromMaybe "_" $ getmaybe (annexConfig "viewunsetdirectory") + , annexClusters = + M.mapMaybe (mkClusterUUID . toUUID) $ + M.mapKeys removeclusterprefix $ + M.filterWithKey isclusternamekey (config r) } where getbool k d = fromMaybe d $ getmaybebool k @@ -306,6 +315,11 @@ hereuuid = maybe NoUUID toUUID $ getmaybe (annexConfig "uuid") + clusterprefix = annexConfigPrefix <> "cluster." + isclusternamekey k _ = clusterprefix `B.isPrefixOf` (fromConfigKey' k) + && isLegalName (removeclusterprefix k) + removeclusterprefix k = drop (B.length clusterprefix) (fromConfigKey k) + {- Merge a GitConfig that comes from git-config with one containing - repository-global defaults. -} mergeGitConfig :: GitConfig -> GitConfig -> GitConfig @@ -372,9 +386,14 @@ , remoteAnnexBwLimitUpload :: Maybe BwRate , remoteAnnexBwLimitDownload :: Maybe BwRate , remoteAnnexAllowUnverifiedDownloads :: Bool + , remoteAnnexUUID :: Maybe UUID , remoteAnnexConfigUUID :: Maybe UUID , remoteAnnexMaxGitBundles :: Int , remoteAnnexAllowEncryptedGitRepo :: Bool + , remoteAnnexProxy :: Bool + , remoteAnnexProxiedBy :: Maybe UUID + , remoteAnnexClusterNode :: Maybe [RemoteName] + , remoteAnnexClusterGateway :: [ClusterUUID] , remoteUrl :: Maybe String {- These settings are specific to particular types of remotes @@ -409,99 +428,254 @@ extractRemoteGitConfig :: Git.Repo -> RemoteName -> STM RemoteGitConfig extractRemoteGitConfig r remotename = do annexcost <- mkDynamicConfig readCommandRunner - (notempty $ getmaybe "cost-command") - (getmayberead "cost") + (notempty $ getmaybe CostCommandField) + (getmayberead CostField) annexignore <- mkDynamicConfig unsuccessfullCommandRunner - (notempty $ getmaybe "ignore-command") - (getbool "ignore" False) + (notempty $ getmaybe IgnoreCommandField) + (getbool IgnoreField False) annexsync <- mkDynamicConfig successfullCommandRunner - (notempty $ getmaybe "sync-command") - (getbool "sync" True) + (notempty $ getmaybe SyncCommandField) + (getbool SyncField True) return $ RemoteGitConfig { remoteAnnexCost = annexcost , remoteAnnexIgnore = annexignore , remoteAnnexSync = annexsync - , remoteAnnexPull = getbool "pull" True - , remoteAnnexPush = getbool "push" True - , remoteAnnexReadOnly = getbool "readonly" False - , remoteAnnexCheckUUID = getbool "checkuuid" True - , remoteAnnexVerify = getbool "verify" True + , remoteAnnexPull = getbool PullField True + , remoteAnnexPush = getbool PushField True + , remoteAnnexReadOnly = getbool ReadOnlyField False + , remoteAnnexCheckUUID = getbool CheckUUIDField True + , remoteAnnexVerify = getbool VerifyField True , remoteAnnexTrackingBranch = Git.Ref . encodeBS <$> - ( notempty (getmaybe "tracking-branch") - <|> notempty (getmaybe "export-tracking") -- old name + ( notempty (getmaybe TrackingBranchField) + <|> notempty (getmaybe ExportTrackingField) -- old name ) - , remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel" - , remoteAnnexStartCommand = notempty $ getmaybe "start-command" - , remoteAnnexStopCommand = notempty $ getmaybe "stop-command" + , remoteAnnexTrustLevel = notempty $ getmaybe TrustLevelField + , remoteAnnexStartCommand = notempty $ getmaybe StartCommandField + , remoteAnnexStopCommand = notempty $ getmaybe StopCommandField , remoteAnnexSpeculatePresent = - getbool "speculate-present" False - , remoteAnnexBare = getmaybebool "bare" - , remoteAnnexRetry = getmayberead "retry" - , remoteAnnexForwardRetry = getmayberead "forward-retry" + getbool SpeculatePresentField False + , remoteAnnexBare = getmaybebool BareField + , remoteAnnexRetry = getmayberead RetryField + , remoteAnnexForwardRetry = getmayberead ForwardRetryField , remoteAnnexRetryDelay = Seconds - <$> getmayberead "retrydelay" + <$> getmayberead RetryDelayField , remoteAnnexStallDetection = - readStallDetection =<< getmaybe "stalldetection" + readStallDetection =<< getmaybe StallDetectionField , remoteAnnexStallDetectionUpload = - readStallDetection =<< getmaybe "stalldetection-upload" + readStallDetection =<< getmaybe StallDetectionUploadField , remoteAnnexStallDetectionDownload = - readStallDetection =<< getmaybe "stalldetection-download" + readStallDetection =<< getmaybe StallDetectionDownloadField , remoteAnnexBwLimit = - readBwRatePerSecond =<< getmaybe "bwlimit" + readBwRatePerSecond =<< getmaybe BWLimitField , remoteAnnexBwLimitUpload = - readBwRatePerSecond =<< getmaybe "bwlimit-upload" + readBwRatePerSecond =<< getmaybe BWLimitUploadField , remoteAnnexBwLimitDownload = - readBwRatePerSecond =<< getmaybe "bwlimit-download" + readBwRatePerSecond =<< getmaybe BWLimitDownloadField , remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ - getmaybe ("security-allow-unverified-downloads") + getmaybe SecurityAllowUnverifiedDownloadsField + , remoteAnnexUUID = toUUID <$> getmaybe UUIDField + , remoteAnnexConfigUUID = toUUID <$> getmaybe ConfigUUIDField , remoteAnnexMaxGitBundles = - fromMaybe 100 (getmayberead "max-git-bundles") - , remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid" - , remoteAnnexShell = getmaybe "shell" - , remoteAnnexSshOptions = getoptions "ssh-options" - , remoteAnnexRsyncOptions = getoptions "rsync-options" - , remoteAnnexRsyncDownloadOptions = getoptions "rsync-download-options" - , remoteAnnexRsyncUploadOptions = getoptions "rsync-upload-options" - , remoteAnnexRsyncTransport = getoptions "rsync-transport" - , remoteAnnexGnupgOptions = getoptions "gnupg-options" - , remoteAnnexGnupgDecryptOptions = getoptions "gnupg-decrypt-options" - , remoteAnnexSharedSOPCommand = SOPCmd <$> - notempty (getmaybe "shared-sop-command") - , remoteAnnexSharedSOPProfile = SOPProfile <$> - notempty (getmaybe "shared-sop-profile") - , remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl" - , remoteAnnexBupRepo = getmaybe "buprepo" - , remoteAnnexBorgRepo = getmaybe "borgrepo" - , remoteAnnexTahoe = getmaybe "tahoe" - , remoteAnnexBupSplitOptions = getoptions "bup-split-options" - , remoteAnnexDirectory = notempty $ getmaybe "directory" - , remoteAnnexAndroidDirectory = notempty $ getmaybe "androiddirectory" - , remoteAnnexAndroidSerial = notempty $ getmaybe "androidserial" - , remoteAnnexGCrypt = notempty $ getmaybe "gcrypt" - , remoteAnnexGitLFS = getbool "git-lfs" False - , remoteAnnexDdarRepo = getmaybe "ddarrepo" - , remoteAnnexHookType = notempty $ getmaybe "hooktype" - , remoteAnnexExternalType = notempty $ getmaybe "externaltype" + fromMaybe 100 (getmayberead MaxGitBundlesField) , remoteAnnexAllowEncryptedGitRepo = - getbool "allow-encrypted-gitrepo" False + getbool AllowEncryptedGitRepoField False + , remoteAnnexProxy = getbool ProxyField False + , remoteAnnexProxiedBy = toUUID <$> getmaybe ProxiedByField + , remoteAnnexClusterNode = + (filter isLegalName . words) + <$> getmaybe ClusterNodeField + , remoteAnnexClusterGateway = fromMaybe [] $ + (mapMaybe (mkClusterUUID . toUUID) . words) + <$> getmaybe ClusterGatewayField , remoteUrl = - case Git.Config.getMaybe (remoteConfig remotename "url") r of + case Git.Config.getMaybe (remoteConfig remotename (remoteGitConfigKey UrlField)) r of Just (ConfigValue b) | B.null b -> Nothing | otherwise -> Just (decodeBS b) _ -> Nothing + , remoteAnnexShell = getmaybe ShellField + , remoteAnnexSshOptions = getoptions SshOptionsField + , remoteAnnexRsyncOptions = getoptions RsyncOptionsField + , remoteAnnexRsyncDownloadOptions = getoptions RsyncDownloadOptionsField + , remoteAnnexRsyncUploadOptions = getoptions RsyncUploadOptionsField + , remoteAnnexRsyncTransport = getoptions RsyncTransportField + , remoteAnnexGnupgOptions = getoptions GnupgOptionsField + , remoteAnnexGnupgDecryptOptions = getoptions GnupgDecryptOptionsField + , remoteAnnexSharedSOPCommand = SOPCmd <$> + notempty (getmaybe SharedSOPCommandField) + , remoteAnnexSharedSOPProfile = SOPProfile <$> + notempty (getmaybe SharedSOPProfileField) + , remoteAnnexRsyncUrl = notempty $ getmaybe RsyncUrlField + , remoteAnnexBupRepo = getmaybe BupRepoField + , remoteAnnexBorgRepo = getmaybe BorgRepoField + , remoteAnnexTahoe = getmaybe TahoeField + , remoteAnnexBupSplitOptions = getoptions BupSplitOptionsField + , remoteAnnexDirectory = notempty $ getmaybe DirectoryField + , remoteAnnexAndroidDirectory = notempty $ getmaybe AndroidDirectoryField + , remoteAnnexAndroidSerial = notempty $ getmaybe AndroidSerialField + , remoteAnnexGCrypt = notempty $ getmaybe GCryptField + , remoteAnnexGitLFS = getbool GitLFSField False + , remoteAnnexDdarRepo = getmaybe DdarRepoField + , remoteAnnexHookType = notempty $ getmaybe HookTypeField + , remoteAnnexExternalType = notempty $ getmaybe ExternalTypeField } where getbool k d = fromMaybe d $ getmaybebool k getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k getmayberead k = readish =<< getmaybe k getmaybe = fmap fromConfigValue . getmaybe' - getmaybe' k = - Git.Config.getMaybe (remoteAnnexConfig remotename k) r - <|> - Git.Config.getMaybe (annexConfig k) r + getmaybe' :: RemoteGitConfigField -> Maybe ConfigValue + getmaybe' f = + let k = remoteGitConfigKey f + in Git.Config.getMaybe (remoteAnnexConfig remotename k) r + <|> Git.Config.getMaybe (annexConfig k) r getoptions k = fromMaybe [] $ words <$> getmaybe k +data RemoteGitConfigField + = CostField + | CostCommandField + | IgnoreField + | IgnoreCommandField + | SyncField + | SyncCommandField + | PullField + | PushField + | ReadOnlyField + | CheckUUIDField + | VerifyField + | TrackingBranchField + | ExportTrackingField + | TrustLevelField + | StartCommandField + | StopCommandField + | SpeculatePresentField + | BareField + | RetryField + | ForwardRetryField + | RetryDelayField + | StallDetectionField + | StallDetectionUploadField + | StallDetectionDownloadField + | BWLimitField + | BWLimitUploadField + | BWLimitDownloadField + | UUIDField + | ConfigUUIDField + | SecurityAllowUnverifiedDownloadsField + | MaxGitBundlesField + | AllowEncryptedGitRepoField + | ProxyField + | ProxiedByField + | ClusterNodeField + | ClusterGatewayField + | UrlField + | ShellField + | SshOptionsField + | RsyncOptionsField + | RsyncDownloadOptionsField + | RsyncUploadOptionsField + | RsyncTransportField + | GnupgOptionsField + | GnupgDecryptOptionsField + | SharedSOPCommandField + | SharedSOPProfileField + | RsyncUrlField + | BupRepoField + | BorgRepoField + | TahoeField + | BupSplitOptionsField + | DirectoryField + | AndroidDirectoryField + | AndroidSerialField + | GCryptField + | GitLFSField + | DdarRepoField + | HookTypeField + | ExternalTypeField + deriving (Enum, Bounded) + +remoteGitConfigField :: RemoteGitConfigField -> (UnqualifiedConfigKey, ProxyInherited) +remoteGitConfigField = \case + -- Hard to know the true cost of accessing eg a slow special + -- remote via the proxy. The cost of the proxy is the best guess + -- so do inherit it. + CostField -> inherited "cost" + CostCommandField -> inherited "cost-command" + IgnoreField -> inherited "ignore" + IgnoreCommandField -> inherited "ignore-command" + SyncField -> inherited "sync" + SyncCommandField -> inherited "sync-command" + PullField -> inherited "pull" + PushField -> inherited "push" + ReadOnlyField -> inherited "readonly" + CheckUUIDField -> uninherited "checkuuid" + VerifyField -> inherited "verify" + TrackingBranchField -> uninherited "tracking-branch" + ExportTrackingField -> uninherited "export-tracking" + TrustLevelField -> uninherited "trustlevel" + StartCommandField -> uninherited "start-command" + StopCommandField -> uninherited "stop-command" + SpeculatePresentField -> inherited "speculate-present" + BareField -> inherited "bare" + RetryField -> inherited "retry" + ForwardRetryField -> inherited "forward-retry" + RetryDelayField -> inherited "retrydelay" + StallDetectionField -> inherited "stalldetection" + StallDetectionUploadField -> inherited "stalldetection-upload" + StallDetectionDownloadField -> inherited "stalldetection-download" + BWLimitField -> inherited "bwlimit" + BWLimitUploadField -> inherited "bwlimit-upload" + BWLimitDownloadField -> inherited "bwlimit-upload" + UUIDField -> uninherited "uuid" + ConfigUUIDField -> uninherited "config-uuid" + SecurityAllowUnverifiedDownloadsField -> inherited "security-allow-unverified-downloads" + MaxGitBundlesField -> inherited "max-git-bundles" + AllowEncryptedGitRepoField -> inherited "allow-encrypted-gitrepo" + -- Allow proxy chains. + ProxyField -> inherited "proxy" + ProxiedByField -> uninherited "proxied-by" + ClusterNodeField -> uninherited "cluster-node" + ClusterGatewayField -> uninherited "cluster-gateway" + UrlField -> uninherited "url" + ShellField -> inherited "shell" + SshOptionsField -> inherited "ssh-options" + RsyncOptionsField -> inherited "rsync-options" + RsyncDownloadOptionsField -> inherited "rsync-download-options" + RsyncUploadOptionsField -> inherited "rsync-upload-options" + RsyncTransportField -> inherited "rsync-transport" + GnupgOptionsField -> inherited "gnupg-options" + GnupgDecryptOptionsField -> inherited "gnupg-decrypt-options" + SharedSOPCommandField -> inherited "shared-sop-command" + SharedSOPProfileField -> inherited "shared-sop-profile" + RsyncUrlField -> uninherited "rsyncurl" + BupRepoField -> uninherited "buprepo" + BorgRepoField -> uninherited "borgrepo" + TahoeField -> uninherited "tahoe" + BupSplitOptionsField -> uninherited "bup-split-options" + DirectoryField -> uninherited "directory" + AndroidDirectoryField -> uninherited "androiddirectory" + AndroidSerialField -> uninherited "androidserial" + GCryptField -> uninherited "gcrypt" + GitLFSField -> uninherited "git-lfs" + DdarRepoField -> uninherited "ddarrepo" + HookTypeField -> uninherited "hooktype" + ExternalTypeField -> uninherited "externaltype" + where + inherited f = (f, ProxyInherited True) + uninherited f = (f, ProxyInherited False) + +newtype ProxyInherited = ProxyInherited Bool + +-- All remote config fields that are inherited from a proxy. +proxyInheritedFields :: [UnqualifiedConfigKey] +proxyInheritedFields = + map fst $ + filter (\(_, ProxyInherited p) -> p) $ + map remoteGitConfigField [minBound..maxBound] + +remoteGitConfigKey :: RemoteGitConfigField -> UnqualifiedConfigKey +remoteGitConfigKey = fst . remoteGitConfigField + notempty :: Maybe String -> Maybe String notempty Nothing = Nothing notempty (Just "") = Nothing @@ -513,9 +687,12 @@ type UnqualifiedConfigKey = B.ByteString +annexConfigPrefix :: B.ByteString +annexConfigPrefix = "annex." + {- A global annex setting in git config. -} annexConfig :: UnqualifiedConfigKey -> ConfigKey -annexConfig key = ConfigKey ("annex." <> key) +annexConfig key = ConfigKey (annexConfigPrefix <> key) class RemoteNameable r where getRemoteName :: r -> RemoteName diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -91,7 +91,7 @@ -- The key should not appear to be present on the remote until -- all of its contents have been transferred. -- Throws exception on failure. - , storeKey :: Key -> AssociatedFile -> MeterUpdate -> a () + , storeKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> a () -- Retrieves a key's contents to a file. -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.) diff --git a/Types/Transfer.hs b/Types/Transfer.hs --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -89,6 +89,12 @@ observeBool Nothing = False observeFailure = Nothing +instance Observable (Either e (Maybe a)) where + observeBool (Left _) = False + observeBool (Right Nothing) = False + observeBool (Right (Just _)) = True + observeFailure = Right Nothing + class Transferrable t where descTransfrerrable :: t -> Maybe String diff --git a/Utility/LockFile/Windows.hs b/Utility/LockFile/Windows.hs --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -21,6 +21,9 @@ import Utility.Path.Windows import Utility.FileSystemEncoding +#if MIN_VERSION_Win32(2,13,4) +import Common (tryNonAsync) +#endif type LockFile = RawFilePath @@ -59,9 +62,9 @@ openLock sharemode f = do f' <- convertToWindowsNativeNamespace f #if MIN_VERSION_Win32(2,13,4) - r <- tryNonAsync $ createFile_NoRetry f' gENERIC_READ sharemode - security_attributes oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL - (maybePtr Nothing) + r <- tryNonAsync $ createFile_NoRetry (fromRawFilePath f') gENERIC_READ sharemode + Nothing oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL + Nothing return $ case r of Left _ -> Nothing Right h -> Just h diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs --- a/Utility/SimpleProtocol.hs +++ b/Utility/SimpleProtocol.hs @@ -1,6 +1,6 @@ {- Simple line-based protocols. - - - Copyright 2013-2020 Joey Hess + - Copyright 2013-2024 Joey Hess - - License: BSD-2-clause -} @@ -21,6 +21,7 @@ parse3, parse4, parse5, + parseList, dupIoHandles, getProtocolLine, ) where @@ -110,6 +111,10 @@ splitWord :: String -> (String, String) splitWord = separate isSpace + +{- Only safe to use when the serialization does not include whitespace. -} +parseList :: Serializable p => ([p] -> a) -> Parser a +parseList mk v = mk <$> mapM deserialize (words v) {- When a program speaks a simple protocol over stdio, any other output - to stdout (or anything that attempts to read from stdin) 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: 10.20240531 +Version: 10.20240701 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -508,6 +508,7 @@ Annex.ChangedRefs Annex.CheckAttr Annex.CheckIgnore + Annex.Cluster Annex.Common Annex.Concurrent Annex.Concurrent.Utility @@ -549,6 +550,7 @@ Annex.Path Annex.Perms Annex.PidLock + Annex.Proxy Annex.Queue Annex.ReplaceFile Annex.RemoteTrackingBranch @@ -556,6 +558,7 @@ Annex.SpecialRemote.Config Annex.Ssh Annex.StallDetection + Annex.Startup Annex.TaggedPush Annex.Tmp Annex.Transfer @@ -635,6 +638,7 @@ Command.EnableRemote Command.EnableTor Command.ExamineKey + Command.ExtendCluster Command.Expire Command.Export Command.FilterBranch @@ -658,6 +662,7 @@ Command.Indirect Command.Info Command.Init + Command.InitCluster Command.InitRemote Command.Inprogress Command.List @@ -720,6 +725,8 @@ Command.UnregisterUrl Command.Untrust Command.Unused + Command.UpdateCluster + Command.UpdateProxy Command.Upgrade Command.VAdd Command.VCycle @@ -814,6 +821,8 @@ Logs.AdjustedBranchUpdate Logs.Chunk Logs.Chunk.Pure + Logs.Cluster + Logs.Cluster.Basic Logs.Config Logs.ContentIdentifier Logs.ContentIdentifier.Pure @@ -838,6 +847,7 @@ Logs.PreferredContent.Raw Logs.Presence Logs.Presence.Pure + Logs.Proxy Logs.Remote Logs.Remote.Pure Logs.RemoteState @@ -868,6 +878,7 @@ P2P.Auth P2P.IO P2P.Protocol + P2P.Proxy Remote Remote.Adb Remote.BitTorrent @@ -930,6 +941,7 @@ Types.BranchState Types.CatFileHandles Types.CleanupActions + Types.Cluster Types.Command Types.Concurrency Types.Creds