From 20df236a13b51257aad21821981a084d59e1ebf6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Oct 2024 12:13:05 -0400 Subject: [PATCH] update http servant for p2p protocol version 4 This is all just adding the v4 routes and boilerplate. At this point v4 is implemented the same as v3. --- P2P/Http.hs | 13 ++++++- P2P/Http/Client.hs | 95 +++++++++++++++++++++++++--------------------- P2P/Http/Server.hs | 12 +++++- P2P/Http/Types.hs | 4 ++ 4 files changed, 79 insertions(+), 45 deletions(-) diff --git a/P2P/Http.hs b/P2P/Http.hs index a096422415..a03b5a5f1a 100644 --- 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 62cad6ca74..d9c2c71f6b 100644 --- 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 124994197f..5ec5438a50 100644 --- 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 92d6bab207..3faabad475 100644 --- 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"