initial implementation of P2P.Annex runner

Untested, and it does not yet update transfer logs.

Verifying transferred content is modeled on git-annex-shell recvkey.
In a direct mode or annex.thin repository, content can change while it's
being transferred. So, verification is always done, even if annex.verify
would normally prevent it.

Note that a WORM or URL key could change in a way the verification
doesn't catch. That can happen in git-annex-shell recvkey too. We don't
worry about it, because those key backends don't guarantee preservation
of data. (Which is to say, I worried about it, and then convinced myself
again it was ok.)

2 files changed, 73 insertions, 5 deletions

diff --git a/P2P/Annex.hs b/P2P/Annex.hs
index ad4b458dd..d9ea530f0 100644
--- a/P2P/Annex.hs
+++ b/P2P/Annex.hs
@@ -16,8 +16,11 @@ import Annex.Common
 import Annex.Content
 import P2P.Protocol
 import P2P.IO
+import Logs.Location
+import Types.NumCopies
 
 import Control.Monad.Free
+import qualified Data.ByteString.Lazy as L
 
 -- Full interpreter for Proto, that can receive and send objects.
 runFullProto :: RunEnv -> Proto a -> Annex (Maybe a)
@@ -26,11 +29,74 @@ runFullProto runenv = go
 	go :: RunProto Annex
 	go (Pure v) = pure (Just v)
 	go (Free (Net n)) = runNet runenv go n
-	go (Free (Local l)) = runLocal runenv go l
+	go (Free (Local l)) = runLocal go l
 
-runLocal :: RunEnv -> RunProto Annex -> LocalF (Proto a) -> Annex (Maybe a)
-runLocal runenv runner f = case f of
+runLocal :: RunProto Annex -> LocalF (Proto a) -> Annex (Maybe a)
+runLocal runner a = case a of
 	TmpContentSize k next -> do
 		tmp <- fromRepo $ gitAnnexTmpObjectLocation k
 		size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp
 		runner (next (Len size))
+	ContentSize k next -> do
+		let getsize = liftIO . catchMaybeIO . getFileSize
+		size <- inAnnex' isJust Nothing getsize k
+		runner (next (Len <$> size))
+	-- TODO transfer logs
+	ReadContent k (Offset o) next -> do
+		v <- tryNonAsync $ prepSendAnnex k
+		case v of
+			-- The check can detect a problem after the
+			-- content is sent, but we don't use it.
+			-- Instead, the receiving peer must AlwaysVerify
+			-- the content it receives.
+			Right (Just (f, _check)) -> do
+				v' <- liftIO $ tryNonAsync $ do
+					h <- openBinaryFile f ReadMode
+					when (o /= 0) $
+						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 (Offset o) (Len l) b next -> do
+		ok <- flip catchNonAsync (const $ return False) $
+			getViaTmp AlwaysVerify k $ \tmp -> liftIO $ do
+				withBinaryFile tmp WriteMode $ \h -> do
+					when (o /= 0) $
+						hSeek h AbsoluteSeek o
+					L.hPut h b
+				sz <- getFileSize tmp
+				return (toInteger sz == l, UnVerified)
+		runner (next ok)
+	SetPresent k u next -> do
+		v <- tryNonAsync $ logChange k u InfoPresent
+		case v of
+			Left _ -> return Nothing
+			Right () -> runner next
+	CheckContentPresent k next -> do
+		v <- tryNonAsync $ inAnnex k
+		case v of
+			Left _ -> return Nothing
+			Right result -> runner (next result)
+	RemoveContent k next -> do
+		v <- tryNonAsync $ lockContentForRemoval k $ \contentlock -> do
+				removeAnnex contentlock
+				logStatus k InfoMissing
+				return True
+		case v of
+			Left _ -> return Nothing
+			Right result -> runner (next result)
+	TryLockContent k protoaction next -> do
+		v <- tryNonAsync $ lockContentShared k $ \verifiedcopy -> 
+			case verifiedcopy of
+				LockedCopy _ -> runner (protoaction True)
+				_ -> runner (protoaction False)
+		-- If locking fails, lockContentShared throws an exception.
+		-- Let the peer know it failed.
+		case v of
+			Left _ -> runner $ do
+				protoaction False
+				next
+			Right _ -> runner next
diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index 7c83a26b1..b67dc118d 100644
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -174,7 +174,9 @@ data LocalF c
 	-- May fail if not enough copies to safely drop, etc.
 	| TryLockContent Key (Bool -> Proto ()) c
 	-- ^ Try to lock the content of a key,  preventing it
-	-- from being deleted, and run the provided protocol action.
+	-- from being deleted, while running the provided protocol
+	-- action. If unable to lock the content, runs the protocol action
+	-- with False.
 	deriving (Functor)
 
 type Local = Free LocalF
@@ -291,7 +293,7 @@ serve myuuid = go Nothing
 					when ok $
 						local $ setPresent key myuuid
 		-- setPresent not called because the peer may have
-		-- requested the data but not permanatly stored it.
+		-- requested the data but not permanently stored it.
 		GET offset key -> void $ sendContent key offset
 		CONNECT service -> net $ relayService service
 		_ -> net $ sendMessage (ERROR "unexpected command")