implement put data-present parameter in http servant

Changed the protocol docs because servant parses "true" and "false" for
booleans in query parameters, not "1" and "0".

clientPut with datapresent=True is not used by git-annex, and I don't
anticipate it being used in git-annex, except for testing.

I've tested this by making clientPut be called with datapresent=True and
git-annex copy to a remote succeeds once the object file is first
manually copied to the remote. That would be a good test for the test
suite, but running the http client means exposing it to at least
localhost, and would fail if a real http client was already running on
that port.

diff --git a/P2P/Http.hs b/P2P/Http.hs
index a03b5a5f1ac37b566c319db5d3577508809c8dcf..37fe4c067c6cad79cedc1f7a2b39db818dc206dc 100644 (file)
--- a/P2P/Http.hs
+++ b/P2P/Http.hs
@@ -44,7 +44,9 @@ type P2PHttpAPI
        :<|> "git-annex" :> SU :> PV3 :> "remove-before" :> RemoveBeforeAPI
        :<|> "git-annex" :> SU :> PV4 :> "gettimestamp" :> GetTimestampAPI
        :<|> "git-annex" :> SU :> PV3 :> "gettimestamp" :> GetTimestampAPI
-       :<|> "git-annex" :> SU :> PV4 :> "put" :> PutAPI PutResultPlus
+       :<|> "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

diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs
index d9c2c71f6b25e738636f7cff14721b593932ddb1..d047eca7a0a3f8c3011698281320869b8e69b7bc 100644 (file)
--- a/P2P/Http/Client.hs
+++ b/P2P/Http/Client.hs
@@ -329,27 +329,32 @@ clientPut
        -> 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
@@ -401,7 +406,7 @@ clientPut meterupdate k moffset af contentfile contentfilesize validitycheck cli
        bk = B64Key k
 
        cli src = case ver of
-               4 -> v4 su V4 len bk cu bypass baf moffset src auth
+               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

diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs
index 5ec5438a50191f5c38205efa12764db69a83f0ed..eaf87f36b46080531137d7cf0d43888d7826b7b4 100644 (file)
--- a/P2P/Http/Server.hs
+++ b/P2P/Http/Server.hs
@@ -26,6 +26,7 @@ import P2P.Http
 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
@@ -69,10 +70,10 @@ serveP2pHttp st
        :<|> serveGetTimestamp st
        :<|> serveGetTimestamp st
        :<|> servePut st id
-       :<|> servePut st id
-       :<|> 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
@@ -307,6 +308,7 @@ servePut
        -> (PutResultPlus -> t)
        -> B64UUID ServerSide
        -> v
+       -> Maybe Bool
        -> DataLength
        -> B64Key
        -> B64UUID ClientSide
@@ -317,7 +319,15 @@ servePut
        -> 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
@@ -327,41 +337,27 @@ servePut st resultmangle su apiver (DataLength len) (B64Key k) cu bypass baf mof
                (\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
@@ -399,6 +395,49 @@ servePut st resultmangle su apiver (DataLength len) (B64Key k) cu bypass baf mof
                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

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 2ae518798a2c40faa8a978ab036d6b989bd4f20e..10d582bd36cf1c34734da61c98a72c280e561c53 100644 (file)
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -687,7 +687,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
                                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

diff --git a/doc/design/p2p_protocol_over_http.mdwn b/doc/design/p2p_protocol_over_http.mdwn
index 0e49782fa0dc55ad5e46fb6d3b47bc74dade5e87..de9edbc5588297c61227f6e627fe01d971b8d80a 100644 (file)
--- a/doc/design/p2p_protocol_over_http.mdwn
+++ b/doc/design/p2p_protocol_over_http.mdwn
@@ -388,10 +388,10 @@ There are are also these optional parameters:
 
 * `data-present`
 
-  When set to 1, this indicates that the data has been sent to the repository
-  in some other way. The body of the request will be empty. The server will
-  verify that the data is present in the repository and will proceed the
-  same as if the data was sent in the request.
+  When set to "true", this indicates that the data has been sent to the
+  repository in some other way. The body of the request will be empty.
+  The server will verify that the data is present in the repository and
+  will proceed the same as if the data was sent in the request.
 
 The `Content-Type` header should be `application/octet-stream`.