git-annex 10.20260901 → 10.20261005
raw patch · 33 files changed
+585/−341 lines, 33 filesdep +tasty-tapdep ~cryptondep ~ramdep ~tls
Dependencies added: tasty-tap
Dependency ranges changed: crypton, ram, tls
Files
- Annex/Balanced.hs +5/−4
- Annex/DirHashes.hs +3/−3
- Annex/Import.hs +45/−41
- BuildFlags.hs +5/−0
- CHANGELOG +37/−0
- Command/AddUrl.hs +2/−2
- Command/Export.hs +14/−1
- Command/ImportFeed.hs +6/−5
- Command/TestRemote.hs +90/−24
- Crypto.hs +2/−1
- P2P/Http/Client.hs +47/−32
- P2P/Http/Url.hs +1/−1
- Remote/BitTorrent.hs +1/−1
- Remote/Bup.hs +48/−30
- Remote/External.hs +18/−18
- Remote/Git.hs +56/−41
- Remote/Helper/ExportImport.hs +8/−13
- Remote/HttpAlso.hs +2/−2
- Remote/Mask.hs +11/−6
- Remote/Web.hs +2/−2
- Remote/WebDAV.hs +5/−9
- Test.hs +10/−5
- Test/Framework.hs +58/−27
- Types/Crypto.hs +1/−1
- Types/Remote.hs +2/−2
- Types/Test.hs +2/−1
- Utility/HMAC.hs +0/−56
- Utility/Hash/Crypton.hs +6/−1
- Utility/Hash/HMAC.hs +73/−0
- Utility/Hash/Types.hs +1/−6
- Utility/QuickCheck.hs +5/−0
- git-annex.cabal +17/−6
- stack-NoLLMDependencies.yaml +2/−0
Annex/Balanced.hs view
@@ -11,13 +11,14 @@ import Key import Types.UUID-import Utility.HMAC+import Utility.Hash.HMAC+import Utility.Hash.Types import Data.Maybe import qualified Data.List as L import Data.Bits (shiftL) import qualified Data.Set as S-import qualified "memory" Data.ByteArray as BA+import qualified Data.ByteString as B -- The Int is how many UUIDs to pick. type BalancedPicker = S.Set UUID -> Key -> Int -> [UUID]@@ -34,9 +35,9 @@ where combineduuids = mconcat (map fromUUID (S.toAscList s)) - tointeger :: Digest a -> Integer+ tointeger :: HashDigest -> Integer tointeger = L.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 - . BA.unpack+ . B.unpack . hashDigestByteString {- The selection for a given key never changes. -} prop_balanced_stable :: Bool
Annex/DirHashes.hs view
@@ -22,7 +22,6 @@ import Data.Default import Data.Bits import qualified Data.List.NonEmpty as NE-import qualified "memory" Data.ByteArray as BA import qualified Data.ByteString as S import Common@@ -80,8 +79,9 @@ hashDirMixed :: HashLevels -> Hasher hashDirMixed n k = hashDirs n 2 $ S.pack $ take 4 $ concatMap display_32bits_as_dir $- encodeWord32 $ map fromIntegral $ BA.unpack $- md5s $ serializeKey' $ nonChunkKey k+ encodeWord32 $ map fromIntegral $ + S.unpack $ hashDigestByteString $+ md5s $ serializeKey' $ nonChunkKey k where encodeWord32 (b1:b2:b3:b4:rest) = (shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1)
Annex/Import.hs view
@@ -55,7 +55,7 @@ import Messages.Progress import Utility.DataUnits import Utility.Metered-import Utility.Hash (sha1s)+import Utility.Hash (sha1s, hashByteString, digestToHash) import Logs.Import import Logs.Export import Logs.Location@@ -72,7 +72,6 @@ import Control.Concurrent.STM import qualified Data.Map.Strict as M import qualified Data.Set as S-import qualified "memory" Data.ByteArray.Encoding as BA #ifdef mingw32_HOST_OS import qualified System.FilePath.Posix as Posix #endif@@ -410,7 +409,7 @@ -- ok, hopefully. This checksum never needs to be verified -- by git, which is why this does not bother to prefix the -- cid with its length, like git would.- sha1 = Ref $ BA.convertToBase BA.Base16 $ sha1s cid+ sha1 = Ref $ hashByteString $ digestToHash $ sha1s cid buildImportTreesGeneric :: (Maybe TopFilePath -> [(ImportLocation, v)] -> Annex Tree)@@ -787,10 +786,10 @@ job <- liftIO $ newEmptyTMVarIO let ai = ActionItemOther (Just (QuotedPath (fromImportLocation loc))) let si = SeekInput []- let importaction = starting ("import " ++ Remote.name remote) ai si $ do+ let importaction = do when oldversion $ showNote "old version"- tryNonAsync (importordownload cidmap i largematcher) >>= \case+ res <- tryNonAsync (importordownload cidmap i largematcher) >>= \case Left e -> next $ do warning (UnquotedString (show e)) liftIO $ atomically $@@ -800,10 +799,12 @@ liftIO $ atomically $ putTMVar job r return (isJust r)- commandAction $ bracket_- (waitstart importing cid)- (signaldone importing cid)- importaction+ return res+ commandAction $ starting ("import " ++ Remote.name remote) ai si $+ bracket_+ (waitstart importing cid)+ (signaldone importing cid)+ importaction return (Right job) thirdpartypopulatedimport db (loc, (cid, sz)) = @@ -853,12 +854,12 @@ islargefile <- checkMatcher' matcher mi NoLiveUpdate mempty metered Nothing sz bwlimit $ const $ if islargefile then doimportlarge importkey cidmap loc cid sz f- else doimportsmall cidmap loc cid sz+ else doimportsmall cidmap loc cid sz f doimportlarge importkey cidmap loc cid sz f p = tryNonAsync importer >>= \case- Right (Just (k, True)) -> return $ Just (loc, Right k)- Right _ -> return Nothing+ Right (Just v) -> return $ Just v+ Right Nothing -> return Nothing Left e -> do warning (UnquotedString (show e)) return Nothing@@ -877,55 +878,52 @@ logChange NoLiveUpdate k (Remote.uuid remote) InfoPresent if importcontent then getcontent k- else return (Just (k, True))+ else return (Just (loc, Right k)) Just msg -> giveup (msg ++ " to import") - getcontent :: Key -> Annex (Maybe (Key, Bool)) getcontent k = do- let af = AssociatedFile (Just f) let downloader p' tmpfile = do _ <- Remote.retrieveImport (Remote.importActions remote) loc [cid] tmpfile (Left k) (combineMeterUpdate p' p)- ok <- moveAnnex k tmpfile- when ok $- logStatus NoLiveUpdate k InfoPresent- return (Just (k, ok))- checkDiskSpaceToGet k Nothing Nothing $- notifyTransfer Download af $- download' (Remote.uuid remote) k af Nothing stdRetry $ \p' ->- withTmp k $ downloader p'- + ifM (moveAnnex k tmpfile)+ ( do+ logStatus NoLiveUpdate k InfoPresent+ return (Just (loc, Right k))+ , return Nothing+ )+ downloadimport k f $ \p' ->+ withTmp k $ downloader p'+ -- The file is small, so is added to git, so while importing -- without content does not retrieve annexed files, it does -- need to retrieve this file.- doimportsmall cidmap loc cid sz p = do- let downloader tmpfile = do+ doimportsmall cidmap loc cid sz f p = do+ let downloader p' tmpfile = do (k, _) <- Remote.retrieveImport (Remote.importActions remote) loc [cid] tmpfile (Right (mkkey tmpfile))- p+ (combineMeterUpdate p' p) case keyGitSha k of Just sha -> do recordcidkey cidmap cid k return sha Nothing -> error "internal"- checkDiskSpaceToGet tmpkey Nothing Nothing $+ downloadimport tmpkey f $ \p' -> withTmp tmpkey $ \tmpfile ->- tryNonAsync (downloader tmpfile) >>= \case+ tryNonAsync (downloader p' tmpfile) >>= \case Right sha -> return $ Just (loc, Left sha) Left e -> do warning (UnquotedString (show e)) return Nothing where- tmpkey = importKey cid sz+ tmpkey = tmpImportKey cid sz mkkey tmpfile = gitShaKey <$> hashFile tmpfile dodownload cidmap (loc, (cid, sz)) f matcher = do- let af = AssociatedFile (Just f) let downloader tmpfile p = do (k, _) <- Remote.retrieveImport (Remote.importActions remote)@@ -949,14 +947,12 @@ Left e -> do warning (UnquotedString (show e)) return Nothing- checkDiskSpaceToGet tmpkey Nothing Nothing $- notifyTransfer Download af $- download' (Remote.uuid remote) tmpkey af Nothing stdRetry $ \p ->- withTmp tmpkey $ \tmpfile ->- metered (Just p) tmpkey bwlimit $- const (rundownload tmpfile)+ downloadimport tmpkey f $ \p ->+ withTmp tmpkey $ \tmpfile ->+ metered (Just p) tmpkey bwlimit $+ const (rundownload tmpfile) where- tmpkey = importKey cid sz+ tmpkey = tmpImportKey cid sz mkkey tmpfile = do let mi = MatchingFile FileInfo@@ -975,7 +971,7 @@ } fst <$> genKey ks nullMeterUpdate backend else gitShaKey <$> hashFile tmpfile- + bwlimit = remoteAnnexBwLimitDownload (Remote.gitconfig remote) <|> remoteAnnexBwLimit (Remote.gitconfig remote) @@ -1021,11 +1017,19 @@ CIDLog.recordContentIdentifier rs cid k rs = Remote.remoteStateHandle remote+ + downloadimport :: Key -> OsPath -> (MeterUpdate -> Annex (Maybe (ImportLocation, (Either Sha Key)))) -> Annex (Maybe (ImportLocation, (Either Sha Key)))+ downloadimport k f a =+ checkDiskSpaceToGet k Nothing Nothing $+ notifyTransfer Download af $+ download' (Remote.uuid remote) k af Nothing stdRetry a+ where+ af = AssociatedFile (Just f) {- Temporary key used for import of a ContentIdentifier while downloading - content, before generating its real key. -}-importKey :: ContentIdentifier -> Integer -> Key-importKey (ContentIdentifier cid) size = mkKey $ \k -> k+tmpImportKey :: ContentIdentifier -> Integer -> Key+tmpImportKey (ContentIdentifier cid) size = mkKey $ \k -> k { keyName = genKeyName (decodeBS cid) , keyVariety = OtherKey "CID" , keySize = Just size
BuildFlags.hs view
@@ -83,6 +83,11 @@ #ifdef WITH_NOLLMDEPENDENCIES , "NoLLMDependencies" #endif+#ifdef WITH_TASTYTAP+ , "TastyTap"+#else+#warning Building without tasty-tap support.+#endif ] -- Not a complete list, let alone a listing transitive deps, but only
CHANGELOG view
@@ -1,3 +1,40 @@+git-annex (10.20261005) upstream; urgency=medium++ * Fix mask special remote to not hang after the first file.+ * Fix concurrent import of identical files to not fail with+ "transfer already in progress".+ * Also fixes possible data corruption when importing identical small files.+ * Use git-credential in more situations when accessing urls that need a+ password or other authentication, including the web, bittorrent and+ httpalso special remotes, and git-annex addurl and importfeed.+ * external: Fix DOWNLOAD-URL to support git-credential, which it+ was already documented to do.+ * external: Support git-credential in TRANSFER-RETRIEVE-URL,+ CHECKPRESENT-URL, and RETRIEVEIMPORT-URL+ * webdav: Fix a hang when credentials are not available.+ (Reversion introduced in 10.20260901)+ * export: Display a warning when the user is either in the middle+ of an export conflict, or has been unsafely writing directly to a+ remote that is configured with exporttree=yes but without+ importtree=yes.+ * importfeed: Avoid displaying empty feed titles.+ * Allow retrieval from some importtree=yes special remotes when there+ is no recorded content identifier.+ * Automate updating remote.name.annexUrl for annex+https servers,+ by re-probing the http remote's annex.url config when unable to connect+ to an annex+https server.+ * test, testremote: Support --tap output when built with TastyTap build+ flag.+ * testremote: Add --ensure-readonly mode.+ * Support bup 0.34, while also still working with previous versions.+ * When built with Botan, also use it for HMAC.+ * NoLLMDependencies: Update for crypton.+ * NoLLMDependencies: Update for tls.+ * Support building with QuickCheck 2.17.+ * Support building with crypton 1.1.0.++ -- Joey Hess <id@joeyh.name> Mon, 05 Oct 2026 10:44:55 -0400+ git-annex (10.20260901) upstream; urgency=medium * Behavior change: drop --auto --from a remote does not any longer
Command/AddUrl.hs view
@@ -251,7 +251,7 @@ go url = startingAddUrl si urlstring o $ if relaxedOption (downloadOptions o) then go' url Url.assumeUrlExists- else Url.withUrlOptions Nothing (Url.getUrlInfo urlstring) >>= \case+ else Url.withUrlOptionsPromptingCreds Nothing (Url.getUrlInfo urlstring) >>= \case Right urlinfo -> go' url urlinfo Left err -> do warning (UnquotedString err)@@ -352,7 +352,7 @@ go =<< downloadWith' downloader urlkey webUUID url file where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing True- downloader f p = Url.withUrlOptions Nothing $+ downloader f p = Url.withUrlOptionsPromptingCreds Nothing $ downloadUrl False urlkey p Nothing [url] f go Nothing = return Nothing go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile tmp))
Command/Export.hs view
@@ -283,7 +283,10 @@ stopUnless (notrecordedpresent ek) $ starting ("export " ++ name r) ai si $ ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) ek loc))- ( next $ cleanupExport r db ek loc False+ ( do+ unlessM (isImportSupported r) $+ warning presentwarning + next $ cleanupExport r db ek loc False , do liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True)) performExport r srcrs db ek af (Git.LsTree.sha ti) loc allfilledvar@@ -308,6 +311,16 @@ then return False else notElem (uuid r) <$> loggedLocations ek )+ + presentwarning = UnquotedString $ unwords+ [ "A file by this name is already present in the remote."+ , "This is typically due to an export conflict, which will"+ , "be resolved by this command once the git-annex branch"+ , "is in sync across all writers. (Or it may be due to"+ , "something other than git-annex writing to the remote."+ , "Since the remote is not configured with importtree=yes,"+ , "such modifications will not be preserved.)"+ ] performExport :: Remote -> [Remote] -> ExportHandle -> Key -> AssociatedFile -> Sha -> ExportLocation -> MVar AllFilled -> CommandPerform performExport r srcrs db ek af contentsha loc allfilledvar = do
Command/ImportFeed.hs view
@@ -172,12 +172,13 @@ parse tmpf = liftIO (parseFeedFromFile' tmpf) >>= \case Nothing -> debugfeedcontent tmpf "parsing the feed failed" Just f -> do- let feedtitle = '"' : decodeBS (fromFeedText $ getFeedTitle f) ++ "\""+ let qq s = '"' : s ++ "\""+ let feedtitle = decodeBS (fromFeedText $ getFeedTitle f) unless (null feedtitle) $- showNote (UnquotedString feedtitle)+ showNote (UnquotedString (qq feedtitle)) let feeddesc = if null feedtitle then url- else feedtitle+ else qq feedtitle case findDownloads url f feeddesc of [] -> debugfeedcontent tmpf "bad feed content; no enclosures to download" l -> do@@ -274,7 +275,7 @@ downloadFeed :: URLString -> OsPath -> Annex Bool downloadFeed url f | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url"- | otherwise = Url.withUrlOptions Nothing $+ | otherwise = Url.withUrlOptionsPromptingCreds Nothing $ Url.download nullMeterUpdate Nothing url f startDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> CommandStart@@ -373,7 +374,7 @@ let go urlinfo = Just . maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f if relaxedOption (downloadOptions opts) then go Url.assumeUrlExists- else Url.withUrlOptions Nothing (Url.getUrlInfo url) >>= \case+ else Url.withUrlOptionsPromptingCreds Nothing (Url.getUrlInfo url) >>= \case Right urlinfo -> go urlinfo Left err -> do warning (UnquotedString err)
Command/TestRemote.hs view
@@ -1,11 +1,12 @@ {- git-annex command -- - Copyright 2014-2020 Joey Hess <id@joeyh.name>+ - Copyright 2014-2026 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE RankNTypes, DeriveFunctor, PackageImports, OverloadedStrings #-}+{-# LANGUAGE CPP #-} module Command.TestRemote where @@ -38,6 +39,9 @@ import Test.Tasty import Test.Tasty.Runners import Test.Tasty.HUnit+#ifdef WITH_TASTYTAP+import Test.Tasty.Runners.TAP+#endif import "crypto-api" Crypto.Random import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L@@ -47,14 +51,16 @@ import qualified Data.List.NonEmpty as NE cmd :: Command-cmd = command "testremote" SectionTesting+cmd = noMessages $ command "testremote" SectionTesting "test transfers to/from a remote" paramRemote (seek <$$> optParser) data TestRemoteOptions = TestRemoteOptions { testRemote :: RemoteName , sizeOption :: ByteSize+ , tapOutput :: Bool , testReadonlyFile :: [FilePath]+ , ensureReadonlyFile :: Maybe FilePath } optParser :: CmdParamsDesc -> Parser TestRemoteOptions@@ -65,11 +71,19 @@ <> value (1024 * 1024) <> help "base key size (default 1MiB)" )+ <*> switch+ ( long "tap"+ <> help "use TAP output"+ ) <*> many testreadonly+ <*> optional (option str+ ( long "ensure-readonly" <> metavar paramFile+ <> help "readonly test object (may be deleted from remote)"+ )) where testreadonly = option str ( long "test-readonly" <> metavar paramFile- <> help "readonly test object"+ <> help "readonly test object (will not be modified)" ) seek :: TestRemoteOptions -> CommandSeek@@ -81,15 +95,17 @@ cache <- liftIO newRemoteVariantCache r <- either giveup (disableExportTree cache) =<< Remote.byName' (testRemote o)- ks <- case testReadonlyFile o of- [] -> if Remote.readonly r- then giveup "This remote is readonly, so you need to use the --test-readonly option."- else do- showAction "generating test keys"- NE.fromList- <$> mapM randKey (keySizes basesz fast)- fs -> NE.fromList <$> mapM (getReadonlyKey r . toOsPath) fs- let r' = if null (testReadonlyFile o)+ ks <- if ensureReadonlyFile o == Nothing+ then case testReadonlyFile o of+ [] -> if Remote.readonly r+ then giveup "This remote is readonly, so you need to use the --test-readonly option."+ else gentestkeys fast+ fs -> NE.fromList <$> mapM (getReadonlyKey r . toOsPath) fs+ else gentestkeys fast+ ensurereadonlyk <- case ensureReadonlyFile o of+ Nothing -> pure Nothing+ Just f -> Just <$> getReadonlyKey r (toOsPath f)+ let r' = if null (testReadonlyFile o) && ensureReadonlyFile o == Nothing then r else r { Remote.readonly = True } let drs = if Remote.readonly r'@@ -99,13 +115,16 @@ let exportr = if Remote.readonly r' then return Nothing else exportTreeVariant cache r'- perform drs unavailr exportr ks+ perform o drs unavailr exportr ks ensurereadonlyk where basesz = fromInteger $ sizeOption o si = SeekInput [testRemote o]+ gentestkeys fast = do+ showAction "generating test keys"+ NE.fromList <$> mapM randKey (keySizes basesz fast) -perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> NE.NonEmpty Key -> CommandPerform-perform drs unavailr exportr ks = do+perform :: TestRemoteOptions -> [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> NE.NonEmpty Key -> Maybe Key -> CommandPerform+perform o drs unavailr exportr ks ensurereadonlyk = do st <- liftIO . newTVarIO =<< (,) <$> Annex.getState id <*> Annex.getRead id@@ -114,14 +133,25 @@ drs (pure unavailr) exportr- (NE.map (\k -> Described (desck k) (pure k)) ks)- ok <- case tryIngredients [consoleTestReporter] mempty tests of+ (NE.map mkdesck ks)+ (mkdesck <$> ensurereadonlyk)+ ok <- case tryIngredients testingredients mempty tests of Nothing -> error "No tests found!?" Just act -> liftIO act rs <- catMaybes <$> mapM getVal drs next $ cleanup rs (NE.toList ks) ok where desck k = unwords [ "key size", show (fromKey keySize k) ]+ mkdesck k = Described (desck k) (pure k)+ testingredients =+ if tapOutput o+#ifdef WITH_TASTYTAP+ then [ tapRunner ]+#else+ then error "git-annex was built without --tap support"+#endif+ else []+ ++ [ consoleTestReporter ] remoteVariants :: RemoteVariantCache -> Described (Annex Remote) -> Int -> Bool -> [Described (Annex (Maybe Remote))] remoteVariants cache dr basesz fast = @@ -221,22 +251,31 @@ -> Annex (Maybe Remote) -> Annex (Maybe Remote) -> (NE.NonEmpty (Described (Annex Key)))+ -> (Maybe (Described (Annex Key))) -> [TestTree]-mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $- [ [ inOrderTestGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (NE.head mkks))) ]- , [ inOrderTestGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- NE.toList mkks, mkr <- mkrs ]- , [ inOrderTestGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 (NE.toList mkks), mkk2 <- take 2 (reverse (NE.toList mkks)) ]- ]+mkTestTrees runannex mkrs mkunavailr mkexportr mkks mkensurereadonlyk = concat $+ case mkensurereadonlyk of+ Nothing ->+ [ [ inOrderTestGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (NE.head mkks))) ]+ , [ inOrderTestGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- NE.toList mkks, mkr <- mkrs ]+ , [ inOrderTestGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 (NE.toList mkks), mkk2 <- take 2 (reverse (NE.toList mkks)) ]+ ]+ Just ensurereadonlyk ->+ [ [ inOrderTestGroup (desc mkr mkk) (testEnsureReadOnly runannex (getVal mkr) (getVal mkk) (getVal ensurereadonlyk)) | mkk <- NE.toList mkks, mkr <- mkrs ]+ ] where- desc r k = intercalate "; " $ map unwords+ desc r k = combinedescs [ [ getDesc k ] , [ getDesc r ]+ , map getDesc $ maybeToList mkensurereadonlyk ]- descexport k1 k2 = intercalate "; " $ map unwords+ descexport k1 k2 = combinedescs [ [ "exporttree=yes" ] , [ getDesc k1 ] , [ getDesc k2 ]+ , map getDesc $ maybeToList mkensurereadonlyk ]+ combinedescs = intercalate "; " . map unwords . filter (not . null) test :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree] test runannex mkr mkk =@@ -306,6 +345,33 @@ tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified)+ store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate+ remove r k = Remote.removeKey r Nothing k++testEnsureReadOnly :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree]+testEnsureReadOnly runannex mkr mkk mkensurereadonlyk =+ [ check "removeKey when present fails" $ \r _ k ->+ shouldfail $ runBool (remove r k)+ , check "removeKey did not remove" $ \r _ k ->+ present r k True+ , check "removeKey when not present fails" $ \r k _ ->+ shouldfail $ runBool (remove r k)+ , check "storeKey when not present fails" $ \r k _ ->+ shouldfail $ runBool (store r k)+ ]+ where+ check desc a = testCase desc $ do+ let a' = mkr >>= \case+ Just r -> do+ k <- mkk+ ensurereadonlyk <- mkensurereadonlyk+ a r k ensurereadonlyk+ Nothing -> return True+ runannex a' @? "failed"+ shouldfail a = tryNonAsync a >>= \case+ Left _ -> return True+ Right _ -> return False+ present r k b = (== Right b) <$> Remote.hasKey r k store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate remove r k = Remote.removeKey r Nothing k
Crypto.hs view
@@ -48,6 +48,7 @@ import Types.Key import Annex.SpecialRemote.Config import Utility.Tmp.Dir+import Utility.Hash.Types {- The number of bytes of entropy used to generate a Cipher. -@@ -241,7 +242,7 @@ macWithCipher :: Mac -> Cipher -> S.ByteString -> String macWithCipher mac c = macWithCipher' mac (cipherMac c) macWithCipher' :: Mac -> S.ByteString -> S.ByteString -> String-macWithCipher' mac c s = calcMac show mac c s+macWithCipher' mac c s = calcMac (decodeBS . hashByteString . digestToHash) mac c s {- Ensure that macWithCipher' returns the same thing forevermore. -} prop_HmacSha1WithCipher_sane :: Bool
P2P/Http/Client.hs view
@@ -65,48 +65,64 @@ p2pHttpClient :: Remote+ -> Annex Git.Repo -> (String -> Annex a) -> ClientAction a -> Annex a-p2pHttpClient rmt fallback clientaction = - p2pHttpClientVersions (const True) rmt fallback clientaction >>= \case+p2pHttpClient rmt reprobeurl fallback clientaction = + p2pHttpClientVersions (const True) rmt reprobeurl fallback clientaction >>= \case Just res -> return res Nothing -> fallback "git-annex HTTP API server is missing an endpoint" p2pHttpClientVersions :: (ProtocolVersion -> Bool) -> Remote+ -> Annex Git.Repo -> (String -> Annex a) -> ClientAction a -> Annex (Maybe a)-p2pHttpClientVersions allowedversion rmt fallback clientaction = do+p2pHttpClientVersions allowedversion rmt reprobeurl fallback clientaction = do rmtrepo <- getRepo rmt- p2pHttpClientVersions' allowedversion rmt rmtrepo fallback clientaction+ case p2purl of+ Just p2purl' -> p2pHttpClientVersions' allowedversion p2purl' rmt rmtrepo fallbackreprobe clientaction+ Nothing -> error "internal"+ where+ p2purl = remoteAnnexP2PHttpUrl (gitconfig rmt)+ -- When unable to speak to the server, re-probe for its url, and+ -- try again if it changed. This avoids the user needing to manually+ -- update the remote.name.annexUrl config.+ fallbackreprobe s = do+ r <- reprobeurl+ gc <- Annex.getRemoteGitConfig r+ case remoteAnnexP2PHttpUrl gc of+ Just p2purl' | Just p2purl' /= p2purl ->+ p2pHttpClientVersions' allowedversion p2purl' rmt r fallback clientaction >>= \case+ Just res -> return res+ Nothing -> fallback s+ _ -> fallback s p2pHttpClientVersions' :: (ProtocolVersion -> Bool)+ -> P2PHttpUrl -> Remote -> Git.Repo -> (String -> Annex a) -> ClientAction a -> Annex (Maybe a)-p2pHttpClientVersions' allowedversion rmt rmtrepo fallback clientaction =- case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of- Nothing -> error "internal"- Just baseurl -> do- uo <- getUrlOptions (Just (gitconfig rmt))- let clientenv = mkClientEnv (httpManager uo) baseurl- let clientenv' = clientenv- { makeClientRequest = \u r -> - applyRequest uo- <$> makeClientRequest clientenv u r- }- ccv <- Annex.getRead Annex.gitcredentialcache- Git.CredentialCache cc <- liftIO $ atomically $- readTMVar ccv- case M.lookup (Git.CredentialBaseURL credentialbaseurl) cc of- Nothing -> go clientenv' Nothing False Nothing versions- Just cred -> go clientenv' (Just cred) True (credauth cred) versions+p2pHttpClientVersions' allowedversion p2phttpurl rmt rmtrepo fallback clientaction = do+ uo <- getUrlOptions (Just (gitconfig rmt))+ let clientenv = mkClientEnv (httpManager uo) (p2pHttpBaseUrl p2phttpurl)+ let clientenv' = clientenv+ { makeClientRequest = \u r -> + applyRequest uo+ <$> makeClientRequest clientenv u r+ }+ ccv <- Annex.getRead Annex.gitcredentialcache+ Git.CredentialCache cc <- liftIO $ atomically $+ readTMVar ccv+ case M.lookup (Git.CredentialBaseURL credentialbaseurl) cc of+ Nothing -> go clientenv' Nothing False Nothing versions+ Just cred -> go clientenv' (Just cred) True (credauth cred) versions where versions = filter allowedversion allProtocolVersions go clientenv mcred credcached mauth (v:vs) = do@@ -151,13 +167,11 @@ ++ " " ++ decodeBS (statusMessage (responseStatusCode resp)) - credentialbaseurl = case remoteAnnexP2PHttpUrl (gitconfig rmt) of- Just p2phttpurl - | isP2PHttpSameHost p2phttpurl rmtrepo ->- Git.repoLocation rmtrepo- | otherwise ->- p2pHttpUrlString p2phttpurl- Nothing -> error "internal"+ credentialbaseurl+ | isP2PHttpSameHost p2phttpurl rmtrepo =+ Git.repoLocation rmtrepo+ | otherwise =+ p2pHttpUrlString p2phttpurl credauth cred = do ba <- Git.credentialBasicAuth cred@@ -239,16 +253,17 @@ -> Key -> Annex RemoveResultPlus -> Remote+ -> Annex Git.Repo -> Annex RemoveResultPlus-clientRemoveWithProof proof k unabletoremove remote =+clientRemoveWithProof proof k unabletoremove remote reprobeurl = case safeDropProofEndTime =<< proof of Nothing -> removeanytime Just endtime -> removebefore endtime where- removeanytime = p2pHttpClient remote giveup (clientRemove k)+ removeanytime = p2pHttpClient remote reprobeurl giveup (clientRemove k) removebefore endtime =- p2pHttpClientVersions useversion remote giveup clientGetTimestamp >>= \case+ p2pHttpClientVersions useversion remote reprobeurl giveup clientGetTimestamp >>= \case Just (GetTimestampResult (Timestamp remotetime)) -> removebefore' endtime remotetime -- Peer is too old to support REMOVE-BEFORE.@@ -256,7 +271,7 @@ removebefore' endtime remotetime = canRemoveBefore endtime remotetime (liftIO getPOSIXTime) >>= \case- Just remoteendtime -> p2pHttpClient remote giveup $+ Just remoteendtime -> p2pHttpClient remote reprobeurl giveup $ clientRemoveBefore k (Timestamp remoteendtime) Nothing -> unabletoremove
P2P/Http/Url.hs view
@@ -30,7 +30,7 @@ { p2pHttpUrlString :: String , p2pHttpBaseUrl :: BaseUrl }- deriving (Show)+ deriving (Show, Eq) parseP2PHttpUrl :: String -> Maybe P2PHttpUrl parseP2PHttpUrl us
Remote/BitTorrent.hs view
@@ -216,7 +216,7 @@ withTmpFileIn othertmp (literalOsPath "torrent") $ \f h -> do liftIO $ hClose h resetAnnexFilePerm f- ok <- Url.withUrlOptions (Just gc) $ + ok <- Url.withUrlOptionsPromptingCreds (Just gc) $ Url.download nullMeterUpdate Nothing u f when ok $ liftIO $ moveFile f torrent
Remote/Bup.hs view
@@ -1,6 +1,6 @@ {- Using bup as a remote. -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -41,8 +41,23 @@ import Utility.Metered import Types.ProposedAccepted -type BupRepo = String+data BupRepo+ = BupRepoPath FilePath+ | BupRepoRemote String +parseBupRepo :: String -> BupRepo+parseBupRepo s+ | ':' `elem` s = BupRepoRemote s+ | otherwise = BupRepoPath s++serializeBupRepo :: BupRepo -> String+serializeBupRepo (BupRepoPath p) = p+serializeBupRepo (BupRepoRemote r) = r++bupRepoLocal :: BupRepo -> Bool+bupRepoLocal (BupRepoPath _) = True+bupRepoLocal (BupRepoRemote _ ) = False+ remote :: RemoteType remote = specialRemoteType $ RemoteType { typename = "bup"@@ -67,7 +82,7 @@ c <- parsedRemoteConfig remote rc bupr <- liftIO $ bup2GitRemote buprepo cst <- remoteCost gc c $- if bupLocal buprepo+ if bupRepoLocal buprepo then nearlyCheapRemoteCost else expensiveRemoteCost (u', bupr') <- getBupUUID bupr u@@ -86,7 +101,7 @@ , removeKey = removeKeyDummy , lockContent = Nothing , checkPresent = checkPresentDummy- , checkPresentCheap = bupLocal buprepo+ , checkPresentCheap = bupRepoLocal buprepo , exportActions = exportUnsupported , importActions = importUnsupported , exportImportActions = exportImportUnsupported@@ -97,18 +112,21 @@ , config = c , getRepo = return r , gitconfig = gc- , localpath = if bupLocal buprepo && not (null buprepo)- then Just (toOsPath buprepo)- else Nothing+ , localpath = case buprepo of+ BupRepoPath p | not (null p) -> Just (toOsPath p)+ _ -> Nothing , remotetype = remote- , availability = if null buprepo- then pure LocallyAvailable- else checkPathAvailability (bupLocal buprepo) (toOsPath buprepo)+ , availability = case buprepo of+ BupRepoPath p+ | null p -> pure LocallyAvailable+ | otherwise ->+ checkPathAvailability True (toOsPath p)+ BupRepoRemote _ -> pure GloballyAvailable , readonly = False , appendonly = False , untrustworthy = False , mkUnavailable = return Nothing- , getInfo = return [("repo", buprepo)]+ , getInfo = return [("repo", serializeBupRepo buprepo)] , claimUrl = Nothing , checkUrl = Nothing , remoteStateHandle = rs@@ -124,15 +142,17 @@ (checkKey bupr') this where- buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc+ buprepo = maybe (giveup "missing buprepo") parseBupRepo $+ remoteAnnexBupRepo gc bupSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) bupSetup ss mu _ _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane- let buprepo = maybe (giveup "Specify buprepo=") fromProposedAccepted $- M.lookup buprepoField c+ let buprepo = maybe (giveup "Specify buprepo=") + (parseBupRepo . fromProposedAccepted)+ (M.lookup buprepoField c) (c', _encsetup) <- encryptionSetup ss c gc -- bup init will create the repository.@@ -144,13 +164,15 @@ -- The buprepo is stored in git config, as well as this repo's -- persistent state, so it can vary between hosts.- gitConfigSpecialRemote u c' [("buprepo", buprepo)]+ gitConfigSpecialRemote u c' [("buprepo", serializeBupRepo buprepo)] return (c', u) bupParams :: String -> BupRepo -> [CommandParam] -> [CommandParam]-bupParams command buprepo params = - Param command : [Param "-r", Param buprepo] ++ params+bupParams command (BupRepoPath buprepo) params = + Param "-d" : Param buprepo : Param command : params+bupParams command (BupRepoRemote buprepo) params = + Param command : Param "-r" : Param buprepo : params bup :: String -> BupRepo -> [CommandParam] -> Annex Bool bup command buprepo params = do@@ -295,19 +317,18 @@ Right r' -> return (toUUID $ Git.Config.get configkeyUUID mempty r', r') Left _ -> return (NoUUID, r) -{- Converts a bup remote path spec into a Git.Repo. There are some- - differences in path representation between git and bup. -}+{- Converts a BupRepo into a Git.Repo. There are some+ - differences in representation between git and bup. -} bup2GitRemote :: BupRepo -> IO Git.Repo-bup2GitRemote "" = do- -- bup -r "" operates on ~/.bup+bup2GitRemote (BupRepoPath "") = do+ -- bup -d "" operates on ~/.bup h <- myHomeDir Git.Construct.fromPath $ toOsPath h </> literalOsPath ".bup"-bup2GitRemote r- | bupLocal r = - if "/" `isPrefixOf` r- then Git.Construct.fromPath (toOsPath r)- else giveup "please specify an absolute path"- | otherwise = Git.Construct.fromUrl False $ "ssh://" ++ host ++ slash dir+bup2GitRemote (BupRepoPath r)+ | "/" `isPrefixOf` r = Git.Construct.fromPath (toOsPath r)+ | otherwise = giveup "please specify an absolute path"+bup2GitRemote (BupRepoRemote r) = + Git.Construct.fromUrl False $ "ssh://" ++ host ++ slash dir where bits = splitc ':' r host = fromMaybe "" $ headMaybe bits@@ -328,9 +349,6 @@ | otherwise = "git-annex-" ++ show (digestToHash (sha2_256 (fromString shown))) where shown = serializeKey k--bupLocal :: BupRepo -> Bool-bupLocal = notElem ':' {- Bup is not concurrency safe, so use a lock file. Only one writer process - should run at a time; multiple readers may run if no writer is running. -}
Remote/External.hs view
@@ -100,9 +100,9 @@ importUnsupported return $ Just $ specialRemote c readonlyStorer- (retrieveUrl gc)+ (retrieveUrlReadOnly gc) readonlyRemoveKey- (checkKeyUrl gc)+ (checkKeyUrlReadOnly gc) rmt | otherwise = do c <- parsedRemoteConfig remote rc@@ -335,7 +335,7 @@ | k == k' -> result $ Left $ respErrorMessage "TRANSFER" errmsg TRANSFER_RETRIEVE_URL k' url- | k == k' -> getResult $ retrieveUrl' gc url dest k p+ | k == k' -> getResult $ retrieveUrl gc url dest k p DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps _ <- retrieveKeyFile delegate k@@ -373,7 +373,7 @@ | k' == k -> result $ Left $ respErrorMessage "CHECKPRESENT" errmsg CHECKPRESENT_URL k' url- | k == k' -> checkKeyUrl' gc k url+ | k == k' -> checkKeyUrl gc k url DELEGATE ps -> Just $ do delegate <- getDelegateRemote external ps Result . Right <$> checkPresent delegate k@@ -432,7 +432,7 @@ TRANSFER_FAILURE Download k' errmsg | k == k' -> result $ Left $ respErrorMessage "TRANSFER" errmsg TRANSFER_RETRIEVE_URL k' url- | k == k' -> Just $ Result <$> retrieveUrl' gc url dest k p+ | k == k' -> Just $ Result <$> retrieveUrl gc url dest k p DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps _ <- retrieveExport (exportActions delegate) k loc dest p@@ -466,7 +466,7 @@ RETRIEVEIMPORT_FAILURE errmsg -> result $ Left $ respErrorMessage "RETRIEVEIMPORT" errmsg RETRIEVEIMPORT_URL url -> getResult $ do- retrieveUrl' gc url dest UnknownSize p >>= \case+ retrieveUrl gc url dest UnknownSize p >>= \case Right () -> Right <$> either pure id gk Left msg -> pure (Left msg) DELEGATE ps -> getResult $ do@@ -522,7 +522,7 @@ | k' == k -> result $ Left $ respErrorMessage srequest errmsg CHECKPRESENT_URL k' url- | k == k' -> checkKeyUrl' gc k url+ | k == k' -> checkKeyUrl gc k url DELEGATE ps -> Just $ do delegate <- getDelegateRemote external ps Result . Right <$> delegateaction delegate k loc@@ -864,7 +864,7 @@ liftIO $ atomically $ do l <- takeTMVar cleanupv putTMVar cleanupv (removeTmpFile tmpf:l)- res <- withUrlOptions (Just gc) $+ res <- withUrlOptionsPromptingCreds (Just gc) $ downloadUrl' False UnknownSize nullMeterUpdate Nothing [url] tmpf@@ -1206,15 +1206,15 @@ where mkmulti (u, s, f) = (u, s, toOsPath f) -retrieveUrl :: RemoteGitConfig -> Retriever-retrieveUrl gc = fileRetriever' $ \f k p iv -> do+retrieveUrlReadOnly :: RemoteGitConfig -> Retriever+retrieveUrlReadOnly gc = fileRetriever' $ \f k p iv -> do us <- getWebUrls k unlessM (withUrlOptions (Just gc) $ downloadUrl True k p iv us f) $ giveup downloadFailed -retrieveUrl' :: MeterSize sizer => RemoteGitConfig -> URLString -> OsPath -> sizer -> MeterUpdate -> Annex (Either String ())-retrieveUrl' gc url dest sizer p = - withUrlOptions (Just gc) $ \uo ->+retrieveUrl :: MeterSize sizer => RemoteGitConfig -> URLString -> OsPath -> sizer -> MeterUpdate -> Annex (Either String ())+retrieveUrl gc url dest sizer p = + withUrlOptionsPromptingCreds (Just gc) $ \uo -> downloadUrl' False sizer p Nothing [url] dest uo >>= return . \case Left msg -> Left msg Right True -> Right ()@@ -1223,14 +1223,14 @@ downloadFailed :: String downloadFailed = "failed to download content" -checkKeyUrl :: RemoteGitConfig -> CheckPresent-checkKeyUrl gc k = do+checkKeyUrlReadOnly :: RemoteGitConfig -> CheckPresent+checkKeyUrlReadOnly gc k = do us <- getWebUrls k anyM (\u -> withUrlOptions (Just gc) $ checkBoth u (fromKey keySize k)) us -checkKeyUrl' :: RemoteGitConfig -> Key -> URLString -> Maybe (Annex (ResponseHandlerResult (Either String Bool)))-checkKeyUrl' gc k url = - Just $ withUrlOptions (Just gc) $ \uo ->+checkKeyUrl :: RemoteGitConfig -> Key -> URLString -> Maybe (Annex (ResponseHandlerResult (Either String Bool)))+checkKeyUrl gc k url = + Just $ withUrlOptionsPromptingCreds (Just gc) $ \uo -> Result <$> checkBoth' url (fromKey keySize k) uo getWebUrls :: Key -> Annex [URLString]
Remote/Git.hs view
@@ -73,6 +73,7 @@ import Messages.Progress import Control.Concurrent+import Control.Concurrent.STM import qualified Data.Map as M import qualified Data.Set as S import qualified Data.List.NonEmpty as NE@@ -377,10 +378,12 @@ setremote (setConfig . annexUrlConfigKey) u _ -> noop return r'- Left err -> do- set_ignore "not usable by git-annex" False- warning $ UnquotedString $ configurl (Git.repoLocationUserVisible r) ++ " " ++ err- return r+ Left err+ | hasuuid -> return r+ | otherwise -> do+ set_ignore "not usable by git-annex" False+ warning $ UnquotedString $ configurl (Git.repoLocationUserVisible r) ++ " " ++ err+ return r configlist_failed = set_ignore "does not have git-annex installed" True @@ -411,7 +414,7 @@ - it if allowed. However, if that fails, still return the read - git config. -} readlocalannexconfig = do- let check = do+ let checker = do Annex.BranchState.disableUpdate catchNonAsync (autoInitialize noop (pure [])) $ \e -> warning $ UnquotedString $ "Remote " ++ Git.repoDescribe r ++@@ -421,7 +424,7 @@ if autoinit then do s <- newLocal r'- liftIO $ Annex.eval s $ check+ liftIO $ Annex.eval s $ checker `finally` quiesce True else liftIO $ Git.Config.read r' @@ -468,13 +471,13 @@ inAnnex' repo rmt st key inAnnex' :: Git.Repo -> Remote -> State -> Key -> Annex Bool-inAnnex' repo rmt st@(State connpool duc _ _ _ _) key+inAnnex' repo rmt st@(State connpool duc _ _ _ _ _) key | isP2PHttp rmt = checkp2phttp | Git.repoIsHttp repo = checkhttp | Git.repoIsUrl repo = checkremote | otherwise = checklocal where- checkp2phttp = p2pHttpClient rmt giveup (clientCheckPresent key)+ checkp2phttp = p2pHttpClient rmt (p2pHttpReprobe st rmt) giveup (clientCheckPresent key) checkhttp = do gc <- Annex.getGitConfig Url.withUrlOptionsPromptingCreds (Just (gitconfig rmt)) $ \uo -> @@ -512,9 +515,9 @@ dropKey' repo r st proof key dropKey' :: Git.Repo -> Remote -> State -> Maybe SafeDropProof -> Key -> Annex ()-dropKey' repo r st@(State connpool duc _ _ _ _) proof key+dropKey' repo r st@(State connpool duc _ _ _ _ _) proof key | isP2PHttp r = - clientRemoveWithProof proof key unabletoremove r >>= \case+ clientRemoveWithProof proof key unabletoremove r (p2pHttpReprobe st r) >>= \case RemoveResultPlus True fanoutuuids -> storefanout fanoutuuids RemoveResultPlus False fanoutuuids -> do@@ -561,12 +564,12 @@ lockKey' repo r st key callback lockKey' :: Git.Repo -> Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r-lockKey' repo r st@(State connpool duc _ _ _ _) key callback+lockKey' repo r st@(State connpool duc _ _ _ _ _) key callback | isP2PHttp r = do showLocking r- p2pHttpClient r giveup (clientLockContent key) >>= \case+ p2pHttpClient r (p2pHttpReprobe st r) giveup (clientLockContent key) >>= \case LockResult True (Just lckid) ->- p2pHttpClient r failedlock $+ p2pHttpClient r (p2pHttpReprobe st r) failedlock $ clientKeepLocked lckid (uuid r) failedlock callback _ -> failedlock@@ -596,7 +599,7 @@ copyFromRemote'' repo r st key file dest meterupdate vc copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification-copyFromRemote'' repo r st@(State connpool _ _ _ _ _) key af dest meterupdate vc+copyFromRemote'' repo r st@(State connpool _ _ _ _ _ _) key af dest meterupdate vc | isP2PHttp r = copyp2phttp | Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do gc <- Annex.getGitConfig@@ -609,8 +612,8 @@ hardlink <- wantHardLink -- run copy from perspective of remote onLocalFast st $ Annex.Content.prepSendAnnex' key Nothing >>= \case- Just (object, _sz, check) -> do- let checksuccess = check >>= \case+ Just (object, _sz, checker) -> do+ let checksuccess = checker >>= \case Just err -> giveup err Nothing -> return True copier <- mkFileCopier hardlink st@@ -642,7 +645,7 @@ _ -> return p let consumer = meteredWrite' p' (writeVerifyChunk iv h)- p2pHttpClient r giveup (clientGet key af consumer startsz) >>= \case+ p2pHttpClient r (p2pHttpReprobe st r) giveup (clientGet key af consumer startsz) >>= \case Valid -> return () Invalid -> giveup "Transfer failed" @@ -672,7 +675,7 @@ copyToRemote' repo r st key af o meterupdate copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()-copyToRemote' repo r st@(State connpool duc _ _ _ _) key af o meterupdate+copyToRemote' repo r st@(State connpool duc _ _ _ _ _) key af o meterupdate | isP2PHttp r = prepsendwith copyp2phttp | not $ Git.repoIsUrl repo = ifM duc ( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $@@ -695,11 +698,11 @@ failedsend = giveup "failed to send content to remote" - copylocal (object, sz, check) = do- -- The check action is going to be run in+ copylocal (object, sz, checker) = do+ -- The checker action is going to be run in -- the remote's Annex, but it needs access to the local -- Annex monad's state.- checkio <- Annex.withCurrentState check+ checkerio <- Annex.withCurrentState checker u <- getUUID hardlink <- wantHardLink -- run copy from perspective of remote@@ -709,7 +712,7 @@ let verify = RemoteVerify r copier <- mkFileCopier hardlink st let rsp = RetrievalAllKeysSecure- let checksuccess = liftIO checkio >>= \case+ let checksuccess = liftIO checkerio >>= \case Just err -> giveup err Nothing -> return True logStatusAfter NoLiveUpdate key $ Annex.Content.getViaTmp rsp verify key (Just sz) $ \dest ->@@ -719,18 +722,18 @@ unless res $ failedsend - copyp2phttp (object, sz, check) =- let check' = check >>= \case+ copyp2phttp (object, sz, checker) =+ let checker' = checker >>= \case Just s -> do warning (UnquotedString s) return False Nothing -> return True- in p2pHttpClient r (const $ pure $ PutOffsetResultPlus (Offset 0)) (clientPutOffset key) >>= \case+ in p2pHttpClient r (p2pHttpReprobe st r) (const $ pure $ PutOffsetResultPlus (Offset 0)) (clientPutOffset key) >>= \case PutOffsetResultPlus (offset@(Offset (P2P.Offset n))) -> metered (Just meterupdate) key bwlimit $ \_ p -> do let p' = offsetMeterUpdate p (BytesProcessed n)- res <- p2pHttpClient r giveup $- clientPut p' key (Just offset) af object sz check' False+ res <- p2pHttpClient r (p2pHttpReprobe st r) giveup $+ clientPut p' key (Just offset) af object sz checker' False case res of PutResultPlus False fanoutuuids -> do storefanout fanoutuuids@@ -786,7 +789,7 @@ - when possible. -} onLocal :: State -> Annex a -> Annex a-onLocal (State _ _ _ _ _ lra) = onLocal' lra+onLocal (State _ _ _ _ _ _ lra) = onLocal' lra onLocalRepo :: Remote -> Git.Repo -> Annex a -> Annex a onLocalRepo r repo a = do@@ -865,32 +868,32 @@ -- done. Also returns Verified if the key's content is verified while -- copying it. mkFileCopier :: Bool -> State -> Annex FileCopier-mkFileCopier remotewanthardlink (State _ _ copycowtried fastcopy _ _) = do+mkFileCopier remotewanthardlink (State _ _ copycowtried _ fastcopy _ _) = do localwanthardlink <- wantHardLink let linker = \src dest -> R.createLink (fromOsPath src) (fromOsPath dest) >> return True if remotewanthardlink || localwanthardlink- then return $ \src dest k p check verifyconfig ->+ then return $ \src dest k p checker verifyconfig -> ifM (liftIO (catchBoolIO (linker src dest)))- ( ifM check+ ( ifM checker ( return (True, Verified) , do verificationOfContentFailed dest return (False, UnVerified) )- , copier src dest k p check verifyconfig+ , copier src dest k p checker verifyconfig ) else return copier where- copier src dest k p check verifyconfig = do+ copier src dest k p checker verifyconfig = do iv <- startVerifyKeyContentIncrementally verifyconfig k liftIO (fileCopier copycowtried fastcopy src dest p iv) >>= \case- Copied -> ifM check+ Copied -> ifM checker ( finishVerifyKeyContentIncrementally iv , do verificationOfContentFailed dest return (False, UnVerified) )- CopiedCoW -> unVerified check+ CopiedCoW -> unVerified checker {- Normally the UUID of a local repository is checked at startup, - but annex-checkuuid config can prevent that. To avoid getting@@ -899,25 +902,28 @@ - This returns False when the repository UUID is not as expected. -} type DeferredUUIDCheck = Annex Bool -data State = State Ssh.P2PShellConnectionPool DeferredUUIDCheck CopyCoWTried FastCopy (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex+type P2pHttpReprobed = TMVar Bool +data State = State Ssh.P2PShellConnectionPool DeferredUUIDCheck CopyCoWTried P2pHttpReprobed FastCopy (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex+ getRepoFromState :: State -> Annex Git.Repo-getRepoFromState (State _ _ _ _ a _) = fst <$> a+getRepoFromState (State _ _ _ _ _ a _) = fst <$> a #ifndef mingw32_HOST_OS {- The config of the remote git repository, cached for speed. -} getGitConfigFromState :: State -> Annex GitConfig-getGitConfigFromState (State _ _ _ _ a _) = snd <$> a+getGitConfigFromState (State _ _ _ _ _ a _) = snd <$> a #endif mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State mkState r u gc = do pool <- Ssh.mkP2PShellConnectionPool copycowtried <- liftIO newCopyCoWTried+ p2phttpretried <- liftIO $ newTMVarIO False fastcopy <- getFastCopy gc lra <- mkLocalRemoteAnnex r gc (duc, getrepo) <- go- return $ State pool duc copycowtried fastcopy getrepo lra+ return $ State pool duc copycowtried p2phttpretried fastcopy getrepo lra where go | remoteAnnexCheckUUID gc = return@@ -1062,8 +1068,6 @@ -- Git remotes that are gcrypt or git-lfs special remotes cannot -- proxy. Local git remotes cannot proxy either because -- git-annex-shell is not used to access a local git url.- -- Proxing is also yet supported for remotes using P2P- -- addresses. canproxy gc r | isP2PHttp' gc = True | remoteAnnexGitLFS gc = False@@ -1077,3 +1081,14 @@ isP2PHttp' :: RemoteGitConfig -> Bool isP2PHttp' = isJust . remoteAnnexP2PHttpUrl +-- Re-read the config of the remote to detect a change to+-- its annex.url, and update the cached remote.name.annexUrl.+p2pHttpReprobe :: State -> Remote -> Annex Git.Repo+p2pHttpReprobe (State _ _ _ reprobed _ _ _) rmt =+ ifM (liftIO (atomically (takeTMVar reprobed)))+ ( getRepo rmt+ , do+ r <- getRepo rmt+ tryGitConfigRead (gitconfig rmt) False r True+ )+ `finally` liftIO (atomically $ putTMVar reprobed True)
Remote/Helper/ExportImport.hs view
@@ -452,20 +452,15 @@ else retrieveWithoutContentIdentifier $ retrieveFromExport getlocs k af dest p - retrieveFromImport getlocs ciddbv k af dest p = do+ retrieveFromImport getlocs ciddbv k _af dest p = do cids <- getkeycids ciddbv k- if not (null cids)- then getlocs $ \loc ->- -- retrieveImport does not guarantee that- -- the file it retrieves has the content- -- identifier, so it must be strongly- -- verified.- stronglyverify $- snd <$> retrieveImport (importActions r) loc cids dest (Left k) p- -- In case a content identifier is somehow missing,- -- try this instead.- else retrieveWithoutContentIdentifier $- retrieveFromExport getlocs k af dest p+ getlocs $ \loc ->+ -- retrieveImport does not guarantee that+ -- the file it retrieves corresponds to any + -- content identifier, so it must be strongly+ -- verified.+ stronglyverify $+ snd <$> retrieveImport (importActions r) loc cids dest (Left k) p retrieveWithoutContentIdentifier a | isexport = a
Remote/HttpAlso.hs view
@@ -134,7 +134,7 @@ downloadAction :: RemoteGitConfig -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () downloadAction gc dest p iv run =- Url.withUrlOptions (Just gc) $ \uo ->+ Url.withUrlOptionsPromptingCreds (Just gc) $ \uo -> run (\url -> Url.download' p iv url dest uo) >>= either giveup (const (return ())) @@ -144,7 +144,7 @@ checkKey' :: RemoteGitConfig -> Key -> URLString -> Annex (Either String Bool) checkKey' gc key url = - Url.withUrlOptions (Just gc) $ Url.checkBoth' url (fromKey keySize key)+ Url.withUrlOptionsPromptingCreds (Just gc) $ Url.checkBoth' url (fromKey keySize key) checkPresentExportHttpAlso :: RemoteGitConfig -> Maybe URLString -> Key -> ExportLocation -> Annex Bool checkPresentExportHttpAlso gc baseurl key loc =
Remote/Mask.hs view
@@ -166,12 +166,17 @@ mkMaskedRemote c gc u = do v <- liftIO $ newTMVarIO Nothing return $ MaskedRemote $ - liftIO (atomically (takeTMVar v)) >>= \case- Just maskedremote -> return maskedremote- Nothing -> do- maskedremote <- findMaskedRemote c gc u- liftIO $ atomically $ putTMVar v (Just maskedremote)- return maskedremote+ liftIO (atomically (takeTMVar v)) >>= \d ->+ go v d `onException` restore v+ where+ go v (Just maskedremote) = do+ liftIO $ atomically $ putTMVar v (Just maskedremote)+ return maskedremote+ go v Nothing = do+ maskedremote <- findMaskedRemote c gc u+ liftIO $ atomically $ putTMVar v (Just maskedremote)+ return maskedremote+ restore v = liftIO (atomically (void (tryPutTMVar v Nothing))) findMaskedRemote :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex Remote findMaskedRemote c gc myuuid = case remoteAnnexMask gc of
Remote/Web.hs view
@@ -141,7 +141,7 @@ ) dl (us, ytus) = do iv <- startVerifyKeyContentIncrementally vc key- ifM (Url.withUrlOptions (Just gc) $ downloadUrl True key p iv (map fst us) dest)+ ifM (Url.withUrlOptionsPromptingCreds (Just gc) $ downloadUrl True key p iv (map fst us) dest) ( finishVerifyKeyContentIncrementally iv >>= \case (True, v) -> postdl v (False, _) -> dl ([], ytus)@@ -193,7 +193,7 @@ case downloader of YoutubeDownloader -> youtubeDlCheck u' _ -> catchMsgIO $- Url.withUrlOptions (Just gc) $+ Url.withUrlOptionsPromptingCreds (Just gc) $ Url.checkBoth u' (fromKey keySize key) where firsthit [] miss _ = return miss
Remote/WebDAV.hs view
@@ -417,12 +417,12 @@ data DavHandle = DavHandle DAVContext DavUser DavPass URLString -type DavHandleVar = TMVar (Either (Annex (Either String DavHandle)) (Either String DavHandle))+type DavHandleVar = TVar (Either (Annex (Either String DavHandle)) (Either String DavHandle)) {- Prepares a DavHandle for later use. Does not connect to the server or do - anything else expensive. -} mkDavHandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex DavHandleVar-mkDavHandleVar c gc u = liftIO $ newTMVarIO $ Left $ do+mkDavHandleVar c gc u = liftIO $ newTVarIO $ Left $ do mcreds <- getCreds c gc u case (mcreds, configUrl c) of (Just (user, pass), Just baseurl) -> do@@ -431,16 +431,12 @@ return (Right h) _ -> return $ Left "webdav credentials not available" -{- Concurrent actions are allowed to run at the same time with the same- - DavHandle, so any use of eg setDepth will affect other actions. -} withDavHandle :: DavHandleVar -> (DavHandle -> Annex a) -> Annex a-withDavHandle hv a = liftIO (atomically (takeTMVar hv)) >>= \case- Right hdl -> do- liftIO $ atomically $ putTMVar hv (Right hdl)- either giveup a hdl+withDavHandle hv a = liftIO (readTVarIO hv) >>= \case+ Right hdl -> either giveup a hdl Left mkhdl -> do hdl <- mkhdl- liftIO $ atomically $ putTMVar hv (Right hdl)+ liftIO $ atomically $ writeTVar hv (Right hdl) either giveup a hdl goDAV :: DavHandle -> DAVT IO a -> IO a
Test.hs view
@@ -79,7 +79,7 @@ import qualified Utility.InodeCache import qualified Utility.Matcher import qualified Utility.Hash-import qualified Utility.HMAC+import qualified Utility.Hash.HMAC import qualified Utility.Scheduled import qualified Utility.Scheduled.QuickCheck import qualified Utility.HumanTime@@ -98,7 +98,7 @@ optParser :: Parser TestOptions optParser = TestOptions- <$> snd (tastyParser (tests 1 False defaulttos))+ <$> snd (tastyParser defaulttos (tests 1 False defaulttos)) <*> switch ( long "keep-failures" <> help "preserve repositories on test failure"@@ -121,6 +121,10 @@ ( long "test-debug" <> help "show debug messages for commands run by test suite" )+ <*> switch+ ( long "tap"+ <> help "use TAP output"+ ) <*> cmdParams "non-options are for internal use only" where parseconfigvalue s = case break (== '=') s of@@ -136,11 +140,12 @@ , concurrentJobs = Nothing , testGitConfig = mempty , testDebug = False+ , tapOutput = False , internalData = mempty } runner :: TestOptions -> IO ()-runner opts = parallelTestRunner opts tests+runner opts = testRunner opts tests tests :: Int -> Bool -> TestOptions -> [TestTree] tests numparts crippledfilesystem opts = @@ -202,7 +207,7 @@ where combos = concat [ Utility.Hash.props_hashes_stable- , Utility.HMAC.props_macs_stable+ , Utility.Hash.HMAC.props_macs_stable ] testRemotes :: TestTree@@ -261,7 +266,7 @@ cv <- annexeval cache liftIO $ atomically $ putTMVar v (r, (unavailr, (exportr, (ks, cv))))- go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr (NE.fromList mkks)+ go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr (NE.fromList mkks) Nothing where runannex = inmainrepo . annexeval mkrs = if testvariants
Test/Framework.hs view
@@ -21,6 +21,9 @@ import Test.Tasty.Ingredients.Rerun import Test.Tasty.Ingredients.ConsoleReporter import qualified Test.Tasty.Patterns.Types as TP+#ifdef WITH_TASTYTAP+import Test.Tasty.Runners.TAP+#endif import Options.Applicative.Types import Control.Concurrent import Control.Concurrent.Async@@ -772,6 +775,23 @@ \_ _ _ pid -> exitWith =<< waitForProcess pid runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps +testRunner :: TestOptions -> (Int -> Bool -> TestOptions -> [TestTree]) -> IO ()+testRunner opts mkts+ | fakeSsh opts = runFakeSsh (internalData opts)+ | tapOutput opts = +#ifdef WITH_TASTYTAP+ parallelTestRunner 1 opts mkts+#else+ error "git-annex was built without --tap support"+#endif+ | otherwise = do+ numjobs <- case concurrentJobs opts of+ Just NonConcurrent -> pure 1+ Just (Concurrent n) -> pure n+ Just ConcurrentPerCpu -> getNumProcessors+ Nothing -> getNumProcessors+ parallelTestRunner numjobs opts mkts+ {- Tests each TestTree in parallel, and exits with success/failure. - - Tasty supports parallel tests, but this does not use it, because@@ -782,17 +802,8 @@ - leave open are closed before finalCleanup is run at the end. This - prevents some failures to clean up after the test suite. -}-parallelTestRunner :: TestOptions -> (Int -> Bool -> TestOptions -> [TestTree]) -> IO ()-parallelTestRunner opts mkts = do- numjobs <- case concurrentJobs opts of- Just NonConcurrent -> pure 1- Just (Concurrent n) -> pure n- Just ConcurrentPerCpu -> getNumProcessors- Nothing -> getNumProcessors- parallelTestRunner' numjobs opts mkts--parallelTestRunner' :: Int -> TestOptions -> (Int -> Bool -> TestOptions -> [TestTree]) -> IO ()-parallelTestRunner' numjobs opts mkts+parallelTestRunner :: Int -> TestOptions -> (Int -> Bool -> TestOptions -> [TestTree]) -> IO ()+parallelTestRunner numjobs opts mkts | fakeSsh opts = runFakeSsh (internalData opts) | otherwise = go =<< Utility.Env.getEnv subenv where@@ -808,6 +819,11 @@ then 1 else numjobs * 2 + mkts' crippledfilesystem+ | tapOutput opts = + [topLevelTestGroup $ mkts 1 crippledfilesystem opts]+ | otherwise = mkts numparts crippledfilesystem opts+ worker rs nvar a = do (n, m) <- atomically $ do (n, m) <- readTVar nvar@@ -819,7 +835,12 @@ r <- a n worker (r:rs) nvar a - summarizeresults a = do+ summarizeresults a+ | tapOutput opts = do+ _ <- a+ return ()+ | otherwise = summarizeresults' a+ summarizeresults' a = do starttime <- getCurrentTime (numts, exitcodes) <- a duration <- Utility.HumanTime.durationSince starttime@@ -846,8 +867,8 @@ <$> Annex.Init.probeCrippledFileSystem' (toOsPath tmpdir) Nothing Nothing False- let ts = mkts numparts crippledfilesystem opts- let warnings = fst (tastyParser ts)+ let ts = mkts' crippledfilesystem+ let warnings = fst (tastyParser opts ts) unless (null warnings) $ do hPutStrLn stderr "warnings from tasty:" mapM_ (hPutStrLn stderr) warnings@@ -855,9 +876,11 @@ args <- getArgs pp <- fromOsPath <$> Annex.Path.programPath termcolor <- hSupportsANSIColor stdout- let ps = if useColor (lookupOption tastyopts) termcolor- then "--color=always":args- else "--color=never":args+ let ps = if tapOutput opts+ then args+ else if useColor (lookupOption tastyopts) termcolor+ then "--color=always":args+ else "--color=never":args let runone n = do let subdir = fromOsPath $ toOsPath tmpdir </> toOsPath (show n) ensuredir subdir@@ -875,9 +898,11 @@ go (Just subenvval) = case readish subenvval of Nothing -> error ("Bad " ++ subenv) Just (n, crippledfilesystem) -> setTestEnv $ do- let ts = mkts numparts crippledfilesystem opts- let t = topLevelTestGroup [ ts !! (n - 1) ]- case tryIngredients ingredients tastyopts t of+ let ts = mkts' crippledfilesystem+ let t = if tapOutput opts+ then ts !! 0+ else topLevelTestGroup [ ts !! (n - 1) ]+ case tryIngredients (ingredients opts) tastyopts t of Nothing -> error "No tests found!?" Just act -> ifM act ( exitSuccess@@ -901,14 +926,20 @@ initTestsName :: String initTestsName = "Init Tests" -tastyParser :: [TestTree] -> ([String], Parser Test.Tasty.Options.OptionSet)-tastyParser ts = suiteOptionParser ingredients (topLevelTestGroup ts)+tastyParser :: TestOptions -> [TestTree] -> ([String], Parser Test.Tasty.Options.OptionSet)+tastyParser opts ts = suiteOptionParser (ingredients opts) (topLevelTestGroup ts) -ingredients :: [Ingredient]-ingredients =- [ listingTests- , rerunningTests [consoleTestReporter]- ]+ingredients :: TestOptions -> [Ingredient]+ingredients opts =+ listingTests :+#ifdef WITH_TASTYTAP+ if tapOutput opts+ then [ tapRunner ]+ else []+#else+ []+#endif+ ++ [ rerunningTests [consoleTestReporter] ] -- Prior to tasty 1.5.4, testGroup ran in order. #if ! MIN_VERSION_tasty(1,5,4)
Types/Crypto.hs view
@@ -20,7 +20,7 @@ calcMac, ) where -import Utility.HMAC+import Utility.Hash.HMAC import Utility.Gpg (KeyIds(..)) import Data.Typeable
Types/Remote.hs view
@@ -481,8 +481,8 @@ -- key. , importKey :: a (Maybe (ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> a (Maybe Key))) -- Like retrieveExportWithContentIdentifier, but does not- -- need to guarantee that the file it retrieves has one- -- of the requested ContentIdentifiers.+ -- need to guarantee that the file it retrieves corresponds+ -- to any of the listed ContentIdentifiers. , retrieveImport :: ImportLocation -> [ContentIdentifier]
Types/Test.hs view
@@ -1,6 +1,6 @@ {- git-annex test data types. -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -20,6 +20,7 @@ , concurrentJobs :: Maybe Concurrency , testGitConfig :: [(ConfigKey, ConfigValue)] , testDebug :: Bool+ , tapOutput :: Bool , internalData :: CmdParams }
− Utility/HMAC.hs
@@ -1,56 +0,0 @@-{- 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/Crypton.hs view
@@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE BangPatterns, PackageImports #-}+{-# LANGUAGE BangPatterns, PackageImports, CPP #-} {-# LANGUAGE RankNTypes #-} module Utility.Hash.Crypton (@@ -64,12 +64,17 @@ Context, mkIncrementalHasher, mkIncrementalVerifier,+ hashDigest, ) where import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.IORef+#if MIN_VERSION_crypton(1,1,0)+import qualified "ram" Data.ByteArray as BA+#else import qualified "memory" Data.ByteArray as BA+#endif import "crypton" Crypto.Hash import Utility.Hash.Types
+ Utility/Hash/HMAC.hs view
@@ -0,0 +1,73 @@+{- Convenience wrapper for HMACs+ -+ - Copyright 2013-2026 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings, CPP #-}++module Utility.Hash.HMAC (+ Mac(..),+ calcMac,+ props_macs_stable,+) where++import Utility.Hash.Types+import qualified Data.ByteString as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+#ifdef WITH_BOTAN+import Botan.Low.MAC+import Botan.Low.Hash hiding (HashDigest)+import System.IO.Unsafe (unsafePerformIO)+#else+import Utility.Hash.Crypton (hashDigest)+import "crypton" Crypto.MAC.HMAC hiding (Context)+import "crypton" Crypto.Hash+#endif++data Mac = HmacSha1 | HmacSha224 | HmacSha256 | HmacSha384 | HmacSha512+ deriving (Eq)++calcMac+ :: (HashDigest -> 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+#ifdef WITH_BOTAN+ use alg k m = unsafePerformIO $ do+ maccer <- macInit (hmac alg)+ macSetKey maccer k+ macUpdate maccer m+ auth <- macFinal maccer+ return (f (HashDigest auth))+#else+ use alg k m = f (hashDigest (hmacGetDigest (hmacWitnessAlg alg k m)))++ hmacWitnessAlg :: HashAlgorithm a => a -> S.ByteString -> S.ByteString -> HMAC a+ hmacWitnessAlg _ = hmac+#endif++-- 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 digestToHash 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/Types.hs view
@@ -11,7 +11,6 @@ module Utility.Hash.Types where import qualified Data.ByteString as S-import "memory" Data.ByteArray import qualified "memory" Data.ByteArray.Encoding as BAE import Data.String import Control.DeepSeq@@ -33,14 +32,10 @@ instance NFData Hash -- the raw hash digest-newtype HashDigest = HashDigest S.ByteString+newtype HashDigest = HashDigest { hashDigestByteString :: 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/QuickCheck.hs view
@@ -8,6 +8,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-tabs #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE CPP #-} module Utility.QuickCheck ( module X@@ -23,7 +24,9 @@ import Data.Ratio import Data.Char import System.Posix.Types+#if ! MIN_VERSION_QuickCheck(2,17,0) import Data.List.NonEmpty (NonEmpty(..))+#endif {- A String, but Arbitrary is limited to ascii. -@@ -78,8 +81,10 @@ instance Arbitrary FileOffset where arbitrary = nonNegative arbitrarySizedIntegral +#if ! MIN_VERSION_QuickCheck(2,17,0) instance Arbitrary l => Arbitrary (NonEmpty l) where arbitrary = (:|) <$> arbitrary <*> arbitrary+#endif nonNegative :: (Num a, Ord a) => Gen a -> Gen a nonNegative g = g `suchThat` (>= 0)
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20260901+Version: 10.20261005 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -194,6 +194,10 @@ Description: Enable XXH3 support Default: False +Flag TastyTap+ Description: Use tasty-tap to support git-annex test TAP output+ Default: True+ source-repository head type: git location: https://git.joeyh.name/git/git-annex.git/@@ -289,10 +293,8 @@ servant-client-core, warp (>= 3.2.8), warp-tls (>= 3.2.2),- crypton, crypton-connection (>= 0.4.3), crypton-x509-store,- tls, aws (>= 0.24.1) CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs -Wincomplete-uni-patterns@@ -309,11 +311,16 @@ ram (< 0.21.0), persistent (>= 2.13.3) && (< 2.15.0.0), warp (< 3.4.11),- magic (<= 1.1)+ magic (<= 1.1),+ crypton (< 1.1.0),+ tls (< 2.4.4) else Build-Depends: base (>= 4.18.2.1 && < 5),- persistent (>= 2.13.3)+ persistent (>= 2.13.3),+ crypton,+ ram,+ tls -- Fully optimize for production. if flag(Production)@@ -364,6 +371,10 @@ Other-Modules: Utility.Hash.XXH3 + if flag(TastyTap)+ Build-Depends: tasty-tap+ CPP-Options: -DWITH_TASTYTAP+ if (os(windows)) Build-Depends: Win32 (>= 2.13.4.0),@@ -1117,7 +1128,7 @@ Utility.Hash.Crypton Utility.Hash.Incremental Utility.Hash.Types- Utility.HMAC+ Utility.Hash.HMAC Utility.HtmlDetect Utility.HumanNumber Utility.HumanTime
stack-NoLLMDependencies.yaml view
@@ -29,3 +29,5 @@ - yesod-form-1.7.9.2 - yesod-static-1.6.1.2 - magic-1.1+- crypton-1.0.6+- tls-2.1.8