diff --git a/Annex/Action.hs b/Annex/Action.hs index 9eaf169851..69b92f8240 100644 --- 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.CheckIgnore 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 @@ -47,34 +39,6 @@ verifiedAction a = tryNonAsync a >>= \case 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/Init.hs b/Annex/Init.hs index 2af4012d43..0cb2e09019 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -103,8 +103,8 @@ genDescription Nothing = do 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 @@ initialize mdescription mversion = checkInitializeAllowed $ \initallowed -> do 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 @@ initialize mdescription mversion = checkInitializeAllowed $ \initallowed -> do -- 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 @@ initialize' mversion _initallowed = do 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 @@ getInitializedVersion = do - - 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 @@ guardSafeToUseRepo a = ifM (inRepo Git.Config.checkRepoConfigInaccessible) - - 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/Startup.hs b/Annex/Startup.hs new file mode 100644 index 0000000000..ad9bbb48c6 --- /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 = + -- 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/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs index d85eb45775..47bf5488a6 100644 --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -19,6 +19,7 @@ import qualified Annex 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 False _ dir desc mgroup = inDir dir $ do 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/CmdLine.hs b/CmdLine.hs index 004198c40a..c90d92a886 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -23,6 +23,7 @@ import qualified Annex 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/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs index 7666f5da03..612e78691e 100644 --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -30,6 +30,7 @@ import qualified Logs.Remote 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 @@ cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do 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/Command.hs b/Command.hs index 7c4caeffa7..aa2fc5b447 100644 --- a/Command.hs +++ b/Command.hs @@ -23,6 +23,7 @@ import CmdLine.Batch as ReExported 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 @@ -125,7 +126,7 @@ commonChecks :: [CommandCheck] 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 index 92db99664d..444b37ca5c 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -17,6 +17,7 @@ import qualified BuildInfo import Utility.HumanTime import Assistant.Install import Remote.List +import Annex.Startup import Control.Concurrent.Async @@ -63,7 +64,7 @@ start o 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 index bb33f7102b..f027887257 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -16,6 +16,7 @@ import Git.Types 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 @@ findOrGenUUID = do 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/Init.hs b/Command/Init.hs index 2b7bbeb8a1..32b14665b7 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -12,6 +12,7 @@ module Command.Init where import Command import Annex.Init import Annex.Version +import Annex.Startup import Types.RepoVersion import qualified Annex.SpecialRemote @@ -77,7 +78,7 @@ perform os = do 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/Reinit.hs b/Command/Reinit.hs index bdc1a6b1c9..0c8181dd1b 100644 --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -10,6 +10,7 @@ module Command.Reinit where import Command import Annex.Init import Annex.UUID +import Annex.Startup import qualified Remote import qualified Annex.SpecialRemote @@ -36,6 +37,6 @@ perform s = do 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/Upgrade.hs b/Command/Upgrade.hs index 31600fabec..46f308369d 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -11,6 +11,7 @@ import Command import Upgrade import Annex.Version import Annex.Init +import Annex.Startup cmd :: Command cmd = dontCheck @@ -46,6 +47,6 @@ start (UpgradeOptions { autoOnly = True }) = 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/Logs/Cluster.hs b/Logs/Cluster.hs index 47da6544b3..67bb4a69da 100644 --- a/Logs/Cluster.hs +++ b/Logs/Cluster.hs @@ -13,6 +13,7 @@ module Logs.Cluster ( fromClusterUUID, ClusterNodeUUID(..), getClusters, + loadClusters, recordCluster, Clusters(..) ) where @@ -24,6 +25,7 @@ import Types.Cluster import Logs import Logs.UUIDBased import Logs.MapLog +import Logs.Trust import qualified Data.Set as S import qualified Data.Map as M @@ -33,15 +35,17 @@ import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.ByteString.Lazy as L getClusters :: Annex Clusters -getClusters = maybe loadClusters return =<< Annex.getState Annex.clusters +getClusters = maybe loadClusters return =<< Annex.getState Annex.clusters +{- Loads the clusters and caches it for later. -} loadClusters :: Annex Clusters loadClusters = do m <- convclusteruuids . M.map value . fromMapLog . parseClusterLog <$> Annex.Branch.get clusterLog + m' <- removedeadnodes m let clusters = Clusters - { clusterUUIDs = m - , clusterNodeUUIDs = M.foldlWithKey inverter mempty m + { clusterUUIDs = m' + , clusterNodeUUIDs = M.foldlWithKey inverter mempty m' } Annex.changeState $ \s -> s { Annex.clusters = Just clusters } return clusters @@ -53,6 +57,14 @@ loadClusters = do inverter m k v = M.unionWith (<>) m (M.fromList (map (, S.singleton k) (S.toList v))) + -- Dead nodes are removed from clusters to avoid inserting the + -- cluster uuid into the location log when only dead nodes contain + -- the content of a key. + removedeadnodes m = do + dead <- (S.fromList . map ClusterNodeUUID) + <$> trustGet DeadTrusted + return $ M.map (`S.difference` dead) m + recordCluster :: ClusterUUID -> S.Set ClusterNodeUUID -> Annex () recordCluster clusteruuid nodeuuids = do -- If a private UUID has been configured as a cluster node, diff --git a/Logs/Location.hs b/Logs/Location.hs index dc7b78c5cc..3172d38153 100644 --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -41,7 +41,7 @@ import Annex.Common import qualified Annex.Branch import Logs import Logs.Presence -import Logs.Cluster +import Types.Cluster import Annex.UUID import Annex.CatFile import Annex.VectorClock @@ -248,3 +248,8 @@ overLocationLogs' iv discarder keyaction = do 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 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/Remote/Git.hs b/Remote/Git.hs index 3cdf50f0f6..29677cfc7b 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -345,7 +345,7 @@ tryGitConfigRead autoinit r hasuuid 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 @@ -601,7 +601,7 @@ repairRemote r a = return $ do 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)]) @@ -645,7 +645,7 @@ onLocal' (LocalRemoteAnnex repo mv) a = liftIO (takeMVar mv) >>= \case [] -> 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) diff --git a/Types/Cluster.hs b/Types/Cluster.hs index 195ff7aafd..2c37915495 100644 --- a/Types/Cluster.hs +++ b/Types/Cluster.hs @@ -13,9 +13,9 @@ module Types.Cluster ( genClusterUUID, fromClusterUUID, isClusterUUID, - fromClusterUUID, ClusterNodeUUID(..), Clusters(..), + noClusters, ) where import Types.UUID @@ -79,3 +79,6 @@ data Clusters = Clusters , clusterNodeUUIDs :: M.Map ClusterNodeUUID (S.Set ClusterUUID) } deriving (Show) + +noClusters :: Clusters +noClusters = Clusters mempty mempty diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn index 4305cc7395..ff317303f0 100644 --- a/doc/todo/git-annex_proxies.mdwn +++ b/doc/todo/git-annex_proxies.mdwn @@ -45,10 +45,14 @@ For June's work on [[design/passthrough_proxy]], implementation plan: * Implement cluster UUID insertation on location log load, and removal on location log store. (done) +* Omit cluster UUIDs when constructing drop proofs, since lockcontent will + always fail on a cluster. (done) + * Don't count cluster UUID as a copy. (Including in `whereis` display.) -* Omit cluster UUIDs when constructing drop proofs, since lockcontent will - always fail on a cluster. + Work in progress. fromNumCopies is sometimes used to get a + number that is compared with a list of UUIDs. And limitCopies doesn't + use numcopies machinery * Basic proxying to special remote support (non-streaming). diff --git a/git-annex.cabal b/git-annex.cabal index 3b26ce1df9..37e5fddd5f 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -556,6 +556,7 @@ Executable git-annex Annex.SpecialRemote.Config Annex.Ssh Annex.StallDetection + Annex.Startup Annex.TaggedPush Annex.Tmp Annex.Transfer