git-annex 10.20260601 → 10.20260624
raw patch · 83 files changed
+1629/−867 lines, 83 filesdep +blake3dep +botan-lowdep +hashabledep −byteabledep −old-localedep −securememdep ~http-types
Dependencies added: blake3, botan-low, hashable, xxhash-ffi
Dependencies removed: byteable, old-locale, securemem
Dependency ranges changed: http-types
Files
- Annex/Balanced.hs +1/−1
- Annex/CopyFile.hs +1/−1
- Annex/DirHashes.hs +2/−6
- Annex/Ssh.hs +2/−1
- Annex/Url.hs +1/−1
- Annex/VariantFile.hs +2/−2
- Annex/Verify.hs +3/−4
- Assistant/Pairing.hs +0/−97
- Assistant/Threads/Merger.hs +1/−1
- Assistant/Types/DaemonStatus.hs +0/−4
- Assistant/WebApp/Types.hs +0/−9
- Backend/External.hs +2/−0
- Backend/GitRemoteAnnex.hs +12/−8
- Backend/Hash.hs +131/−58
- Backend/URL.hs +1/−0
- Backend/Utilities.hs +1/−1
- Backend/VURL.hs +5/−2
- Backend/WORM.hs +1/−0
- BuildFlags.hs +15/−0
- CHANGELOG +28/−0
- COPYRIGHT +5/−0
- CmdLine/Batch.hs +18/−11
- CmdLine/GitAnnex.hs +2/−0
- CmdLine/Seek.hs +11/−5
- Command/Copy.hs +46/−11
- Command/Drop.hs +1/−1
- Command/FilterBranch.hs +1/−1
- Command/Find.hs +1/−1
- Command/FindComputed.hs +2/−1
- Command/FindKeys.hs +2/−1
- Command/Fix.hs +1/−1
- Command/Fsck.hs +1/−1
- Command/Get.hs +3/−3
- Command/ImportFeed.hs +3/−1
- Command/Inprogress.hs +2/−1
- Command/List.hs +1/−1
- Command/Lock.hs +1/−1
- Command/Log.hs +1/−1
- Command/Merge.hs +3/−3
- Command/MetaData.hs +1/−1
- Command/Migrate.hs +1/−1
- Command/Mirror.hs +2/−2
- Command/Move.hs +105/−98
- Command/Multicast.hs +1/−1
- Command/PostReceive.hs +2/−2
- Command/Put.hs +83/−0
- Command/Recompute.hs +1/−1
- Command/Sync.hs +115/−93
- Command/Unannex.hs +1/−1
- Command/Unlock.hs +1/−1
- Command/WhereUsed.hs +1/−1
- Command/Whereis.hs +1/−1
- Git/Ref.hs +15/−2
- P2P/Protocol.hs +1/−1
- Remote.hs +33/−1
- Remote/Bup.hs +1/−1
- Remote/External.hs +1/−1
- Remote/GitLFS.hs +2/−1
- Remote/Glacier.hs +1/−1
- Remote/Helper/Http.hs +1/−1
- RemoteDaemon/Transport/P2PGeneric.hs +1/−1
- Test.hs +2/−3
- Types/ActionItem.hs +8/−1
- Types/Backend.hs +7/−1
- Types/Crypto.hs +1/−1
- Types/Key.hs +33/−0
- Types/Remote.hs +1/−1
- Types/StoreRetrieve.hs +1/−1
- Utility/AuthToken.hs +8/−8
- Utility/HMAC.hs +56/−0
- Utility/Hash.hs +69/−333
- Utility/Hash/Blake3.hs +103/−0
- Utility/Hash/Botan.hs +190/−0
- Utility/Hash/Crypton.hs +249/−0
- Utility/Hash/Incremental.hs +47/−0
- Utility/Hash/Types.hs +45/−0
- Utility/Hash/XXH3.hs +43/−0
- Utility/LockFile/PidLock.hs +1/−1
- Utility/Url.hs +2/−10
- Utility/Verifiable.hs +0/−46
- git-annex.cabal +43/−7
- stack-botan.yaml +28/−0
- stack.yaml +7/−0
Annex/Balanced.hs view
@@ -9,7 +9,7 @@ import Key import Types.UUID-import Utility.Hash+import Utility.HMAC import Data.Maybe import qualified Data.List as L
Annex/CopyFile.hs view
@@ -15,7 +15,7 @@ import Utility.CopyFile import Utility.FileMode import Utility.Touch-import Utility.Hash (IncrementalVerifier(..))+import Utility.Hash.Incremental import qualified Utility.FileIO as F import qualified Utility.RawFilePath as R
Annex/DirHashes.hs view
@@ -21,7 +21,6 @@ import Data.Bits import qualified Data.List.NonEmpty as NE import qualified Data.ByteArray as BA-import qualified Data.ByteArray.Encoding as BA import qualified Data.ByteString as S import Common@@ -71,11 +70,8 @@ (h, t) = S.splitAt sz s hashDirLower :: HashLevels -> Hasher-hashDirLower n k = hashDirs n 3 $ S.pack $ take 6 $ conv $+hashDirLower n k = hashDirs n 3 $ S.take 6 $ hashByteString $ digestToHash $ md5s $ serializeKey' $ nonChunkKey k- where- conv v = BA.unpack $- (BA.convertToBase BA.Base16 v :: BA.Bytes) {- This was originally using Data.Hash.MD5 from MissingH. This new version - is faster, but ugly as it has to replicate the 4 Word32's that produced. -}@@ -83,7 +79,7 @@ hashDirMixed n k = hashDirs n 2 $ S.pack $ take 4 $ concatMap display_32bits_as_dir $ encodeWord32 $ map fromIntegral $ BA.unpack $- Utility.Hash.md5s $ serializeKey' $ nonChunkKey k+ md5s $ serializeKey' $ nonChunkKey k where encodeWord32 (b1:b2:b3:b4:rest) = (shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1)
Annex/Ssh.hs view
@@ -351,7 +351,8 @@ fromSshHost host ++ "!" ++ show port hostport2socket' :: String -> OsPath hostport2socket' s- | length s' > lengthofmd5s = toOsPath $ show $ md5 $ encodeBL s'+ | length s' > lengthofmd5s =+ toOsPath $ hashByteString $ digestToHash $ md5 $ encodeBL s' | otherwise = toOsPath s' where lengthofmd5s = 32
Annex/Url.hs view
@@ -37,7 +37,7 @@ import qualified Utility.Url as U import qualified Utility.Url.Parse as U import Annex.Hook-import Utility.Hash (IncrementalVerifier)+import Utility.Hash.Incremental import Utility.IPAddress import Utility.Metered import Utility.Env
Annex/VariantFile.hs view
@@ -44,5 +44,5 @@ where doubleconflict = variantMarker `OS.isInfixOf` file -shortHash :: S.ByteString -> String-shortHash = take 4 . show . md5s+shortHash :: S.ByteString -> S.ByteString+shortHash = S.take 4 . hashByteString . digestToHash . md5s
Annex/Verify.hs view
@@ -34,7 +34,7 @@ import qualified Types.Backend import qualified Backend import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..))-import Utility.Hash (IncrementalVerifier(..))+import Utility.Hash.Incremental import Utility.Metered import Annex.WorkerPool import Types.WorkerPool@@ -102,9 +102,6 @@ resumeVerifyKeyContent k f iv _ -> verifyKeyContent k f --- When possible, does an incremental verification, because that can be--- faster. Eg, the VURL backend can need to try multiple checksums and only--- with an incremental verification does it avoid reading files twice. verifyKeyContent :: Key -> OsPath -> Annex Bool verifyKeyContent k f = verifyKeySize k f <&&> verifyKeyContent' k f @@ -115,6 +112,8 @@ Nothing -> return True Just b -> case (Types.Backend.verifyKeyContentIncrementally b, Types.Backend.verifyKeyContent b) of (Nothing, Nothing) -> return True+ (_, Just verifier) | Types.Backend.verifyKeyContentIsFaster b -> + verifier k f (Just mkiv, mverifier) -> do iv <- mkiv k showAction (UnquotedString (descIncrementalVerifier iv))
− Assistant/Pairing.hs
@@ -1,97 +0,0 @@-{- git-annex assistant repo pairing, core data types- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Assistant.Pairing where--import Annex.Common-import Utility.Verifiable-import Assistant.Ssh--import Control.Concurrent-import Network.Socket-import Data.Char-import qualified Data.Text as T--data PairStage- {- "I'll pair with anybody who shares the secret that can be used- - to verify this request." -}- = PairReq- {- "I've verified your request, and you can verify this to see- - that I know the secret. I set up your ssh key already.- - Here's mine for you to set up." -}- | PairAck- {- "I saw your PairAck; you can stop sending them." -}- | PairDone- deriving (Eq, Read, Show, Ord, Enum)--newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))- deriving (Eq, Read, Show)--verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool-verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip--fromPairMsg :: PairMsg -> Verifiable (PairStage, PairData, SomeAddr)-fromPairMsg (PairMsg m) = m--pairMsgStage :: PairMsg -> PairStage-pairMsgStage (PairMsg (Verifiable (s, _, _) _)) = s--pairMsgData :: PairMsg -> PairData-pairMsgData (PairMsg (Verifiable (_, d, _) _)) = d--pairMsgAddr :: PairMsg -> SomeAddr-pairMsgAddr (PairMsg (Verifiable (_, _, a) _)) = a--data PairData = PairData- -- uname -n output, not a full domain name- { remoteHostName :: Maybe HostName- , remoteUserName :: UserName- , remoteDirectory :: FilePath- , remoteSshPubKey :: SshPubKey- , pairUUID :: UUID- }- deriving (Eq, Read, Show)--checkSane :: PairData -> Bool-checkSane p = all (not . any isControl)- [ fromMaybe "" (remoteHostName p)- , remoteUserName p- , remoteDirectory p- , remoteSshPubKey p- , fromUUID (pairUUID p)- ]--type UserName = String--{- A pairing that is in progress has a secret, a thread that is- - broadcasting pairing messages, and a SshKeyPair that has not yet been- - set up on disk. -}-data PairingInProgress = PairingInProgress- { inProgressSecret :: Secret- , inProgressThreadId :: Maybe ThreadId- , inProgressSshKeyPair :: SshKeyPair- , inProgressPairData :: PairData- , inProgressPairStage :: PairStage- }- deriving (Show)--data AddrClass = IPv4AddrClass | IPv6AddrClass--data SomeAddr = IPv4Addr HostAddress- | IPv6Addr HostAddress6- deriving (Ord, Eq, Read, Show)--{- This contains the whole secret, just lightly obfuscated to make it not- - too obvious. It's only displayed in the user's web browser. -}-newtype SecretReminder = SecretReminder [Int]- deriving (Show, Eq, Ord, Read)--toSecretReminder :: T.Text -> SecretReminder-toSecretReminder = SecretReminder . map ord . T.unpack--fromSecretReminder :: SecretReminder -> T.Text-fromSecretReminder (SecretReminder s) = T.pack $ map chr s
Assistant/Threads/Merger.hs view
@@ -98,7 +98,7 @@ mc def cmode- [changedbranch]+ [(changedbranch, noop)] recordCommit | changedbranch == b = -- Record commit so the pusher pushes it out.
Assistant/Types/DaemonStatus.hs view
@@ -8,7 +8,6 @@ module Assistant.Types.DaemonStatus where import Annex.Common-import Assistant.Pairing import Utility.NotificationBroadcaster import Types.Transfer import Assistant.Types.ThreadName@@ -57,8 +56,6 @@ , syncingToCloudRemote :: Bool -- Set of uuids of remotes that are currently connected. , currentlyConnectedRemotes :: S.Set UUID- -- Pairing request that is in progress.- , pairingInProgress :: Maybe PairingInProgress -- Broadcasts notifications about all changes to the DaemonStatus. , changeNotifier :: NotificationBroadcaster -- Broadcasts notifications when queued or current transfers change.@@ -105,7 +102,6 @@ <*> pure [] <*> pure False <*> pure S.empty- <*> pure Nothing <*> newNotificationBroadcaster <*> newNotificationBroadcaster <*> newNotificationBroadcaster
Assistant/WebApp/Types.hs view
@@ -18,7 +18,6 @@ import Assistant.Common import Assistant.Ssh-import Assistant.Pairing import Utility.NotificationBroadcaster import Utility.AuthToken import Utility.WebApp@@ -153,14 +152,6 @@ fromPathPiece = readish . unpack instance PathPiece Transfer where- toPathPiece = pack . show- fromPathPiece = readish . unpack--instance PathPiece PairMsg where- toPathPiece = pack . show- fromPathPiece = readish . unpack--instance PathPiece SecretReminder where toPathPiece = pack . show fromPathPiece = readish . unpack
Backend/External.hs view
@@ -69,6 +69,7 @@ nullMeterUpdate else Nothing , verifyKeyContentIncrementally = Nothing+ , verifyKeyContentIsFaster = True , canUpgradeKey = Nothing , fastMigrate = Nothing , isStableKey = const isstable@@ -84,6 +85,7 @@ , genKey = Nothing , verifyKeyContent = Nothing , verifyKeyContentIncrementally = Nothing+ , verifyKeyContentIsFaster = True , canUpgradeKey = Nothing , fastMigrate = Nothing , isStableKey = const False
Backend/GitRemoteAnnex.hs view
@@ -39,6 +39,7 @@ -- git-remote-annex. , verifyKeyContent = Just $ Hash.checkKeyChecksum sameCheckSum hash , verifyKeyContentIncrementally = Just (liftIO . incrementalVerifier)+ , verifyKeyContentIsFaster = True , canUpgradeKey = Nothing , fastMigrate = Nothing , isStableKey = const True@@ -53,6 +54,7 @@ , genKey = Nothing , verifyKeyContent = Nothing , verifyKeyContentIncrementally = Nothing+ , verifyKeyContentIsFaster = True , canUpgradeKey = Nothing , fastMigrate = Nothing , isStableKey = const True@@ -61,26 +63,28 @@ } -- git bundle keys use the sha256 hash.-hash :: Hash.Hash+hash :: Hash.HashType hash = Hash.SHA2Hash (HashSize 256) incrementalVerifier :: Key -> IO IncrementalVerifier incrementalVerifier = - mkIncrementalVerifier sha2_256_context "checksum" . sameCheckSum+ mkIncrementalVerifier sha2_256_hasher "checksum" . sameCheckSum -sameCheckSum :: Key -> String -> Bool-sameCheckSum key s = s == expected+sameCheckSum :: Key -> Hash -> Bool+sameCheckSum key h = h == expected where -- The checksum comes after a UUID.- expected = reverse $ takeWhile (/= '-') $ reverse $- decodeBS $ S.fromShort $ fromKey keyName key+ expected = Hash $ encodeBS $ + reverse $ takeWhile (/= '-') $ reverse $+ decodeBS $ S.fromShort $ fromKey keyName key genGitBundleKey :: UUID -> OsPath -> MeterUpdate -> Annex Key genGitBundleKey remoteuuid file meterupdate = do filesize <- liftIO $ getFileSize file- s <- Hash.hashFile hash file meterupdate+ h <- Hash.hashFile hash file meterupdate return $ mkKey $ \k -> k- { keyName = S.toShort $ fromUUID remoteuuid <> "-" <> encodeBS s+ { keyName = S.toShort $+ fromUUID remoteuuid <> "-" <> hashByteString h , keyVariety = GitBundleKey , keySize = Just filesize }
Backend/Hash.hs view
@@ -1,17 +1,18 @@ {- git-annex hashing backends -- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Backend.Hash ( backends, keyHash, descChecksum,- Hash(..),+ HashType(..), cryptographicallySecure, hashFile, checkKeyChecksum,@@ -32,10 +33,11 @@ import qualified Data.ByteString.Short as S (toShort, fromShort) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L+import Data.Char import Control.DeepSeq import Control.Exception (evaluate) -data Hash+data HashType = MD5Hash | SHA1Hash | SHA2Hash HashSize@@ -45,8 +47,14 @@ | Blake2bpHash HashSize | Blake2sHash HashSize | Blake2spHash HashSize+#ifdef WITH_BLAKE3+ | Blake3Hash+#endif+#ifdef WITH_XXH3+ | XXH3Hash+#endif -cryptographicallySecure :: Hash -> Bool+cryptographicallySecure :: HashType -> Bool cryptographicallySecure (SHA2Hash _) = True cryptographicallySecure (SHA3Hash _) = True cryptographicallySecure (SkeinHash _) = True@@ -54,6 +62,12 @@ cryptographicallySecure (Blake2bpHash _) = True cryptographicallySecure (Blake2sHash _) = True cryptographicallySecure (Blake2spHash _) = True+#ifdef WITH_BLAKE3+cryptographicallySecure Blake3Hash = True+#endif+#ifdef WITH_XXH3+cryptographicallySecure XXH3Hash = False+#endif cryptographicallySecure SHA1Hash = False cryptographicallySecure MD5Hash = False @@ -61,7 +75,7 @@ - uses, and must be cryptographically secure. - - Also, want more common sizes earlier than uncommon sizes. -}-hashes :: [Hash]+hashes :: [HashType] hashes = concat [ map (SHA2Hash . HashSize) [256, 512, 224, 384] , map (SHA3Hash . HashSize) [256, 512, 224, 384]@@ -70,6 +84,14 @@ , map (Blake2bpHash . HashSize) [512] , map (Blake2sHash . HashSize) [256, 160, 224] , map (Blake2spHash . HashSize) [256, 224]+#ifdef WITH_BLAKE3+ , [Blake3Hash]+#endif+#ifdef WITH_XXH3+ , if xxh3Supported+ then [XXH3Hash]+ else []+#endif , [SHA1Hash] , [MD5Hash] ]@@ -78,12 +100,13 @@ backends :: [Backend] backends = concatMap (\h -> [genBackendE h, genBackend h]) hashes -genBackend :: Hash -> Backend+genBackend :: HashType -> Backend genBackend hash = Backend { backendVariety = hashKeyVariety hash (HasExt False) , genKey = Just (keyValue hash) , verifyKeyContent = Just $ checkKeyChecksum sameCheckSum hash- , verifyKeyContentIncrementally = Just $ checkKeyChecksumIncremental hash+ , verifyKeyContentIncrementally = checkKeyChecksumIncremental hash+ , verifyKeyContentIsFaster = True , canUpgradeKey = Just needsUpgrade , fastMigrate = Just trivialMigrate , isStableKey = const True@@ -92,13 +115,13 @@ cryptographicallySecure hash } -genBackendE :: Hash -> Backend+genBackendE :: HashType -> Backend genBackendE hash = (genBackend hash) { backendVariety = hashKeyVariety hash (HasExt True) , genKey = Just (keyValueE hash) } -hashKeyVariety :: Hash -> HasExt -> KeyVariety+hashKeyVariety :: HashType -> HasExt -> KeyVariety hashKeyVariety MD5Hash he = MD5Key he hashKeyVariety SHA1Hash he = SHA1Key he hashKeyVariety (SHA2Hash size) he = SHA2Key size he@@ -108,26 +131,32 @@ hashKeyVariety (Blake2bpHash size) he = Blake2bpKey size he hashKeyVariety (Blake2sHash size) he = Blake2sKey size he hashKeyVariety (Blake2spHash size) he = Blake2spKey size he+#ifdef WITH_BLAKE3+hashKeyVariety Blake3Hash he = Blake3Key he+#endif+#ifdef WITH_XXH3+hashKeyVariety XXH3Hash he = XXH3Key he+#endif {- A key is a hash of its contents. -}-keyValue :: Hash -> KeySource -> MeterUpdate -> Annex Key-keyValue hash source meterupdate = do+keyValue :: HashType -> KeySource -> MeterUpdate -> Annex Key+keyValue hashtype source meterupdate = do let file = contentLocation source filesize <- liftIO $ getFileSize file- s <- hashFile hash file meterupdate+ hash <- hashFile hashtype file meterupdate return $ mkKey $ \k -> k- { keyName = S.toShort (encodeBS s)- , keyVariety = hashKeyVariety hash (HasExt False)+ { keyName = S.toShort (hashByteString hash)+ , keyVariety = hashKeyVariety hashtype (HasExt False) , keySize = Just filesize } {- Extension preserving keys. -}-keyValueE :: Hash -> KeySource -> MeterUpdate -> Annex Key+keyValueE :: HashType -> KeySource -> MeterUpdate -> Annex Key keyValueE hash source meterupdate = keyValue hash source meterupdate >>= addE source (const $ hashKeyVariety hash (HasExt True)) -checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> OsPath -> Annex Bool+checkKeyChecksum :: (Key -> Hash -> Bool) -> HashType -> Key -> OsPath -> Annex Bool checkKeyChecksum issame hash key file = catchIOErrorType HardwareFault hwfault $ do showAction (UnquotedString descChecksum) issame key @@ -137,19 +166,23 @@ warning $ UnquotedString $ "hardware fault: " ++ show e return False -sameCheckSum :: Key -> String -> Bool-sameCheckSum key s- | s == expected = True+sameCheckSum :: Key -> Hash -> Bool+sameCheckSum key hash+ | hash == Hash expected = True {- A bug caused checksums to be prefixed with \ in some - cases; still accept these as legal now that the bug - has been fixed. -}- | '\\' : s == expected = True- | otherwise = False+ | otherwise = case S.uncons expected of+ Just (h, t) | h == backslash -> hash == Hash t+ _ -> False where- expected = decodeBS (keyHash key)+ expected = keyHash key+ backslash = fromIntegral (ord '\\') -checkKeyChecksumIncremental :: Hash -> Key -> Annex IncrementalVerifier-checkKeyChecksumIncremental hash key = liftIO $ (snd $ hasher hash) key+checkKeyChecksumIncremental :: HashType -> Maybe (Key -> Annex IncrementalVerifier)+checkKeyChecksumIncremental hash = case hashIncremental (hasher hash) of+ Just iv -> Just (liftIO . iv)+ Nothing -> Nothing keyHash :: Key -> S.ByteString keyHash = fst . splitKeyNameExtension@@ -205,18 +238,28 @@ oldvariety = fromKey keyVariety oldkey newvariety = backendVariety newbackend -hashFile :: Hash -> OsPath -> MeterUpdate -> Annex String-hashFile hash file meterupdate = - liftIO $ withMeteredFile file meterupdate $ \b -> do- let h = (fst $ hasher hash) b+hashFile :: HashType -> OsPath -> MeterUpdate -> Annex Hash+hashFile hashtype file meterupdate = case hashFileFast o of+ Nothing -> liftIO hashpure+ Just a -> liftIO $ a file >>= \case+ Just h -> return h+ Nothing -> hashpure+ where+ o = hasher hashtype+ hashpure = withMeteredFile file meterupdate $ \b -> do+ let h = (hashPure o) b -- Force full evaluation of hash so whole file is read -- before returning. evaluate (rnf h) return h -type Hasher = (L.ByteString -> String, Key -> IO IncrementalVerifier)+data Hasher = Hasher+ { hashPure :: L.ByteString -> Hash+ , hashFileFast :: Maybe (OsPath -> IO (Maybe Hash))+ , hashIncremental :: Maybe (Key -> IO IncrementalVerifier)+ } -hasher :: Hash -> Hasher+hasher :: HashType -> Hasher hasher MD5Hash = md5Hasher hasher SHA1Hash = sha1Hasher hasher (SHA2Hash hashsize) = sha2Hasher hashsize@@ -226,64 +269,94 @@ hasher (Blake2bpHash hashsize) = blake2bpHasher hashsize hasher (Blake2sHash hashsize) = blake2sHasher hashsize hasher (Blake2spHash hashsize) = blake2spHasher hashsize+#ifdef WITH_BLAKE3+hasher Blake3Hash = blake3Hasher+#endif+#ifdef WITH_XXH3+hasher XXH3Hash = xxh3Hasher+#endif -mkHasher :: HashAlgorithm h => (L.ByteString -> Digest h) -> Context h -> Hasher-mkHasher h c = (show . h, mkIncrementalVerifier c descChecksum . sameCheckSum)+mkHasher :: (L.ByteString -> HashDigest) -> IO IncrementalHasher -> Hasher+mkHasher h i = Hasher+ { hashPure = digestToHash . h+ , hashFileFast = Nothing+ , hashIncremental = Just $+ mkIncrementalVerifier i descChecksum . sameCheckSum+ } sha2Hasher :: HashSize -> Hasher sha2Hasher (HashSize hashsize)- | hashsize == 256 = mkHasher sha2_256 sha2_256_context- | hashsize == 224 = mkHasher sha2_224 sha2_224_context- | hashsize == 384 = mkHasher sha2_384 sha2_384_context- | hashsize == 512 = mkHasher sha2_512 sha2_512_context+ | hashsize == 256 = mkHasher sha2_256 sha2_256_hasher+ | hashsize == 224 = mkHasher sha2_224 sha2_224_hasher+ | hashsize == 384 = mkHasher sha2_384 sha2_384_hasher+ | hashsize == 512 = mkHasher sha2_512 sha2_512_hasher | otherwise = giveup $ "unsupported SHA2 size " ++ show hashsize sha3Hasher :: HashSize -> Hasher sha3Hasher (HashSize hashsize)- | hashsize == 256 = mkHasher sha3_256 sha3_256_context- | hashsize == 224 = mkHasher sha3_224 sha3_224_context- | hashsize == 384 = mkHasher sha3_384 sha3_384_context- | hashsize == 512 = mkHasher sha3_512 sha3_512_context+ | hashsize == 256 = mkHasher sha3_256 sha3_256_hasher+ | hashsize == 224 = mkHasher sha3_224 sha3_224_hasher+ | hashsize == 384 = mkHasher sha3_384 sha3_384_hasher+ | hashsize == 512 = mkHasher sha3_512 sha3_512_hasher | otherwise = giveup $ "unsupported SHA3 size " ++ show hashsize skeinHasher :: HashSize -> Hasher skeinHasher (HashSize hashsize)- | hashsize == 256 = mkHasher skein256 skein256_context- | hashsize == 512 = mkHasher skein512 skein512_context+ | hashsize == 256 = mkHasher skein256 skein256_hasher+ | hashsize == 512 = mkHasher skein512 skein512_hasher | otherwise = giveup $ "unsupported SKEIN size " ++ show hashsize blake2bHasher :: HashSize -> Hasher blake2bHasher (HashSize hashsize)- | hashsize == 256 = mkHasher blake2b_256 blake2b_256_context- | hashsize == 512 = mkHasher blake2b_512 blake2b_512_context- | hashsize == 160 = mkHasher blake2b_160 blake2b_160_context- | hashsize == 224 = mkHasher blake2b_224 blake2b_224_context- | hashsize == 384 = mkHasher blake2b_384 blake2b_384_context+ | hashsize == 256 = mkHasher blake2b_256 blake2b_256_hasher+ | hashsize == 512 = mkHasher blake2b_512 blake2b_512_hasher+ | hashsize == 160 = mkHasher blake2b_160 blake2b_160_hasher+ | hashsize == 224 = mkHasher blake2b_224 blake2b_224_hasher+ | hashsize == 384 = mkHasher blake2b_384 blake2b_384_hasher | otherwise = giveup $ "unsupported BLAKE2B size " ++ show hashsize blake2bpHasher :: HashSize -> Hasher blake2bpHasher (HashSize hashsize)- | hashsize == 512 = mkHasher blake2bp_512 blake2bp_512_context+ | hashsize == 512 = mkHasher blake2bp_512 blake2bp_512_hasher | otherwise = giveup $ "unsupported BLAKE2BP size " ++ show hashsize blake2sHasher :: HashSize -> Hasher blake2sHasher (HashSize hashsize)- | hashsize == 256 = mkHasher blake2s_256 blake2s_256_context- | hashsize == 160 = mkHasher blake2s_160 blake2s_160_context- | hashsize == 224 = mkHasher blake2s_224 blake2s_224_context+ | hashsize == 256 = mkHasher blake2s_256 blake2s_256_hasher+ | hashsize == 160 = mkHasher blake2s_160 blake2s_160_hasher+ | hashsize == 224 = mkHasher blake2s_224 blake2s_224_hasher | otherwise = giveup $ "unsupported BLAKE2S size " ++ show hashsize blake2spHasher :: HashSize -> Hasher blake2spHasher (HashSize hashsize)- | hashsize == 256 = mkHasher blake2sp_256 blake2sp_256_context- | hashsize == 224 = mkHasher blake2sp_224 blake2sp_224_context+ | hashsize == 256 = mkHasher blake2sp_256 blake2sp_256_hasher+ | hashsize == 224 = mkHasher blake2sp_224 blake2sp_224_hasher | otherwise = giveup $ "unsupported BLAKE2SP size " ++ show hashsize +#ifdef WITH_BLAKE3+blake3Hasher :: Hasher+blake3Hasher = Hasher+ { hashPure = blake3+ , hashFileFast = Just blake3File+ , hashIncremental = Just $+ blake3IncrementalVerifier descChecksum . sameCheckSum+ }+#endif++#ifdef WITH_XXH3+xxh3Hasher :: Hasher+xxh3Hasher = Hasher+ { hashPure = digestToHash . xxh3+ , hashFileFast = Nothing+ , hashIncremental = xxh3Incremental+ }+#endif+ sha1Hasher :: Hasher-sha1Hasher = mkHasher sha1 sha1_context+sha1Hasher = mkHasher sha1 sha1_hasher md5Hasher :: Hasher-md5Hasher = mkHasher md5 md5_context+md5Hasher = mkHasher md5 md5_hasher descChecksum :: String descChecksum = "checksum"@@ -310,12 +383,12 @@ where longext = ".this-is-a-test-key" -testKeyHash :: Hash+testKeyHash :: HashType testKeyHash = SHA2Hash (HashSize 256) genTestKey :: L.ByteString -> Key genTestKey content = addTestE $ mkKey $ \kd -> kd- { keyName = S.toShort $ encodeBS $- (fst $ hasher testKeyHash) content+ { keyName = S.toShort $ hashByteString $+ (hashPure $ hasher testKeyHash) content , keyVariety = backendVariety testKeyBackend }
Backend/URL.hs view
@@ -26,6 +26,7 @@ , genKey = Nothing , verifyKeyContent = Nothing , verifyKeyContentIncrementally = Nothing+ , verifyKeyContentIsFaster = True , canUpgradeKey = Nothing , fastMigrate = Just migrateFromURLToVURL -- The content of an url can change at any time, so URL keys are
Backend/Utilities.hs view
@@ -31,7 +31,7 @@ -- Avoid making keys longer than the length of a SHA256 checksum. | bytelen > sha256len = S.toShort $ truncateFilePath (sha256len - md5len - 1) s' - <> "-" <> encodeBS (show (md5 bl))+ <> "-" <> hashByteString (digestToHash (md5 bl)) | otherwise = S.toShort s' where s' = encodeBS $ preSanitizeKeyName s
Backend/VURL.hs view
@@ -16,7 +16,7 @@ import Logs.EquivilantKeys import Backend.Variety import Backend.Hash (descChecksum)-import Utility.Hash+import Utility.Hash.Incremental import Backend.VURL.Utilities backends :: [Backend]@@ -72,7 +72,10 @@ , positionIncrementalVerifier = getM positionIncrementalVerifier l , descIncrementalVerifier = descChecksum- } + }+ -- Incremental is faster because it avoids reading the file more+ -- than once when there are multiple equivilant keys.+ , verifyKeyContentIsFaster = False , canUpgradeKey = Nothing , fastMigrate = Just migrateFromVURLToURL -- Even if a hash is recorded on initial download from the web and
Backend/WORM.hs view
@@ -29,6 +29,7 @@ , genKey = Just keyValue , verifyKeyContent = Nothing , verifyKeyContentIncrementally = Nothing+ , verifyKeyContentIsFaster = True , canUpgradeKey = Just needsUpgrade , fastMigrate = Just removeProblemChars , isStableKey = const True
BuildFlags.hs view
@@ -65,6 +65,21 @@ #else #warning Building without the OsPath build flag set results in slower filename manipulation and is not recommended. #endif+#ifdef WITH_BOTAN+ , "Botan"+#else +#warning Consider building with the Botan build flag set, it speeds up checksumming by up 4x to 8x.+#endif+#ifdef WITH_BLAKE3+ , "Blake3"+#else+#warning Building without Blake3 support.+#endif+#ifdef WITH_XXH3+ , "XXH3"+#else+#warning Building without XXH3 support.+#endif ] -- Not a complete list, let alone a listing transitive deps, but only
CHANGELOG view
@@ -1,3 +1,31 @@+git-annex (10.20260624) upstream; urgency=medium++ * Added Botan build flag, which speeds up checksumming significantly+ for most existing hash backends.+ * Added Blake3 build flag, which is the fastest available+ cryptographically secure hash.+ Thanks to edef for implementing this.+ * When b3sum is in PATH, use it for faster blake3 hashing.+ * Added XXH3 build flag, which is the fastest available+ non-cryptographically secure hash, and is a smaller hash+ than MD5 or SHA1.+ * Improve handling of synced/master and similar branches, by+ only creating such branches when necessary to push to a non-bare+ remote, and by removing the local synced branch once its changes+ are merged.+ * put: New command.+ * move: Fix bug where an interrupted command other than move could+ be treated as an interrupted move, resulting in dropping content+ when not allowed by numcopies.+ * Fix build with http-types-0.12.5+ * merge, post-receive: Fix bug that prevented merging any synced/+ branches into the current branch.+ (Reversion introduced in 10.20260601)+ * git-annex.cabal: Remove unused dependency on old-locale.+ * Remove dependencies on securemem and byteable.++ -- Joey Hess <id@joeyh.name> Thu, 25 Jun 2026 12:28:43 -0400+ git-annex (10.20260601) upstream; urgency=medium * Avoid an error message displaying a password embedded in a git remote url.
COPYRIGHT view
@@ -51,6 +51,11 @@ Copyright: © 2010-2023 Joey Hess <id@joeyh.name> License: AGPL-3+ +Files: Utility.Hash.Blake3+Copyright 2026 Joey Hess <id@joeyh.name>+ 2022 edef <edef@edef.eu>+License: AGPL-3++ Files: Utility/* Copyright: 2012-2025 Joey Hess <id@joeyh.name> License: BSD-2-clause
CmdLine/Batch.hs view
@@ -155,22 +155,24 @@ -- -- File matching options are checked, and non-matching files skipped. batchFiles :: BatchFormat -> ((SeekInput, OsPath) -> CommandStart) -> Annex ()-batchFiles fmt a = batchFilesKeys fmt $ \(si, v) -> case v of- Right f -> a (si, f)- Left _k -> return Nothing+batchFiles fmt a = batchFilesKeys fmt $ \(si, v) -> + return $ case v of+ Right f -> [a (si, f)]+ Left _k -> [return Nothing] -batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key OsPath) -> CommandStart) -> Annex ()+batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key OsPath) -> Annex [CommandStart]) -> Annex () batchFilesKeys fmt a = do matcher <- getMatcher go $ \si v -> case v of Right f -> ifM (matcher $ MatchingFile $ FileInfo f f Nothing) ( a (si, Right f)- , return Nothing+ , return [return Nothing] ) Left k -> a (si, Left k) where- go a' = batchInput fmt parser (batchCommandAction . uncurry a')+ go a' = batchInput fmt parser $ \v ->+ mapM_ batchCommandAction =<< uncurry a' v parser = case fmt of -- Absolute filepaths are converted to relative, -- because in non-batch mode, that is done when@@ -184,32 +186,37 @@ Nothing -> Left "not a valid key" batchAnnexedFiles :: BatchFormat -> AnnexedFileSeeker -> Annex ()-batchAnnexedFiles fmt seeker = batchAnnexed fmt seeker (const (return Nothing))+batchAnnexedFiles fmt seeker = + batchAnnexed' fmt seeker (const (return [return Nothing])) -- Reads lines of batch input and passes filepaths to the AnnexedFileSeeker -- to handle them. Or, with --batch-keys, passes keys to the keyaction. -- -- Matching options are checked, and non-matching items skipped. batchAnnexed :: BatchFormat -> AnnexedFileSeeker -> ((SeekInput, Key, ActionItem) -> CommandStart) -> Annex ()-batchAnnexed fmt seeker keyaction = do+batchAnnexed fmt seeker keyaction =+ batchAnnexed' fmt seeker $ \v -> return [keyaction v]++batchAnnexed' :: BatchFormat -> AnnexedFileSeeker -> ((SeekInput, Key, ActionItem) -> Annex [CommandStart]) -> Annex ()+batchAnnexed' fmt seeker keyaction = do matcher <- getMatcher batchFilesKeys fmt $ \(si, v) -> case v of Right f -> lookupKeyStaged f >>= \case- Nothing -> return Nothing+ Nothing -> return [return Nothing] Just k -> checkpresent k $ startAction seeker Nothing si f k Left k -> ifM (matcher (MatchingInfo (mkinfo k))) ( checkpresent k $ keyaction (si, k, mkActionItem k)- , return Nothing)+ , return [return Nothing]) where checkpresent k cont = case checkContentPresent seeker of Just v -> do present <- inAnnex k if present == v then cont- else return Nothing+ else return [return Nothing] Nothing -> cont mkinfo k = ProvidedInfo
CmdLine/GitAnnex.hs view
@@ -104,6 +104,7 @@ import qualified Command.Assist import qualified Command.Pull import qualified Command.Push+import qualified Command.Put import qualified Command.Satisfy import qualified Command.Mirror import qualified Command.AddUrl@@ -161,6 +162,7 @@ , Command.Assist.cmd , Command.Pull.cmd , Command.Push.cmd+ , Command.Put.cmd , Command.Satisfy.cmd , Command.Mirror.cmd , Command.AddUrl.cmd
CmdLine/Seek.hs view
@@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. -- - Copyright 2010-2023 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -58,11 +58,16 @@ import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID) data AnnexedFileSeeker = AnnexedFileSeeker- { startAction :: Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart+ { startAction :: Maybe KeySha -> SeekInput -> OsPath -> Key -> Annex [CommandStart] , checkContentPresent :: Maybe Bool , usesLocationLog :: Bool } +startSingle+ :: (Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart)+ -> Maybe KeySha -> SeekInput -> OsPath -> Key -> Annex [CommandStart]+startSingle a ks i p k = return [a ks i p k]+ -- The Sha that was read to get the Key. newtype KeySha = KeySha Git.Sha @@ -381,8 +386,9 @@ where finisher mi oreader checktimelimit = liftIO oreader >>= \case Just ((si, f, keysha), content) -> checktimelimit (liftIO discard) $ do- keyaction f mi content $- commandAction . startAction seeker keysha si f+ keyaction f mi content $ \k ->+ commandActions+ =<< startAction seeker keysha si f k finisher mi oreader checktimelimit Nothing -> return () where@@ -396,7 +402,7 @@ checkMatcherWhen mi (matcherNeedsLocationLog mi && not (matcherNeedsFileName mi)) (MatchingFile $ FileInfo f f (Just k))- (commandAction $ startAction seeker keysha si f k)+ (commandActions =<< startAction seeker keysha si f k) precachefinisher mi lreader checktimelimit Nothing -> return () where
Command/Copy.hs view
@@ -8,6 +8,7 @@ module Command.Copy where import Command+import qualified Annex import qualified Command.Move import qualified Remote import Annex.Wanted@@ -26,6 +27,7 @@ , autoMode :: Bool , wantedMode :: Bool , batchOption :: BatchMode+ , moveAction :: Command.Move.MoveAction } optParser :: CmdParamsDesc -> Parser CopyOptions@@ -36,6 +38,7 @@ <*> parseAutoOption <*> parseWantedOption <*> parseBatchOption True+ <*> pure (Command.Move.Copy False) instance DeferredParseClass CopyOptions where finishParse v = CopyOptions@@ -46,10 +49,14 @@ <*> pure (autoMode v) <*> pure (wantedMode v) <*> pure (batchOption v)+ <*> pure (moveAction v) seek :: CopyOptions -> CommandSeek seek o = case fromToOptions o of- Just fto -> seek' o fto+ Just fto -> do+ fast <- Annex.getRead Annex.fast+ let o' = o { moveAction = Command.Move.Copy fast }+ seek' o' fto Nothing -> giveup "Specify --from or --to" seek' :: CopyOptions -> FromToHereOptions -> CommandSeek@@ -57,16 +64,16 @@ case batchOption o of NoBatch -> withKeyOptions (keyOptions o) (autoMode o || wantedMode o) seeker- (commandAction . keyaction)+ (commandAction . startKey o fto id) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (copyFiles o) Batch fmt -> batchOnly (keyOptions o) (copyFiles o) $- batchAnnexed fmt seeker keyaction+ batchAnnexed fmt seeker (startKey o fto id) where ww = WarnUnmatchLsFiles "copy" seeker = AnnexedFileSeeker- { startAction = const $ start o fto+ { startAction = startSingle $ const $ start o fto id , checkContentPresent = case fto of FromOrToRemote (FromRemote _) -> Just False FromOrToRemote (ToRemote _) -> Just True@@ -75,13 +82,19 @@ FromAnywhereToRemote _ -> Nothing , usesLocationLog = True }- keyaction = Command.Move.startKey NoLiveUpdate fto Command.Move.RemoveNever {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or - sending non-preferred content. -}-start :: CopyOptions -> FromToHereOptions -> SeekInput -> OsPath -> Key -> CommandStart-start o fto si file key = do+start+ :: CopyOptions+ -> FromToHereOptions+ -> (ActionItem -> ActionItem)+ -> SeekInput+ -> OsPath+ -> Key+ -> CommandStart+start o fto fai si file key = do ru <- case fto of FromOrToRemote (ToRemote dest) -> getru dest FromOrToRemote (FromRemote _) -> pure Nothing@@ -89,13 +102,26 @@ FromRemoteToRemote _ dest -> getru dest FromAnywhereToRemote dest -> getru dest lu <- prepareLiveUpdate ru key AddingKey- start' lu o fto si file key++ start' lu o fto afile si file key ai where getru dest = Just . Remote.uuid <$> getParsed dest+ + afile = AssociatedFile (Just file)+ ai = fai $ mkActionItem (key, afile) -start' :: LiveUpdate -> CopyOptions -> FromToHereOptions -> SeekInput -> OsPath -> Key -> CommandStart-start' lu o fto si file key = stopUnless shouldCopy $ - Command.Move.start lu fto Command.Move.RemoveNever si file key+start'+ :: LiveUpdate+ -> CopyOptions+ -> FromToHereOptions+ -> AssociatedFile+ -> SeekInput+ -> OsPath+ -> Key+ -> ActionItem+ -> CommandStart+start' lu o fto afile si file key ai = stopUnless shouldCopy $ + Command.Move.start' lu fto (moveAction o) afile si key ai where shouldCopy | autoMode o = want <||> numCopiesCheck file key (<)@@ -112,3 +138,12 @@ (Remote.uuid <$> getParsed dest) >>= wantGetBy lu False (Just key) (AssociatedFile (Just file)) checkwantget = wantGet lu False (Just key) (AssociatedFile (Just file))++startKey+ :: CopyOptions+ -> FromToHereOptions+ -> (ActionItem -> ActionItem)+ -> (SeekInput, Key, ActionItem)+ -> CommandStart+startKey o fto fai (si, k, ai) = + Command.Move.startKey NoLiveUpdate fto (moveAction o) (si, k, fai ai)
Command/Drop.hs view
@@ -61,7 +61,7 @@ then pure Nothing else pure (Just remote) let seeker = AnnexedFileSeeker- { startAction = const $ start o from+ { startAction = startSingle $ const $ start o from , checkContentPresent = case from of Nothing -> Just True Just _ -> Nothing
Command/FilterBranch.hs view
@@ -155,7 +155,7 @@ =<< Annex.Branch.get f next (return True) let seeker = AnnexedFileSeeker- { startAction = \_ _ _ k -> addkeyinfo k+ { startAction = startSingle $ \_ _ _ k -> addkeyinfo k , checkContentPresent = Nothing , usesLocationLog = True }
Command/Find.hs view
@@ -63,7 +63,7 @@ checkNotBareRepo isterminal <- liftIO $ checkIsTerminal stdout seeker <- contentPresentUnlessLimited $ AnnexedFileSeeker- { startAction = const (start o isterminal)+ { startAction = startSingle $ const (start o isterminal) , checkContentPresent = Nothing , usesLocationLog = False }
Command/FindComputed.hs view
@@ -59,7 +59,8 @@ isterminal <- liftIO $ checkIsTerminal stdout computeremotes <- filter isComputeRemote <$> Remote.remoteList let seeker = AnnexedFileSeeker- { startAction = const (start o isterminal computeremotes)+ { startAction = startSingle $ + const (start o isterminal computeremotes) , checkContentPresent = Nothing , usesLocationLog = True }
Command/FindKeys.hs view
@@ -33,7 +33,8 @@ , usesLocationLog = False -- startAction is not actually used since this -- is not used to seek files- , startAction = \_ _ _ key -> start' o isterminal key+ , startAction = startSingle $ + \_ _ _ key -> start' o isterminal key } withKeyOptions (Just WantAllKeys) False seeker (commandAction . start o isterminal)
Command/Fix.hs view
@@ -38,7 +38,7 @@ where ww = WarnUnmatchLsFiles "fix" seeker = AnnexedFileSeeker- { startAction = const $ start FixAll+ { startAction = startSingle $ const $ start FixAll , checkContentPresent = Nothing , usesLocationLog = False }
Command/Fsck.hs view
@@ -108,7 +108,7 @@ cleanupLinkedWorkTreeBug i <- prepIncremental u (incrementalOpt o) let seeker = AnnexedFileSeeker- { startAction = const $ start from i+ { startAction = startSingle $ const $ start from i , checkContentPresent = Nothing , usesLocationLog = True }
Command/Get.hs view
@@ -18,7 +18,7 @@ cmd :: Command cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ command "get" SectionCommon - "make content of annexed files available"+ "get content of annexed files" paramPaths (seek <$$> optParser) data GetOptions = GetOptions@@ -43,7 +43,7 @@ seek o = startConcurrency transferStages $ do from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) let seeker = AnnexedFileSeeker- { startAction = const $ start o from+ { startAction = startSingle $ const $ start o from , checkContentPresent = Just False , usesLocationLog = True }@@ -81,7 +81,7 @@ Nothing -> go $ perform lu key afile Just src -> stopUnless (Command.Move.fromOk src key) $- go $ Command.Move.fromPerform lu src Command.Move.RemoveNever key afile+ go $ Command.Move.fromPerform lu src Command.Move.Get key afile where go = starting "get" (OnlyActionOn key ai) si
Command/ImportFeed.hs view
@@ -228,7 +228,7 @@ , do j <- jsonOutputEnabled unless j $- showStartMessage (StartMessage "importfeed" (ActionItemOther (Just "gathering known urls")) (SeekInput []))+ showStartMessage $ StartMessage "importfeed" ai si h <- Db.openDb unless j showEndOk@@ -237,6 +237,8 @@ where tmpl = Utility.Format.gen $ fromMaybe defaultTemplate opttemplate ret h = return $ Cache h tmpl+ ai = ActionItemOther (Just "gathering known urls")+ si = SeekInput [] findDownloads :: URLString -> Feed -> [ToDownload] findDownloads u f = catMaybes $ map mk (feedItems f)
Command/Inprogress.hs view
@@ -42,7 +42,8 @@ _ -> do let s = S.fromList ts let seeker = AnnexedFileSeeker- { startAction = const $ start isterminal s+ { startAction = startSingle $+ const $ start isterminal s , checkContentPresent = Nothing , usesLocationLog = False }
Command/List.hs view
@@ -49,7 +49,7 @@ list <- getList o printHeader list let seeker = AnnexedFileSeeker- { startAction = const $ start list+ { startAction = startSingle $ const $ start list , checkContentPresent = Nothing , usesLocationLog = True }
Command/Lock.hs view
@@ -34,7 +34,7 @@ where ww = WarnUnmatchLsFiles "lock" seeker = AnnexedFileSeeker- { startAction = const start+ { startAction = startSingle $ const start , checkContentPresent = Nothing , usesLocationLog = False }
Command/Log.hs view
@@ -134,7 +134,7 @@ zone <- liftIO getCurrentTimeZone outputter <- mkOutputter m zone o <$> jsonOutputEnabled let seeker = AnnexedFileSeeker- { startAction = const $ \si file key ->+ { startAction = startSingle $ const $ \si file key -> start o outputter (si, key, mkActionItem (file, key)) , checkContentPresent = Nothing -- the way this uses the location log would not be
Command/Merge.hs view
@@ -12,7 +12,7 @@ import qualified Git import qualified Git.Branch import Annex.CurrentBranch-import Command.Sync (prepMerge, mergeLocal, mergeConfig, merge, notOnlyAnnexOption, parseUnrelatedHistoriesOption)+import Command.Sync (prepMerge, mergeLocalLikePull, mergeConfig, merge, notOnlyAnnexOption, parseUnrelatedHistoriesOption) import Git.Types cmd :: Command@@ -55,14 +55,14 @@ mergeSyncedBranch :: MergeOptions -> CommandStart mergeSyncedBranch o = do mc <- mergeConfig (allowUnrelatedHistories o)- mergeLocal mc def =<< getCurrentBranch+ mergeLocalLikePull mc def =<< getCurrentBranch mergeBranch :: MergeOptions -> Git.Ref -> CommandStart mergeBranch o r = starting "merge" ai si $ do currbranch <- getCurrentBranch mc <- mergeConfig (allowUnrelatedHistories o) let so = def { notOnlyAnnexOption = True }- next $ merge currbranch mc so Git.Branch.ManualCommit [r]+ next $ merge currbranch mc so Git.Branch.ManualCommit [(r, noop)] where ai = ActionItemOther (Just (UnquotedString (Git.fromRef r))) si = SeekInput []
Command/MetaData.hs view
@@ -77,7 +77,7 @@ c <- currentVectorClock let ww = WarnUnmatchLsFiles "metadata" let seeker = AnnexedFileSeeker- { startAction = const $ start c o+ { startAction = startSingle $ const $ start c o , checkContentPresent = Nothing , usesLocationLog = False }
Command/Migrate.hs view
@@ -66,7 +66,7 @@ where ww = WarnUnmatchLsFiles "migrate" seeker = AnnexedFileSeeker- { startAction = start o+ { startAction = startSingle $ start o , checkContentPresent = Nothing , usesLocationLog = False }
Command/Mirror.hs view
@@ -52,7 +52,7 @@ ToRemote _ -> commandStages ww = WarnUnmatchLsFiles "mirror" seeker = AnnexedFileSeeker- { startAction = const $ start o+ { startAction = startSingle $ const $ start o , checkContentPresent = Nothing , usesLocationLog = True }@@ -66,7 +66,7 @@ startKey :: MirrorOptions -> AssociatedFile -> (SeekInput, Key, ActionItem) -> CommandStart startKey o afile (si, key, ai) = case fromToOptions o of ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)- ( Command.Move.toStart NoLiveUpdate Command.Move.RemoveNever afile key ai si =<< getParsed r+ ( Command.Move.toStart NoLiveUpdate (Command.Move.Copy False) afile key ai si =<< getParsed r , do (numcopies, mincopies) <- getSafestNumMinCopies afile key Command.Drop.startRemote NoLiveUpdate pcc afile ai si numcopies mincopies key (Command.Drop.DroppingUnused False)
Command/Move.hs view
@@ -35,7 +35,7 @@ data MoveOptions = MoveOptions { moveFiles :: CmdParams , fromToOptions :: Maybe FromToHereOptions- , removeWhen :: RemoveWhen+ , moveAction :: MoveAction , keyOptions :: Maybe KeyOptions , batchOption :: BatchMode }@@ -44,7 +44,7 @@ optParser desc = MoveOptions <$> cmdParams desc <*> parseFromToHereOptions- <*> pure RemoveSafe+ <*> pure Move <*> optional (parseKeyOptions <|> parseFailedTransfersOption) <*> parseBatchOption True @@ -53,13 +53,23 @@ <$> pure (moveFiles v) <*> maybe (pure Nothing) (Just <$$> finishParse) (fromToOptions v)- <*> pure (removeWhen v)+ <*> pure (moveAction v) <*> pure (keyOptions v) <*> pure (batchOption v) -data RemoveWhen = RemoveSafe | RemoveNever+data MoveAction+ = Move+ | Copy { copyFast :: Bool }+ | Put+ | Get deriving (Show, Eq) +describeMoveAction :: MoveAction -> String+describeMoveAction Move = "move"+describeMoveAction (Copy _) = "copy"+describeMoveAction Put = "put"+describeMoveAction Get = "get"+ seek :: MoveOptions -> CommandSeek seek o = case fromToOptions o of Just fto -> seek' o fto@@ -76,7 +86,8 @@ batchAnnexed fmt seeker keyaction where seeker = AnnexedFileSeeker- { startAction = const $ start NoLiveUpdate fto (removeWhen o)+ { startAction = startSingle $ + const $ start NoLiveUpdate fto (moveAction o) , checkContentPresent = case fto of FromOrToRemote (FromRemote _) -> Nothing FromOrToRemote (ToRemote _) -> Just True@@ -85,7 +96,7 @@ FromAnywhereToRemote _ -> Nothing , usesLocationLog = True }- keyaction = startKey NoLiveUpdate fto (removeWhen o)+ keyaction = startKey NoLiveUpdate fto (moveAction o) ww = WarnUnmatchLsFiles "move" stages :: FromToHereOptions -> UsedStages@@ -95,77 +106,74 @@ stages (FromRemoteToRemote _ _) = transferStages stages (FromAnywhereToRemote _) = transferStages -start :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> SeekInput -> OsPath -> Key -> CommandStart-start lu fromto removewhen si f k = start' lu fromto removewhen afile si k ai+start :: LiveUpdate -> FromToHereOptions -> MoveAction -> SeekInput -> OsPath -> Key -> CommandStart+start lu fromto moveaction si f k = start' lu fromto moveaction afile si k ai where afile = AssociatedFile (Just f) ai = mkActionItem (k, afile) -startKey :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> (SeekInput, Key, ActionItem) -> CommandStart-startKey lu fromto removewhen (si, k, ai) = - start' lu fromto removewhen (AssociatedFile Nothing) si k ai+startKey :: LiveUpdate -> FromToHereOptions -> MoveAction -> (SeekInput, Key, ActionItem) -> CommandStart+startKey lu fromto moveaction (si, k, ai) = + start' lu fromto moveaction (AssociatedFile Nothing) si k ai -start' :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> AssociatedFile -> SeekInput -> Key -> ActionItem -> CommandStart-start' lu fromto removewhen afile si key ai =+start' :: LiveUpdate -> FromToHereOptions -> MoveAction -> AssociatedFile -> SeekInput -> Key -> ActionItem -> CommandStart+start' lu fromto moveaction afile si key ai = case fromto of FromOrToRemote (FromRemote src) -> checkFailedTransferDirection ai Download $- fromStart lu removewhen afile key ai si =<< getParsed src+ fromStart lu moveaction afile key ai si =<< getParsed src FromOrToRemote (ToRemote dest) -> checkFailedTransferDirection ai Upload $- toStart lu removewhen afile key ai si =<< getParsed dest+ toStart lu moveaction afile key ai si =<< getParsed dest ToHere -> checkFailedTransferDirection ai Download $- toHereStart lu removewhen afile key ai si+ toHereStart lu moveaction afile key ai si FromRemoteToRemote src dest -> do src' <- getParsed src dest' <- getParsed dest- fromToStart lu removewhen afile key ai si src' dest'+ fromToStart lu moveaction afile key ai si src' dest' FromAnywhereToRemote dest -> do dest' <- getParsed dest- fromAnywhereToStart lu removewhen afile key ai si dest'--describeMoveAction :: RemoveWhen -> String-describeMoveAction RemoveNever = "copy"-describeMoveAction _ = "move"+ fromAnywhereToStart lu moveaction afile key ai si dest' -toStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart-toStart lu removewhen afile key ai si dest = do+toStart :: LiveUpdate -> MoveAction -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart+toStart lu moveaction afile key ai si dest = do u <- getUUID if u == Remote.uuid dest then stop- else toStart' lu dest removewhen afile key ai si+ else toStart' lu dest moveaction afile key ai si -toStart' :: LiveUpdate -> Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart-toStart' lu dest removewhen afile key ai si = do- fast <- Annex.getRead Annex.fast- if fast && removewhen == RemoveNever- then ifM (expectedPresent dest key)+toStart' :: LiveUpdate -> Remote -> MoveAction -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart+toStart' lu dest moveaction afile key ai si =+ case moveaction of+ Move -> checkhaskey+ Copy { copyFast = False } -> checkhaskey+ _ -> ifM (expectedPresent dest key) ( stop , go True (pure $ Right False) )- else go False (Remote.hasKey dest key) where+ checkhaskey = go False (Remote.hasKey dest key) go fastcheck isthere =- starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $- toPerform lu dest removewhen key afile fastcheck =<< isthere+ starting (describeMoveAction moveaction) (OnlyActionOn key ai) si $+ toPerform lu dest moveaction key afile fastcheck =<< isthere expectedPresent :: Remote -> Key -> Annex Bool expectedPresent dest key = do remotes <- Remote.keyPossibilities (Remote.IncludeIgnored True) key return $ dest `elem` remotes -toPerform :: LiveUpdate -> Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform+toPerform :: LiveUpdate -> Remote -> MoveAction -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform toPerform = toPerform' Nothing -toPerform' :: Maybe ContentRemovalLock -> LiveUpdate -> Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform-toPerform' mcontentlock lu dest removewhen key afile fastcheck isthere = do+toPerform' :: Maybe ContentRemovalLock -> LiveUpdate -> Remote -> MoveAction -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform+toPerform' mcontentlock lu dest moveaction key afile fastcheck isthere = do srcuuid <- getUUID case isthere of Left err -> do showNote (UnquotedString err) stop- Right False -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> do+ Right False -> logMove moveaction srcuuid destuuid False key $ \deststartedwithcopy -> do showAction $ UnquotedString $ "to " ++ Remote.name dest ok <- notifyTransfer Upload afile $ upload dest key afile stdRetry@@ -177,18 +185,14 @@ when fastcheck $ warning "This could have failed because --fast is enabled." stop- Right True -> logMove srcuuid destuuid True key $ \deststartedwithcopy ->+ Right True -> logMove moveaction srcuuid destuuid True key $ \deststartedwithcopy -> finish deststartedwithcopy $ unlessM (expectedPresent dest key) $ Remote.logStatus lu dest key InfoPresent where destuuid = Remote.uuid dest- finish deststartedwithcopy setpresentremote = case removewhen of- RemoveNever -> do- setpresentremote- logMoveCleanup deststartedwithcopy- next $ return True- RemoveSafe -> lockcontentforremoval $ \contentlock -> do+ finish deststartedwithcopy setpresentremote = case moveaction of+ Move -> lockcontentforremoval $ \contentlock -> do srcuuid <- getUUID r <- willDropMakeItWorse lu srcuuid destuuid deststartedwithcopy key afile >>= \case DropAllowed -> drophere setpresentremote contentlock "moved"@@ -203,6 +207,10 @@ DropWorse -> faileddrophere setpresentremote logMoveCleanup deststartedwithcopy return r+ _ -> do+ setpresentremote+ logMoveCleanup deststartedwithcopy+ next $ return True showproof proof = "proof: " ++ show proof drophere setpresentremote contentlock reason = do fastDebug "Command.Move" $ unwords@@ -235,11 +243,11 @@ lockfailed = next $ Command.Drop.cleanupLocal lu key (Command.Drop.DroppingUnused False) -fromStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart-fromStart lu removewhen afile key ai si src = +fromStart :: LiveUpdate -> MoveAction -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart+fromStart lu moveaction afile key ai si src = stopUnless (fromOk src key) $- starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $- fromPerform lu src removewhen key afile+ starting (describeMoveAction moveaction) (OnlyActionOn key ai) si $+ fromPerform lu src moveaction key afile fromOk :: Remote -> Key -> Annex Bool fromOk src key@@ -259,17 +267,17 @@ remotes <- Remote.keyPossibilities (Remote.IncludeIgnored True) key return $ u /= Remote.uuid src && elem src remotes -fromPerform :: LiveUpdate -> Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform-fromPerform lu src removewhen key afile = do+fromPerform :: LiveUpdate -> Remote -> MoveAction -> Key -> AssociatedFile -> CommandPerform+fromPerform lu src moveaction key afile = do present <- inAnnex key- finish <- fromPerform' lu present True src key afile- finish removewhen+ finish <- fromPerform' lu present True src moveaction key afile+ finish moveaction -fromPerform' :: LiveUpdate -> Bool -> Bool -> Remote -> Key -> AssociatedFile -> Annex (RemoveWhen -> CommandPerform)-fromPerform' lu present updatelocationlog src key afile = do+fromPerform' :: LiveUpdate -> Bool -> Bool -> Remote -> MoveAction -> Key -> AssociatedFile -> Annex (MoveAction -> CommandPerform)+fromPerform' lu present updatelocationlog src moveaction key afile = do showAction $ UnquotedString $ "from " ++ Remote.name src destuuid <- getUUID- logMove (Remote.uuid src) destuuid present key $ \deststartedwithcopy ->+ logMove moveaction (Remote.uuid src) destuuid present key $ \deststartedwithcopy -> if present then return $ finish deststartedwithcopy True else do@@ -287,13 +295,13 @@ finish deststartedwithcopy False _ = do logMoveCleanup deststartedwithcopy stop -- copy failed- finish deststartedwithcopy True RemoveNever = do- logMoveCleanup deststartedwithcopy- next $ return True -- copy complete- finish deststartedwithcopy True RemoveSafe = do+ finish deststartedwithcopy True Move = do destuuid <- getUUID lockContentShared key Nothing $ \_lck -> fromDrop lu src destuuid deststartedwithcopy key afile id+ finish deststartedwithcopy True _ = do+ logMoveCleanup deststartedwithcopy+ next $ return True -- copy complete fromDrop :: LiveUpdate -> Remote -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> ([UnVerifiedCopy] -> [UnVerifiedCopy])-> CommandPerform fromDrop lu src destuuid deststartedwithcopy key afile adjusttocheck =@@ -337,59 +345,57 @@ - - When moving, the content is removed from all the reachable remotes that - it can safely be removed from. -}-toHereStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart-toHereStart lu removewhen afile key ai si = +toHereStart ::LiveUpdate -> MoveAction -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart+toHereStart lu moveaction afile key ai si = startingNoMessage (OnlyActionOn key ai) $ do rs <- Remote.keyPossibilities (Remote.IncludeIgnored False) key forM_ rs $ \r -> includeCommandAction $- starting (describeMoveAction removewhen) ai si $- fromPerform lu r removewhen key afile+ starting (describeMoveAction moveaction) ai si $+ fromPerform lu r moveaction key afile next $ return True -fromToStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> Remote -> CommandStart-fromToStart lu removewhen afile key ai si src dest = +fromToStart :: LiveUpdate -> MoveAction -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> Remote -> CommandStart+fromToStart lu moveaction afile key ai si src dest = stopUnless somethingtodo $ do u <- getUUID if u == Remote.uuid src- then toStart lu removewhen afile key ai si dest+ then toStart lu moveaction afile key ai si dest else if u == Remote.uuid dest- then fromStart lu removewhen afile key ai si src+ then fromStart lu moveaction afile key ai si src else stopUnless (fromOk src key) $- starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $- fromToPerform lu src dest removewhen key afile+ starting (describeMoveAction moveaction) (OnlyActionOn key ai) si $+ fromToPerform lu src dest moveaction key afile where somethingtodo | Remote.uuid src == Remote.uuid dest = return False- | otherwise = do- fast <- Annex.getRead Annex.fast- if fast && removewhen == RemoveNever- then not <$> expectedPresent dest key- else return True+ | otherwise = case moveaction of+ Move -> return True+ Copy { copyFast = False } -> return True+ _ -> not <$> expectedPresent dest key -fromAnywhereToStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart-fromAnywhereToStart lu removewhen afile key ai si dest =+fromAnywhereToStart :: LiveUpdate -> MoveAction -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart+fromAnywhereToStart lu moveaction afile key ai si dest = stopUnless somethingtodo $ do u <- getUUID if u == Remote.uuid dest- then toHereStart lu removewhen afile key ai si+ then toHereStart lu moveaction afile key ai si else startingNoMessage (OnlyActionOn key ai) $ do rs <- filter (/= dest) <$> Remote.keyPossibilities (Remote.IncludeIgnored False) key forM_ rs $ \r -> includeCommandAction $- starting (describeMoveAction removewhen) ai si $- fromToPerform lu r dest removewhen key afile+ starting (describeMoveAction moveaction) ai si $+ fromToPerform lu r dest moveaction key afile whenM (inAnnex key) $ void $ includeCommandAction $- toStart lu removewhen afile key ai si dest + toStart lu moveaction afile key ai si dest next $ return True where- somethingtodo = do- fast <- Annex.getRead Annex.fast- if fast && removewhen == RemoveNever- then not <$> expectedPresent dest key- else return True+ somethingtodo = case moveaction of+ Move -> return True+ Copy { copyFast = False } -> return True+ _ -> not <$> expectedPresent dest key {- When there is a local copy, transfer it to the dest, and drop from the src. -@@ -406,8 +412,8 @@ - may end up locally present, or not. This is similar to the behavior - when running `git-annex move --to` concurrently with git-annex get. -}-fromToPerform :: LiveUpdate -> Remote -> Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform-fromToPerform lu src dest removewhen key afile = do+fromToPerform :: LiveUpdate -> Remote -> Remote -> MoveAction -> Key -> AssociatedFile -> CommandPerform+fromToPerform lu src dest moveaction key afile = do hereuuid <- getUUID loggedpresent <- any (== hereuuid) <$> loggedLocations key@@ -429,9 +435,9 @@ dropsrc <- fromsrc True combinecleanups -- Send to dest, preserve local copy.- (todest Nothing RemoveNever haskey)+ (todest Nothing (Copy False) haskey) (\senttodest -> if senttodest- then dropsrc removewhen+ then dropsrc moveaction else stop ) go ispresent _loggedpresent = do@@ -466,26 +472,26 @@ lockContentForRemoval key stop $ \contentlock -> combinecleanups -- Send to dest and remove local copy.- (todest (Just contentlock) RemoveSafe haskey)+ (todest (Just contentlock) Move haskey) (\senttodest -> -- Drop from src, checking -- copies including dest. combinecleanups- (cleanupfromsrc RemoveNever)+ (cleanupfromsrc (Copy False)) (\_ -> if senttodest then dropfromsrc (\l -> UnVerifiedRemote dest : l) else stop ) ) - fromsrc present = fromPerform' lu present False src key afile+ fromsrc present = fromPerform' lu present False src moveaction key afile - todest mcontentlock removewhen' = toPerform' mcontentlock lu dest removewhen' key afile False+ todest mcontentlock moveaction' = toPerform' mcontentlock lu dest moveaction' key afile False - dropfromsrc adjusttocheck = case removewhen of- RemoveSafe -> logMove (Remote.uuid src) (Remote.uuid dest) True key $ \deststartedwithcopy ->+ dropfromsrc adjusttocheck = case moveaction of+ Move -> logMove moveaction (Remote.uuid src) (Remote.uuid dest) True key $ \deststartedwithcopy -> fromDrop lu src (Remote.uuid dest) deststartedwithcopy key afile adjusttocheck- RemoveNever -> next (return True)+ _ -> next (return True) combinecleanups a b = a >>= \case Just cleanupa -> b True >>= \case@@ -569,8 +575,8 @@ - copy, and so could refuse to allow the drop. By providing the logged - DestStartedWithCopy, this avoids that annoyance. -}-logMove :: UUID -> UUID -> Bool -> Key -> (DestStartedWithCopy -> Annex a) -> Annex a-logMove srcuuid destuuid deststartedwithcopy key a = go =<< setup+logMove :: MoveAction -> UUID -> UUID -> Bool -> Key -> (DestStartedWithCopy -> Annex a) -> Annex a+logMove Move srcuuid destuuid deststartedwithcopy key a = go =<< setup where logline = L.fromStrict $ B8.unwords [ fromUUID srcuuid@@ -608,3 +614,4 @@ go' fs deststartedwithcopy' = a $ DestStartedWithCopy deststartedwithcopy' (cleanup fs)+logMove _ _ _ _ _ a = a (DestStartedWithCopy False noop)
Command/Multicast.hs view
@@ -239,7 +239,7 @@ -- is a 8 digit hex number in the form "0xnnnnnnnn" -- Derive it from the UUID. uftpUID :: UUID -> String-uftpUID u = "0x" ++ (take 8 $ show $ sha2_256 $ B8.fromString (fromUUID u))+uftpUID u = "0x" ++ (take 8 $ show $ digestToHash $ sha2_256 $ B8.fromString (fromUUID u)) withAuthList :: (OsPath -> Annex a) -> Annex a withAuthList a = do
Command/PostReceive.hs view
@@ -14,7 +14,7 @@ import qualified Annex import Annex.UpdateInstead import Annex.CurrentBranch-import Command.Sync (mergeLocal, prepMerge, mergeConfig, SyncOptions(..))+import Command.Sync (mergeLocalLikePull, prepMerge, mergeConfig, SyncOptions(..)) import Annex.Proxy import Remote import qualified Types.Remote as Remote@@ -53,7 +53,7 @@ prepMerge let o = def { notOnlyAnnexOption = True } mc <- mergeConfig False- mergeLocal mc o =<< getCurrentBranch+ mergeLocalLikePull mc o =<< getCurrentBranch proxyExportTree :: CommandSeek proxyExportTree = do
+ Command/Put.hs view
@@ -0,0 +1,83 @@+{- git-annex command+ -+ - Copyright 2026 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.Put where++import Command+import qualified Annex+import qualified Command.Copy+import qualified Command.Move (MoveAction(..))+import qualified Remote++cmd :: Command+cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $+ command "put" SectionCommon+ "send content of files to other repositories"+ paramPaths (seek <$$> optParser)++data PutOptions = PutOptions+ { putFiles :: CmdParams+ , keyOptions :: Maybe KeyOptions+ , wantedMode :: Bool+ , autoMode :: Bool+ , batchOption :: BatchMode+ }++optParser :: CmdParamsDesc -> Parser PutOptions+optParser desc = PutOptions+ <$> cmdParams desc+ <*> optional (parseKeyOptions <|> parseFailedTransfersOption)+ <*> parseWantedOption+ <*> parseAutoOption+ <*> parseBatchOption True++seek :: PutOptions -> CommandSeek+seek o = startConcurrency commandStages $ do+ fast <- Annex.getRead Annex.fast+ let fastest = fromMaybe [] . headMaybe+ contentremotes <- filter Remote.canPut+ . (if fast then fastest else concat)+ . Remote.byCost + <$> (Remote.contentRemotes =<< Remote.remoteList)+ let seeker = AnnexedFileSeeker+ { startAction = \_ si p k ->+ return $ flip map contentremotes $ \r ->+ Command.Copy.start co (to r) (fai r) si p k+ , checkContentPresent = Just True+ , usesLocationLog = True+ }+ let keyaction v = + return $ flip map contentremotes $ \r ->+ Command.Copy.startKey co (to r) (fai r) v+ case batchOption o of+ NoBatch -> withKeyOptions+ (keyOptions o) (autoMode o || wantedMode o) seeker+ (\v -> commandActions =<< keyaction v)+ (withFilesInGitAnnex ww seeker)+ =<< workTreeItems ww (putFiles o)+ Batch fmt -> batchOnly (keyOptions o) (putFiles o) $+ batchAnnexed' fmt seeker keyaction+ where+ ww = WarnUnmatchLsFiles "put"++ co = Command.Copy.CopyOptions+ { Command.Copy.copyFiles = putFiles o+ , Command.Copy.fromToOptions = Nothing+ , Command.Copy.keyOptions = keyOptions o+ , Command.Copy.autoMode = autoMode o+ , Command.Copy.wantedMode = wantedMode o+ , Command.Copy.batchOption = batchOption o+ , Command.Copy.moveAction = Command.Move.Put+ }+ + to = FromOrToRemote . ToRemote . ReadyParse++ -- Since put can send to remotes of its choosing, suppliment the+ -- ActionItem with the uuid. This makes the json include the remote+ -- uuid.+ fai r ai = ActionItemForUUID (Remote.uuid r) ai+
Command/Recompute.hs view
@@ -59,7 +59,7 @@ computeremote <- maybe (pure Nothing) (Just <$$> getParsed) (computeRemote o) let seeker = AnnexedFileSeeker- { startAction = const $ start o computeremote+ { startAction = startSingle $ const $ start o computeremote , checkContentPresent = Nothing , usesLocationLog = True }
Command/Sync.hs view
@@ -17,7 +17,7 @@ mergeConfig, merge, prepMerge,- mergeLocal,+ mergeLocalLikePull, mergeRemote, commitMsg, pushBranch,@@ -273,11 +273,8 @@ ] remotes <- mapM (pushToCreate o) =<< syncRemotes (syncWith o)- -- Remotes that git can push to and pull from. let gitremotes = filter Remote.gitSyncableRemote remotes- -- Remotes that contain annex object content.- contentremotes <- filter (\r -> Remote.uuid r /= NoUUID)- <$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes+ contentremotes <- Remote.contentRemotes remotes if cleanupOption o then do@@ -297,9 +294,9 @@ whenM (annexSyncMigrations <$> Annex.getGitConfig) $ Command.Migrate.seekDistributedMigrations True - forM_ (filter isImport contentremotes) $+ forM_ (filter Remote.isImport contentremotes) $ withbranch . importRemote changehere o- forM_ (filter isThirdPartyPopulated contentremotes) $+ forM_ (filter Remote.isThirdPartyPopulated contentremotes) $ pullThirdPartyPopulated o when content $ do@@ -314,8 +311,8 @@ -- importing only downloads new files not -- old files) let shouldsynccontent r- | isExport r && not (isImport r) - && not (exportHasAnnexObjects r) = False+ | Remote.isExport r && not (Remote.isImport r) + && not (annexObjects (Remote.config r)) = False | otherwise = True syncedcontent <- withbranch $ seekSyncContent o@@ -363,17 +360,26 @@ else Nothing ] -merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> [Git.Branch] -> Annex Bool+merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> [(Git.Branch, Annex ())] -> Annex Bool merge currbranch mergeconfig o commitmode tomergel = runsGitAnnexChildProcessViaGit $ do canresolvemerge <- if resolveMergeOverride o then getGitConfigVal annexResolveMerge else return False and <$> case currbranch of- (Just b, Just adj) -> forM tomergel $ \tomerge ->+ (Just b, Just adj) -> forM tomergel $ \(tomerge, postmerge) -> mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode- (b, _) -> forM tomergel $ \tomerge ->+ `andthen` postmerge+ (b, _) -> forM tomergel $ \(tomerge, postmerge) -> autoMergeFrom tomerge b mergeconfig commitmode canresolvemerge+ `andthen` postmerge+ where+ andthen a b = ifM a+ ( do+ () <- b+ return True+ , return False+ ) syncBranch :: Git.Branch -> Git.Branch syncBranch = Git.Ref.underBase "refs/heads/synced" . origBranch@@ -439,28 +445,30 @@ ++ maybe "unknown" fromUUIDDesc (M.lookup u m) mergeLocal :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart-mergeLocal mergeconfig o currbranch = stopUnless shouldmerge $- mergeLocal' mergeconfig o currbranch- where- shouldmerge = pure (pullOption o) <&&> notOnlyAnnex o+mergeLocal mergeconfig o currbranch = stopUnless (pure (pullOption o)) $+ mergeLocalLikePull mergeconfig o currbranch -mergeLocal' :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart-mergeLocal' mergeconfig o currbranch@(Just branch, _) =+mergeLocalLikePull :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart+mergeLocalLikePull mergeconfig o currbranch = stopUnless (notOnlyAnnex o) $ + mergeLocal'' mergeconfig o currbranch++mergeLocal'' :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart+mergeLocal'' mergeconfig o currbranch@(Just branch, _) = needMerge currbranch branch >>= \case [] -> stop tomerge -> do- let ai = ActionItemOther (Just $ UnquotedString $ unwords $ map Git.Ref.describe tomerge)+ let ai = ActionItemOther (Just $ UnquotedString $ unwords $ map Git.Ref.describe $ map fst tomerge) let si = SeekInput [] starting "merge" ai si $ next $ merge currbranch mergeconfig o Git.Branch.ManualCommit tomerge-mergeLocal' _ _ currbranch@(Nothing, _) = inRepo Git.Branch.currentUnsafe >>= \case+mergeLocal'' _ _ currbranch@(Nothing, _) = inRepo Git.Branch.currentUnsafe >>= \case Just branch -> needMerge currbranch branch >>= \case [] -> stop tomerge -> do- let ai = ActionItemOther (Just $ UnquotedString $ unwords $ map Git.Ref.describe tomerge)+ let ai = ActionItemOther (Just $ UnquotedString $ unwords $ map Git.Ref.describe $ map fst tomerge) let si = SeekInput [] starting "merge" ai si $ do- warning $ UnquotedString $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ unwords (map Git.fromRef tomerge) ++ " into it."+ warning $ UnquotedString $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ unwords (map (Git.fromRef . fst) tomerge) ++ " into it." next $ return False Nothing -> stop @@ -468,34 +476,62 @@ -- -- Usually this is the sync branch. However, when in an adjusted branch, -- it can be either the sync branch or the original branch, or both.-needMerge :: CurrBranch -> Git.Branch -> Annex [Git.Branch]+--+-- Branches are accompanied by an action to run once they have been+-- successfully merged.+needMerge :: CurrBranch -> Git.Branch -> Annex [(Git.Branch, Annex ())] needMerge currbranch headbranch | is_branchView headbranch = return [] | otherwise = ifM isBareRepo ( return [] , do- syncbranchret <- usewhen syncbranch syncbranchchecks+ syncbranchret <- usewhen (removeaftermerge syncbranch) syncbranchchecks adjbranchret <- case currbranch of (Just origbranch, Just adj) -> - usewhen origbranch $+ usewhen (pure (origbranch, noop)) $ canMergeToAdjustedBranch origbranch (origbranch, adj) _ -> return [] return (syncbranchret++adjbranchret) ) where- usewhen v c = ifM c- ( return [v]+ usewhen getv c = ifM c+ ( do+ v <- getv+ return [v] , return [] ) syncbranch = syncBranch headbranch+ syncbranchchecks = case currbranch of (Just _, madj) -> syncbranchchanged madj (Nothing, _) -> hassyncbranch+ hassyncbranch = inRepo (Git.Ref.exists syncbranch)- syncbranchchanged madj =++ syncbranchchanged madj = do let branch' = maybe headbranch (adjBranch . originalToAdjusted headbranch) madj- in hassyncbranch <&&> inRepo (Git.Branch.changed branch' syncbranch)+ inRepo (Git.Ref.sha syncbranch) >>= \case+ Nothing -> return False+ Just sha -> ifM (inRepo $ Git.Branch.changed branch' sha)+ ( return True+ , do+ removewhenunchanged (Just sha) syncbranch+ return False+ ) + -- Remove the ref after merging, but only if its value does not+ -- change in the meantime. The sync branch can get changes pushed+ -- to it at any time, and this avoids losing them.+ removeaftermerge b = do+ sorig <- inRepo $ Git.Ref.sha b+ return (b, removewhenunchanged sorig b)+ + removewhenunchanged sorig b =+ inRepo (Git.Ref.sha b) >>= \case+ Just s | Just s == sorig ->+ inRepo $ Git.Ref.deleteQuiet s b+ _ -> noop+ updateLocal :: SyncOptions -> CurrBranch -> CommandStart updateLocal o b = stopUnless (notOnlyAnnex o) $ do updateBranches (pullOption o || syncmode) (pushOption o || syncmode) b@@ -519,9 +555,6 @@ when forpull $ updateadjustedbranch adj Nothing -> noop- - -- Update the sync branch to match the new state of the branch- inRepo $ updateBranch (syncBranch branch) (fromViewBranch branch) where -- The adjusted branch may need to be updated, if the adjustment -- is not stable, and the usual configuration does not update it.@@ -636,7 +669,7 @@ wantpull = remoteAnnexPull (Remote.gitconfig remote) -{- The remote probably has both a master and a synced/master branch.+{- The remote often has both a master and a synced/master branch. - Which to merge from? Well, the master has whatever latest changes - were committed (or pushed changes, if this is a bare remote), - while the synced/master may have changes that some@@ -647,20 +680,22 @@ , case currbranch of (Nothing, _) -> do branch <- inRepo Git.Branch.currentUnsafe- mergelisted (pure (branchlist branch))- (Just branch, _) -> do- inRepo $ updateBranch (syncBranch branch) branch- mergelisted (tomerge (branchlist (Just branch)))+ domerge =<< branchlist branch+ (Just branch, _) ->+ domerge+ =<< changedfrom branch+ =<< branchlist (Just branch) ) where- mergelisted getlist =- merge currbranch mergeconfig o Git.Branch.ManualCommit- =<< map (remoteBranch remote) <$> getlist- tomerge = filterM (changed remote)- branchlist Nothing = []+ domerge = merge currbranch mergeconfig o Git.Branch.ManualCommit . map (\b -> (b, noop))+ changedfrom branch = filterM (inRepo . Git.Branch.changed branch)+ branchlist Nothing = pure [] branchlist (Just branch)- | is_branchView branch = []- | otherwise = [origBranch branch, syncBranch branch]+ | is_branchView branch = pure []+ | otherwise = filterM (inRepo . Git.Ref.exists)+ [ remoteBranch remote (origBranch branch)+ , remoteBranch remote (syncBranch branch)+ ] pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart pushRemote _o _remote (Nothing, _) = stop@@ -686,9 +721,14 @@ needpush mainbranch | remoteAnnexReadOnly gc = return False | not (remoteAnnexPush gc) = return False- | otherwise = anyM (newer remote) $ catMaybes- [ syncBranch <$> mainbranch- , Just (Annex.Branch.name)+ | otherwise = anyM id $ concat+ [ case mainbranch of+ Just b ->+ [ newer remote b b True+ , newer remote (syncBranch b) b False+ ]+ Nothing -> []+ , [ newer remote Annex.Branch.name Annex.Branch.name True ] ] -- Older remotes on crippled filesystems may not have a -- post-receive hook set up, so when updateInstead emulation@@ -717,7 +757,7 @@ - branch directly to it, so that cloning/pulling will get it. - On the other hand, if it's not bare, pushing to the checked out branch - will generally fail (except with receive.denyCurrentBranch=updateInstead),- - and this is why we push to its syncBranch.+ - and this is when it's useful to push to its syncBranch. - - Git offers no way to tell if a remote is bare or not, so both methods - are tried.@@ -726,8 +766,9 @@ - github may treat the first branch pushed to a new repository as the - default branch for that repository. -- - The sync push first sends the synced/master branch,- - and then forces the update of the remote synced/git-annex branch.+ - The sync push first sends the synced/master branch+ - (when the direct push failed), and then forces the update of + - the remote synced/git-annex branch. - - The forcing is necessary if a transition has rewritten the git-annex branch. - Normally any changes to the git-annex branch get pulled and merged before@@ -756,16 +797,18 @@ pushparams True [ Git.fromRef $ Git.Ref.base $ origBranch branch ] let p' = p { std_err = CreatePipe }- bracket (createProcess p') cleanupProcess $ \h -> do+ exitcode <- bracket (createProcess p') cleanupProcess $ \h -> do filterstderr [] (stderrHandle h) (processHandle h)- void $ waitForProcess (processHandle h)- return True- Nothing -> return False- - syncpush directpushed = do+ waitForProcess (processHandle h)+ return (True, exitcode == ExitSuccess)+ Nothing -> return (False, False)+ + syncpush (directpushed, directbranchupdated) = do let p = flip Git.Command.gitCreateProcess g $ pushparams (not directpushed) $ catMaybes- [ (syncrefspec . origBranch) <$> mbranch+ [ if not directbranchupdated+ then (syncrefspec . origBranch) <$> mbranch+ else Nothing , Just $ Git.Branch.forcePush $ syncrefspec Annex.Branch.name ] -- stderr is relayed through a pipe so that the push@@ -833,20 +876,12 @@ void Annex.Branch.forceUpdate stop -changed :: Remote -> Git.Ref -> Annex Bool-changed remote b = do- let r = remoteBranch remote b- ifM (inRepo $ Git.Ref.exists r)- ( inRepo $ Git.Branch.changed b r- , return False- )--newer :: Remote -> Git.Ref -> Annex Bool-newer remote b = do- let r = remoteBranch remote b+newer :: Remote -> Git.Ref -> Git.Ref -> Bool -> Annex Bool+newer remote rb b dne = do+ let r = remoteBranch remote rb ifM (inRepo $ Git.Ref.exists r) ( inRepo $ Git.Branch.changed r b- , return True+ , return dne ) {- Without --all, only looks at files in the work tree.@@ -894,7 +929,8 @@ where seekworktree mvar l bloomfeeder = do let seeker = AnnexedFileSeeker- { startAction = const $ gofile bloomfeeder mvar+ { startAction = startSingle $ + const $ gofile bloomfeeder mvar , checkContentPresent = Nothing , usesLocationLog = True }@@ -1008,10 +1044,7 @@ wantput lu r | pushOption o == False && not satisfymode = return False- | Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False- | isImport r && not (isExport r) = return False- | isExport r && not (exportHasAnnexObjects r) = return False- | isThirdPartyPopulated r = return False+ | not (Remote.canPut r) = return False | otherwise = wantGetBy lu True (Just k) af (Remote.uuid r) handleput lack inhere | inhere = catMaybes <$>@@ -1023,8 +1056,8 @@ ) ) | otherwise = return []- put lu dest = includeCommandAction $ - Command.Move.toStart' lu dest Command.Move.RemoveNever af k ai si+ put lu dest = includeCommandAction $+ Command.Move.toStart' lu dest Command.Move.Put af k ai si dropfromhere = changehere && (pullOption o || satisfymode) @@ -1036,7 +1069,7 @@ ai = mkActionItem (k, af) si = SeekInput []-+ {- When a remote has an annex-tracking-branch configuration, and that branch - is currently checked out, change the export to contain the current content - of the branch. (If the branch is not currently checked out, anything@@ -1053,7 +1086,7 @@ seekExportContent o rs currbranch = seekExportContent' o (filter canexportcontent rs) currbranch where- canexportcontent r = isExport r && not (isProxied r)+ canexportcontent r = Remote.isExport r && not (isProxied r) seekExportContent' :: Maybe SyncOptions -> [Remote] -> CurrBranch -> Annex Bool seekExportContent' o rs (mcurrbranch, madj)@@ -1219,21 +1252,6 @@ | onlyAnnexOption o = pure True | otherwise = getGitConfigVal annexSyncOnlyAnnex -isExport :: Remote -> Bool-isExport = exportTree . Remote.config--isImport :: Remote -> Bool-isImport = importTree . Remote.config--isProxied :: Remote -> Bool-isProxied = isJust . remoteAnnexProxiedBy . Remote.gitconfig--exportHasAnnexObjects :: Remote -> Bool-exportHasAnnexObjects = annexObjects . Remote.config--isThirdPartyPopulated :: Remote -> Bool-isThirdPartyPopulated = Remote.thirdPartyPopulated . Remote.remotetype- {- Support for push-to-create of git repositories. - - When the remote does not exist yet, annex-ignore and@@ -1273,3 +1291,7 @@ case filter (\r' -> Remote.name r' == Remote.name r) rs of (r':_) -> return r' _ -> return r++isProxied :: Remote -> Bool+isProxied = isJust . remoteAnnexProxiedBy . Remote.gitconfig+
Command/Unannex.hs view
@@ -34,7 +34,7 @@ seeker :: Bool -> AnnexedFileSeeker seeker fast = AnnexedFileSeeker- { startAction = const $ start fast+ { startAction = startSingle $ const $ start fast , checkContentPresent = Just True , usesLocationLog = False }
Command/Unlock.hs view
@@ -35,7 +35,7 @@ where ww = WarnUnmatchLsFiles "unlock" seeker = AnnexedFileSeeker- { startAction = const start+ { startAction = startSingle $ const start , checkContentPresent = Nothing , usesLocationLog = False }
Command/WhereUsed.hs view
@@ -49,7 +49,7 @@ (commandAction . start o) dummyfilecommandseek (WorkTreeItems []) where dummyfileseeker = AnnexedFileSeeker- { startAction = \_ _ _ _ -> return Nothing+ { startAction = startSingle $ \_ _ _ _ -> return Nothing , checkContentPresent = Nothing , usesLocationLog = False }
Command/Whereis.hs view
@@ -52,7 +52,7 @@ seek o = do m <- remoteMap id let seeker = AnnexedFileSeeker- { startAction = const $ start o m+ { startAction = startSingle $ const $ start o m , checkContentPresent = Nothing , usesLocationLog = True }
Git/Ref.hs view
@@ -178,8 +178,12 @@ in (Ref r, Ref b) {- Deletes a ref when it contains the specified sha. - - This can delete refs that are not branches, which- - git branch --delete refuses to delete. -}+ -+ - This can delete refs that are not branches, which git branch --delete+ - refuses to delete.+ -+ - Displays a warning on stderr if the ref does not contain the specified sha.+ -} delete :: Sha -> Ref -> Repo -> IO () delete oldvalue ref = run [ Param "update-ref"@@ -187,6 +191,15 @@ , Param $ fromRef ref , Param $ fromRef oldvalue ]++{- Like delete, but with no output on stderr. -}+deleteQuiet :: Sha -> Ref -> Repo -> IO ()+deleteQuiet oldvalue ref r = void $ tryNonAsync $ runQuiet+ [ Param "update-ref"+ , Param "-d"+ , Param $ fromRef ref+ , Param $ fromRef oldvalue+ ] r {- Deletes a ref no matter what it contains. -} delete' :: Ref -> Repo -> IO ()
P2P/Protocol.hs view
@@ -21,7 +21,7 @@ import Types.UUID import Types.Transfer import Types.Remote (Verification(..))-import Utility.Hash (IncrementalVerifier(..))+import Utility.Hash.Incremental import Utility.AuthToken import Utility.Applicative import Utility.PartialPrelude
Remote.hs view
@@ -1,6 +1,6 @@ {- git-annex remotes -- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -65,6 +65,11 @@ isExportSupported, gitSyncableRemote, gitSyncableRemoteType,+ contentRemotes,+ canPut,+ isExport,+ isImport,+ isThirdPartyPopulated, ) where import Data.Ord@@ -75,6 +80,7 @@ import Annex.Common import Types.Remote import qualified Annex+import Annex.SpecialRemote.Config import Annex.UUID import Annex.Action import Logs.UUID@@ -463,3 +469,29 @@ | otherwise = case remoteUrl (gitconfig r) of Just u | "annex::" `isPrefixOf` u -> True _ -> False++{- Filters a list of remotes to those that contain annex object content. -}+contentRemotes :: [Remote] -> Annex [Remote]+contentRemotes remotes = + filter (\r -> uuid r /= NoUUID)+ <$> filterM (not <$$> ignored) remotes+ where+ ignored = liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig++{- Can annex objects be stored on a remote? -}+canPut :: Remote -> Bool+canPut r+ | readonly r || remoteAnnexReadOnly (gitconfig r) = False+ | isImport r && not (isExport r) = False+ | isExport r && not (annexObjects (config r)) = False+ | isThirdPartyPopulated r = False+ | otherwise = True++isExport :: Remote -> Bool+isExport = exportTree . config++isImport :: Remote -> Bool+isImport = importTree . config++isThirdPartyPopulated :: Remote -> Bool+isThirdPartyPopulated = thirdPartyPopulated . remotetype
Remote/Bup.hs view
@@ -323,7 +323,7 @@ bupRef :: Key -> String bupRef k | Git.Ref.legal True shown = shown- | otherwise = "git-annex-" ++ show (sha2_256 (fromString shown))+ | otherwise = "git-annex-" ++ show (digestToHash (sha2_256 (fromString shown))) where shown = serializeKey k
Remote/External.hs view
@@ -1073,7 +1073,7 @@ delegatename = concat [ fromMaybe "external" (externalRemoteName external) , "-delegate-"- , show $ md5s $ encodeBS $ show ps+ , show $ digestToHash $ md5s $ encodeBS $ show ps ] gendelegate = do
Remote/GitLFS.hs view
@@ -422,7 +422,8 @@ rememberboth sha256 size ret sha256 size where- calcsha256 = liftIO $ T.pack . show . sha2_256 <$> F.readFile content+ calcsha256 = T.pack . show . digestToHash . sha2_256 + <$> liftIO (F.readFile content) ret sha256 size = do let obj = LFS.TransferRequestObject { LFS.req_oid = sha256
Remote/Glacier.hs view
@@ -28,7 +28,7 @@ import Annex.UUID import Utility.Env import Types.ProposedAccepted-import Utility.Hash (IncrementalVerifier)+import Utility.Hash.Incremental type Vault = String type Archive = FilePath
Remote/Helper/Http.hs view
@@ -13,7 +13,7 @@ import Types.StoreRetrieve import Remote.Helper.Special import Utility.Metered-import Utility.Hash (IncrementalVerifier(..))+import Utility.Hash.Incremental import qualified Utility.FileIO as F import qualified Data.ByteString.Lazy as L
RemoteDaemon/Transport/P2PGeneric.hs view
@@ -84,7 +84,7 @@ createAnnexDirectory d -- Since unix socket path length is limited, use a md5sum of -- the netname and address.- let f = d </> toOsPath (show (md5 (encodeBL (netname ++ ":" ++ address))))+ let f = d </> toOsPath (hashByteString (digestToHash (md5 (encodeBL (netname ++ ":" ++ address))))) -- Use whichever is shorter of the absolute or relative path. relf <- liftIO $ relPathCwdToFile f absf <- liftIO $ absPath f
Test.hs view
@@ -73,12 +73,12 @@ import qualified Utility.FileMode import qualified BuildInfo import qualified Utility.Format-import qualified Utility.Verifiable import qualified Utility.Process import qualified Utility.Misc import qualified Utility.InodeCache import qualified Utility.Matcher import qualified Utility.Hash+import qualified Utility.HMAC import qualified Utility.Scheduled import qualified Utility.Scheduled.QuickCheck import qualified Utility.HumanTime@@ -178,7 +178,6 @@ , testProperty "prop_HmacSha1WithCipher_sane" Crypto.prop_HmacSha1WithCipher_sane , testProperty "prop_VectorClock_sane" Annex.VectorClock.prop_VectorClock_sane , testProperty "prop_addMapLog_sane" Logs.MapLog.prop_addMapLog_sane- , testProperty "prop_verifiable_sane" Utility.Verifiable.prop_verifiable_sane , testProperty "prop_segment_regressionTest" Utility.Misc.prop_segment_regressionTest , testProperty "prop_read_write_transferinfo" Logs.Transfer.prop_read_write_transferinfo , testProperty "prop_read_show_inodecache" Utility.InodeCache.prop_read_show_inodecache@@ -201,7 +200,7 @@ where combos = concat [ Utility.Hash.props_hashes_stable- , Utility.Hash.props_macs_stable+ , Utility.HMAC.props_macs_stable ] testRemotes :: TestTree
Types/ActionItem.hs view
@@ -1,6 +1,6 @@ {- items that a command can act on -- - Copyright 2016-2023 Joey Hess <id@joeyh.name>+ - Copyright 2016-2026 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -29,6 +29,7 @@ | ActionItemUUID UUID StringContainingQuotedPath -- ^ UUID with a description or name of the repository | ActionItemOther (Maybe StringContainingQuotedPath)+ | ActionItemForUUID UUID ActionItem | OnlyActionOn Key ActionItem -- ^ Use to avoid more than one thread concurrently processing the -- same Key.@@ -85,6 +86,7 @@ actionItemDesc (ActionItemUUID _ desc) = desc actionItemDesc (ActionItemOther Nothing) = mempty actionItemDesc (ActionItemOther (Just v)) = v+actionItemDesc (ActionItemForUUID _ ai) = actionItemDesc ai actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai actionItemKey :: ActionItem -> Maybe Key@@ -95,21 +97,26 @@ actionItemKey (ActionItemTreeFile _) = Nothing actionItemKey (ActionItemUUID _ _) = Nothing actionItemKey (ActionItemOther _) = Nothing+actionItemKey (ActionItemForUUID _ ai) = actionItemKey ai actionItemKey (OnlyActionOn _ ai) = actionItemKey ai actionItemFile :: ActionItem -> Maybe OsPath actionItemFile (ActionItemAssociatedFile (AssociatedFile af) _) = af actionItemFile (ActionItemTreeFile f) = Just f actionItemFile (ActionItemUUID _ _) = Nothing+actionItemFile (ActionItemForUUID _ ai) = actionItemFile ai actionItemFile (OnlyActionOn _ ai) = actionItemFile ai actionItemFile _ = Nothing actionItemUUID :: ActionItem -> Maybe UUID actionItemUUID (ActionItemUUID uuid _) = Just uuid+actionItemUUID (ActionItemForUUID uuid _) = Just uuid+actionItemUUID (OnlyActionOn _ ai) = actionItemUUID ai actionItemUUID _ = Nothing actionItemTransferDirection :: ActionItem -> Maybe Direction actionItemTransferDirection (ActionItemFailedTransfer t _) = Just $ transferDirection t+actionItemTransferDirection (ActionItemForUUID _ ai) = actionItemTransferDirection ai actionItemTransferDirection (OnlyActionOn _ ai) = actionItemTransferDirection ai actionItemTransferDirection _ = Nothing
Types/Backend.hs view
@@ -14,7 +14,7 @@ import Utility.Metered import Utility.OsPath import Utility.FileSystemEncoding-import Utility.Hash (IncrementalVerifier)+import Utility.Hash.Incremental data BackendA a = Backend { backendVariety :: KeyVariety@@ -26,6 +26,12 @@ -- hash as verifyKeyContent, but with the content provided -- incrementally a piece at a time, until finalized. , verifyKeyContentIncrementally :: Maybe (Key -> a IncrementalVerifier)+ -- Is verifyKeyContent sufficiently faster than+ -- verifyKeyContentIncrementally that it should be used when the+ -- content of the file is already available? (Even if so, it+ -- still makes sense to use verifyKeyContentIncrementally when+ -- downloading a file.)+ , verifyKeyContentIsFaster :: Bool -- Checks if a key can be upgraded to a better form. , canUpgradeKey :: Maybe (Key -> Bool) -- Checks if there is a fast way to migrate a key to a different
Types/Crypto.hs view
@@ -20,7 +20,7 @@ calcMac, ) where -import Utility.Hash+import Utility.HMAC import Utility.Gpg (KeyIds(..)) import Data.Typeable
Types/Key.hs view
@@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings, DeriveGeneric #-} module Types.Key (@@ -213,6 +214,12 @@ | Blake2bpKey HashSize HasExt | Blake2sKey HashSize HasExt | Blake2spKey HashSize HasExt+#ifdef WITH_BLAKE3+ | Blake3Key HasExt+#endif+#ifdef WITH_XXH3+ | XXH3Key HasExt+#endif | SHA1Key HasExt | MD5Key HasExt | WORMKey@@ -249,6 +256,12 @@ hasExt (Blake2bpKey _ (HasExt b)) = b hasExt (Blake2sKey _ (HasExt b)) = b hasExt (Blake2spKey _ (HasExt b)) = b+#ifdef WITH_BLAKE3+hasExt (Blake3Key (HasExt b)) = b+#endif+#ifdef WITH_XXH3+hasExt (XXH3Key (HasExt b)) = b+#endif hasExt (SHA1Key (HasExt b)) = b hasExt (MD5Key (HasExt b)) = b hasExt WORMKey = False@@ -267,6 +280,12 @@ sameExceptExt (Blake2bpKey sz1 _) (Blake2bpKey sz2 _) = sz1 == sz2 sameExceptExt (Blake2sKey sz1 _) (Blake2sKey sz2 _) = sz1 == sz2 sameExceptExt (Blake2spKey sz1 _) (Blake2spKey sz2 _) = sz1 == sz2+#ifdef WITH_BLAKE3+sameExceptExt (Blake3Key _) (Blake3Key _) = True+#endif+#ifdef WITH_XXH3+sameExceptExt (XXH3Key _) (XXH3Key _) = True+#endif sameExceptExt (SHA1Key _) (SHA1Key _) = True sameExceptExt (MD5Key _) (MD5Key _) = True sameExceptExt _ _ = False@@ -280,6 +299,12 @@ Blake2bpKey sz e -> adde e (addsz sz "BLAKE2BP") Blake2sKey sz e -> adde e (addsz sz "BLAKE2S") Blake2spKey sz e -> adde e (addsz sz "BLAKE2SP")+#ifdef WITH_BLAKE3+ Blake3Key e -> adde e "BLAKE3_256"+#endif+#ifdef WITH_XXH3+ XXH3Key e -> adde e "XXH3"+#endif SHA1Key e -> adde e "SHA1" MD5Key e -> adde e "MD5" WORMKey -> "WORM"@@ -345,6 +370,14 @@ parseKeyVariety "BLAKE2SP224E" = Blake2spKey (HashSize 224) (HasExt True) parseKeyVariety "BLAKE2SP256" = Blake2spKey (HashSize 256) (HasExt False) parseKeyVariety "BLAKE2SP256E" = Blake2spKey (HashSize 256) (HasExt True)+#ifdef WITH_BLAKE3+parseKeyVariety "BLAKE3_256" = Blake3Key (HasExt False)+parseKeyVariety "BLAKE3_256E" = Blake3Key (HasExt True)+#endif+#ifdef WITH_XXH3+parseKeyVariety "XXH3" = XXH3Key (HasExt False)+parseKeyVariety "XXH3E" = XXH3Key (HasExt True)+#endif parseKeyVariety "SHA1" = SHA1Key (HasExt False) parseKeyVariety "SHA1E" = SHA1Key (HasExt True) parseKeyVariety "MD5" = MD5Key (HasExt False)
Types/Remote.hs view
@@ -44,7 +44,7 @@ import Types.Export import Types.Import import Types.RemoteConfig-import Utility.Hash (IncrementalVerifier)+import Utility.Hash.Incremental import Config.Cost import Utility.Metered import Git.Types (RemoteName)
Types/StoreRetrieve.hs view
@@ -12,7 +12,7 @@ import Annex.Common import Types.NumCopies import Utility.Metered-import Utility.Hash (IncrementalVerifier)+import Utility.Hash.Incremental import qualified Data.ByteString.Lazy as L
Utility/AuthToken.hs view
@@ -23,10 +23,9 @@ import Utility.Hash import Utility.Exception -import Data.SecureMem import Data.Maybe import Data.Char-import Data.Byteable+import qualified Data.ByteArray as BA import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as L@@ -40,7 +39,7 @@ -- To avoid decoding issues, and presentation issues, the content -- of an AuthToken is limited to ASCII characters a-z, and 0-9. -- This is enforced by all exported AuthToken constructors.-newtype AuthToken = AuthToken SecureMem+newtype AuthToken = AuthToken BA.ScrubbedBytes deriving (Show, Eq) allowedChar :: Char -> Bool@@ -51,7 +50,7 @@ deserialize = toAuthToken . T.pack fromAuthToken :: AuthToken -> T.Text-fromAuthToken (AuthToken t ) = TE.decodeLatin1 (toBytes t)+fromAuthToken (AuthToken t ) = TE.decodeLatin1 (BA.convert t) -- | Upper-case characters are lower-cased to make them fit in the allowed -- character set. This allows AuthTokens to be compared effectively@@ -61,18 +60,18 @@ toAuthToken :: T.Text -> Maybe AuthToken toAuthToken t | all allowedChar s = Just $ AuthToken $ - secureMemFromByteString $ TE.encodeUtf8 $ T.pack s+ BA.convert $ TE.encodeUtf8 $ T.pack s | otherwise = Nothing where s = map toLower $ T.unpack t -- | The empty AuthToken, for those times when you don't want any security. nullAuthToken :: AuthToken-nullAuthToken = AuthToken $ secureMemFromByteString $ TE.encodeUtf8 T.empty+nullAuthToken = AuthToken $ BA.convert $ TE.encodeUtf8 T.empty -- | Display in place of a real AuthToken in protocol dumps. displayAuthToken :: AuthToken-displayAuthToken = AuthToken $ secureMemFromByteString $ TE.encodeUtf8 $ T.pack "<AUTHTOKEN>"+displayAuthToken = AuthToken $ BA.convert $ TE.encodeUtf8 $ T.pack "<AUTHTOKEN>" -- | Generates an AuthToken of a specified length. This is done by -- generating a random bytestring, hashing it with sha2 512, and truncating@@ -88,7 +87,8 @@ Left e -> giveup $ "failed to generate auth token: " ++ show e Right (s, _) -> fromMaybe (giveup "auth token encoding failed") $ toAuthToken $ T.pack $ take len $- show $ sha2_512 $ L.fromChunks [s]+ show $ digestToHash $ + sha2_512 $ L.fromChunks [s] -- | For when several AuthTokens are allowed to be used. newtype AllowedAuthTokens = AllowedAuthTokens [AuthToken]
+ Utility/HMAC.hs view
@@ -0,0 +1,56 @@+{- Convenience wrapper around crypton's HMACs+ -+ - Copyright 2013-2026 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}++module Utility.HMAC (+ Mac(..),+ calcMac,+ Digest,+ props_macs_stable,+) where++import qualified Data.ByteString as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import "crypton" Crypto.MAC.HMAC hiding (Context)+import "crypton" Crypto.Hash++data Mac = HmacSha1 | HmacSha224 | HmacSha256 | HmacSha384 | HmacSha512+ deriving (Eq)++calcMac+ :: (forall a. Digest a -> t) -- ^ applied to MAC'ed message+ -> Mac -- ^ MAC+ -> S.ByteString -- ^ secret key+ -> S.ByteString -- ^ message+ -> t+calcMac f mac = case mac of+ HmacSha1 -> use SHA1+ HmacSha224 -> use SHA224+ HmacSha256 -> use SHA256+ HmacSha384 -> use SHA384+ HmacSha512 -> use SHA512+ where+ use alg k m = f (hmacGetDigest (hmacWitnessAlg alg k m))++ hmacWitnessAlg :: HashAlgorithm a => a -> S.ByteString -> S.ByteString -> HMAC a+ hmacWitnessAlg _ = hmac++-- Check that all the MACs continue to produce the same.+props_macs_stable :: [(String, Bool)]+props_macs_stable = map (\(desc, mac, result) -> (desc ++ " stable", calcMac show mac key msg == result))+ [ ("HmacSha1", HmacSha1, "46b4ec586117154dacd49d664e5d63fdc88efb51")+ , ("HmacSha224", HmacSha224, "4c1f774863acb63b7f6e9daa9b5c543fa0d5eccf61e3ffc3698eacdd")+ , ("HmacSha256", HmacSha256, "f9320baf0249169e73850cd6156ded0106e2bb6ad8cab01b7bbbebe6d1065317")+ , ("HmacSha384", HmacSha384, "3d10d391bee2364df2c55cf605759373e1b5a4ca9355d8f3fe42970471eca2e422a79271a0e857a69923839015877fc6")+ , ("HmacSha512", HmacSha512, "114682914c5d017dfe59fdc804118b56a3a652a0b8870759cf9e792ed7426b08197076bf7d01640b1b0684df79e4b67e37485669e8ce98dbab60445f0db94fce")+ ]+ where+ key = T.encodeUtf8 $ T.pack "foo"+ msg = T.encodeUtf8 $ T.pack "bar"
Utility/Hash.hs view
@@ -1,349 +1,85 @@-{- Convenience wrapper around crypton's hashing.+{- Convenience wrapper for hashing libraries. -- - Copyright 2013-2024 Joey Hess <id@joeyh.name>+ - Copyright 2026 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} -{-# LANGUAGE BangPatterns, PackageImports #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings, CPP #-} -module Utility.Hash (- sha1,- sha1_context,- sha1s,- sha2_224,- sha2_224_context,- sha2_256,- sha2_256_context,- sha2_384,- sha2_384_context,- sha2_512,- sha2_512_context,- sha3_224,- sha3_224_context,- sha3_256,- sha3_256_context,- sha3_384,- sha3_384_context,- sha3_512,- sha3_512_context,- skein256,- skein256_context,- skein512,- skein512_context,- blake2s_160,- blake2s_160_context,- blake2s_224,- blake2s_224_context,- blake2s_256,- blake2s_256_context,- blake2sp_224,- blake2sp_224_context,- blake2sp_256,- blake2sp_256_context,- blake2b_160,- blake2b_160_context,- blake2b_224,- blake2b_224_context,- blake2b_256,- blake2b_256_context,- blake2b_384,- blake2b_384_context,- blake2b_512,- blake2b_512_context,- blake2bp_512,- blake2bp_512_context,- md5,- md5_context,- md5s,- hashUpdate,- hashFinalize,- Digest,- HashAlgorithm,- Context,- props_hashes_stable,- Mac(..),- calcMac,- props_macs_stable,- IncrementalHasher(..),- mkIncrementalHasher,- IncrementalVerifier(..),- mkIncrementalVerifier,-) where+module Utility.Hash (module X, props_hashes_stable) where -import qualified Data.ByteString as S+import Utility.Hash.Types as X+import Utility.Hash.Incremental as X+#ifdef WITH_BOTAN+import Utility.Hash.Botan as X+-- Fall back to crypton for hashes not in botan.+import Utility.Hash.Crypton as X+ ( skein256+ , skein256_hasher+ , blake2s_160+ , blake2s_160_hasher+ , blake2s_224+ , blake2s_224_hasher+ , blake2s_256+ , blake2s_256_hasher+ , blake2sp_224+ , blake2sp_224_hasher+ , blake2sp_256+ , blake2sp_256_hasher+ , blake2bp_512+ , blake2bp_512_hasher+ )+#else+import Utility.Hash.Crypton as X+#endif+#ifdef WITH_BLAKE3+import Utility.Hash.Blake3 as X+#endif+#ifdef WITH_XXH3+import Utility.Hash.XXH3 as X+#endif+ import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import qualified Data.Text.Encoding as T-import Data.IORef-import "crypton" Crypto.MAC.HMAC hiding (Context)-import "crypton" Crypto.Hash -sha1 :: L.ByteString -> Digest SHA1-sha1 = hashlazy--sha1_context :: Context SHA1-sha1_context = hashInit--sha1s :: S.ByteString -> Digest SHA1-sha1s = hash--sha2_224 :: L.ByteString -> Digest SHA224-sha2_224 = hashlazy--sha2_224_context :: Context SHA224-sha2_224_context = hashInit--sha2_256 :: L.ByteString -> Digest SHA256-sha2_256 = hashlazy--sha2_256_context :: Context SHA256-sha2_256_context = hashInit--sha2_384 :: L.ByteString -> Digest SHA384-sha2_384 = hashlazy--sha2_384_context :: Context SHA384-sha2_384_context = hashInit--sha2_512 :: L.ByteString -> Digest SHA512-sha2_512 = hashlazy--sha2_512_context :: Context SHA512-sha2_512_context = hashInit--sha3_224 :: L.ByteString -> Digest SHA3_224-sha3_224 = hashlazy--sha3_224_context :: Context SHA3_224-sha3_224_context = hashInit--sha3_256 :: L.ByteString -> Digest SHA3_256-sha3_256 = hashlazy--sha3_256_context :: Context SHA3_256-sha3_256_context = hashInit--sha3_384 :: L.ByteString -> Digest SHA3_384-sha3_384 = hashlazy--sha3_384_context :: Context SHA3_384-sha3_384_context = hashInit--sha3_512 :: L.ByteString -> Digest SHA3_512-sha3_512 = hashlazy--sha3_512_context :: Context SHA3_512-sha3_512_context = hashInit--skein256 :: L.ByteString -> Digest Skein256_256-skein256 = hashlazy--skein256_context :: Context Skein256_256-skein256_context = hashInit--skein512 :: L.ByteString -> Digest Skein512_512-skein512 = hashlazy--skein512_context :: Context Skein512_512-skein512_context = hashInit--blake2s_160 :: L.ByteString -> Digest Blake2s_160-blake2s_160 = hashlazy--blake2s_160_context :: Context Blake2s_160-blake2s_160_context = hashInit--blake2s_224 :: L.ByteString -> Digest Blake2s_224-blake2s_224 = hashlazy--blake2s_224_context :: Context Blake2s_224-blake2s_224_context = hashInit--blake2s_256 :: L.ByteString -> Digest Blake2s_256-blake2s_256 = hashlazy--blake2s_256_context :: Context Blake2s_256-blake2s_256_context = hashInit--blake2sp_224 :: L.ByteString -> Digest Blake2sp_224-blake2sp_224 = hashlazy--blake2sp_224_context :: Context Blake2sp_224-blake2sp_224_context = hashInit--blake2sp_256 :: L.ByteString -> Digest Blake2sp_256-blake2sp_256 = hashlazy--blake2sp_256_context :: Context Blake2sp_256-blake2sp_256_context = hashInit--blake2b_160 :: L.ByteString -> Digest Blake2b_160-blake2b_160 = hashlazy--blake2b_160_context :: Context Blake2b_160-blake2b_160_context = hashInit--blake2b_224 :: L.ByteString -> Digest Blake2b_224-blake2b_224 = hashlazy--blake2b_224_context :: Context Blake2b_224-blake2b_224_context = hashInit--blake2b_256 :: L.ByteString -> Digest Blake2b_256-blake2b_256 = hashlazy--blake2b_256_context :: Context Blake2b_256-blake2b_256_context = hashInit--blake2b_384 :: L.ByteString -> Digest Blake2b_384-blake2b_384 = hashlazy--blake2b_384_context :: Context Blake2b_384-blake2b_384_context = hashInit--blake2b_512 :: L.ByteString -> Digest Blake2b_512-blake2b_512 = hashlazy--blake2b_512_context :: Context Blake2b_512-blake2b_512_context = hashInit--blake2bp_512 :: L.ByteString -> Digest Blake2bp_512-blake2bp_512 = hashlazy--blake2bp_512_context :: Context Blake2bp_512-blake2bp_512_context = hashInit--md5 :: L.ByteString -> Digest MD5-md5 = hashlazy--md5_context :: Context MD5-md5_context = hashInit--md5s :: S.ByteString -> Digest MD5-md5s = hash- {- Check that all the hashes continue to hash the same. -} props_hashes_stable :: [(String, Bool)]-props_hashes_stable = map (\(desc, hasher, result) -> (desc ++ " stable", hasher foo == result))- [ ("sha1", show . sha1, "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33")- , ("sha2_224", show . sha2_224, "0808f64e60d58979fcb676c96ec938270dea42445aeefcd3a4e6f8db")- , ("sha2_256", show . sha2_256, "2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae")- , ("sha2_384", show . sha2_384, "98c11ffdfdd540676b1a137cb1a22b2a70350c9a44171d6b1180c6be5cbb2ee3f79d532c8a1dd9ef2e8e08e752a3babb")- , ("sha2_512", show . sha2_512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7")- , ("skein256", show . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33")- , ("skein512", show . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7")- , ("sha3_224", show . sha3_224, "f4f6779e153c391bbd29c95e72b0708e39d9166c7cea51d1f10ef58a")- , ("sha3_256", show . sha3_256, "76d3bc41c9f588f7fcd0d5bf4718f8f84b1c41b20882703100b9eb9413807c01")- , ("sha3_384", show . sha3_384, "665551928d13b7d84ee02734502b018d896a0fb87eed5adb4c87ba91bbd6489410e11b0fbcc06ed7d0ebad559e5d3bb5")- , ("sha3_512", show . sha3_512, "4bca2b137edc580fe50a88983ef860ebaca36c857b1f492839d6d7392452a63c82cbebc68e3b70a2a1480b4bb5d437a7cba6ecf9d89f9ff3ccd14cd6146ea7e7")- , ("blake2s_160", show . blake2s_160, "52fb63154f958a5c56864597273ea759e52c6f00")- , ("blake2s_224", show . blake2s_224, "9466668503ac415d87b8e1dfd7f348ab273ac1d5e4f774fced5fdb55")- , ("blake2s_256", show . blake2s_256, "08d6cad88075de8f192db097573d0e829411cd91eb6ec65e8fc16c017edfdb74")- , ("blake2sp_224", show . blake2sp_224, "8492d356fbac99f046f55e114301f7596649cb590e5b083d1a19dcdb")- , ("blake2sp_256", show . blake2sp_256, "050dc5786037ea72cb9ed9d0324afcab03c97ec02e8c47368fc5dfb4cf49d8c9")- , ("blake2b_160", show . blake2b_160, "983ceba2afea8694cc933336b27b907f90c53a88")- , ("blake2b_224", show . blake2b_224, "853986b3fe231d795261b4fb530e1a9188db41e460ec4ca59aafef78")- , ("blake2b_256", show . blake2b_256, "b8fe9f7f6255a6fa08f668ab632a8d081ad87983c77cd274e48ce450f0b349fd")- , ("blake2b_384", show . blake2b_384, "e629ee880953d32c8877e479e3b4cb0a4c9d5805e2b34c675b5a5863c4ad7d64bb2a9b8257fac9d82d289b3d39eb9cc2")- , ("blake2b_512", show . blake2b_512, "ca002330e69d3e6b84a46a56a6533fd79d51d97a3bb7cad6c2ff43b354185d6dc1e723fb3db4ae0737e120378424c714bb982d9dc5bbd7a0ab318240ddd18f8d")- , ("blake2bp_512", show . blake2bp_512, "8ca9ccee7946afcb686fe7556628b5ba1bf9a691da37ca58cd049354d99f37042c007427e5f219b9ab5063707ec6823872dee413ee014b4d02f2ebb6abb5f643")- , ("md5", show . md5, "acbd18db4cc2f85cedef654fccc4a4d8")+props_hashes_stable = map testhash $+ [ ("sha1", digestToHash . sha1, "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33")+ , ("sha2_224", digestToHash . sha2_224, "0808f64e60d58979fcb676c96ec938270dea42445aeefcd3a4e6f8db")+ , ("sha2_256", digestToHash . sha2_256, "2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae")+ , ("sha2_384", digestToHash . sha2_384, "98c11ffdfdd540676b1a137cb1a22b2a70350c9a44171d6b1180c6be5cbb2ee3f79d532c8a1dd9ef2e8e08e752a3babb")+ , ("sha2_512", digestToHash . sha2_512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7")+ , ("skein256", digestToHash . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33")+ , ("skein512", digestToHash . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7")+ , ("sha3_224", digestToHash . sha3_224, "f4f6779e153c391bbd29c95e72b0708e39d9166c7cea51d1f10ef58a")+ , ("sha3_256", digestToHash . sha3_256, "76d3bc41c9f588f7fcd0d5bf4718f8f84b1c41b20882703100b9eb9413807c01")+ , ("sha3_384", digestToHash . sha3_384, "665551928d13b7d84ee02734502b018d896a0fb87eed5adb4c87ba91bbd6489410e11b0fbcc06ed7d0ebad559e5d3bb5")+ , ("sha3_512", digestToHash . sha3_512, "4bca2b137edc580fe50a88983ef860ebaca36c857b1f492839d6d7392452a63c82cbebc68e3b70a2a1480b4bb5d437a7cba6ecf9d89f9ff3ccd14cd6146ea7e7")+ , ("blake2s_160", digestToHash . blake2s_160, "52fb63154f958a5c56864597273ea759e52c6f00")+ , ("blake2s_224", digestToHash . blake2s_224, "9466668503ac415d87b8e1dfd7f348ab273ac1d5e4f774fced5fdb55")+ , ("blake2s_256", digestToHash . blake2s_256, "08d6cad88075de8f192db097573d0e829411cd91eb6ec65e8fc16c017edfdb74")+ , ("blake2sp_224", digestToHash . blake2sp_224, "8492d356fbac99f046f55e114301f7596649cb590e5b083d1a19dcdb")+ , ("blake2sp_256", digestToHash . blake2sp_256, "050dc5786037ea72cb9ed9d0324afcab03c97ec02e8c47368fc5dfb4cf49d8c9")+ , ("blake2b_160", digestToHash . blake2b_160, "983ceba2afea8694cc933336b27b907f90c53a88")+ , ("blake2b_224", digestToHash . blake2b_224, "853986b3fe231d795261b4fb530e1a9188db41e460ec4ca59aafef78")+ , ("blake2b_256", digestToHash . blake2b_256, "b8fe9f7f6255a6fa08f668ab632a8d081ad87983c77cd274e48ce450f0b349fd")+ , ("blake2b_384", digestToHash . blake2b_384, "e629ee880953d32c8877e479e3b4cb0a4c9d5805e2b34c675b5a5863c4ad7d64bb2a9b8257fac9d82d289b3d39eb9cc2")+ , ("blake2b_512", digestToHash . blake2b_512, "ca002330e69d3e6b84a46a56a6533fd79d51d97a3bb7cad6c2ff43b354185d6dc1e723fb3db4ae0737e120378424c714bb982d9dc5bbd7a0ab318240ddd18f8d")+ , ("blake2bp_512", digestToHash . blake2bp_512, "8ca9ccee7946afcb686fe7556628b5ba1bf9a691da37ca58cd049354d99f37042c007427e5f219b9ab5063707ec6823872dee413ee014b4d02f2ebb6abb5f643")+ , ("md5", digestToHash . md5, "acbd18db4cc2f85cedef654fccc4a4d8") ]+#ifdef WITH_BLAKE3+ ++ [("blake3", blake3, "04e0bb39f30b1a3feb89f536c93be15055482df748674b00d26e5a75777702e9")]+#endif+#ifdef WITH_XXH3+ ++ if xxh3Supported+ then [("xxh3", digestToHash . xxh3, "ab6e5f64077e7d8a")]+ else []+#endif where+ testhash (desc, hasher, result) = + (desc ++ " stable", hasher foo == result) foo = L.fromChunks [T.encodeUtf8 $ T.pack "foo"]--data Mac = HmacSha1 | HmacSha224 | HmacSha256 | HmacSha384 | HmacSha512- deriving (Eq)--calcMac- :: (forall a. Digest a -> t) -- ^ applied to MAC'ed message- -> Mac -- ^ MAC- -> S.ByteString -- ^ secret key- -> S.ByteString -- ^ message- -> t-calcMac f mac = case mac of- HmacSha1 -> use SHA1- HmacSha224 -> use SHA224- HmacSha256 -> use SHA256- HmacSha384 -> use SHA384- HmacSha512 -> use SHA512- where- use alg k m = f (hmacGetDigest (hmacWitnessAlg alg k m))-- hmacWitnessAlg :: HashAlgorithm a => a -> S.ByteString -> S.ByteString -> HMAC a- hmacWitnessAlg _ = hmac---- Check that all the MACs continue to produce the same.-props_macs_stable :: [(String, Bool)]-props_macs_stable = map (\(desc, mac, result) -> (desc ++ " stable", calcMac show mac key msg == result))- [ ("HmacSha1", HmacSha1, "46b4ec586117154dacd49d664e5d63fdc88efb51")- , ("HmacSha224", HmacSha224, "4c1f774863acb63b7f6e9daa9b5c543fa0d5eccf61e3ffc3698eacdd")- , ("HmacSha256", HmacSha256, "f9320baf0249169e73850cd6156ded0106e2bb6ad8cab01b7bbbebe6d1065317")- , ("HmacSha384", HmacSha384, "3d10d391bee2364df2c55cf605759373e1b5a4ca9355d8f3fe42970471eca2e422a79271a0e857a69923839015877fc6")- , ("HmacSha512", HmacSha512, "114682914c5d017dfe59fdc804118b56a3a652a0b8870759cf9e792ed7426b08197076bf7d01640b1b0684df79e4b67e37485669e8ce98dbab60445f0db94fce")- ]- where- key = T.encodeUtf8 $ T.pack "foo"- msg = T.encodeUtf8 $ T.pack "bar"--data IncrementalHasher = IncrementalHasher- { updateIncrementalHasher :: S.ByteString -> IO ()- -- ^ Called repeatedly on each piece of the content.- , finalizeIncrementalHasher :: IO (Maybe String)- -- ^ Called once the full content has been sent, returns- -- the hash. (Nothing if unableIncremental was called.)- , unableIncrementalHasher :: IO ()- -- ^ Call if the incremental hashing is unable to be done.- , positionIncrementalHasher :: IO (Maybe Integer)- -- ^ Returns the number of bytes that have been fed to this- -- incremental hasher so far. (Nothing if unableIncremental was- -- called.)- , descIncrementalHasher :: String- }--mkIncrementalHasher :: HashAlgorithm h => Context h -> String -> IO IncrementalHasher-mkIncrementalHasher ctx desc = do- v <- newIORef (Just (ctx, 0))- return $ IncrementalHasher- { updateIncrementalHasher = \b ->- modifyIORef' v $ \case- (Just (ctx', n)) -> - let !ctx'' = hashUpdate ctx' b- !n' = n + fromIntegral (S.length b)- in (Just (ctx'', n'))- Nothing -> Nothing- , finalizeIncrementalHasher =- readIORef v >>= \case- (Just (ctx', _)) -> do- let digest = hashFinalize ctx'- return $ Just $ show digest- Nothing -> return Nothing- , unableIncrementalHasher = writeIORef v Nothing- , positionIncrementalHasher = readIORef v >>= \case- Just (_, n) -> return (Just n)- Nothing -> return Nothing- , descIncrementalHasher = desc- }--data IncrementalVerifier = IncrementalVerifier- { updateIncrementalVerifier :: S.ByteString -> IO ()- , finalizeIncrementalVerifier :: IO (Maybe Bool)- , unableIncrementalVerifier :: IO ()- , positionIncrementalVerifier :: IO (Maybe Integer)- , descIncrementalVerifier :: String- }--mkIncrementalVerifier :: HashAlgorithm h => Context h -> String -> (String -> Bool) -> IO IncrementalVerifier-mkIncrementalVerifier ctx desc samechecksum = do- hasher <- mkIncrementalHasher ctx desc- return $ IncrementalVerifier- { updateIncrementalVerifier = updateIncrementalHasher hasher- , finalizeIncrementalVerifier = - maybe Nothing (Just . samechecksum)- <$> finalizeIncrementalHasher hasher- , unableIncrementalVerifier = unableIncrementalHasher hasher- , positionIncrementalVerifier = positionIncrementalHasher hasher- , descIncrementalVerifier = descIncrementalHasher hasher- }
+ Utility/Hash/Blake3.hs view
@@ -0,0 +1,103 @@+{- Blake3 convenience wrapper with b3hash support.+ -+ - Copyright 2026 Joey Hess <id@joeyh.name>+ - Copyright 2022 edef <edef@edef.eu>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}++module Utility.Hash.Blake3 (+ blake3,+ blake3IncrementalVerifier,+ blake3File,+) where++import Utility.Hash.Types+import Utility.Hash.Incremental+import Utility.FileSystemEncoding+import Utility.OsPath+import Utility.Path+import Utility.FileSize+import Utility.Process+import Utility.Exception+import Utility.Monad++import qualified BLAKE3+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.IORef+import Control.Concurrent.MVar+import GHC.IO (unsafePerformIO)++finalize :: BLAKE3.Hasher -> BLAKE3.Digest BLAKE3.DEFAULT_DIGEST_LEN+finalize = BLAKE3.finalize++blake3 :: L.ByteString -> Hash+blake3 = Hash . encodeBS . show . finalize . L.foldlChunks ((. pure) . BLAKE3.update) (BLAKE3.init Nothing)++blake3IncrementalVerifier :: String -> (Hash -> Bool) -> IO IncrementalVerifier+blake3IncrementalVerifier desc samechecksum = do+ v <- newIORef (Just (BLAKE3.init Nothing, 0))+ return $ IncrementalVerifier+ { updateIncrementalVerifier = \b ->+ modifyIORef' v $ \case+ (Just (ctx', n)) ->+ let !ctx'' = BLAKE3.update ctx' [b]+ !n' = n + fromIntegral (S.length b)+ in (Just (ctx'', n'))+ Nothing -> Nothing+ , finalizeIncrementalVerifier =+ fmap (samechecksum . Hash . encodeBS . show . finalize . fst) <$> readIORef v+ , unableIncrementalVerifier = writeIORef v Nothing+ , positionIncrementalVerifier = fmap snd <$> readIORef v+ , descIncrementalVerifier = desc+ }++{- When b3sum is in the path, this uses it to hash a file. For large+ - files, that is much faster due to supporting parallelism.+ -+ - This returns Nothing when b3sum is not in the path, or exits nonzero, + - or when the file is too small to be worth running it.+ -}+blake3File :: OsPath -> IO (Maybe Hash)+blake3File file = takeMVar b3sumAvailable >>= \case+ Just True -> do+ putMVar b3sumAvailable (Just True)+ runb3sum+ Just False -> do+ putMVar b3sumAvailable (Just False)+ return Nothing+ Nothing -> ifM (inSearchPath "b3sum")+ ( do+ putMVar b3sumAvailable (Just True)+ runb3sum+ , do+ putMVar b3sumAvailable (Just False)+ return Nothing+ )+ where+ runb3sum = ifM filelargeenough+ ( tryNonAsync runb3sum' >>= return . \case+ Right output -> case lines output of+ (hash:[]) | length hash == 64 ->+ Just $ Hash $ encodeBS hash+ _ -> Nothing+ Left _ -> Nothing+ , return Nothing+ )+ runb3sum' = readProcess "b3sum" ["--no-names", "--", fromOsPath file]+ + -- A file needs to be about 3mb in size before the overhead of+ -- starting a b3sum process is worthwhile.+ filelargeenough = tryNonAsync (getFileSize file) >>= return . \case+ Right sz -> sz > 3000000+ Left _ -> False++{- Used to avoid needing to check the PATH for b3sum each time+ - blake3File is called. -}+{-# NOINLINE b3sumAvailable #-}+b3sumAvailable :: MVar (Maybe Bool)+b3sumAvailable = unsafePerformIO $ newMVar Nothing
+ Utility/Hash/Botan.hs view
@@ -0,0 +1,190 @@+{- Convenience wrapper around botan's hashing.+ -+ - Copyright 2026 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE BangPatterns #-}++module Utility.Hash.Botan (+ sha1,+ sha1_hasher,+ sha1s,+ sha2_224,+ sha2_224_hasher,+ sha2_256,+ sha2_256_hasher,+ sha2_384,+ sha2_384_hasher,+ sha2_512,+ sha2_512_hasher,+ sha3_224,+ sha3_224_hasher,+ sha3_256,+ sha3_256_hasher,+ sha3_384,+ sha3_384_hasher,+ sha3_512,+ sha3_512_hasher,+ skein512,+ skein512_hasher,+ blake2b_160,+ blake2b_160_hasher,+ blake2b_224,+ blake2b_224_hasher,+ blake2b_256,+ blake2b_256_hasher,+ blake2b_384,+ blake2b_384_hasher,+ blake2b_512,+ blake2b_512_hasher,+ md5,+ md5_hasher,+ md5s,+) where++import qualified Botan.Low.Hash as Botan+import Control.Monad+import System.IO.Unsafe (unsafePerformIO)+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S+import Data.IORef++import Utility.Hash.Types+import Utility.Hash.Incremental++sha1 :: L.ByteString -> HashDigest+sha1 = hashLazy Botan.SHA1++sha1_hasher :: IO IncrementalHasher+sha1_hasher = mkIncrementalHasher Botan.SHA1++sha1s :: S.ByteString -> HashDigest+sha1s = hashStrict Botan.SHA1++sha2_224 :: L.ByteString -> HashDigest+sha2_224 = hashLazy Botan.SHA224++sha2_224_hasher :: IO IncrementalHasher+sha2_224_hasher = mkIncrementalHasher Botan.SHA224++sha2_256 :: L.ByteString -> HashDigest+sha2_256 = hashLazy Botan.SHA256++sha2_256_hasher :: IO IncrementalHasher+sha2_256_hasher = mkIncrementalHasher Botan.SHA256++sha2_384 :: L.ByteString -> HashDigest+sha2_384 = hashLazy Botan.SHA384++sha2_384_hasher :: IO IncrementalHasher+sha2_384_hasher = mkIncrementalHasher Botan.SHA384++sha2_512 :: L.ByteString -> HashDigest+sha2_512 = hashLazy Botan.SHA512++sha2_512_hasher :: IO IncrementalHasher+sha2_512_hasher = mkIncrementalHasher Botan.SHA512++sha3_224 :: L.ByteString -> HashDigest+sha3_224 = hashLazy (Botan.sha3 (224 :: Int))++sha3_224_hasher :: IO IncrementalHasher+sha3_224_hasher = mkIncrementalHasher (Botan.sha3 (224 :: Int))++sha3_256 :: L.ByteString -> HashDigest+sha3_256 = hashLazy (Botan.sha3 (256 :: Int))++sha3_256_hasher :: IO IncrementalHasher+sha3_256_hasher = mkIncrementalHasher (Botan.sha3 (256 :: Int))++sha3_384 :: L.ByteString -> HashDigest+sha3_384 = hashLazy (Botan.sha3 (384 :: Int))++sha3_384_hasher :: IO IncrementalHasher+sha3_384_hasher = mkIncrementalHasher (Botan.sha3 (384 :: Int))++sha3_512 :: L.ByteString -> HashDigest+sha3_512 = hashLazy (Botan.sha3 (512 :: Int))++sha3_512_hasher :: IO IncrementalHasher+sha3_512_hasher = mkIncrementalHasher (Botan.sha3 (512 :: Int))++skein512 :: L.ByteString -> HashDigest+skein512 = hashLazy Botan.Skein512++skein512_hasher :: IO IncrementalHasher+skein512_hasher = mkIncrementalHasher Botan.Skein512++blake2b_160 :: L.ByteString -> HashDigest+blake2b_160 = hashLazy (Botan.blake2b (160 :: Int))++blake2b_160_hasher :: IO IncrementalHasher+blake2b_160_hasher = mkIncrementalHasher (Botan.blake2b (160 :: Int))++blake2b_224 :: L.ByteString -> HashDigest+blake2b_224 = hashLazy (Botan.blake2b (224 :: Int))++blake2b_224_hasher :: IO IncrementalHasher+blake2b_224_hasher = mkIncrementalHasher (Botan.blake2b (224 :: Int))++blake2b_256 :: L.ByteString -> HashDigest+blake2b_256 = hashLazy (Botan.blake2b (256 :: Int))++blake2b_256_hasher :: IO IncrementalHasher+blake2b_256_hasher = mkIncrementalHasher (Botan.blake2b (256 :: Int))++blake2b_384 :: L.ByteString -> HashDigest+blake2b_384 = hashLazy (Botan.blake2b (384 :: Int))++blake2b_384_hasher :: IO IncrementalHasher+blake2b_384_hasher = mkIncrementalHasher (Botan.blake2b (384 :: Int))++blake2b_512 :: L.ByteString -> HashDigest+blake2b_512 = hashLazy (Botan.blake2b (512 :: Int))++blake2b_512_hasher :: IO IncrementalHasher+blake2b_512_hasher = mkIncrementalHasher (Botan.blake2b (512 :: Int))++md5 :: L.ByteString -> HashDigest+md5 = hashLazy Botan.MD5++md5_hasher :: IO IncrementalHasher+md5_hasher = mkIncrementalHasher Botan.MD5++md5s :: S.ByteString -> HashDigest+md5s = hashStrict Botan.MD5++hashLazy :: Botan.HashName -> L.ByteString -> HashDigest+hashLazy h b = unsafePerformIO $ do+ hasher <- Botan.hashInit h+ forM_ (L.toChunks b) (Botan.hashUpdate hasher)+ HashDigest <$> Botan.hashFinal hasher++hashStrict :: Botan.HashName -> S.ByteString -> HashDigest+hashStrict h b = unsafePerformIO $ do+ hasher <- Botan.hashInit h+ Botan.hashUpdate hasher b+ HashDigest <$> Botan.hashFinal hasher++mkIncrementalHasher :: Botan.HashName -> IO IncrementalHasher+mkIncrementalHasher h = do+ hasher <- Botan.hashInit h+ v <- newIORef (Just 0)+ return $ IncrementalHasher+ { updateIncrementalHasher = \b -> do+ readIORef v >>= \case+ Just n -> do+ let !n' = n + fromIntegral (S.length b)+ writeIORef v (Just n')+ Botan.hashUpdate hasher b+ Nothing -> return ()+ , finalizeIncrementalHasher = do+ readIORef v >>= \case+ Just _ -> Just . HashDigest+ <$> Botan.hashFinal hasher+ Nothing -> return Nothing+ , unableIncrementalHasher = writeIORef v Nothing+ , positionIncrementalHasher = readIORef v+ }
+ Utility/Hash/Crypton.hs view
@@ -0,0 +1,249 @@+{- Convenience wrapper around crypton's hashing.+ -+ - Copyright 2013-2026 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE BangPatterns, PackageImports #-}+{-# LANGUAGE RankNTypes #-}++module Utility.Hash.Crypton (+ sha1,+ sha1_hasher,+ sha1s,+ sha2_224,+ sha2_224_hasher,+ sha2_256,+ sha2_256_hasher,+ sha2_384,+ sha2_384_hasher,+ sha2_512,+ sha2_512_hasher,+ sha3_224,+ sha3_224_hasher,+ sha3_256,+ sha3_256_hasher,+ sha3_384,+ sha3_384_hasher,+ sha3_512,+ sha3_512_hasher,+ skein256,+ skein256_hasher,+ skein512,+ skein512_hasher,+ blake2s_160,+ blake2s_160_hasher,+ blake2s_224,+ blake2s_224_hasher,+ blake2s_256,+ blake2s_256_hasher,+ blake2sp_224,+ blake2sp_224_hasher,+ blake2sp_256,+ blake2sp_256_hasher,+ blake2b_160,+ blake2b_160_hasher,+ blake2b_224,+ blake2b_224_hasher,+ blake2b_256,+ blake2b_256_hasher,+ blake2b_384,+ blake2b_384_hasher,+ blake2b_512,+ blake2b_512_hasher,+ blake2bp_512,+ blake2bp_512_hasher,+ md5,+ md5_hasher,+ md5s,+ hashUpdate,+ hashFinalize,+ Digest,+ HashAlgorithm,+ Context,+ mkIncrementalHasher,+ mkIncrementalVerifier,+) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.IORef+import qualified Data.ByteArray as BA+import "crypton" Crypto.Hash++import Utility.Hash.Types+import Utility.Hash.Incremental++sha1 :: L.ByteString -> HashDigest+sha1 = hashDigest . (hashlazy :: HashLazy SHA1)++sha1_hasher :: IO IncrementalHasher+sha1_hasher = mkIncrementalHasher (hashInit :: Context SHA1)++sha1s :: S.ByteString -> HashDigest+sha1s = hashDigest . (hash :: HashStrict SHA1)++sha2_224 :: L.ByteString -> HashDigest+sha2_224 = hashDigest . (hashlazy :: HashLazy SHA224)++sha2_224_hasher :: IO IncrementalHasher+sha2_224_hasher = mkIncrementalHasher (hashInit :: Context SHA224)++sha2_256 :: L.ByteString -> HashDigest+sha2_256 = hashDigest . (hashlazy :: HashLazy SHA256)++sha2_256_hasher :: IO IncrementalHasher+sha2_256_hasher = mkIncrementalHasher (hashInit :: Context SHA256)++sha2_384 :: L.ByteString -> HashDigest+sha2_384 = hashDigest . (hashlazy :: HashLazy SHA384)++sha2_384_hasher :: IO IncrementalHasher+sha2_384_hasher = mkIncrementalHasher (hashInit :: Context SHA384)++sha2_512 :: L.ByteString -> HashDigest+sha2_512 = hashDigest . (hashlazy :: HashLazy SHA512)++sha2_512_hasher :: IO IncrementalHasher+sha2_512_hasher = mkIncrementalHasher (hashInit :: Context SHA512)++sha3_224 :: L.ByteString -> HashDigest+sha3_224 = hashDigest . (hashlazy :: HashLazy SHA3_224)++sha3_224_hasher :: IO IncrementalHasher+sha3_224_hasher = mkIncrementalHasher (hashInit :: Context SHA3_224)++sha3_256 :: L.ByteString -> HashDigest+sha3_256 = hashDigest . (hashlazy :: HashLazy SHA3_256)++sha3_256_hasher :: IO IncrementalHasher+sha3_256_hasher = mkIncrementalHasher (hashInit :: Context SHA3_256)++sha3_384 :: L.ByteString -> HashDigest+sha3_384 = hashDigest . (hashlazy :: HashLazy SHA3_384)++sha3_384_hasher :: IO IncrementalHasher+sha3_384_hasher = mkIncrementalHasher (hashInit :: Context SHA3_384)++sha3_512 :: L.ByteString -> HashDigest+sha3_512 = hashDigest . (hashlazy :: HashLazy SHA3_512)++sha3_512_hasher :: IO IncrementalHasher+sha3_512_hasher = mkIncrementalHasher (hashInit :: Context SHA3_512)++skein256 :: L.ByteString -> HashDigest+skein256 = hashDigest . (hashlazy :: HashLazy Skein256_256)++skein256_hasher :: IO IncrementalHasher+skein256_hasher = mkIncrementalHasher (hashInit :: Context Skein256_256)++skein512 :: L.ByteString -> HashDigest+skein512 = hashDigest . (hashlazy :: HashLazy Skein512_512)++skein512_hasher :: IO IncrementalHasher+skein512_hasher = mkIncrementalHasher (hashInit :: Context Skein512_512)++blake2s_160 :: L.ByteString -> HashDigest+blake2s_160 = hashDigest . (hashlazy :: HashLazy Blake2s_160)++blake2s_160_hasher :: IO IncrementalHasher+blake2s_160_hasher = mkIncrementalHasher (hashInit :: Context Blake2s_160)++blake2s_224 :: L.ByteString -> HashDigest+blake2s_224 = hashDigest . (hashlazy :: HashLazy Blake2s_224)++blake2s_224_hasher :: IO IncrementalHasher+blake2s_224_hasher = mkIncrementalHasher (hashInit :: Context Blake2s_224)++blake2s_256 :: L.ByteString -> HashDigest+blake2s_256 = hashDigest . (hashlazy :: HashLazy Blake2s_256)++blake2s_256_hasher :: IO IncrementalHasher+blake2s_256_hasher = mkIncrementalHasher (hashInit :: Context Blake2s_256)++blake2sp_224 :: L.ByteString -> HashDigest+blake2sp_224 = hashDigest . (hashlazy :: HashLazy Blake2sp_224)++blake2sp_224_hasher :: IO IncrementalHasher+blake2sp_224_hasher = mkIncrementalHasher (hashInit :: Context Blake2sp_224)++blake2sp_256 :: L.ByteString -> HashDigest+blake2sp_256 = hashDigest . (hashlazy :: HashLazy Blake2sp_256)++blake2sp_256_hasher :: IO IncrementalHasher+blake2sp_256_hasher = mkIncrementalHasher (hashInit :: Context Blake2sp_256)++blake2b_160 :: L.ByteString -> HashDigest+blake2b_160 = hashDigest . (hashlazy :: HashLazy Blake2b_160)++blake2b_160_hasher :: IO IncrementalHasher+blake2b_160_hasher = mkIncrementalHasher (hashInit :: Context Blake2b_160)++blake2b_224 :: L.ByteString -> HashDigest+blake2b_224 = hashDigest . (hashlazy :: HashLazy Blake2b_224)++blake2b_224_hasher :: IO IncrementalHasher+blake2b_224_hasher = mkIncrementalHasher (hashInit :: Context Blake2b_224)++blake2b_256 :: L.ByteString -> HashDigest+blake2b_256 = hashDigest . (hashlazy :: HashLazy Blake2b_256)++blake2b_256_hasher :: IO IncrementalHasher+blake2b_256_hasher = mkIncrementalHasher (hashInit :: Context Blake2b_256)++blake2b_384 :: L.ByteString -> HashDigest+blake2b_384 = hashDigest . (hashlazy :: HashLazy Blake2b_384)++blake2b_384_hasher :: IO IncrementalHasher+blake2b_384_hasher = mkIncrementalHasher (hashInit :: Context Blake2b_384)++blake2b_512 :: L.ByteString -> HashDigest+blake2b_512 = hashDigest . (hashlazy :: HashLazy Blake2b_512)++blake2b_512_hasher :: IO IncrementalHasher+blake2b_512_hasher = mkIncrementalHasher (hashInit :: Context Blake2b_512)++blake2bp_512 :: L.ByteString -> HashDigest+blake2bp_512 = hashDigest . (hashlazy :: HashLazy Blake2bp_512)++blake2bp_512_hasher :: IO IncrementalHasher+blake2bp_512_hasher = mkIncrementalHasher (hashInit :: Context Blake2bp_512)++md5 :: L.ByteString -> HashDigest+md5 = hashDigest . (hashlazy :: HashLazy MD5)++md5_hasher :: IO IncrementalHasher+md5_hasher = mkIncrementalHasher (hashInit :: Context MD5)++md5s :: S.ByteString -> HashDigest+md5s = hashDigest . (hash :: HashStrict MD5)++type HashStrict t = S.ByteString -> Digest t++type HashLazy t = L.ByteString -> Digest t++hashDigest :: Digest a -> HashDigest+hashDigest = HashDigest . BA.convert++mkIncrementalHasher :: HashAlgorithm h => Context h -> IO IncrementalHasher+mkIncrementalHasher ctx = do+ v <- newIORef (Just (ctx, 0))+ return $ IncrementalHasher+ { updateIncrementalHasher = \b ->+ modifyIORef' v $ \case+ (Just (ctx', n)) -> + let !ctx'' = hashUpdate ctx' b+ !n' = n + fromIntegral (S.length b)+ in (Just (ctx'', n'))+ Nothing -> Nothing+ , finalizeIncrementalHasher =+ readIORef v >>= \case+ (Just (ctx', _)) -> return $ Just $+ hashDigest $ hashFinalize ctx'+ Nothing -> return Nothing+ , unableIncrementalHasher = writeIORef v Nothing+ , positionIncrementalHasher = readIORef v >>= \case+ Just (_, n) -> return (Just n)+ Nothing -> return Nothing+ }
+ Utility/Hash/Incremental.hs view
@@ -0,0 +1,47 @@+{- Incremental hashing+ -+ - Copyright 2013-2026 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++module Utility.Hash.Incremental where++import Utility.Hash.Types++import qualified Data.ByteString as S++data IncrementalHasher = IncrementalHasher+ { updateIncrementalHasher :: S.ByteString -> IO ()+ -- ^ Called repeatedly on each piece of the content.+ , finalizeIncrementalHasher :: IO (Maybe HashDigest)+ -- ^ Called once the full content has been sent, returns+ -- the hash. (Nothing if unableIncremental was called.)+ , unableIncrementalHasher :: IO ()+ -- ^ Call if the incremental hashing is unable to be done.+ , positionIncrementalHasher :: IO (Maybe Integer)+ -- ^ Returns the number of bytes that have been fed to this+ -- incremental hasher so far. (Nothing if unableIncrementalHasher+ -- was called.)+ }++data IncrementalVerifier = IncrementalVerifier+ { updateIncrementalVerifier :: S.ByteString -> IO ()+ , finalizeIncrementalVerifier :: IO (Maybe Bool)+ , unableIncrementalVerifier :: IO ()+ , positionIncrementalVerifier :: IO (Maybe Integer)+ , descIncrementalVerifier :: String+ }++mkIncrementalVerifier :: IO IncrementalHasher -> String -> (Hash -> Bool) -> IO IncrementalVerifier+mkIncrementalVerifier mkhasher desc samechecksum = do+ hasher <- mkhasher+ return $ IncrementalVerifier+ { updateIncrementalVerifier = updateIncrementalHasher hasher+ , finalizeIncrementalVerifier = + maybe Nothing (Just . samechecksum . digestToHash)+ <$> finalizeIncrementalHasher hasher+ , unableIncrementalVerifier = unableIncrementalHasher hasher+ , positionIncrementalVerifier = positionIncrementalHasher hasher+ , descIncrementalVerifier = desc+ }
+ Utility/Hash/Types.hs view
@@ -0,0 +1,45 @@+{- Hash types+ -+ - Copyright 2026 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE DeriveGeneric #-}++module Utility.Hash.Types where++import qualified Data.ByteString as S+import Data.ByteArray+import qualified Data.ByteArray.Encoding as BAE+import Data.String+import Control.DeepSeq+import GHC.Generics+import Prelude hiding (length)++import Utility.FileSystemEncoding++-- base16 encoded hash+newtype Hash = Hash { hashByteString :: S.ByteString } + deriving (Eq, Generic)++instance Show Hash where+ show (Hash v) = decodeBS v++instance IsString Hash where+ fromString = Hash . encodeBS++instance NFData Hash++-- the raw hash digest+newtype HashDigest = HashDigest S.ByteString+ deriving (Eq, Generic)++digestToHash :: HashDigest -> Hash+digestToHash (HashDigest d) = Hash $ BAE.convertToBase BAE.Base16 d++instance NFData HashDigest++instance ByteArrayAccess HashDigest where+ length (HashDigest d) = length d+ withByteArray (HashDigest d) = withByteArray d
+ Utility/Hash/XXH3.hs view
@@ -0,0 +1,43 @@+{- XXH3 convenience wrapper.+ -+ - Copyright 2026 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++module Utility.Hash.XXH3 where++import Utility.Hash.Types++import qualified Data.ByteString.Lazy as L+import qualified Data.Digest.XXHash.FFI as XXH3+import qualified Data.Hashable as Hashable+import Data.Word+import Data.Bits+import Data.ByteString.Builder++-- Due to use of Int, the xxhash-ffi library is currently only suitable+-- for use on 64 bit (or higher) systems. Trying to use it on+-- 32 bit systems will produce non-canonical values.+-- https://github.com/haskell-haskey/xxhash-ffi/issues/6+xxh3Supported :: Bool+xxh3Supported = finiteBitSize (0 :: Int) >= 64++xxh3 :: L.ByteString -> HashDigest+xxh3 = convcanonical . Hashable.hashWithSalt 0 . XXH3.XXH3+ where+ -- Convert to XXH3 canonical representation.+ -- This is unfortunately not exposed by xxhash-ffi so has to+ -- be re-implemented here.+ -- See https://github.com/haskell-haskey/xxhash-ffi/issues/8+ convcanonical = HashDigest + . L.toStrict . toLazyByteString + . word64BE . fromint+ fromint :: Int -> Word64+ fromint = fromIntegral+ +-- The haskell library does not support incremental verification+-- (without going too low-level to be appropriate here).+-- https://github.com/haskell-haskey/xxhash-ffi/issues/7+xxh3Incremental :: Maybe a+xxh3Incremental = Nothing
Utility/LockFile/PidLock.hs view
@@ -124,7 +124,7 @@ let shortbase = reverse $ take 32 $ reverse base let md5sum = if base == shortbase then ""- else show (md5 (encodeBL base))+ else show (digestToHash (md5 (encodeBL base))) dir <- ifM (doesDirectoryExist (literalOsPath "/dev/shm")) ( return (literalOsPath "/dev/shm") , return (literalOsPath "/tmp")
Utility/Url.hs view
@@ -50,12 +50,13 @@ import Network.HTTP.Client.Restricted import Utility.IPAddress import qualified Utility.RawFilePath as R-import Utility.Hash (IncrementalVerifier(..))+import Utility.Hash.Incremental import Utility.Url.Parse import qualified Utility.FileIO as F import Network.URI import Network.HTTP.Types+import Network.HTTP.Types.Header (hAcceptEncoding, hContentDisposition, hContentRange) import qualified System.FilePath.Posix as UrlPath import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as B@@ -669,15 +670,6 @@ | uriPort ua == ":" -> parseRequest $ show $ u { uriAuthority = Just $ ua { uriPort = "" } } _ -> parseRequest (show u)--hAcceptEncoding :: CI.CI B.ByteString-hAcceptEncoding = "Accept-Encoding"--hContentDisposition :: CI.CI B.ByteString-hContentDisposition = "Content-Disposition"--hContentRange :: CI.CI B.ByteString-hContentRange = "Content-Range" resumeFromHeader :: FileSize -> Header resumeFromHeader sz = (hRange, renderByteRanges [ByteRangeFrom sz])
− Utility/Verifiable.hs
@@ -1,46 +0,0 @@-{- values verified using a shared secret- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--module Utility.Verifiable (- Secret,- HMACDigest,- Verifiable(..),- mkVerifiable,- verify,- prop_verifiable_sane,-) where--import Data.ByteString.UTF8 (fromString)-import qualified Data.ByteString as S--import Utility.Hash-import Utility.QuickCheck--type Secret = S.ByteString-type HMACDigest = String--{- A value, verifiable using a HMAC digest and a secret. -}-data Verifiable a = Verifiable- { verifiableVal :: a- , verifiableDigest :: HMACDigest- }- deriving (Eq, Read, Show)--mkVerifiable :: Show a => a -> Secret -> Verifiable a-mkVerifiable a secret = Verifiable a (calcDigest (show a) secret)--verify :: (Eq a, Show a) => Verifiable a -> Secret -> Bool-verify v secret = v == mkVerifiable (verifiableVal v) secret--calcDigest :: String -> Secret -> HMACDigest-calcDigest v secret = calcMac show HmacSha1 secret (fromString v)--prop_verifiable_sane :: TestableString -> TestableString -> Bool-prop_verifiable_sane v ts = - verify (mkVerifiable (fromTestableString v) secret) secret- where- secret = fromString (fromTestableString ts)
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20260601+Version: 10.20260624 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -35,6 +35,7 @@ -- Include only files that are needed make cabal install git-annex work. Extra-Source-Files: stack.yaml+ stack-botan.yaml README CHANGELOG NEWS@@ -157,6 +158,10 @@ Default: False Manual: True +Flag Botan+ Description: Build with the Botan C++ library for faster hashing+ Default: False+ Flag TorrentParser Description: Use haskell torrent library to parse torrent files @@ -178,6 +183,14 @@ Flag Dbus Description: Enable dbus support +Flag Blake3+ Description: Enable BLAKE3 support+ Default: True++Flag XXH3+ Description: Enable XXH3 support+ Default: False+ source-repository head type: git location: https://git.joeyh.name/git/git-annex.git/@@ -233,12 +246,11 @@ resourcet, http-client (>= 0.5.3), http-client-tls (>= 0.3.2),- http-types (>= 0.7),+ http-types (>= 0.9), http-conduit (>= 2.3.0), http-client-restricted (>= 0.0.2), conduit, time (>= 1.9.1),- old-locale, persistent-sqlite (>= 2.13.3), persistent (>= 2.13.3), persistent-template (>= 2.8.0),@@ -251,9 +263,7 @@ feed (>= 1.1.0), regex-tdfa, socks (>= 0.6.0),- byteable, stm-chans,- securemem, crypto-api, memory, deepseq,@@ -320,6 +330,29 @@ Build-Depends: filepath-bytestring (>= 1.4.2.1.1) + if flag(Botan)+ Build-Depends:+ botan-low (< 0.3)+ CPP-Options: -DWITH_BOTAN+ Other-Modules:+ Utility.Hash.Botan++ -- Disabled on arm until this issue is resolved:+ -- https://github.com/k0001/hs-blake3/issues/8+ if flag(Blake3) && (! arch(aarch64) && ! arch(arm))+ Build-Depends: blake3 (>= 0.3)+ CPP-Options: -DWITH_BLAKE3+ Other-Modules:+ Utility.Hash.Blake3+ + if flag(XXH3)+ Build-Depends:+ xxhash-ffi (>= 0.3),+ hashable+ CPP-Options: -DWITH_XXH3+ Other-Modules:+ Utility.Hash.XXH3+ if (os(windows)) Build-Depends: Win32 (>= 2.13.4.0),@@ -363,7 +396,6 @@ Assistant.MakeRepo Assistant.Monad Assistant.NamedThread- Assistant.Pairing Assistant.Pushes Assistant.RemoteControl Assistant.Repair@@ -700,6 +732,7 @@ Command.PreCommit Command.Pull Command.Push+ Command.Put Command.Recompute Command.ReKey Command.ReadPresentKey@@ -1061,6 +1094,10 @@ Utility.Glob Utility.Gpg Utility.Hash+ Utility.Hash.Crypton+ Utility.Hash.Incremental+ Utility.Hash.Types+ Utility.HMAC Utility.HtmlDetect Utility.HumanNumber Utility.HumanTime@@ -1132,7 +1169,6 @@ Utility.Url Utility.Url.Parse Utility.UserInfo- Utility.Verifiable if (os(windows)) Other-Modules:
+ stack-botan.yaml view
@@ -0,0 +1,28 @@+flags:+ git-annex:+ production: true+ parallelbuild: true+ assistant: true+ torrentparser: true+ magicmime: false+ dbus: false+ debuglocks: false+ benchmark: true+ ospath: true+ botan: true+ blake3: true+ xxh3: true+ file-io:+ os-string: true+ xxhash-ffi:+ pkg-config: false+packages:+- '.'+resolver: lts-24.26+extra-deps:+- aws-0.25.2+- file-io-0.2.0+- botan-low-0.2.0.1+- botan-bindings-0.3.0.0+- blake3-0.3+- xxhash-ffi-0.3.1
stack.yaml view
@@ -9,11 +9,18 @@ debuglocks: false benchmark: true ospath: true+ botan: false+ blake3: true+ xxh3: true file-io: os-string: true+ xxhash-ffi:+ pkg-config: false packages: - '.' resolver: lts-24.26 extra-deps: - aws-0.25.2 - file-io-0.2.0+- blake3-0.3+- xxhash-ffi-0.3.1