implemented servePutOffset and clientPutOffset

But, it's buggy: the server hangs without processing the VALIDITY,
and I can't seem to work out why. As far as I can see, storefile
is getting as far as running the validitycheck, which is supposed to
read that, but never does.

This is especially strange because what seems like the same protocol
doesn't hang when servePut runs it. This made me think that it needed
to use inAnnexWorker to be more like servePut, but that didn't help.

Another small problem with this is that it does create an empty
.git/annex/tmp/ file for the key. Since this will usually be used in
combination with servePut, that doesn't seem worth worrying about much.

Command/P2PHttp.hs

@@ -73,7 +73,7 @@ seek o = getAnnexWorkerPool $ \workerpool -> do
 	-- XXX remove this
 	when (isNothing (portOption o)) $ do
 		liftIO $ putStrLn "test begins"
-		testPut
+		testPutOffset
 		giveup "TEST DONE" 
 	withLocalP2PConnections workerpool $ \acquireconn -> liftIO $ do
 		authenv <- getAuthEnv
@@ -182,11 +182,23 @@ testPut = do
 		(B64UUID (toUUID ("cu" :: String)))
 		[]
 		Nothing
-		(Just (Offset 584754208))
+		Nothing
 		(AssociatedFile (Just "foo"))
-		"bigfile3content"
-		1048576000
-		(liftIO (print "validity check") >> return True)
+		"emptyfile"
+		0
+		(liftIO (print "validity check") >> return False)
+	liftIO $ print res
+
+testPutOffset = do
+	mgr <- httpManager <$> getUrlOptions
+	burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
+	res <- liftIO $ clientPutOffset (mkClientEnv mgr burl)
+		(P2P.ProtocolVersion 3)
+		(B64Key (fromJust $ deserializeKey ("SHA256E-s1048576000--b460ca923520db561d01b99483e9e2fe65ff9dfbdd52c17acba6ac4e874e27d5")))
+		(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
+		(B64UUID (toUUID ("cu" :: String)))
+		[]
+		Nothing
 	liftIO $ print res
 
 testRemove = do

P2P/Http.hs

@@ -720,6 +720,8 @@ type PutOffsetAPI result
 	= KeyParam
 	:> CU Required
 	:> BypassUUIDs
+	:> IsSecure
+	:> AuthHeader
 	:> Post '[JSON] result
 
 servePutOffset
@@ -731,29 +733,50 @@ servePutOffset
 	-> B64Key
 	-> B64UUID ClientSide
 	-> [B64UUID Bypass]
+	-> IsSecure
+	-> Maybe Auth
 	-> Handler t
-servePutOffset st resultmangle su apiver (B64Key k) cu bypass = undefined
-
+servePutOffset st resultmangle su apiver (B64Key k) cu bypass sec auth = do
+	res <- withP2PConnection apiver st cu su bypass sec auth WriteAction
+		(\cst -> cst { connectionWaitVar = False }) $ \conn ->
+			liftIO $ proxyClientNetProto conn $ getPutOffset k af
+	case res of
+		Right offset -> return $ resultmangle $
+			PutOffsetResultPlus (Offset offset)
+		Left plusuuids -> return $ resultmangle $
+			PutOffsetResultAlreadyHavePlus (map B64UUID plusuuids)
+  where
+	af = AssociatedFile Nothing
 
 clientPutOffset
-	:: B64UUID ServerSide
+	:: ClientEnv
 	-> ProtocolVersion
 	-> B64Key
+	-> B64UUID ServerSide
 	-> B64UUID ClientSide
 	-> [B64UUID Bypass]
-	-> ClientM PutOffsetResultPlus
-clientPutOffset su (ProtocolVersion ver) = case ver of
-	3 -> v3 su V3
-	2 -> v2 su V2
-	_ -> error "unsupported protocol version"
+	-> Maybe Auth
+	-> IO PutOffsetResultPlus
+clientPutOffset clientenv (ProtocolVersion ver) k su cu bypass auth
+	| ver == 0 = return (PutOffsetResultPlus (Offset 0))
+	| otherwise = 
+		withClientM cli clientenv $ \case
+			Left err -> throwM err
+			Right res -> return res
   where
+	cli = case ver of
+		3 -> v3 su V3 k cu bypass auth
+		2 -> v2 su V2 k cu bypass auth
+		1 -> plus <$> v1 su V1 k cu bypass auth
+		_ -> error "unsupported protocol version"
+	
 	_ :<|> _ :<|> _ :<|> _ :<|>
 		_ :<|> _ :<|> _ :<|> _ :<|>
 		_ :<|> _ :<|> _ :<|> _ :<|>
 		_ :<|>
 		_ :<|>
 		_ :<|> _ :<|> _ :<|> _ :<|>
-		v3 :<|> v2 :<|> _ = client p2pHttpAPI
+		v3 :<|> v2 :<|> v1 :<|> _ = client p2pHttpAPI
 
 type LockContentAPI
 	= KeyParam

P2P/Http/Types.hs

@@ -107,10 +107,14 @@ newtype PutResult = PutResult Bool
 data PutResultPlus = PutResultPlus Bool [B64UUID Plus]
 	deriving (Show)
 
-newtype PutOffsetResult = PutOffsetResult Offset
+data PutOffsetResult
+	= PutOffsetResult Offset
+	| PutOffsetResultAlreadyHave
 	deriving (Show)
 
-data PutOffsetResultPlus = PutOffsetResultPlus Offset [B64UUID Plus]
+data PutOffsetResultPlus 
+	= PutOffsetResultPlus Offset
+	| PutOffsetResultAlreadyHavePlus [B64UUID Plus]
 	deriving (Show, Generic, NFData)
 
 newtype Offset = Offset P2P.Offset
@@ -296,23 +300,37 @@ instance FromJSON GetTimestampResult where
 instance ToJSON PutOffsetResult where
 	toJSON (PutOffsetResult (Offset (P2P.Offset o))) = object
 		["offset" .= o]
+	toJSON PutOffsetResultAlreadyHave = object
+		["alreadyhave" .= True]
 
 instance FromJSON PutOffsetResult where
 	parseJSON = withObject "PutOffsetResult" $ \v ->
-		PutOffsetResult
-			<$> (Offset . P2P.Offset <$> v .: "offset")
+		(PutOffsetResult
+			<$> (Offset . P2P.Offset <$> v .: "offset"))
+		<|> (mkalreadyhave
+			<$> (v .: "alreadyhave"))
+	  where
+		mkalreadyhave :: Bool -> PutOffsetResult
+		mkalreadyhave _ = PutOffsetResultAlreadyHave
 
 instance ToJSON PutOffsetResultPlus where
-	toJSON (PutOffsetResultPlus (Offset (P2P.Offset o)) us) = object
-		[ "offset" .= o
+	toJSON (PutOffsetResultPlus (Offset (P2P.Offset o))) = object
+		[ "offset" .= o ]
+	toJSON (PutOffsetResultAlreadyHavePlus us) = object
+		[ "alreadyhave" .= True
 		, "plusuuids" .= plusList us
 		]
 
 instance FromJSON PutOffsetResultPlus where
 	parseJSON = withObject "PutOffsetResultPlus" $ \v ->
-		PutOffsetResultPlus
-			<$> (Offset . P2P.Offset <$> v .: "offset")
-			<*> v .: "plusuuids"
+		(PutOffsetResultPlus
+			<$> (Offset . P2P.Offset <$> v .: "offset"))
+		<|> (mkalreadyhave
+			<$> (v .: "alreadyhave")
+			<*> (v .: "plusuuids"))
+	  where
+		mkalreadyhave :: Bool -> [B64UUID Plus] -> PutOffsetResultPlus
+		mkalreadyhave _ us = PutOffsetResultAlreadyHavePlus us
 
 instance FromJSON (B64UUID t) where
 	parseJSON (String t) = case decodeB64Text t of
@@ -358,5 +376,8 @@ instance PlusClass PutResultPlus PutResult where
 	plus (PutResult b) = PutResultPlus b mempty
 
 instance PlusClass PutOffsetResultPlus PutOffsetResult where
-	dePlus (PutOffsetResultPlus o _) = PutOffsetResult o
-	plus (PutOffsetResult o) = PutOffsetResultPlus o mempty
+	dePlus (PutOffsetResultPlus o) = PutOffsetResult o
+	dePlus (PutOffsetResultAlreadyHavePlus _) = PutOffsetResultAlreadyHave
+	plus (PutOffsetResult o) = PutOffsetResultPlus o
+	plus PutOffsetResultAlreadyHave = PutOffsetResultAlreadyHavePlus []
+

P2P/Protocol.hs

@@ -482,6 +482,24 @@ put' key af sender = do
 			net $ sendMessage (ERROR "expected PUT_FROM or ALREADY_HAVE")
 			return Nothing
 
+-- The protocol does not have a way to get the PUT offset
+-- without sending DATA, so send an empty bytestring and indicate
+-- it is not valid.
+getPutOffset :: Key -> AssociatedFile -> Proto (Either [UUID] Offset)
+getPutOffset key af = do
+	net $ sendMessage (PUT (ProtoAssociatedFile af) key)
+	r <- net receiveMessage
+	case r of
+		Just (PUT_FROM offset) -> do
+			void $ sendContent' nullMeterUpdate (Len 0) L.empty $
+				return Invalid
+			return (Right offset)
+		Just ALREADY_HAVE -> return (Left [])
+		Just (ALREADY_HAVE_PLUS uuids) -> return (Left uuids)
+		_ -> do
+			net $ sendMessage (ERROR "expected PUT_FROM or ALREADY_HAVE")
+			return (Left [])
+
 data ServerHandler a
 	= ServerGot a
 	| ServerContinue
@@ -686,7 +704,7 @@ sendContent key af o offset@(Offset n) p = go =<< local (contentSize key)
 			else local $ readContent key af o offset $
 				sender (Len len)
 	-- Content not available to send. Indicate this by sending
-	-- empty data and indlicate it's invalid.
+	-- empty data and indicate it's invalid.
  	go Nothing = sender (Len 0) L.empty (return Invalid)
 
 	sender = sendContent' p'

doc/design/p2p_protocol_over_http/draft1.mdwn

@@ -276,7 +276,7 @@ Same as v3, except the JSON will not include "plusuuids".
 
 ### POST /git-annex/$uuid/v0/remove
 
-Identival to v1.
+Identical to v1.
 
 ## POST /git-annex/$uuid/v3/remove-before
 
@@ -389,8 +389,8 @@ The body of the request is empty.
 The server responds with a JSON object with an "offset" field that 
 is the largest allowable offset.
 
-If the server already has the content of the key, it will respond with a
-JSON object with an "alreadyhave" field that is set to true. This JSON
+If the server already has the content of the key, it will respond instead
+with a JSON object with an "alreadyhave" field that is set to true. This JSON
 object may also have a field "plusuuids" that lists 
 the UUIDs of other repositories where the content is stored, in addition to
 the serveruuid.

doc/todo/git-annex_proxies.mdwn

@@ -28,14 +28,17 @@ Planned schedule of work:
 
 ## work notes
 
-* Implement: servePutOffset, serveLockContent
+* servePutOffset crashes with "TMVar left full VALIDITY Invalid".
+  Seems nothing consumes the INVALID sent by the client, but why?
+
+* Implement serveLockContent
 
 * A Locker should expire the lock on its own after 10 minutes initially.
 
 * Since each held lock needs a connection to a proxy, the Locker
   could reference count, and avoid holding more than one lock per key.
 
-* Make Remote.Git use http client when annex.url is configured.
+* Make Remote.Git use http client when remote.name.annex-url is configured.
 
 * Make http server support proxies and clusters.
 
@@ -51,6 +54,8 @@ Planned schedule of work:
 
 * implemented server and client for HTTP P2P protocol
 
+* added git-annex p2phttp command to serve HTTP P2P protocol
+
 ## items deferred until later for [[design/passthrough_proxy]]
 
 * Check annex.diskreserve when proxying for special remotes