import Types.CatFileHandles
import Types.RemoteConfig
import Types.TransferrerPool
+import Types.VectorClock
+import Annex.VectorClock.Utility
import qualified Database.Keys.Handle as Keys
import Utility.InodeCache
import Utility.Url
, fast :: Bool
, daemon :: Bool
, branchstate :: BranchState
+ , getvectorclock :: IO VectorClock
, repoqueue :: Maybe (Git.Queue.Queue Annex)
, catfilehandles :: CatFileHandles
, hashobjecthandle :: Maybe HashObjectHandle
sc <- newTMVarIO False
kh <- Keys.newDbHandle
tp <- newTransferrerPool
+ vc <- startVectorClock
return $ AnnexState
{ repo = r
, repoadjustment = return
, fast = False
, daemon = False
, branchstate = startBranchState
+ , getvectorclock = vc
, repoqueue = Nothing
, catfilehandles = catFileHandlesNonConcurrent
, hashobjecthandle = Nothing
import Annex.HashObject
import Annex.Transfer
import Annex.CheckIgnore
+import Annex.VectorClock
import Command
import Backend
import Types.Key
bracket CIDDb.openDb CIDDb.closeDb $ \db -> do
CIDDb.needsUpdateFromLog db
>>= maybe noop (CIDDb.updateFromLog db)
- go False cidmap importing importablecontents db
+ (run (go False cidmap importing importablecontents db))
where
+ -- When not importing content, reuse the same vector
+ -- clock for all state that's recorded. This can save
+ -- a little bit of disk space. Individual file downloads
+ -- while downloading take too long for this optimisation
+ -- to be safe to do.
+ run a
+ | importcontent = a
+ | otherwise = reuseVectorClockWhile a
+
go oldversion cidmap importing (ImportableContents l h) db = do
largematcher <- largeFilesMatcher
jobs <- forM l $ \i ->
- We don't have a way yet to keep true distributed vector clocks.
- The next best thing is a timestamp.
-
- - Copyright 2017-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
-module Annex.VectorClock where
+module Annex.VectorClock (
+ module Annex.VectorClock,
+ module Types.VectorClock,
+) where
-import Data.Time.Clock.POSIX
-import Data.ByteString.Builder
-import Control.Applicative
-import Prelude
-
-import Utility.Env
+import Types.VectorClock
+import Annex.Common
+import qualified Annex
import Utility.TimeStamp
-import Utility.QuickCheck
+
+import Data.ByteString.Builder
import qualified Data.Attoparsec.ByteString.Lazy as A
--- | Some very old logs did not have any time stamp at all;
--- Unknown is used for those.
-data VectorClock = Unknown | VectorClock POSIXTime
- deriving (Eq, Ord, Show)
+currentVectorClock :: Annex VectorClock
+currentVectorClock = liftIO =<< Annex.getState Annex.getvectorclock
--- Unknown is oldest.
-prop_VectorClock_sane :: Bool
-prop_VectorClock_sane = Unknown < VectorClock 1
+-- Runs the action and uses the same vector clock throughout.
+--
+-- When the action modifies several files in the git-annex branch,
+-- this can cause less space to be used, since the same vector clock
+-- value is used, which can compress better.
+--
+-- However, this should not be used when running a long-duration action,
+-- because the vector clock is based on the start of the action, and not on
+-- the later points where it writes changes. For example, if this were
+-- used across downloads of several files, the location log information
+-- would have an earlier vector clock than necessary, which might cause it
+-- to be disregarded in favor of other information that was collected
+-- at an earlier point in time than when the transfers completted and the
+-- log was written.
+reuseVectorClockWhile :: Annex a -> Annex a
+reuseVectorClockWhile = bracket setup cleanup . const
+ where
+ setup = do
+ origget <- Annex.getState Annex.getvectorclock
+ vc <- liftIO origget
+ use (pure vc)
+ return origget
-instance Arbitrary VectorClock where
- arbitrary = VectorClock <$> arbitrary
+ cleanup origget = use origget
-currentVectorClock :: IO VectorClock
-currentVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK"
- where
- go Nothing = VectorClock <$> getPOSIXTime
- go (Just s) = case parsePOSIXTime s of
- Just t -> return (VectorClock t)
- Nothing -> VectorClock <$> getPOSIXTime
+ use vc = Annex.changeState $ \s ->
+ s { Annex.getvectorclock = vc }
formatVectorClock :: VectorClock -> String
formatVectorClock Unknown = "0"
--- /dev/null
+{- git-annex vector clock utilities
+ -
+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Annex.VectorClock.Utility where
+
+import Data.Time.Clock.POSIX
+
+import Types.VectorClock
+import Utility.Env
+import Utility.TimeStamp
+
+startVectorClock :: IO (IO VectorClock)
+startVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK"
+ where
+ go Nothing = timebased
+ go (Just s) = case parsePOSIXTime s of
+ Just t -> return (pure (VectorClock t))
+ Nothing -> timebased
+ timebased = return (VectorClock <$> getPOSIXTime)
start :: ForgetOptions -> CommandStart
start o = starting "forget" ai si $ do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
let basets = addTransition c ForgetGitHistory noTransitions
let ts = if dropDead o
then addTransition c ForgetDeadRemotes basets
seek :: MetaDataOptions -> CommandSeek
seek o = case batchOption o of
NoBatch -> do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
let ww = WarnUnmatchLsFiles
let seeker = AnnexedFileSeeker
{ startAction = start c o
, keyOptions = Nothing
, batchOption = NoBatch
}
- t <- liftIO currentVectorClock
+ t <- currentVectorClock
-- It would be bad if two batch mode changes used exactly
-- the same timestamp, since the order of adds and removals
-- of the same metadata value would then be indeterminate.
recordActivity :: Activity -> UUID -> Annex ()
recordActivity act uuid = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change activityLog $
buildLogOld buildActivity
. changeLog c uuid (Right act)
chunksStored :: UUID -> Key -> ChunkMethod -> ChunkCount -> Annex ()
chunksStored u k chunkmethod chunkcount = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
config <- Annex.getGitConfig
Annex.Branch.change (chunkLogFile config k) $
buildLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog
setGlobalConfig' :: ConfigKey -> ConfigValue -> Annex ()
setGlobalConfig' name new = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change configLog $
buildGlobalConfig . changeMapLog c name new . parseGlobalConfig
-- so ones that were recorded before are preserved.
recordContentIdentifier :: RemoteStateHandle -> ContentIdentifier -> Key -> Annex ()
recordContentIdentifier (RemoteStateHandle u) cid k = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
config <- Annex.getGitConfig
Annex.Branch.maybeChange (remoteContentIdentifierLogFile config k) $
addcid c . parseLog
recordDifferences :: Differences -> UUID -> Annex ()
recordDifferences ds@(Differences {}) uuid = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change differenceLog $
buildLogOld byteString
. changeLog c uuid (encodeBS $ showDifferences ds)
-- This is called before any changes are made to the remote.
recordExportBeginning :: UUID -> Git.Ref -> Annex ()
recordExportBeginning remoteuuid newtree = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
u <- getUUID
let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }
old <- fromMaybe (Exported emptyTree [])
-- forward in lock-step.
recordExportUnderway :: UUID -> ExportChange -> Annex ()
recordExportUnderway remoteuuid ec = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
u <- getUUID
let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }
let exported = Exported (newTreeish ec) []
groupChange :: UUID -> (S.Set Group -> S.Set Group) -> Annex ()
groupChange uuid@(UUID _) modifier = do
curr <- lookupGroups uuid
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change groupLog $
buildLogOld buildGroup . changeLog c uuid (modifier curr) . parseLogOld parseGroup
addMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex ()
addMetaData' getlogfile k metadata =
- addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock
+ addMetaDataClocked' getlogfile k metadata =<< currentVectorClock
{- Reusing the same VectorClock when making changes to the metadata
- of multiple keys is a nice optimisation. The same metadata lines
recordFingerprint :: Fingerprint -> UUID -> Annex ()
recordFingerprint fp uuid = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change multicastLog $
buildLogOld buildFindgerPrint
. changeLog c uuid fp
setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex ()
setLog logfile uuid@(UUID _) val = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change logfile $
buildLogOld buildPreferredContentExpression
. changeLog c uuid val
{- Changes the preferred content configuration of a group. -}
groupPreferredContentSet :: Group -> PreferredContentExpression -> Annex ()
groupPreferredContentSet g val = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change groupPreferredContentLog $
buildGroupPreferredContent
. changeMapLog c g val
{- Generates a new LogLine with the current time. -}
logNow :: LogStatus -> LogInfo -> Annex LogLine
logNow s i = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
return $ LogLine c s i
{- Reads a log and returns only the info that is still in effect. -}
{- Adds or updates a remote's config in the log. -}
configSet :: UUID -> RemoteConfig -> Annex ()
configSet u cfg = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change remoteLog $
buildRemoteConfigLog
. changeLog c u (removeSameasInherited cfg)
setRemoteState :: RemoteStateHandle -> Key -> RemoteState -> Annex ()
setRemoteState (RemoteStateHandle u) k s = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
config <- Annex.getGitConfig
Annex.Branch.change (remoteStateLogFile config k) $
buildRemoteState . changeLog c u s . parseRemoteState
scheduleSet :: UUID -> [ScheduledActivity] -> Annex ()
scheduleSet uuid@(UUID _) activities = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change scheduleLog $
buildLogOld byteString
. changeLog c uuid (encodeBS val)
setLog :: (SingleValueSerializable v) => RawFilePath -> v -> Annex ()
setLog f v = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
let ent = LogEntry c v
Annex.Branch.change f $ \_old -> buildLog (S.singleton ent)
{- Changes the trust level for a uuid in the trustLog. -}
trustSet :: UUID -> TrustLevel -> Annex ()
trustSet uuid@(UUID _) level = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change trustLog $
buildLogOld buildTrustLevel .
changeLog c uuid level .
{- Records a description for a uuid in the log. -}
describeUUID :: UUID -> UUIDDesc -> Annex ()
describeUUID uuid desc = do
- c <- liftIO currentVectorClock
+ c <- currentVectorClock
Annex.Branch.change uuidLog $
buildLogOld buildUUIDDesc . changeLog c uuid desc . parseUUIDLog
--- /dev/null
+{- git-annex vector clocks
+ -
+ - We don't have a way yet to keep true distributed vector clocks.
+ - The next best thing is a timestamp.
+ -
+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Types.VectorClock where
+
+import Data.Time.Clock.POSIX
+import Control.Applicative
+import Prelude
+
+import Utility.QuickCheck
+
+-- | Some very old logs did not have any time stamp at all;
+-- Unknown is used for those.
+data VectorClock = Unknown | VectorClock POSIXTime
+ deriving (Eq, Ord, Show)
+
+-- Unknown is oldest.
+prop_VectorClock_sane :: Bool
+prop_VectorClock_sane = Unknown < VectorClock 1
+
+instance Arbitrary VectorClock where
+ arbitrary = VectorClock <$> arbitrary
(""), implementing this would make the content of the logs all identical,
and so avoid any overhead entirely. Well.. perhaps that's my actual
motivation. ;-) --[[Joey]]
+
+> [[done]], though reuseVectorClockWhile could be used in other places
+> perhaps. --[[Joey]]
Annex.UUID
Annex.Url
Annex.VectorClock
+ Annex.VectorClock.Utility
Annex.VariantFile
Annex.Version
Annex.View
Types.TrustLevel
Types.UUID
Types.UrlContents
+ Types.VectorClock
Types.View
Types.WorkerPool
Upgrade
projects / git-annex.git / commitdiff