packages feed

git-annex 10.20240927 → 10.20241031

raw patch · 46 files changed

+657/−226 lines, 46 filesdep ~stm

Dependency ranges changed: stm

Files

Annex/AdjustedBranch.hs view
@@ -11,7 +11,7 @@ 	Adjustment(..), 	LinkAdjustment(..), 	PresenceAdjustment(..),-	LinkPresentAdjustment(..),+	LockUnlockPresentAdjustment(..), 	adjustmentHidesFiles, 	adjustmentIsStable, 	OrigBranch,@@ -88,11 +88,11 @@ 		adjustTreeItem p t >>= \case 			Nothing -> return Nothing 			Just t' -> adjustTreeItem l t'-	adjustTreeItem (LinkPresentAdjustment l) t = adjustTreeItem l t+	adjustTreeItem (LockUnlockPresentAdjustment l) t = adjustTreeItem l t  	adjustmentIsStable (LinkAdjustment l) = adjustmentIsStable l 	adjustmentIsStable (PresenceAdjustment p _) = adjustmentIsStable p-	adjustmentIsStable (LinkPresentAdjustment l) = adjustmentIsStable l+	adjustmentIsStable (LockUnlockPresentAdjustment l) = adjustmentIsStable l  instance AdjustTreeItem LinkAdjustment where 	adjustTreeItem UnlockAdjustment =@@ -115,7 +115,7 @@ 	adjustmentIsStable HideMissingAdjustment = False 	adjustmentIsStable ShowMissingAdjustment = True -instance AdjustTreeItem LinkPresentAdjustment where+instance AdjustTreeItem LockUnlockPresentAdjustment where 	adjustTreeItem UnlockPresentAdjustment =  		ifPresent adjustToPointer adjustToSymlink 	adjustTreeItem LockPresentAdjustment =
Annex/AdjustedBranch/Name.hs view
@@ -37,7 +37,7 @@ 		serializeAdjustment p 	serializeAdjustment (PresenceAdjustment p (Just l)) =  		serializeAdjustment p <> "-" <> serializeAdjustment l-	serializeAdjustment (LinkPresentAdjustment l) =+	serializeAdjustment (LockUnlockPresentAdjustment l) = 		serializeAdjustment l 	deserializeAdjustment s =  		(LinkAdjustment <$> deserializeAdjustment s)@@ -46,7 +46,7 @@ 			<|> 		(PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing) 			<|>-		(LinkPresentAdjustment <$> deserializeAdjustment s)+		(LockUnlockPresentAdjustment <$> deserializeAdjustment s) 	  where 		(s1, s2) = separate' (== (fromIntegral (ord '-'))) s @@ -68,7 +68,7 @@ 	deserializeAdjustment "showmissing" = Just ShowMissingAdjustment 	deserializeAdjustment _ = Nothing -instance SerializeAdjustment LinkPresentAdjustment where+instance SerializeAdjustment LockUnlockPresentAdjustment where 	serializeAdjustment UnlockPresentAdjustment = "unlockpresent" 	serializeAdjustment LockPresentAdjustment = "lockpresent" 	deserializeAdjustment "unlockpresent" = Just UnlockPresentAdjustment
Annex/Ingest.hs view
@@ -359,8 +359,8 @@ 	go (LinkAdjustment UnFixAdjustment) = False 	go (PresenceAdjustment _ (Just la)) = go (LinkAdjustment la) 	go (PresenceAdjustment _ Nothing) = False-	go (LinkPresentAdjustment UnlockPresentAdjustment) = contentpresent-	go (LinkPresentAdjustment LockPresentAdjustment) = False+	go (LockUnlockPresentAdjustment UnlockPresentAdjustment) = contentpresent+	go (LockUnlockPresentAdjustment LockPresentAdjustment) = False  {- Adds a file to the work tree for the key, and stages it in the index.  - The content of the key may be provided in a temp file, which will be
Annex/Proxy.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Annex.Proxy where  import Annex.Common@@ -28,14 +30,20 @@ import Utility.Metered import Git.Types import qualified Database.Export as Export+#ifndef mingw32_HOST_OS+import Utility.OpenFile+#endif +import Control.Concurrent import Control.Concurrent.STM import Control.Concurrent.Async import qualified Data.ByteString as B+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P import qualified Data.Map as M import qualified Data.Set as S+import System.IO.Unsafe  proxyRemoteSide :: ProtocolVersion -> Bypass -> Remote -> Annex RemoteSide proxyRemoteSide clientmaxversion bypass r@@ -104,10 +112,7 @@ 	go :: Annex () 	go = liftIO receivemessage >>= \case 		Just (CHECKPRESENT k) -> do-			tryNonAsync (Remote.checkPresent r k) >>= \case-				Right True -> liftIO $ sendmessage SUCCESS-				Right False -> liftIO $ sendmessage FAILURE-				Left err -> liftIO $ propagateerror err+			checkpresent k 			go 		Just (LOCKCONTENT _) -> do 			-- Special remotes do not support locking content.@@ -171,35 +176,47 @@ 		withTmpDirIn (fromRawFilePath othertmpdir) "proxy" $ \tmpdir -> 			a (toRawFilePath tmpdir P.</> keyFile k) 			-	-- Verify the content received from the client, to avoid bad content-	-- being stored in the special remote. 	proxyput af k = do 		liftIO $ sendmessage $ PUT_FROM (Offset 0)-		withproxytmpfile k $ \tmpfile -> do-			let store = tryNonAsync (storeput k af (decodeBS tmpfile)) >>= \case-				Right () -> liftIO $ sendmessage SUCCESS-				Left err -> liftIO $ propagateerror err-			liftIO receivemessage >>= \case-				Just (DATA (Len len)) -> do-					iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k-					h <- liftIO $ openFile (fromRawFilePath tmpfile) WriteMode-					gotall <- liftIO $ receivetofile iv h len-					liftIO $ hClose h-					verified <- if gotall-						then fst <$> finishVerifyKeyContentIncrementally' True iv-						else pure False-					if protoversion > ProtocolVersion 1-						then liftIO receivemessage >>= \case-							Just (VALIDITY Valid)-								| verified -> store-								| otherwise -> liftIO $ sendmessage FAILURE-							Just (VALIDITY Invalid) ->+		liftIO receivemessage >>= \case+			Just (DATA (Len len)) -> withproxytmpfile k $ \tmpfile -> do+				-- Verify the content received from+				-- the client, to avoid bad content+				-- being stored in the special remote.+				iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k+				h <- liftIO $ openFile (fromRawFilePath tmpfile) WriteMode+				let nuketmp = liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile)+				gotall <- liftIO $ receivetofile iv h len+				liftIO $ hClose h+				verified <- if gotall+					then fst <$> finishVerifyKeyContentIncrementally' True iv+					else pure False+				let store = tryNonAsync (storeput k af (decodeBS tmpfile)) >>= \case+					Right () -> liftIO $ sendmessage SUCCESS+					Left err -> liftIO $ propagateerror err+				if protoversion > ProtocolVersion 1+					then liftIO receivemessage >>= \case+						Just (VALIDITY Valid)+							| verified -> store >> nuketmp+							| otherwise -> do+								nuketmp 								liftIO $ sendmessage FAILURE-							_ -> giveup "protocol error"-						else store-				_ -> giveup "protocol error"-			liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile)+						Just (VALIDITY Invalid) -> do+							nuketmp+							liftIO $ sendmessage FAILURE+						_ -> do+							nuketmp+							giveup "protocol error"+					else store >> nuketmp+			Just DATA_PRESENT -> checkpresent k+			_ -> giveup "protocol error" +	checkpresent k = +		tryNonAsync (Remote.checkPresent r k) >>= \case+			Right True -> liftIO $ sendmessage SUCCESS+			Right False -> liftIO $ sendmessage FAILURE+			Left err -> liftIO $ propagateerror err+ 	storeput k af tmpfile = case mexportdb of 		Just exportdb -> liftIO (Export.getExportTree exportdb k) >>= \case 			[] -> storeputkey k af tmpfile@@ -221,11 +238,11 @@  	receivetofile iv h n = liftIO receivebytestring >>= \case 		Just b -> do+			n' <- storetofile iv h n (L.toChunks b) 			liftIO $ atomically $  				putTMVar owaitv () 					`orElse` 				readTMVar oclosedv-			n' <- storetofile iv h n (L.toChunks b) 			-- Normally all the data is sent in a single 			-- lazy bytestring. However, when the special 			-- remote is a node in a cluster, a PUT is@@ -241,25 +258,101 @@ 		storetofile iv h (n - fromIntegral (B.length b)) bs  	proxyget offset af k = withproxytmpfile k $ \tmpfile -> do+		let retrieve = tryNonAsync $ Remote.retrieveKeyFile r k af+			(fromRawFilePath tmpfile) nullMeterUpdate vc+		ordered <- Remote.retrieveKeyFileInOrder r+		case fromKey keySize k of+#ifndef mingw32_HOST_OS+			Just size | size > 0 && ordered -> do+				cancelv <- liftIO newEmptyMVar+				donev <- liftIO newEmptyMVar+				streamer <- liftIO $ async $+					streamdata offset tmpfile size cancelv donev+				retrieve >>= \case+					Right _ -> liftIO $ do+						putMVar donev ()+						wait streamer+					Left err -> liftIO $ do+						putMVar cancelv ()+						wait streamer+						propagateerror err+#endif+			_ -> retrieve >>= \case+				Right _ -> liftIO $ senddata offset tmpfile+				Left err -> liftIO $ propagateerror err+	  where 		-- Don't verify the content from the remote, 		-- because the client will do its own verification.-		let vc = Remote.NoVerify-		tryNonAsync (Remote.retrieveKeyFile r k af (fromRawFilePath tmpfile) nullMeterUpdate vc) >>= \case-			Right _ -> liftIO $ senddata offset tmpfile-			Left err -> liftIO $ propagateerror err-	+		vc = Remote.NoVerify++#ifndef mingw32_HOST_OS+	streamdata (Offset offset) f size cancelv donev = do+		sendlen offset size+		waitforfile+		x <- tryNonAsync $ do+			h <- openFileBeingWritten f+			hSeek h AbsoluteSeek offset+			senddata' h (getcontents size)+		case x of+			Left err -> do+				hPutStrLn stderr (show err)+				throwM err+			Right res -> return res+	  where+		-- The file doesn't exist at the start.+		-- Wait for some data to be written to it as well,+		-- in case an empty file is first created and then+		-- overwritten. When there is an offset, wait for+		-- the file to get that large. Note that this is not used+		-- when the size is 0.+		waitforfile = tryNonAsync (fromIntegral <$> getFileSize f) >>= \case+			Right sz | sz > 0 && sz >= offset -> return ()+			_ -> ifM (isEmptyMVar cancelv <&&> isEmptyMVar donev)+				( do+					threadDelay 40000+					waitforfile+				, do+					return ()+				)++		getcontents n h = unsafeInterleaveIO $ do+			isdone <- (not <$> isEmptyMVar donev) <||> (not <$> isEmptyMVar cancelv)+			c <- BS.hGet h defaultChunkSize+			let n' = n - fromIntegral (BS.length c)+			let c' = L.fromChunks [BS.take (fromIntegral n) c]+			if BS.null c+				then if isdone+					then return mempty+					else do+						-- Wait for more data to be+						-- written to the file.+						threadDelay 40000+						getcontents n h+				else if n' > 0+					then do+						-- unsafeInterleaveIO causes +						-- this to be deferred until+						-- data is read from the lazy+						-- ByteString.+						cs <- getcontents n' h+						return $ L.append c' cs+					else return c'+#endif+ 	senddata (Offset offset) f = do 		size <- fromIntegral <$> getFileSize f-		let n = max 0 (size - offset)-		sendmessage $ DATA (Len n)+		sendlen offset size 		withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do 			hSeek h AbsoluteSeek offset-			sendbs =<< L.hGetContents h-			-- Important to keep the handle open until-			-- the client responds. The bytestring-			-- could still be lazily streaming out to-			-- the client.-			waitclientresponse+			senddata' h L.hGetContents++	senddata' h getcontents = do+		sendbs =<< getcontents h+		-- Important to keep the handle open until+		-- the client responds. The bytestring+		-- could still be lazily streaming out to+		-- the client.+		waitclientresponse 	  where 		sendbs bs = do 			sendbytestring bs@@ -272,6 +365,11 @@ 				Just FAILURE -> return () 				Just _ -> giveup "protocol error" 				Nothing -> return ()+	+	sendlen offset size = do+		let n = max 0 (size - offset)+		sendmessage $ DATA (Len n)+  {- Check if this repository can proxy for a specified remote uuid,  - and if so enable proxying for it. -}
Annex/View.hs view
@@ -513,7 +513,7 @@ 		Nothing -> stagesymlink uh f k 		Just (LinkAdjustment UnlockAdjustment) -> 			stagepointerfile uh f k mtreeitemtype-		Just (LinkPresentAdjustment UnlockPresentAdjustment) ->+		Just (LockUnlockPresentAdjustment UnlockPresentAdjustment) -> 			ifM (inAnnex k) 				( stagepointerfile uh f k mtreeitemtype 				, stagesymlink uh f k
CHANGELOG view
@@ -1,3 +1,32 @@+git-annex (10.20241031) upstream; urgency=medium++  * Sped up proxied downloads from special remotes, by streaming.+  * Added GETORDERED request to external special remote protocol. +    When the external special remote responds with ORDERED, it can stream+    through a proxy.+  * p2phttp: Support serving unauthenticated users while requesting+    authentication for operations that need it. Eg, --unauth-readonly+    can be combined with --authenv.+  * p2phttp: Allow unauthenticated users to lock content by default.+  * p2phttp: Added --unauth-nolocking option to prevent unauthenticated+    users from locking content.+  * Allow enabling the servant build flag with older versions of stm,+    allowing building with ghc 9.0.2.+  * git-remote-annex: Fix bug that prevented using it with external special+    remotes, leading to protocol error messages involving "GITMANIFEST".+  * adjust: Allow any order of options when combining --hide-missing with+    options like --unlock.+  * Support P2P protocol version 4. This allows DATA-PRESENT to be sent+    after PUT (and in the HTTP P2P protocol, v4/put has a data-present+    parameter). When used with a proxy to a special remote like a S3+    bucket, this allows a custom client to upload content to S3 itself,+    and then use the P2P protocol to inform the proxy that the content has+    been stored there, which will result in the same git-annex branch state+    updates as sending DATA via the proxy.+  * Fix hang when receiving a large file into a proxied special remote.++ -- Joey Hess <id@joeyh.name>  Thu, 31 Oct 2024 17:19:56 -0400+ git-annex (10.20240927) upstream; urgency=medium    * Detect when a preferred content expression contains "not present",
Command/Adjust.hs view
@@ -17,9 +17,24 @@  optParser :: CmdParamsDesc -> Parser Adjustment optParser _ =-	(LinkAdjustment <$> linkAdjustmentParser)-	<|> (PresenceAdjustment <$> presenceAdjustmentParser <*> maybeLinkAdjustmentParser)-	<|> (LinkPresentAdjustment <$> linkPresentAdjustmentParser)+	linkPresentAdjustmentParser+	<|> (LockUnlockPresentAdjustment <$> lockUnlockPresentAdjustmentParser)+	+linkPresentAdjustmentParser :: Parser Adjustment+linkPresentAdjustmentParser = comb <$> some ps+  where+	ps = (LinkAdjustment <$> linkAdjustmentParser)+		<|> (PresenceAdjustment <$> presenceAdjustmentParser <*> pure Nothing)+	comb (LinkAdjustment _ : LinkAdjustment b : c) =+		comb (LinkAdjustment b : c)+	comb (PresenceAdjustment _a1 a2 : PresenceAdjustment b1 b2 : c) = +		comb (PresenceAdjustment b1 (b2 <|> a2) : c)+	comb (LinkAdjustment a : PresenceAdjustment b1 b2 : c) =+		comb (PresenceAdjustment b1 (b2 <|> Just a) : c)+	comb (PresenceAdjustment a1 _a2 : LinkAdjustment b : c) =+		comb (PresenceAdjustment a1 (Just b) : c)+	comb (a : _) = a+	comb [] = error "internal"  linkAdjustmentParser :: Parser LinkAdjustment linkAdjustmentParser =@@ -36,9 +51,6 @@ 		<> help "fix symlinks to annnexed files" 		) -maybeLinkAdjustmentParser :: Parser (Maybe LinkAdjustment)-maybeLinkAdjustmentParser = Just <$> linkAdjustmentParser <|> pure Nothing- presenceAdjustmentParser :: Parser PresenceAdjustment presenceAdjustmentParser = 	flag' HideMissingAdjustment@@ -46,8 +58,8 @@ 		<> help "hide annexed files whose content is not present" 		) -linkPresentAdjustmentParser :: Parser LinkPresentAdjustment-linkPresentAdjustmentParser =+lockUnlockPresentAdjustmentParser :: Parser LockUnlockPresentAdjustment+lockUnlockPresentAdjustmentParser = 	flag' UnlockPresentAdjustment 		( long "unlock-present" 		<> help "unlock files whose content is present; lock rest"
Command/P2PHttp.hs view
@@ -40,6 +40,7 @@ 	, authEnvHttpOption :: Bool 	, unauthReadOnlyOption :: Bool 	, unauthAppendOnlyOption :: Bool+	, unauthNoLockingOption :: Bool 	, wideOpenOption :: Bool 	, proxyConnectionsOption :: Maybe Integer 	, clusterJobsOption :: Maybe Int@@ -84,6 +85,10 @@ 		<> help "allow unauthenticated users to read and append to the repository" 		) 	<*> switch+		( long "unauth-nolocking"+		<> help "prevent unauthenticated users from locking content in the repository"+		)+	<*> switch 		( long "wideopen" 		<> help "give unauthenticated users full read+write access" 		)@@ -128,10 +133,25 @@  mkGetServerMode :: M.Map Auth P2P.ServerMode -> Options -> GetServerMode mkGetServerMode _ o _ Nothing-	| wideOpenOption o = Just P2P.ServeReadWrite-	| unauthAppendOnlyOption o = Just P2P.ServeAppendOnly-	| unauthReadOnlyOption o = Just P2P.ServeReadOnly-	| otherwise = Nothing+	| wideOpenOption o = ServerMode+		{ serverMode = P2P.ServeReadWrite+		, unauthenticatedLockingAllowed = unauthlock+		, authenticationAllowed = False +		}+	| unauthAppendOnlyOption o = ServerMode +		{ serverMode = P2P.ServeAppendOnly+		, unauthenticatedLockingAllowed = unauthlock+		, authenticationAllowed = canauth+		}+	| unauthReadOnlyOption o = ServerMode+		{ serverMode = P2P.ServeReadOnly+		, unauthenticatedLockingAllowed = unauthlock+		, authenticationAllowed = canauth+		}+	| otherwise = CannotServeRequests+  where+	canauth = authEnvOption o || authEnvHttpOption o+	unauthlock = not (unauthNoLockingOption o) mkGetServerMode authenv o issecure (Just auth) = 	case (issecure, authEnvOption o, authEnvHttpOption o) of 		(Secure, True, _) -> checkauth@@ -139,9 +159,14 @@ 		_ -> noauth   where 	checkauth = case M.lookup auth authenv of-		Just servermode -> Just servermode+		Just servermode -> ServerMode +			{ serverMode = servermode+			, authenticationAllowed = False+			, unauthenticatedLockingAllowed = False+			} 		Nothing -> noauth-	noauth = mkGetServerMode authenv o issecure Nothing+	noauth = mkGetServerMode authenv noautho issecure Nothing+	noautho = o { authEnvOption = False, authEnvHttpOption = False }  getAuthEnv :: IO (M.Map Auth P2P.ServerMode) getAuthEnv = do
Database/RepoSize.hs view
@@ -400,6 +400,11 @@ 				map (\(k, v) -> (k, [v])) $ 					fromMaybe [] $ 						M.lookup u livechanges+		-- This could be optimised to a single SQL join, rather+		-- than querying once for each live change. That would make+		-- it less expensive when there are a lot happening at the+		-- same time. Persistent is not capable of that join,+		-- it would need a dependency on esquelito. 		livechanges' <- combinelikelivechanges <$>  			filterM (nonredundantlivechange livechangesbykey u) 				(fromMaybe [] $ M.lookup u livechanges)
P2P/Http.hs view
@@ -25,34 +25,46 @@ import qualified Data.ByteString as B  type P2PHttpAPI-	=    "git-annex" :> SU :> PV3 :> "key" :> GetAPI+	=    "git-annex" :> SU :> PV4 :> "key" :> GetAPI+	:<|> "git-annex" :> SU :> PV3 :> "key" :> GetAPI 	:<|> "git-annex" :> SU :> PV2 :> "key" :> GetAPI 	:<|> "git-annex" :> SU :> PV1 :> "key" :> GetAPI 	:<|> "git-annex" :> SU :> PV0 :> "key" :> GetAPI+	:<|> "git-annex" :> SU :> PV4 :> "checkpresent" :> CheckPresentAPI 	:<|> "git-annex" :> SU :> PV3 :> "checkpresent" :> CheckPresentAPI 	:<|> "git-annex" :> SU :> PV2 :> "checkpresent" :> CheckPresentAPI 	:<|> "git-annex" :> SU :> PV1 :> "checkpresent" :> CheckPresentAPI 	:<|> "git-annex" :> SU :> PV0 :> "checkpresent" :> CheckPresentAPI+	:<|> "git-annex" :> SU :> PV4 :> "remove" :> RemoveAPI RemoveResultPlus 	:<|> "git-annex" :> SU :> PV3 :> "remove" :> RemoveAPI RemoveResultPlus 	:<|> "git-annex" :> SU :> PV2 :> "remove" :> RemoveAPI RemoveResultPlus 	:<|> "git-annex" :> SU :> PV1 :> "remove" :> RemoveAPI RemoveResult 	:<|> "git-annex" :> SU :> PV0 :> "remove" :> RemoveAPI RemoveResult+	:<|> "git-annex" :> SU :> PV4 :> "remove-before" :> RemoveBeforeAPI 	:<|> "git-annex" :> SU :> PV3 :> "remove-before" :> RemoveBeforeAPI+	:<|> "git-annex" :> SU :> PV4 :> "gettimestamp" :> GetTimestampAPI 	:<|> "git-annex" :> SU :> PV3 :> "gettimestamp" :> GetTimestampAPI+	:<|> "git-annex" :> SU :> PV4 :> "put" +		:> QueryParam "data-present" Bool+		:> PutAPI PutResultPlus 	:<|> "git-annex" :> SU :> PV3 :> "put" :> PutAPI PutResultPlus 	:<|> "git-annex" :> SU :> PV2 :> "put" :> PutAPI PutResultPlus 	:<|> "git-annex" :> SU :> PV1 :> "put" :> PutAPI PutResult 	:<|> "git-annex" :> SU :> PV0 :> "put" :> PutAPI PutResult+	:<|> "git-annex" :> SU :> PV4 :> "putoffset"+		:> PutOffsetAPI PutOffsetResultPlus 	:<|> "git-annex" :> SU :> PV3 :> "putoffset" 		:> PutOffsetAPI PutOffsetResultPlus 	:<|> "git-annex" :> SU :> PV2 :> "putoffset" 		:> PutOffsetAPI PutOffsetResultPlus 	:<|> "git-annex" :> SU :> PV1 :> "putoffset" 		:> PutOffsetAPI PutOffsetResult+	:<|> "git-annex" :> SU :> PV4 :> "lockcontent" :> LockContentAPI 	:<|> "git-annex" :> SU :> PV3 :> "lockcontent" :> LockContentAPI 	:<|> "git-annex" :> SU :> PV2 :> "lockcontent" :> LockContentAPI 	:<|> "git-annex" :> SU :> PV1 :> "lockcontent" :> LockContentAPI 	:<|> "git-annex" :> SU :> PV0 :> "lockcontent" :> LockContentAPI+	:<|> "git-annex" :> SU :> PV4 :> "keeplocked" :> KeepLockedAPI 	:<|> "git-annex" :> SU :> PV3 :> "keeplocked" :> KeepLockedAPI 	:<|> "git-annex" :> SU :> PV2 :> "keeplocked" :> KeepLockedAPI 	:<|> "git-annex" :> SU :> PV1 :> "keeplocked" :> KeepLockedAPI@@ -177,6 +189,7 @@  type AuthHeader = Header "Authorization" Auth +type PV4 = Capture "v4" V4 type PV3 = Capture "v3" V3 type PV2 = Capture "v2" V2 type PV1 = Capture "v1" V1
P2P/Http/Client.hs view
@@ -36,6 +36,7 @@ import Annex.Concurrent import Utility.Url (BasicAuth(..)) import Utility.HumanTime+import Utility.STM import qualified Git.Credential as Git  import Servant hiding (BasicAuthData(..))@@ -46,7 +47,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Internal as LI import qualified Data.Map as M-import Control.Concurrent.STM import Control.Concurrent.Async import Control.Concurrent import System.IO.Unsafe@@ -187,13 +187,14 @@ 				if dl == len then Valid else Invalid   where 	cli =case ver of+		4 -> v4 su V4 		3 -> v3 su V3 		2 -> v2 su V2 		1 -> v1 su V1 		0 -> v0 su V0 		_ -> error "unsupported protocol version" 	-	v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI+	v4 :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI  	gather = unsafeInterleaveIO . gather' 	gather' S.Stop = return LI.Empty@@ -215,14 +216,15 @@ 		Right (CheckPresentResult res) -> return (Right res)   where 	cli = case ver of+		4 -> flip v4 V4 		3 -> flip v3 V3 		2 -> flip v2 V2 		1 -> flip v1 V1 		0 -> flip v0 V0 		_ -> error "unsupported protocol version" 	-	_ :<|> _ :<|> _ :<|> _ :<|>-		v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI+	_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		v4 :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI #else clientCheckPresent _ = () #endif@@ -264,15 +266,16 @@ 	bk = B64Key k  	cli = case ver of+		4 -> v4 su V4 bk cu bypass auth 		3 -> v3 su V3 bk cu bypass auth 		2 -> v2 su V2 bk cu bypass auth 		1 -> plus <$> v1 su V1 bk cu bypass auth 		0 -> plus <$> v0 su V0 bk cu bypass auth 		_ -> error "unsupported protocol version" 	-	_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI+	_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		v4 :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI #else clientRemove _ = () #endif@@ -286,13 +289,14 @@ 	liftIO $ withClientM (cli su (B64Key k) cu bypass ts auth) clientenv return   where 	cli = case ver of+		4 -> flip v4 V4 		3 -> flip v3 V3 		_ -> error "unsupported protocol version" 	-	_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		v3 :<|> _ = client p2pHttpAPI+	_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|>_ :<|> _ :<|> _ :<|> _ :<|>+		v4 :<|> v3 :<|> _ = client p2pHttpAPI #else clientRemoveBefore _ _ = () #endif@@ -303,14 +307,15 @@ 	liftIO $ withClientM (cli su cu bypass auth) clientenv return   where 	cli = case ver of+		4 -> flip v4 V4 		3 -> flip v3 V3 		_ -> error "unsupported protocol version" 	-	_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|>-		v3 :<|> _ = client p2pHttpAPI+	_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|>+		v4 :<|> v3 :<|> _ = client p2pHttpAPI #else clientGetTimestamp = () #endif@@ -324,27 +329,32 @@ 	-> FileSize 	-> Annex Bool 	-- ^ Called after sending the file to check if it's valid.+	-> Bool+	-- ^ Set data-present parameter and do not actually send data+	-- (v4+ only) 	-> ClientAction PutResultPlus #ifdef WITH_SERVANT-clientPut meterupdate k moffset af contentfile contentfilesize validitycheck clientenv (ProtocolVersion ver) su cu bypass auth = do-	checkv <- liftIO newEmptyTMVarIO-	checkresultv <- liftIO newEmptyTMVarIO-	let checker = do-		liftIO $ atomically $ takeTMVar checkv-		validitycheck >>= liftIO . atomically . putTMVar checkresultv-	checkerthread <- liftIO . async =<< forkState checker-	v <- liftIO $ withBinaryFile contentfile ReadMode $ \h -> do-		when (offset /= 0) $-			hSeek h AbsoluteSeek offset-		withClientM (cli (stream h checkv checkresultv)) clientenv return-	case v of-		Left err -> do-			void $ liftIO $ atomically $ tryPutTMVar checkv ()-			join $ liftIO (wait checkerthread)-			return (Left err)-		Right res -> do-			join $ liftIO (wait checkerthread)-			return (Right res)+clientPut meterupdate k moffset af contentfile contentfilesize validitycheck datapresent clientenv (ProtocolVersion ver) su cu bypass auth+	| datapresent = liftIO $ withClientM (cli mempty) clientenv return+	| otherwise = do+		checkv <- liftIO newEmptyTMVarIO+		checkresultv <- liftIO newEmptyTMVarIO+		let checker = do+			liftIO $ atomically $ takeTMVar checkv+			validitycheck >>= liftIO . atomically . putTMVar checkresultv+		checkerthread <- liftIO . async =<< forkState checker+		v <- liftIO $ withBinaryFile contentfile ReadMode $ \h -> do+			when (offset /= 0) $+				hSeek h AbsoluteSeek offset+			withClientM (cli (stream h checkv checkresultv)) clientenv return+		case v of+			Left err -> do+				void $ liftIO $ atomically $ tryPutTMVar checkv ()+				join $ liftIO (wait checkerthread)+				return (Left err)+			Right res -> do+				join $ liftIO (wait checkerthread)+				return (Right res)   where 	stream h checkv checkresultv = S.SourceT $ \a -> do 		bl <- hGetContentsMetered h meterupdate@@ -396,18 +406,19 @@ 	bk = B64Key k  	cli src = case ver of+		4 -> v4 su V4 (if datapresent then Just True else Nothing) len bk cu bypass baf moffset src auth 		3 -> v3 su V3 len bk cu bypass baf moffset src auth 		2 -> v2 su V2 len bk cu bypass baf moffset src auth 		1 -> plus <$> v1 su V1 len bk cu bypass baf moffset src auth 		0 -> plus <$> v0 su V0 len bk cu bypass baf moffset src auth 		_ -> error "unsupported protocol version" -	_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|>-		_ :<|>-		v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI+	_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|>+		_ :<|> _ :<|>+		v4 :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI #else clientPut _ _ _ _ _ _ _ = () #endif@@ -423,18 +434,19 @@ 	bk = B64Key k  	cli = case ver of+		4 -> v4 su V4 bk cu bypass auth 		3 -> v3 su V3 bk cu bypass auth 		2 -> v2 su V2 bk cu bypass auth 		1 -> plus <$> v1 su V1 bk cu bypass auth 		_ -> error "unsupported protocol version" 	-	_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|>-		_ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		v3 :<|> v2 :<|> v1 :<|> _ = client p2pHttpAPI+	_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|>+		_ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		v4 :<|> v3 :<|> v2 :<|> v1 :<|> _ = client p2pHttpAPI #else clientPutOffset _ = () #endif@@ -447,20 +459,21 @@ 	liftIO $ withClientM (cli (B64Key k) cu bypass auth) clientenv return   where 	cli = case ver of+		4 -> v4 su V4 		3 -> v3 su V3 		2 -> v2 su V2 		1 -> v1 su V1 		0 -> v0 su V0 		_ -> error "unsupported protocol version" 	-	_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|>-		_ :<|>+	_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|>+		_ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> 		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|>-		v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI+		v4 :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI #else clientLockContent _ = () #endif@@ -518,21 +531,22 @@ 					else S.Yield (UnlockRequest True) S.Stop 	 	cli = case ver of+		4 -> v4 su V4 		3 -> v3 su V3 		2 -> v2 su V2 		1 -> v1 su V1 		0 -> v0 su V0 		_ -> error "unsupported protocol version" 	-	_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|>-		_ :<|>-		_ :<|> _ :<|> _ :<|> _ :<|>-		_ :<|> _ :<|> _ :<|>+	_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		_ :<|> _ :<|>+		_ :<|> _ :<|>+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> 		_ :<|> _ :<|> _ :<|> _ :<|>-		v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI+		_ :<|> _ :<|> _ :<|> _ :<|> _ :<|>+		v4 :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI #else clientKeepLocked _ _ _ _ = () #endif
P2P/Http/Server.hs view
@@ -26,19 +26,20 @@ import P2P.Http.Types import P2P.Http.State import P2P.Protocol hiding (Offset, Bypass, auth)+import qualified P2P.Protocol import P2P.IO import P2P.Annex import Annex.WorkerPool import Types.WorkerPool import Types.Direction import Utility.Metered+import Utility.STM  import Servant import qualified Servant.Types.SourceT as S import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as LI-import Control.Concurrent.STM import Control.Concurrent.Async import Control.Concurrent import System.IO.Unsafe@@ -53,31 +54,40 @@ 	:<|> serveGet st 	:<|> serveGet st 	:<|> serveGet st+	:<|> serveGet st 	:<|> serveCheckPresent st 	:<|> serveCheckPresent st 	:<|> serveCheckPresent st 	:<|> serveCheckPresent st+	:<|> serveCheckPresent st 	:<|> serveRemove st id 	:<|> serveRemove st id+	:<|> serveRemove st id 	:<|> serveRemove st dePlus 	:<|> serveRemove st dePlus 	:<|> serveRemoveBefore st+	:<|> serveRemoveBefore st 	:<|> serveGetTimestamp st-	:<|> servePut st id+	:<|> serveGetTimestamp st 	:<|> servePut st id-	:<|> servePut st dePlus-	:<|> servePut st dePlus+	:<|> servePut' st id+	:<|> servePut' st id+	:<|> servePut' st dePlus+	:<|> servePut' st dePlus 	:<|> servePutOffset st id 	:<|> servePutOffset st id+	:<|> servePutOffset st id 	:<|> servePutOffset st dePlus 	:<|> serveLockContent st 	:<|> serveLockContent st 	:<|> serveLockContent st 	:<|> serveLockContent st+	:<|> serveLockContent st 	:<|> serveKeepLocked st 	:<|> serveKeepLocked st 	:<|> serveKeepLocked st 	:<|> serveKeepLocked st+	:<|> serveKeepLocked st 	:<|> serveGetGeneric st  serveGetGeneric@@ -125,10 +135,11 @@ 			return $ \v -> do 				liftIO $ atomically $ putTMVar validityv v 				return True+		let noothermessages = const Nothing 		enteringStage (TransferStage Upload) $ 			runFullProto (clientRunState conn) (clientP2PConnection conn) $ 				void $ receiveContent Nothing nullMeterUpdate-					sizer storer getreq+					sizer storer noothermessages getreq 	void $ liftIO $ forkIO $ waitfinal endv finalv conn annexworker 	(Len len, bs) <- liftIO $ atomically $ takeTMVar bsv 	bv <- liftIO $ newMVar (filter (not . B.null) (L.toChunks bs))@@ -297,6 +308,7 @@ 	-> (PutResultPlus -> t) 	-> B64UUID ServerSide 	-> v+	-> Maybe Bool 	-> DataLength 	-> B64Key 	-> B64UUID ClientSide@@ -307,7 +319,15 @@ 	-> IsSecure 	-> Maybe Auth 	-> Handler t-servePut st resultmangle su apiver (DataLength len) (B64Key k) cu bypass baf moffset stream sec auth = do+servePut st resultmangle su apiver (Just True) _ k cu bypass baf _ _ sec auth = do+	res <- withP2PConnection' apiver st cu su bypass sec auth WriteAction+		(\cst -> cst { connectionWaitVar = False }) (liftIO . protoaction)+	servePutResult resultmangle res+  where+	protoaction conn = servePutAction st conn k baf $ \_offset -> do+		net $ sendMessage DATA_PRESENT+		checkSuccessPlus+servePut st resultmangle su apiver _datapresent (DataLength len) k cu bypass baf moffset stream sec auth = do 	validityv <- liftIO newEmptyTMVarIO 	let validitycheck = local $ runValidityCheck $ 		liftIO $ atomically $ readTMVar validityv@@ -317,41 +337,27 @@ 		(\cst -> cst { connectionWaitVar = False }) $ \conn -> do 			liftIO $ void $ async $ checktooshort conn tooshortv 			liftIO (protoaction conn content validitycheck)-	case res of-		Right (Right (Just plusuuids)) -> return $ resultmangle $-			PutResultPlus True (map B64UUID plusuuids)-		Right (Right Nothing) -> return $ resultmangle $-			PutResultPlus False []-		Right (Left protofail) -> throwError $-			err500 { errBody = encodeBL (describeProtoFailure protofail) }-		Left err -> throwError $-			err500 { errBody = encodeBL (show err) }+	servePutResult resultmangle res   where-	protoaction conn content validitycheck = inAnnexWorker st $-		enteringStage (TransferStage Download) $-			runFullProto (clientRunState conn) (clientP2PConnection conn) $-				protoaction' content validitycheck-	-	protoaction' content validitycheck = put' k af $ \offset' ->-		let offsetdelta = offset' - offset-		in case compare offset' offset of-			EQ -> sendContent' nullMeterUpdate (Len len)-				content validitycheck-			GT -> sendContent' nullMeterUpdate-				(Len (len - fromIntegral offsetdelta))-				(L.drop (fromIntegral offsetdelta) content)-				validitycheck-			LT -> sendContent' nullMeterUpdate-				(Len len)-				content-				(validitycheck >>= \_ -> return Invalid)+	protoaction conn content validitycheck = +		servePutAction st conn k baf $ \offset' ->+			let offsetdelta = offset' - offset+			in case compare offset' offset of+				EQ -> sendContent' nullMeterUpdate (Len len)+					content validitycheck+				GT -> sendContent' nullMeterUpdate+					(Len (len - fromIntegral offsetdelta))+					(L.drop (fromIntegral offsetdelta) content)+					validitycheck+				LT -> sendContent' nullMeterUpdate+					(Len len)+					content+					(validitycheck >>= \_ -> return Invalid) 	 	offset = case moffset of 		Just (Offset o) -> o 		Nothing -> 0 -	af = b64FilePathToAssociatedFile baf- 	-- Streams the ByteString from the client. Avoids returning a longer 	-- than expected ByteString by truncating to the expected length.  	-- Returns a shorter than expected ByteString when the data is not@@ -389,6 +395,49 @@ 		liftIO $ whenM (atomically $ takeTMVar tooshortv) $ 			closeP2PConnection conn +servePutAction+	:: P2PHttpServerState+	-> P2PConnectionPair+	-> B64Key+	-> Maybe B64FilePath+	-> (P2P.Protocol.Offset -> Proto (Maybe [UUID]))+	-> IO (Either SomeException (Either ProtoFailure (Maybe [UUID])))+servePutAction st conn (B64Key k) baf a = inAnnexWorker st $+	enteringStage (TransferStage Download) $+		runFullProto (clientRunState conn) (clientP2PConnection conn) $+			put' k af a+  where+	af = b64FilePathToAssociatedFile baf++servePutResult :: (PutResultPlus -> t) -> Either SomeException (Either ProtoFailure (Maybe [UUID])) -> Handler t+servePutResult resultmangle res = case res of+	Right (Right (Just plusuuids)) -> return $ resultmangle $+		PutResultPlus True (map B64UUID plusuuids)+	Right (Right Nothing) -> return $ resultmangle $+		PutResultPlus False []+	Right (Left protofail) -> throwError $+		err500 { errBody = encodeBL (describeProtoFailure protofail) }+	Left err -> throwError $+		err500 { errBody = encodeBL (show err) }++servePut'+	:: APIVersion v+	=> P2PHttpServerState+	-> (PutResultPlus -> t)+	-> B64UUID ServerSide+	-> v+	-> DataLength+	-> B64Key+	-> B64UUID ClientSide+	-> [B64UUID Bypass]+	-> Maybe B64FilePath+	-> Maybe Offset+	-> S.SourceT IO B.ByteString+	-> IsSecure+	-> Maybe Auth+	-> Handler t+servePut' st resultmangle su v = servePut st resultmangle su v Nothing+ servePutOffset 	:: APIVersion v 	=> P2PHttpServerState@@ -425,7 +474,7 @@ 	-> Maybe Auth 	-> Handler LockResult serveLockContent st su apiver (B64Key k) cu bypass sec auth = do-	conn <- getP2PConnection apiver st cu su bypass sec auth WriteAction id+	conn <- getP2PConnection apiver st cu su bypass sec auth LockAction id 	let lock = do 		lockresv <- newEmptyTMVarIO 		unlockv <- newEmptyTMVarIO@@ -465,7 +514,7 @@ 	-> S.SourceT IO UnlockRequest 	-> Handler LockResult serveKeepLocked st _su _apiver lckid _cu _bypass sec auth _ _ unlockrequeststream = do-	checkAuthActionClass st sec auth WriteAction $ \_ -> do+	checkAuthActionClass st sec auth LockAction $ \_ -> do 		liftIO $ keepingLocked lckid st 		_ <- liftIO $ S.unSourceT unlockrequeststream go 		return (LockResult False Nothing)
P2P/Http/State.hs view
@@ -35,12 +35,12 @@ import Annex.Cluster import qualified P2P.Proxy as Proxy import qualified Types.Remote as Remote+import Utility.STM  import Servant import qualified Data.Map.Strict as M import qualified Data.Set as S import Control.Concurrent.Async-import Control.Concurrent.STM import Data.Time.Clock.POSIX  data P2PHttpServerState = P2PHttpServerState@@ -52,9 +52,16 @@  type AnnexWorkerPool = TMVar (WorkerPool (Annex.AnnexState, Annex.AnnexRead)) --- Nothing when the server is not allowed to serve any requests.-type GetServerMode = IsSecure -> Maybe Auth -> Maybe P2P.ServerMode+type GetServerMode = IsSecure -> Maybe Auth -> ServerMode +data ServerMode+	= ServerMode+		{ serverMode :: P2P.ServerMode+		, unauthenticatedLockingAllowed :: Bool+		, authenticationAllowed :: Bool+		}+	| CannotServeRequests+ mkP2PHttpServerState :: AcquireP2PConnection -> AnnexWorkerPool -> GetServerMode -> IO P2PHttpServerState mkP2PHttpServerState acquireconn annexworkerpool getservermode = P2PHttpServerState 	<$> pure acquireconn@@ -62,7 +69,7 @@ 	<*> pure getservermode 	<*> newTMVarIO mempty -data ActionClass = ReadAction | WriteAction | RemoveAction+data ActionClass = ReadAction | WriteAction | RemoveAction | LockAction 	deriving (Eq)  withP2PConnection@@ -143,19 +150,36 @@ 	-> (P2P.ServerMode -> Handler a) 	-> Handler a checkAuthActionClass st sec auth actionclass go =-	case (getServerMode st sec auth, actionclass) of-		(Just P2P.ServeReadWrite, _) -> go P2P.ServeReadWrite-		(Just P2P.ServeAppendOnly, RemoveAction) -> throwError err403-		(Just P2P.ServeAppendOnly, _) -> go P2P.ServeAppendOnly-		(Just P2P.ServeReadOnly, ReadAction) -> go P2P.ServeReadOnly-		(Just P2P.ServeReadOnly, _) -> throwError err403-		(Nothing, _) -> throwError basicAuthRequired+	case (sm, actionclass) of+		(ServerMode { serverMode = P2P.ServeReadWrite }, _) ->+			go P2P.ServeReadWrite+		(ServerMode { unauthenticatedLockingAllowed = True }, LockAction) ->+			go P2P.ServeReadOnly+		(ServerMode { serverMode = P2P.ServeAppendOnly }, RemoveAction) -> +			throwError $ forbiddenWithoutAuth sm+		(ServerMode { serverMode = P2P.ServeAppendOnly }, _) ->+			go P2P.ServeAppendOnly+		(ServerMode { serverMode = P2P.ServeReadOnly }, ReadAction) ->+			go P2P.ServeReadOnly+		(ServerMode { serverMode = P2P.ServeReadOnly }, _) -> +			throwError $ forbiddenWithoutAuth sm+		(CannotServeRequests, _) -> throwError basicAuthRequired+  where+	sm = getServerMode st sec auth +forbiddenAction :: ServerError+forbiddenAction = err403+ basicAuthRequired :: ServerError basicAuthRequired = err401 { errHeaders = [(h, v)] }   where 	h = "WWW-Authenticate" 	v = "Basic realm=\"git-annex\", charset=\"UTF-8\""++forbiddenWithoutAuth :: ServerMode -> ServerError+forbiddenWithoutAuth sm+	| authenticationAllowed sm = basicAuthRequired+	| otherwise = forbiddenAction  data ConnectionParams = ConnectionParams 	{ connectionProtocolVersion :: P2P.ProtocolVersion
P2P/Http/Types.hs view
@@ -32,6 +32,7 @@ import Control.DeepSeq import GHC.Generics (Generic) +data V4 = V4 deriving (Show) data V3 = V3 deriving (Show) data V2 = V2 deriving (Show) data V1 = V1 deriving (Show)@@ -40,6 +41,7 @@ class APIVersion v where 	protocolVersion :: v -> P2P.ProtocolVersion +instance APIVersion V4 where protocolVersion _ = P2P.ProtocolVersion 4 instance APIVersion V3 where protocolVersion _ = P2P.ProtocolVersion 3 instance APIVersion V2 where protocolVersion _ = P2P.ProtocolVersion 2 instance APIVersion V1 where protocolVersion _ = P2P.ProtocolVersion 1@@ -194,11 +196,13 @@ instance FromHttpApiData KeepAlive where 	parseUrlPiece = Right . KeepAlive +instance ToHttpApiData V4 where toUrlPiece _ = "v4" instance ToHttpApiData V3 where toUrlPiece _ = "v3" instance ToHttpApiData V2 where toUrlPiece _ = "v2" instance ToHttpApiData V1 where toUrlPiece _ = "v1" instance ToHttpApiData V0 where toUrlPiece _ = "v0" +instance FromHttpApiData V4 where parseUrlPiece = parseAPIVersion V4 "v4" instance FromHttpApiData V3 where parseUrlPiece = parseAPIVersion V3 "v3" instance FromHttpApiData V2 where parseUrlPiece = parseAPIVersion V2 "v2" instance FromHttpApiData V1 where parseUrlPiece = parseAPIVersion V1 "v1"
P2P/Protocol.hs view
@@ -61,12 +61,13 @@ defaultProtocolVersion = ProtocolVersion 0  maxProtocolVersion :: ProtocolVersion-maxProtocolVersion = ProtocolVersion 3+maxProtocolVersion = ProtocolVersion 4  -- In order from newest to oldest. allProtocolVersions :: [ProtocolVersion] allProtocolVersions =-	[ ProtocolVersion 3+	[ ProtocolVersion 4+	, ProtocolVersion 3 	, ProtocolVersion 2 	, ProtocolVersion 1 	, ProtocolVersion 0@@ -113,6 +114,7 @@ 	| FAILURE_PLUS [UUID] 	| BYPASS Bypass 	| DATA Len -- followed by bytes of data+	| DATA_PRESENT 	| VALIDITY Validity 	| TIMESTAMP MonotonicTimestamp 	| ERROR String@@ -144,6 +146,7 @@ 	formatMessage (FAILURE_PLUS uuids) = ("FAILURE-PLUS":map Proto.serialize uuids) 	formatMessage (BYPASS (Bypass uuids)) = ("BYPASS":map Proto.serialize (S.toList uuids)) 	formatMessage (DATA len) = ["DATA", Proto.serialize len]+	formatMessage DATA_PRESENT = ["DATA-PRESENT"] 	formatMessage (VALIDITY Valid) = ["VALID"] 	formatMessage (VALIDITY Invalid) = ["INVALID"] 	formatMessage (TIMESTAMP ts) = ["TIMESTAMP", Proto.serialize ts]@@ -175,6 +178,7 @@ 	parseCommand "FAILURE-PLUS" = Proto.parseList FAILURE_PLUS 	parseCommand "BYPASS" = Proto.parseList (BYPASS . Bypass . S.fromList) 	parseCommand "DATA" = Proto.parse1 DATA+	parseCommand "DATA-PRESENT" = Proto.parse0 DATA_PRESENT 	parseCommand "VALID" = Proto.parse0 (VALIDITY Valid) 	parseCommand "INVALID" = Proto.parse0 (VALIDITY Invalid) 	parseCommand "TIMESTAMP" = Proto.parse1 TIMESTAMP@@ -477,11 +481,12 @@  get :: FilePath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification) get dest key iv af m p = -	receiveContent (Just m) p sizer storer $ \offset ->+	receiveContent (Just m) p sizer storer noothermessages $ \offset -> 		GET offset (ProtoAssociatedFile af) key   where 	sizer = fileSize dest 	storer = storeContentTo dest iv+	noothermessages = const Nothing  put :: Key -> AssociatedFile -> MeterUpdate -> Proto (Maybe [UUID]) put key af p = put' key af $ \offset ->@@ -664,7 +669,16 @@ 			else do 				let sizer = tmpContentSize key 				let storer = storeContent key af-				v <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM+				ver <- net getProtocolVersion+				let handleothermessages+					| ver >= ProtocolVersion 4 = \case+						DATA_PRESENT -> Just $+							checkContentPresent key+						_ -> Nothing+					| otherwise = const Nothing+				v <- receiveContent Nothing nullMeterUpdate +					sizer storer handleothermessages +					PUT_FROM 				when (observeBool v) $ 					local $ setPresent key myuuid 		return ServerContinue@@ -743,9 +757,10 @@ 	-> MeterUpdate 	-> Local Len 	-> (Offset -> Len -> Proto L.ByteString -> Proto (Maybe Validity) -> Local t)+	-> (Message -> Maybe (Local t)) 	-> (Offset -> Message) 	-> Proto t-receiveContent mm p sizer storer mkmsg = do+receiveContent mm p sizer storer handleothermessages mkmsg = do 	Len n <- local sizer 	let p' = offsetMeterUpdate p (toBytesProcessed n) 	let offset = Offset n@@ -764,16 +779,23 @@ 						net $ sendMessage (ERROR "expected VALID or INVALID") 						return Nothing 				else return Nothing-			v <- local $ storer offset len+			sendresultof $ storer offset len 				(net (receiveBytes len p')) 				validitycheck-			sendSuccess (observeBool v)-			return v 		Just (ERROR _err) -> 			return observeFailure-		_ -> do-			net $ sendMessage (ERROR "expected DATA")-			return observeFailure+		Just msg -> +			maybe unsupportedmessage sendresultof+				(handleothermessages msg)+		Nothing -> unsupportedmessage+  where+	unsupportedmessage = do+		net $ sendMessage (ERROR "expected DATA")+		return observeFailure+	sendresultof a = do+		v <- local a+		sendSuccess (observeBool v)+		return v  checkSuccess :: Proto Bool checkSuccess = either (const False) id <$> checkSuccess'
P2P/Proxy.hs view
@@ -302,6 +302,7 @@ 		FAILURE -> protoerr 		FAILURE_PLUS _ -> protoerr 		DATA _ -> protoerr+		DATA_PRESENT -> protoerr 		VALIDITY _ -> protoerr 		UNLOCKCONTENT -> protoerr 		-- If the client errors out, give up.@@ -486,7 +487,7 @@ 					getresponse client resp $  						withDATA 							(relayPUT remoteside k)-							(const protoerr)+							(handlePut_DATA_PRESENT remoteside k) 				_ -> protoerr 	handlePUT [] _ _ =  		protoerrhandler requestcomplete $@@ -563,8 +564,8 @@ 					let minoffset = minimum (map snd l') 					getresponse client (PUT_FROM (Offset minoffset)) $ 						withDATA (relayPUTMulti minoffset l' k)-							(const protoerr)-	+							(handlePutMulti_DATA_PRESENT l' k)+ 	relayPUTMulti minoffset remotes k (Len datalen) _ = do 		-- Tell each remote how much data to expect, depending 		-- on the remote's offset.@@ -664,6 +665,9 @@ 					Just (Just resp) -> 						relayPUTRecord k r resp 					_ -> return Nothing+			relayDATAFinishMulti' storeduuids++	relayDATAFinishMulti' storeduuids = 			protoerrhandler requestcomplete $ 				client $ net $ sendMessage $ 					case concat (catMaybes storeduuids) of@@ -671,6 +675,24 @@ 						us 							| proxyClientProtocolVersion proxyparams < ProtocolVersion 2 -> SUCCESS 							| otherwise -> SUCCESS_PLUS us+	+	handlePutMulti_DATA_PRESENT remotes k DATA_PRESENT = do+		storeduuids <- forMC (proxyConcurrencyConfig proxyparams) remotes $ \(remoteside, _) -> do+			resp <- runRemoteSideOrSkipFailed remoteside $ do+				net $ sendMessage DATA_PRESENT+				net receiveMessage+			case resp of+				Just (Just resp') -> relayPUTRecord k remoteside resp'+				_ -> return Nothing+		relayDATAFinishMulti' storeduuids+	handlePutMulti_DATA_PRESENT _ _ _ = protoerr++	handlePut_DATA_PRESENT remoteside k DATA_PRESENT =+		getresponse (runRemoteSide remoteside) DATA_PRESENT $ \resp -> do+			void $ relayPUTRecord k remoteside resp+			protoerrhandler requestcomplete $+				client $ net $ sendMessage resp+	handlePut_DATA_PRESENT _ _ _ = protoerr  	-- The associated file received from the P2P protocol 	-- is relative to the top of the git repository. But this process
Remote/Adb.hs view
@@ -81,6 +81,7 @@ 		, name = Git.repoDescribe r 		, storeKey = storeKeyDummy 		, retrieveKeyFile = retrieveKeyFileDummy+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		, retrievalSecurityPolicy = RetrievalAllKeysSecure 		, removeKey = removeKeyDummy
Remote/BitTorrent.hs view
@@ -69,6 +69,9 @@ 		, name = Git.repoDescribe r 		, storeKey = uploadKey 		, retrieveKeyFile = downloadKey+		-- Bittorrent downloads out of order, but downloadTorrentContent+		-- moves the downloaded file to the destination at the end.+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		-- Bittorrent does its own hash checks. 		, retrievalSecurityPolicy = RetrievalAllKeysSecure
Remote/Borg.hs view
@@ -86,6 +86,7 @@ 		, name = Git.repoDescribe r 		, storeKey = storeKeyDummy 		, retrieveKeyFile = retrieveKeyFileDummy+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		-- Borg cryptographically verifies content. 		, retrievalSecurityPolicy = RetrievalAllKeysSecure
Remote/Bup.hs view
@@ -78,6 +78,7 @@ 		, name = Git.repoDescribe r 		, storeKey = storeKeyDummy 		, retrieveKeyFile = retrieveKeyFileDummy+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		-- Bup uses git, which cryptographically verifies content 		-- (with SHA1, but sufficiently for this).
Remote/Ddar.hs view
@@ -79,6 +79,7 @@ 		, name = Git.repoDescribe r 		, storeKey = storeKeyDummy 		, retrieveKeyFile = retrieveKeyFileDummy+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		-- ddar communicates over ssh, not subject to http redirect 		-- type attacks
Remote/Directory.hs view
@@ -98,6 +98,7 @@ 			, name = Git.repoDescribe r 			, storeKey = storeKeyDummy 			, retrieveKeyFile = retrieveKeyFileDummy+			, retrieveKeyFileInOrder = pure True 			, retrieveKeyFileCheap = retrieveKeyFileCheapM dir chunkconfig 			, retrievalSecurityPolicy = RetrievalAllKeysSecure 			, removeKey = removeKeyDummy@@ -173,7 +174,7 @@ locations' :: RawFilePath -> Key -> [RawFilePath] locations' d k = NE.toList (locations d k) -{- Returns the location off a Key in the directory. If the key is+{- Returns the location of a Key in the directory. If the key is  - present, returns the location that is actually used, otherwise  - returns the first, default location. -} getLocation :: RawFilePath -> Key -> IO RawFilePath
Remote/Directory/LegacyChunked.hs view
@@ -98,7 +98,7 @@  - :/ This is legacy code..  -} retrieve :: (RawFilePath -> Key -> [RawFilePath]) -> RawFilePath -> Retriever-retrieve locations d basek p miv c = withOtherTmp $ \tmpdir -> do+retrieve locations d basek p _dest miv c = withOtherTmp $ \tmpdir -> do 	showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." 	let tmp = tmpdir P.</> keyFile basek <> ".directorylegacy.tmp" 	let tmp' = fromRawFilePath tmp@@ -110,7 +110,7 @@ 		b <- liftIO $ L.readFile tmp' 		liftIO $ removeWhenExistsWith R.removeLink tmp 		sink b-	byteRetriever go basek p miv c+	byteRetriever go basek p tmp miv c  checkKey :: RawFilePath -> (RawFilePath -> Key -> [RawFilePath]) -> Key -> Annex Bool checkKey d locations k = liftIO $
Remote/External.hs view
@@ -68,7 +68,7 @@ 	| externalprogram' == ExternalType "readonly" = do 		c <- parsedRemoteConfig remote rc 		cst <- remoteCost gc c expensiveRemoteCost-		let rmt = mk c cst (pure GloballyAvailable)+		let rmt = mk c cst (pure True) (pure GloballyAvailable) 			Nothing 			(externalInfo externalprogram') 			Nothing@@ -105,7 +105,9 @@ 		let cheapexportsupported = if exportsupported 			then exportIsSupported 			else exportUnsupported-		let rmt = mk c cst (getAvailability external)+		let rmt = mk c cst+			(getOrdered external)+			(getAvailability external) 			(Just (whereisKeyM external)) 			(getInfoM external) 			(Just (claimUrlM external))@@ -119,13 +121,14 @@ 			(checkPresentM external) 			rmt   where-	mk c cst avail towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported =+	mk c cst ordered avail towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = 		Remote 			{ uuid = u 			, cost = cst 			, name = Git.repoDescribe r 			, storeKey = storeKeyDummy 			, retrieveKeyFile = retrieveKeyFileDummy+			, retrieveKeyFileInOrder = ordered 			, retrieveKeyFileCheap = Nothing 			-- External special remotes use many http libraries 			-- and have no protection against redirects to@@ -800,6 +803,14 @@ 		UNSUPPORTED_REQUEST -> result defavail 		_ -> Nothing 	defavail = GloballyAvailable++getOrdered :: External -> Annex Bool+getOrdered external = catchNonAsync query (const (pure False))+  where+	query = handleRequest external GETORDERED Nothing $ \req -> case req of+		ORDERED -> result True+		UNORDERED -> result False+		_ -> result False  claimUrlM :: External -> URLString -> Annex Bool claimUrlM external url =
Remote/External/Types.hs view
@@ -168,6 +168,7 @@ 	| INITREMOTE 	| GETCOST 	| GETAVAILABILITY+	| GETORDERED 	| CLAIMURL URLString 	| CHECKURL URLString 	| TRANSFER Direction SafeKey FilePath@@ -200,6 +201,7 @@ 	formatMessage INITREMOTE = ["INITREMOTE"] 	formatMessage GETCOST = ["GETCOST"] 	formatMessage GETAVAILABILITY = ["GETAVAILABILITY"]+	formatMessage GETORDERED = ["GETORDERED"] 	formatMessage (CLAIMURL url) = [ "CLAIMURL", Proto.serialize url ] 	formatMessage (CHECKURL url) = [ "CHECKURL", Proto.serialize url ] 	formatMessage (TRANSFER direction key file) =@@ -248,6 +250,8 @@ 	| REMOVE_FAILURE Key ErrorMsg 	| COST Cost 	| AVAILABILITY Availability+	| ORDERED+	| UNORDERED 	| INITREMOTE_SUCCESS 	| INITREMOTE_FAILURE ErrorMsg 	| CLAIMURL_SUCCESS@@ -284,6 +288,8 @@ 	parseCommand "REMOVE-FAILURE" = Proto.parse2 REMOVE_FAILURE 	parseCommand "COST" = Proto.parse1 COST 	parseCommand "AVAILABILITY" = Proto.parse1 AVAILABILITY+	parseCommand "ORDERED" = Proto.parse0 ORDERED+	parseCommand "UNORDERED" = Proto.parse0 UNORDERED 	parseCommand "INITREMOTE-SUCCESS" = Proto.parse0 INITREMOTE_SUCCESS 	parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE 	parseCommand "CLAIMURL-SUCCESS" = Proto.parse0 CLAIMURL_SUCCESS
Remote/GCrypt.hs view
@@ -140,6 +140,7 @@ 		, name = Git.repoDescribe r 		, storeKey = storeKeyDummy 		, retrieveKeyFile = retrieveKeyFileDummy+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		, retrievalSecurityPolicy = RetrievalAllKeysSecure 		, removeKey = removeKeyDummy@@ -409,9 +410,9 @@ 	storersync = fileStorer $ Remote.Rsync.store rsyncopts  retrieve :: Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Retriever-retrieve r rsyncopts accessmethod k p miv sink = do+retrieve r rsyncopts accessmethod k p dest miv sink = do 	repo <- getRepo r-	retrieve' repo r rsyncopts accessmethod k p miv sink+	retrieve' repo r rsyncopts accessmethod k p dest miv sink  retrieve' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Retriever retrieve' repo r rsyncopts accessmethod
Remote/Git.hs view
@@ -210,6 +210,7 @@ 			, name = Git.repoDescribe r 			, storeKey = copyToRemote new st 			, retrieveKeyFile = copyFromRemote new st+			, retrieveKeyFileInOrder = pure True 			, retrieveKeyFileCheap = copyFromRemoteCheap st r 			, retrievalSecurityPolicy = RetrievalAllKeysSecure 			, removeKey = dropKey new st@@ -686,7 +687,7 @@ 				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'+						clientPut p' key (Just offset) af object sz check' False 					case res of 						PutResultPlus False fanoutuuids -> do 							storefanout fanoutuuids
Remote/GitLFS.hs view
@@ -105,6 +105,7 @@ 		, name = Git.repoDescribe r 		, storeKey = storeKeyDummy 		, retrieveKeyFile = retrieveKeyFileDummy+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		-- content stored on git-lfs is hashed with SHA256 		-- no matter what git-annex key it's for, and the hash
Remote/Glacier.hs view
@@ -81,6 +81,7 @@ 			, name = Git.repoDescribe r 			, storeKey = storeKeyDummy 			, retrieveKeyFile = retrieveKeyFileDummy+			, retrieveKeyFileInOrder = pure True 			, retrieveKeyFileCheap = Nothing 			-- glacier-cli does not follow redirects and does 			-- not support file://, as far as we know, but@@ -177,7 +178,7 @@ 		forceSuccessProcess cmd pid 	go' _ _ _ _ _ = error "internal" -retrieve :: forall a. Remote -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a+retrieve :: forall a. Remote -> Key -> MeterUpdate -> RawFilePath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a retrieve = byteRetriever . retrieve'  retrieve' :: forall a. Remote -> Key -> (L.ByteString -> Annex a) -> Annex a
Remote/Helper/Chunked.hs view
@@ -294,8 +294,10 @@ 			let p = maybe basep 				(offsetMeterUpdate basep . toBytesProcessed) 				offset-			v <- tryNonAsync $-				retriever (encryptor k) p Nothing $ \content ->+			v <- tryNonAsync $ do+				let enck = encryptor k+				objloc <- fromRepo $ gitAnnexTmpObjectLocation enck+				retriever enck p objloc Nothing $ \content -> 					bracket (maybe opennew openresume offset) (liftIO . hClose . fst) $ \(h, iv) -> do 						retrieved iv (Just h) p content 						let sz = toBytesProcessed $@@ -316,7 +318,9 @@ 	getrest p h iv sz bytesprocessed (k:ks) = do 		let p' = offsetMeterUpdate p bytesprocessed 		liftIO $ p' zeroBytesProcessed-		retriever (encryptor k) p' Nothing $ +		let enck = encryptor k+		objloc <- fromRepo $ gitAnnexTmpObjectLocation enck+		retriever enck p' objloc Nothing $  			retrieved iv (Just h) p' 		getrest p h iv sz (addBytesProcessed bytesprocessed sz) ks @@ -324,7 +328,9 @@ 		iv <- startVerifyKeyContentIncrementally vc basek 		case enc of 			Just _ -> do-				retriever (encryptor basek) basep Nothing $+				let enck = encryptor basek+				objloc <- fromRepo $ gitAnnexTmpObjectLocation enck+				retriever (encryptor basek) basep objloc Nothing $ 					retrieved iv Nothing basep 				return (Right iv) 			-- Not chunked and not encrypted, so ask the@@ -333,7 +339,7 @@ 			-- passing the whole file content to the 			-- incremental verifier though. 			Nothing -> do-				retriever (encryptor basek) basep iv $+				retriever (encryptor basek) basep (toRawFilePath dest) iv $ 					retrieved iv Nothing basep 				return $ case iv of 					Nothing -> Right iv
Remote/Helper/Special.hs view
@@ -42,6 +42,7 @@ import Types.Remote import Annex.Verify import Annex.UUID+import Annex.Perms import Config import Config.Cost import Utility.Metered@@ -106,10 +107,10 @@ -- A Retriever that generates a lazy ByteString containing the Key's -- content, and passes it to a callback action which will fully consume it -- before returning.-byteRetriever :: (Key -> (L.ByteString -> Annex a) -> Annex a) -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a-byteRetriever a k _m _miv callback = a k (callback . ByteContent)+byteRetriever :: (Key -> (L.ByteString -> Annex a) -> Annex a) -> Key -> MeterUpdate -> RawFilePath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a+byteRetriever a k _m _dest _miv callback = a k (callback . ByteContent) --- A Retriever that writes the content of a Key to a provided file.+-- A Retriever that writes the content of a Key to a file. -- The action is responsible for updating the progress meter as it  -- retrieves data. The incremental verifier is updated in the background as -- the action writes to the file, but may not be updated with the entire@@ -119,15 +120,15 @@ 	let retrieve = a f k m 	in tailVerify miv f retrieve -{- A Retriever that writes the content of a Key to a provided file.+{- A Retriever that writes the content of a Key to a file.  - The action is responsible for updating the progress meter and the   - incremental verifier as it retrieves data.  -} fileRetriever' :: (RawFilePath -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> Annex ()) -> Retriever-fileRetriever' a k m miv callback = do-	f <- prepTmp k-	a f k m miv-	pruneTmpWorkDirBefore f (callback . FileContent . fromRawFilePath)+fileRetriever' a k m dest miv callback = do+	createAnnexDirectory (parentDir dest)+	a dest k m miv+	pruneTmpWorkDirBefore dest (callback . FileContent . fromRawFilePath)  {- The base Remote that is provided to specialRemote needs to have  - storeKey, retrieveKeyFile, removeKey, and checkPresent methods,
Remote/Hook.hs view
@@ -62,6 +62,7 @@ 			, name = Git.repoDescribe r 			, storeKey = storeKeyDummy 			, retrieveKeyFile = retrieveKeyFileDummy+			, retrieveKeyFileInOrder = pure False 			, retrieveKeyFileCheap = Nothing 			-- A hook could use http and be vulnerable to 			-- redirect to file:// attacks, etc.
Remote/HttpAlso.hs view
@@ -67,6 +67,7 @@ 		, name = Git.repoDescribe r 		, storeKey = cannotModify 		, retrieveKeyFile = retrieveKeyFileDummy+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		-- HttpManagerRestricted is used here, so this is 		-- secure.
Remote/P2P.hs view
@@ -59,6 +59,7 @@ 		, name = Git.repoDescribe r 		, storeKey = store u gc protorunner 		, retrieveKeyFile = retrieve gc protorunner+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		, retrievalSecurityPolicy = RetrievalAllKeysSecure 		, removeKey = remove u protorunner
Remote/Rsync.hs view
@@ -94,6 +94,7 @@ 			, name = Git.repoDescribe r 			, storeKey = storeKeyDummy 			, retrieveKeyFile = retrieveKeyFileDummy+			, retrieveKeyFileInOrder = pure True 			, retrieveKeyFileCheap = Just (retrieveCheap o) 			, retrievalSecurityPolicy = RetrievalAllKeysSecure 			, removeKey = removeKeyDummy
Remote/S3.hs view
@@ -209,6 +209,7 @@ 			, name = Git.repoDescribe r 			, storeKey = storeKeyDummy 			, retrieveKeyFile = retrieveKeyFileDummy+			, retrieveKeyFileInOrder = pure True 			, retrieveKeyFileCheap = Nothing 			-- HttpManagerRestricted is used here, so this is 			-- secure.
Remote/Tahoe.hs view
@@ -89,6 +89,9 @@ 		, name = Git.repoDescribe r 		, storeKey = store rs hdl 		, retrieveKeyFile = retrieve rs hdl+		-- Unsure about whether tahoe might sometimes write chunks+		-- out of order.+		, retrieveKeyFileInOrder = pure False 		, retrieveKeyFileCheap = Nothing 		-- Tahoe cryptographically verifies content. 		, retrievalSecurityPolicy = RetrievalAllKeysSecure
Remote/Web.hs view
@@ -77,6 +77,7 @@ 		, name = Git.repoDescribe r 		, storeKey = uploadKey 		, retrieveKeyFile = downloadKey urlincludeexclude+		, retrieveKeyFileInOrder = pure True 		, retrieveKeyFileCheap = Nothing 		-- HttpManagerRestricted is used here, so this is 		-- secure.
Remote/WebDAV.hs view
@@ -88,6 +88,7 @@ 			, name = Git.repoDescribe r 			, storeKey = storeKeyDummy 			, retrieveKeyFile = retrieveKeyFileDummy+			, retrieveKeyFileInOrder = pure True 			, retrieveKeyFileCheap = Nothing 			-- HttpManagerRestricted is used here, so this is 			-- secure.
Types/AdjustedBranch.hs view
@@ -10,7 +10,7 @@ data Adjustment 	= LinkAdjustment LinkAdjustment 	| PresenceAdjustment PresenceAdjustment (Maybe LinkAdjustment)-	| LinkPresentAdjustment LinkPresentAdjustment+	| LockUnlockPresentAdjustment LockUnlockPresentAdjustment 	deriving (Show, Eq)  data LinkAdjustment@@ -25,7 +25,7 @@ 	| ShowMissingAdjustment 	deriving (Show, Eq) -data LinkPresentAdjustment+data LockUnlockPresentAdjustment 	= UnlockPresentAdjustment 	| LockPresentAdjustment 	deriving (Show, Eq)@@ -41,8 +41,8 @@ 		LinkAdjustment (reverseAdjustment l) 	reverseAdjustment (PresenceAdjustment p ml) = 		PresenceAdjustment (reverseAdjustment p) (fmap reverseAdjustment ml)-	reverseAdjustment (LinkPresentAdjustment l) =-		LinkPresentAdjustment (reverseAdjustment l)+	reverseAdjustment (LockUnlockPresentAdjustment l) =+		LockUnlockPresentAdjustment (reverseAdjustment l)  instance ReversableAdjustment LinkAdjustment where 	reverseAdjustment UnlockAdjustment = LockAdjustment@@ -55,7 +55,7 @@ 	reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment 	reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment -instance ReversableAdjustment LinkPresentAdjustment where+instance ReversableAdjustment LockUnlockPresentAdjustment where 	reverseAdjustment UnlockPresentAdjustment = LockPresentAdjustment 	reverseAdjustment LockPresentAdjustment = UnlockPresentAdjustment
Types/Key.hs view
@@ -354,6 +354,7 @@ parseKeyVariety "URL"          = URLKey parseKeyVariety "VURL"         = VURLKey parseKeyVariety "GITBUNDLE"    = GitBundleKey+parseKeyVariety "GITMANIFEST"  = GitManifestKey parseKeyVariety b 	| "X" `S.isPrefixOf` b =  		let b' = S.tail b
Types/Remote.hs view
@@ -98,6 +98,8 @@ 	-- sequentially to the file.) 	-- Throws exception on failure. 	, retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfigA a -> a Verification+	{- Will retrieveKeyFile write to the file in order? -}+	, retrieveKeyFileInOrder :: a Bool 	-- Retrieves a key's contents to a tmp file, if it can be done cheaply. 	-- It's ok to create a symlink or hardlink. 	-- Throws exception on failure.
Types/StoreRetrieve.hs view
@@ -35,12 +35,15 @@ -- Throws exception if key is not present, or remote is not accessible. -- -- When it retrieves FileContent, it is responsible for updating the--- MeterUpdate. And when the IncrementalVerifier is passed to it,+-- MeterUpdate, and the provided FilePath can be used to store the file+-- it retrieves. +--+-- When the IncrementalVerifier is passed to it, -- and it retrieves FileContent, it can feed some or all of the file's -- content to the verifier before running the callback. -- This should not be done when it retrieves ByteContent. type Retriever = forall a.-	Key -> MeterUpdate -> Maybe IncrementalVerifier+	Key -> MeterUpdate -> RawFilePath -> Maybe IncrementalVerifier 		-> (ContentSource -> Annex a) -> Annex a  -- Action that removes a Key's content from a remote.
+ Utility/OpenFile.hs view
@@ -0,0 +1,38 @@+{- Opening files+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.OpenFile where++#ifndef mingw32_HOST_OS++import System.IO+import System.Posix.IO+import GHC.IO.FD+import GHC.IO.Handle.FD+import GHC.IO.Device++import Utility.OpenFd+import Utility.RawFilePath+import Utility.FileSystemEncoding++{- Usually, opening a Handle to a file that another thread also has open+ - for write is prevented, which avoids a lot of concurrency bugs especially+ - with lazy IO.+ - + - However, sometimes one thread is writing and another thread really wants+ - to read from the same file. This bypasses the usual locking, by claiming+ - that an opened FD is a Stream.+ -}+openFileBeingWritten :: RawFilePath -> IO Handle+openFileBeingWritten f = do+	fd <- openFdWithMode f ReadOnly Nothing defaultFileFlags+	(fd', fdtype) <- mkFD (fromIntegral fd) ReadMode (Just (Stream, 0, 0)) False False+	mkHandleFromFD fd' fdtype (fromRawFilePath f) ReadMode False Nothing++#endif
+ Utility/STM.hs view
@@ -0,0 +1,23 @@+{- support for old versions of the stm package+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.STM (+	module Control.Concurrent.STM,+#if ! MIN_VERSION_stm(2,5,1)+	writeTMVar+#endif+) where++import Control.Concurrent.STM++#if ! MIN_VERSION_stm(2,5,1)+writeTMVar :: TMVar t -> t -> STM ()+writeTMVar t new = tryTakeTMVar t >> putTMVar t new+#endif
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20240927+Version: 10.20241031 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -321,8 +321,7 @@       servant-client,       servant-client-core,       warp (>= 3.2.8),-      warp-tls (>= 3.2.2),-      stm (>= 2.5.1)+      warp-tls (>= 3.2.2)     CPP-Options: -DWITH_SERVANT     Other-Modules:       Command.P2PHttp@@ -1091,6 +1090,7 @@     Utility.Network     Utility.NotificationBroadcaster     Utility.OpenFd+    Utility.OpenFile     Utility.OptParse     Utility.OSX     Utility.PID@@ -1119,6 +1119,7 @@     Utility.SshConfig     Utility.SshHost     Utility.StatelessOpenPGP+    Utility.STM     Utility.Su     Utility.SystemDirectory     Utility.Terminal