plumb assicated files through P2P protocol for updating transfer logs

ReadContent can't update the log, since it reads lazily. This part of
the P2P monad will need to be rethought.

Associated files are heavily sanitized when received from a peer;
they could be an exploit vector.

This commit was sponsored by Jochen Bartl on Patreon.

Annex/Notification.hs

@@ -7,7 +7,7 @@
 
 {-# LANGUAGE CPP #-}
 
-module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where
+module Annex.Notification (NotifyWitness, noNotification, notifyTransfer, notifyDrop) where
 
 import Annex.Common
 import Types.Transfer
@@ -21,6 +21,10 @@ import qualified DBus.Client
 -- Witness that notification has happened.
 data NotifyWitness = NotifyWitness
 
+-- Only use when no notification should be done.
+noNotification :: NotifyWitness
+noNotification = NotifyWitness
+
 {- Wrap around an action that performs a transfer, which may run multiple
  - attempts. Displays notification when supported and when the user asked
  - for it. -}

P2P/Annex.hs

@@ -15,6 +15,8 @@ module P2P.Annex
 
 import Annex.Common
 import Annex.Content
+import Annex.Transfer
+import Annex.Notification
 import P2P.Protocol
 import P2P.IO
 import Logs.Location
@@ -48,8 +50,8 @@ runLocal runmode runner a = case a of
 		let getsize = liftIO . catchMaybeIO . getFileSize
 		size <- inAnnex' isJust Nothing getsize k
 		runner (next (Len <$> size))
-	-- TODO transfer logs
+	-- TODO transfer log not updated
-	ReadContent k (Offset o) next -> do
+	ReadContent k af (Offset o) next -> do
 		v <- tryNonAsync $ prepSendAnnex k
 		case v of
 			-- The check can detect a problem after the
@@ -57,25 +59,26 @@ runLocal runmode runner a = case a of
 			-- Instead, the receiving peer must AlwaysVerify
 			-- the content it receives.
 			Right (Just (f, _check)) -> do
-				v' <- liftIO $ tryNonAsync $ do
+				v' <- tryNonAsync $ -- transfer upload k af $
-					h <- openBinaryFile f ReadMode
+					liftIO $ do
-					when (o /= 0) $
+						h <- openBinaryFile f ReadMode
-						hSeek h AbsoluteSeek o
+						when (o /= 0) $
-					L.hGetContents h
+							hSeek h AbsoluteSeek o
+						L.hGetContents h
 				case v' of
 					Left _ -> return Nothing
 					Right b -> runner (next b)
 			_ -> return Nothing
-	-- TODO transfer logs
+	WriteContent k af (Offset o) (Len l) b next -> do
-	WriteContent k (Offset o) (Len l) b next -> do
 		ok <- flip catchNonAsync (const $ return False) $
-			getViaTmp AlwaysVerify k $ \tmp -> liftIO $ do
+			transfer download k af $
-				withBinaryFile tmp WriteMode $ \h -> do
+				getViaTmp AlwaysVerify k $ \tmp -> liftIO $ do
-					when (o /= 0) $
+					withBinaryFile tmp WriteMode $ \h -> do
-						hSeek h AbsoluteSeek o
+						when (o /= 0) $
-					L.hPut h b
+							hSeek h AbsoluteSeek o
-				sz <- getFileSize tmp
+						L.hPut h b
-				return (toInteger sz == l, UnVerified)
+					sz <- getFileSize tmp
+					return (toInteger sz == l, UnVerified)
 		runner (next ok)
 	SetPresent k u next -> do
 		v <- tryNonAsync $ logChange k u InfoPresent
@@ -107,3 +110,11 @@ runLocal runmode runner a = case a of
 				protoaction False
 				next
 			Right _ -> runner next
+  where
+	transfer mk k af a = case runmode of
+		-- Update transfer logs when serving.
+		Serving theiruuid -> 
+			mk theiruuid k af noRetry (const a) noNotification
+		-- Transfer logs are updated higher in the stack when
+		-- a client.
+		Client -> a

P2P/Protocol.hs

@@ -5,7 +5,9 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts, RankNTypes #-}
+{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module P2P.Protocol where
 
@@ -15,14 +17,17 @@ import Types.UUID
 import Utility.AuthToken
 import Utility.Applicative
 import Utility.PartialPrelude
+import Git.FilePath
 
 import Control.Monad
 import Control.Monad.Free
 import Control.Monad.Free.TH
 import Control.Monad.Catch
+import System.FilePath
 import System.Exit (ExitCode(..))
 import System.IO
 import qualified Data.ByteString.Lazy as L
+import Data.Char
 
 newtype Offset = Offset Integer
 	deriving (Show)
@@ -46,8 +51,8 @@ data Message
 	| LOCKCONTENT Key
 	| UNLOCKCONTENT
 	| REMOVE Key
-	| GET Offset Key
+	| GET Offset AssociatedFile Key
-	| PUT Key
+	| PUT AssociatedFile Key
 	| PUT_FROM Offset
 	| ALREADY_HAVE
 	| SUCCESS
@@ -66,8 +71,8 @@ instance Proto.Sendable Message where
 	formatMessage (LOCKCONTENT key) = ["LOCKCONTENT", Proto.serialize key]
 	formatMessage UNLOCKCONTENT = ["UNLOCKCONTENT"]
 	formatMessage (REMOVE key) = ["REMOVE", Proto.serialize key]
-	formatMessage (GET offset key) = ["GET", Proto.serialize offset, Proto.serialize key]
+	formatMessage (GET offset af key) = ["GET", Proto.serialize offset, Proto.serialize af, Proto.serialize key]
-	formatMessage (PUT key) = ["PUT", Proto.serialize key]
+	formatMessage (PUT af key) = ["PUT", Proto.serialize af, Proto.serialize key]
 	formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset]
 	formatMessage ALREADY_HAVE = ["ALREADY-HAVE"]
 	formatMessage SUCCESS = ["SUCCESS"]
@@ -85,8 +90,8 @@ instance Proto.Receivable Message where
 	parseCommand "LOCKCONTENT" = Proto.parse1 LOCKCONTENT
 	parseCommand "UNLOCKCONTENT" = Proto.parse0 UNLOCKCONTENT
 	parseCommand "REMOVE" = Proto.parse1 REMOVE
-	parseCommand "GET" = Proto.parse2 GET
+	parseCommand "GET" = Proto.parse3 GET
-	parseCommand "PUT" = Proto.parse1 PUT
+	parseCommand "PUT" = Proto.parse2 PUT
 	parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM
 	parseCommand "ALREADY-HAVE" = Proto.parse0 ALREADY_HAVE
 	parseCommand "SUCCESS" = Proto.parse0 SUCCESS
@@ -110,6 +115,38 @@ instance Proto.Serializable Service where
 	deserialize "git-receive-pack" = Just ReceivePack
 	deserialize _ = Nothing
 
+-- | Since AssociatedFile is not the last thing in a protocol line,
+-- its serialization cannot contain any whitespace. This is handled
+-- by replacing whitespace with '%' (and '%' with '%%')
+--
+-- When deserializing an AssociatedFile from a peer, it's sanitized,
+-- to avoid any unusual characters that might cause problems when it's
+-- displayed to the user.
+--
+-- These mungings are ok, because an AssociatedFile is only ever displayed
+-- to the user and does not need to match a file on disk.
+instance Proto.Serializable AssociatedFile where
+	serialize Nothing = ""
+	serialize (Just af) = toInternalGitPath $ concatMap esc af
+	  where
+		esc '%' = "%%"
+		esc c 
+			| isSpace c = "%"
+			| otherwise = [c]
+	
+	deserialize s = case fromInternalGitPath $ deesc [] s of
+		[] -> Just Nothing
+		f
+			| isRelative f -> Just (Just f)
+			| otherwise -> Nothing
+	  where
+	  	deesc b [] = reverse b
+		deesc b ('%':'%':cs) = deesc ('%':b) cs
+		deesc b ('%':cs) = deesc ('_':b) cs
+		deesc b (c:cs)
+			| isControl c = deesc ('_':b) cs
+			| otherwise = deesc (c:b) cs
+
 -- | Free monad for the protocol, combining net communication,
 -- and local actions.
 data ProtoF c = Net (NetF c) | Local (LocalF c)
@@ -155,10 +192,10 @@ data LocalF c
 	| ContentSize Key (Maybe Len -> c)
 	-- ^ Gets size of the content of a key, when the full content is
 	-- present.
-	| ReadContent Key Offset (L.ByteString -> c)
+	| ReadContent Key AssociatedFile Offset (L.ByteString -> c)
 	-- ^ Lazily reads the content of a key. Note that the content
 	-- may change while it's being sent.
-	| WriteContent Key Offset Len L.ByteString (Bool -> c)
+	| WriteContent Key AssociatedFile Offset Len L.ByteString (Bool -> c)
 	-- ^ Writes content to temp file starting at an offset.
 	-- Once the whole content of the key has been stored, moves the
 	-- temp file into place and returns True.
@@ -226,15 +263,15 @@ remove key = do
 	net $ sendMessage (REMOVE key)
 	checkSuccess
 
-get :: Key -> Proto Bool
+get :: Key -> AssociatedFile -> Proto Bool
-get key = receiveContent key (`GET` key)
+get key af = receiveContent key af (\offset -> GET offset af key)
 
-put :: Key -> Proto Bool
+put :: Key -> AssociatedFile -> Proto Bool
-put key = do
+put key af = do
-	net $ sendMessage (PUT key)
+	net $ sendMessage (PUT af key)
 	r <- net receiveMessage
 	case r of
-		PUT_FROM offset -> sendContent key offset
+		PUT_FROM offset -> sendContent key af offset
 		ALREADY_HAVE -> return True
 		_ -> do
 			net $ sendMessage (ERROR "expected PUT_FROM")
@@ -307,17 +344,17 @@ serveAuthed myuuid = void $ serverLoop handler
 	handler (REMOVE key) = do
 		sendSuccess =<< local (removeContent key)
 		return ServerContinue
-	handler (PUT key) = do
+	handler (PUT af key) = do
 		have <- local $ checkContentPresent key
 		if have
 			then net $ sendMessage ALREADY_HAVE
 			else do
-				ok <- receiveContent key PUT_FROM
+				ok <- receiveContent key af PUT_FROM
 				when ok $
 					local $ setPresent key myuuid
 		return ServerContinue
-	handler (GET offset key) = do
+	handler (GET offset key af) = do
-		void $ sendContent key offset
+		void $ sendContent af key offset
 		-- setPresent not called because the peer may have
 		-- requested the data but not permanently stored it.
 		return ServerContinue
@@ -326,22 +363,22 @@ serveAuthed myuuid = void $ serverLoop handler
 		return ServerContinue
 	handler _ = return ServerUnexpected
 
-sendContent :: Key -> Offset -> Proto Bool
+sendContent :: Key -> AssociatedFile -> Offset -> Proto Bool
-sendContent key offset = do
+sendContent key af offset = do
-	(len, content) <- readContentLen key offset
+	(len, content) <- readContentLen key af offset
 	net $ sendMessage (DATA len)
 	net $ sendBytes len content
 	checkSuccess
 
-receiveContent :: Key -> (Offset -> Message) -> Proto Bool
+receiveContent :: Key -> AssociatedFile -> (Offset -> Message) -> Proto Bool
-receiveContent key mkmsg = do
+receiveContent key af mkmsg = do
 	Len n <- local $ tmpContentSize key
 	let offset = Offset n
 	net $ sendMessage (mkmsg offset)
 	r <- net receiveMessage
 	case r of
 		DATA len -> do
-			ok <- local . writeContent key offset len
+			ok <- local . writeContent key af offset len
 				=<< net (receiveBytes len)
 			sendSuccess ok
 			return ok
@@ -366,8 +403,8 @@ sendSuccess False = net $ sendMessage FAILURE
 -- Reads content from an offset. The Len should correspond to
 -- the length of the ByteString, but to avoid buffering the content
 -- in memory, is gotten using contentSize.
-readContentLen :: Key -> Offset -> Proto (Len, L.ByteString)
+readContentLen :: Key -> AssociatedFile -> Offset -> Proto (Len, L.ByteString)
-readContentLen key (Offset offset) = go =<< local (contentSize key)
+readContentLen key af (Offset offset) = go =<< local (contentSize key)
   where
 	go Nothing = return (Len 0, L.empty)
 	go (Just (Len totallen)) = do
@@ -375,7 +412,8 @@ readContentLen key (Offset offset) = go =<< local (contentSize key)
 		if len <= 0
 			then return (Len 0, L.empty)
 			else do
-				content <- local $ readContent key (Offset offset)
+				content <- local $
+					readContent key af (Offset offset)
 				return (Len len, content)
 
 connect :: Service -> Handle -> Handle -> Proto ExitCode