projects / git-annex.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: d782b13)
update http servant for p2p protocol version 4
authorJoey Hess <joeyh@joeyh.name>
Tue, 29 Oct 2024 16:13:05 +0000 (12:13 -0400)
committerJoey Hess <joeyh@joeyh.name>
Tue, 29 Oct 2024 16:13:56 +0000 (12:13 -0400)
This is all just adding the v4 routes and boilerplate. At this point v4
is implemented the same as v3.

P2P/Http.hs patch | blob | history
P2P/Http/Client.hs patch | blob | history
P2P/Http/Server.hs patch | blob | history
P2P/Http/Types.hs patch | blob | history

diff --git a/P2P/Http.hs b/P2P/Http.hs
index a096422415a1d72593f240c3ff64d932b66baddf..a03b5a5f1ac37b566c319db5d3577508809c8dcf 100644 (file)
--- a/P2P/Http.hs
+++ b/P2P/Http.hs
@@ -25,34 +25,44 @@ import Servant
 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" :> 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 +187,7 @@ type LockIDParam = QueryParam' '[Required] "lockid" LockID
 
 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
diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs
index 62cad6ca7427f265b1e7d959bd570f6acf961621..d9c2c71f6b25e738636f7cff14721b593932ddb1 100644 (file)
--- a/P2P/Http/Client.hs
+++ b/P2P/Http/Client.hs
@@ -187,13 +187,14 @@ clientGet k af consumer startsz clientenv (ProtocolVersion ver) su cu bypass aut
                                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 @@ clientCheckPresent key clientenv (ProtocolVersion ver) su cu bypass auth =
                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 @@ clientRemove k clientenv (ProtocolVersion ver) su cu bypass auth =
        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 @@ clientRemoveBefore k ts clientenv (ProtocolVersion ver) su cu bypass auth =
        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 @@ clientGetTimestamp clientenv (ProtocolVersion ver) su cu bypass auth =
        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
@@ -396,18 +401,19 @@ 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
                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 +429,19 @@ clientPutOffset k clientenv (ProtocolVersion ver) su cu bypass auth
        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 +454,21 @@ clientLockContent k clientenv (ProtocolVersion ver) su cu bypass auth =
        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 +526,22 @@ clientKeepLocked lckid remoteuuid unablelock callback clientenv (ProtocolVersion
                                        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
diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs
index 124994197f7b3ce0c7d1226c03ec6d174ed6320a..5ec5438a50191f5c38205efa12764db69a83f0ed 100644 (file)
--- a/P2P/Http/Server.hs
+++ b/P2P/Http/Server.hs
@@ -53,27 +53,36 @@ serveP2pHttp st
        :<|> 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
        :<|> serveGetTimestamp st
        :<|> servePut st id
        :<|> 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
@@ -125,10 +134,11 @@ serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do
                        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))
diff --git a/P2P/Http/Types.hs b/P2P/Http/Types.hs
index 92d6bab207a8be06680f0ef962824b2a591e0c40..3faabad475418efff8091dd1e6e840e7e0da44ee 100644 (file)
--- a/P2P/Http/Types.hs
+++ b/P2P/Http/Types.hs
@@ -32,6 +32,7 @@ import Data.Char
 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 @@ data V0 = V0 deriving (Show)
 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 ToHttpApiData KeepAlive where
 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"
Unnamed repository; edit this file 'description' to name the repository.