mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

capture API version in routes

Browse source 
Needed so the client can send it.
This commit is contained in:
Joey Hess 2024-07-09 10:12:36 -04:00
parent 751b8e0baf
commit a3dd8b4bcb
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 127 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

164
P2P/Http.hs
View file

@ -32,42 +32,42 @@ import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
type P2PHttpAPI type P2PHttpAPI
= "git-annex" :> "v3" :> "key" :> CaptureKey :> GetAPI = "git-annex" :> PV3 :> "key" :> CaptureKey :> GetAPI
:<|> "git-annex" :> "v2" :> "key" :> CaptureKey :> GetAPI :<|> "git-annex" :> PV2 :> "key" :> CaptureKey :> GetAPI
:<|> "git-annex" :> "v1" :> "key" :> CaptureKey :> GetAPI :<|> "git-annex" :> PV1 :> "key" :> CaptureKey :> GetAPI
:<|> "git-annex" :> "v0" :> "key" :> CaptureKey :> GetAPI :<|> "git-annex" :> PV0 :> "key" :> CaptureKey :> GetAPI
:<|> "git-annex" :> "v3" :> "checkpresent" :> CheckPresentAPI :<|> "git-annex" :> PV3 :> "checkpresent" :> CheckPresentAPI
:<|> "git-annex" :> "v2" :> "checkpresent" :> CheckPresentAPI :<|> "git-annex" :> PV2 :> "checkpresent" :> CheckPresentAPI
:<|> "git-annex" :> "v1" :> "checkpresent" :> CheckPresentAPI :<|> "git-annex" :> PV1 :> "checkpresent" :> CheckPresentAPI
:<|> "git-annex" :> "v0" :> "checkpresent" :> CheckPresentAPI :<|> "git-annex" :> PV0 :> "checkpresent" :> CheckPresentAPI
:<|> "git-annex" :> "v3" :> "remove" :> RemoveAPI RemoveResultPlus :<|> "git-annex" :> PV3 :> "remove" :> RemoveAPI RemoveResultPlus
:<|> "git-annex" :> "v2" :> "remove" :> RemoveAPI RemoveResultPlus :<|> "git-annex" :> PV2 :> "remove" :> RemoveAPI RemoveResultPlus
:<|> "git-annex" :> "v1" :> "remove" :> RemoveAPI RemoveResult :<|> "git-annex" :> PV1 :> "remove" :> RemoveAPI RemoveResult
:<|> "git-annex" :> "v0" :> "remove" :> RemoveAPI RemoveResult :<|> "git-annex" :> PV0 :> "remove" :> RemoveAPI RemoveResult
:<|> "git-annex" :> "v3" :> "remove-before" :> RemoveBeforeAPI :<|> "git-annex" :> PV3 :> "remove-before" :> RemoveBeforeAPI
:<|> "git-annex" :> "v3" :> "gettimestamp" :> GetTimestampAPI :<|> "git-annex" :> PV3 :> "gettimestamp" :> GetTimestampAPI
:<|> "git-annex" :> "v3" :> "put" :> DataLengthHeader :<|> "git-annex" :> PV3 :> "put" :> DataLengthHeader
:> PutAPI PutResultPlus :> PutAPI PutResultPlus
:<|> "git-annex" :> "v2" :> "put" :> DataLengthHeader :<|> "git-annex" :> PV2 :> "put" :> DataLengthHeader
:> PutAPI PutResultPlus :> PutAPI PutResultPlus
:<|> "git-annex" :> "v1" :> "put" :> DataLengthHeader :<|> "git-annex" :> PV1 :> "put" :> DataLengthHeader
:> PutAPI PutResult :> PutAPI PutResult
:<|> "git-annex" :> "v0" :> "put" :<|> "git-annex" :> PV0 :> "put"
:> PutAPI PutResult :> PutAPI PutResult
:<|> "git-annex" :> "v3" :> "putoffset" :<|> "git-annex" :> PV3 :> "putoffset"
:> PutOffsetAPI PutOffsetResultPlus :> PutOffsetAPI PutOffsetResultPlus
:<|> "git-annex" :> "v2" :> "putoffset" :<|> "git-annex" :> PV2 :> "putoffset"
:> PutOffsetAPI PutOffsetResultPlus :> PutOffsetAPI PutOffsetResultPlus
:<|> "git-annex" :> "v1" :> "putoffset" :<|> "git-annex" :> PV1 :> "putoffset"
:> PutOffsetAPI PutOffsetResult :> PutOffsetAPI PutOffsetResult
:<|> "git-annex" :> "v3" :> "lockcontent" :> LockContentAPI :<|> "git-annex" :> PV3 :> "lockcontent" :> LockContentAPI
:<|> "git-annex" :> "v2" :> "lockcontent" :> LockContentAPI :<|> "git-annex" :> PV2 :> "lockcontent" :> LockContentAPI
:<|> "git-annex" :> "v1" :> "lockcontent" :> LockContentAPI :<|> "git-annex" :> PV1 :> "lockcontent" :> LockContentAPI
:<|> "git-annex" :> "v0" :> "lockcontent" :> LockContentAPI :<|> "git-annex" :> PV0 :> "lockcontent" :> LockContentAPI
:<|> "git-annex" :> "v3" :> "keeplocked" :> KeepLockedAPI :<|> "git-annex" :> PV3 :> "keeplocked" :> KeepLockedAPI
:<|> "git-annex" :> "v2" :> "keeplocked" :> KeepLockedAPI :<|> "git-annex" :> PV2 :> "keeplocked" :> KeepLockedAPI
:<|> "git-annex" :> "v1" :> "keeplocked" :> KeepLockedAPI :<|> "git-annex" :> PV1 :> "keeplocked" :> KeepLockedAPI
:<|> "git-annex" :> "v0" :> "keeplocked" :> KeepLockedAPI :<|> "git-annex" :> PV0 :> "keeplocked" :> KeepLockedAPI
:<|> "git-annex" :> "key" :> CaptureKey :> GetGenericAPI :<|> "git-annex" :> "key" :> CaptureKey :> GetGenericAPI
p2pHttpAPI :: Proxy P2PHttpAPI p2pHttpAPI :: Proxy P2PHttpAPI
@ -95,7 +95,7 @@ serveP2pHttp st
:<|> servePut st id :<|> servePut st id
:<|> servePut st id :<|> servePut st id
:<|> servePut st dePlus :<|> servePut st dePlus
:<|> servePut st dePlus Nothing :<|> (\v -> servePut st dePlus v Nothing)
:<|> servePutOffset st id :<|> servePutOffset st id
:<|> servePutOffset st id :<|> servePutOffset st id
:<|> servePutOffset st dePlus :<|> servePutOffset st dePlus
@ -124,7 +124,9 @@ type GetAPI
(Headers '[DataLengthHeader] (SourceIO B.ByteString)) (Headers '[DataLengthHeader] (SourceIO B.ByteString))
serveGet serveGet
:: P2PHttpServerState :: APIVersion v
=> P2PHttpServerState
-> v
-> B64Key -> B64Key
-> Maybe (B64UUID ClientSide) -> Maybe (B64UUID ClientSide)
-> Maybe (B64UUID ServerSide) -> Maybe (B64UUID ServerSide)
@ -144,10 +146,10 @@ clientGet
-> Maybe Offset -> Maybe Offset
-> ClientM (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString)) -> ClientM (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString))
clientGet (P2P.ProtocolVersion ver) = case ver of clientGet (P2P.ProtocolVersion ver) = case ver of
3 -> v3 3 -> v3 V3
2 -> v2 2 -> v2 V2
1 -> v1 1 -> v1 V1
0 -> v0 0 -> v0 V0
_ -> error "unsupported protocol version" _ -> error "unsupported protocol version"
where where
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
@ -160,13 +162,15 @@ type CheckPresentAPI
:> Post '[JSON] CheckPresentResult :> Post '[JSON] CheckPresentResult
serveCheckPresent serveCheckPresent
:: P2PHttpServerState :: APIVersion v
=> P2PHttpServerState
-> v
-> B64Key -> B64Key
-> B64UUID ClientSide -> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> Handler CheckPresentResult -> Handler CheckPresentResult
serveCheckPresent st (B64Key k) cu su bypass = do serveCheckPresent st apiver (B64Key k) cu su bypass = do
res <- liftIO $ inP2PConnection st cu su bypass $ P2P.checkPresent k res <- liftIO $ inP2PConnection st cu su bypass $ P2P.checkPresent k
case res of case res of
Right (Right b) -> return (CheckPresentResult b) Right (Right b) -> return (CheckPresentResult b)
@ -183,10 +187,10 @@ clientCheckPresent
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> ClientM CheckPresentResult -> ClientM CheckPresentResult
clientCheckPresent (P2P.ProtocolVersion ver) = case ver of clientCheckPresent (P2P.ProtocolVersion ver) = case ver of
3 -> v3 3 -> v3 V3
2 -> v2 2 -> v2 V2
1 -> v1 1 -> v1 V1
0 -> v0 0 -> v0 V0
_ -> error "unsupported protocol version" _ -> error "unsupported protocol version"
where where
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
@ -200,8 +204,10 @@ type RemoveAPI result
:> Post '[JSON] result :> Post '[JSON] result
serveRemove serveRemove
:: P2PHttpServerState :: APIVersion v
=> P2PHttpServerState
-> (RemoveResultPlus -> t) -> (RemoveResultPlus -> t)
-> v
-> B64Key -> B64Key
-> B64UUID ClientSide -> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
@ -217,10 +223,10 @@ clientRemove
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> ClientM RemoveResultPlus -> ClientM RemoveResultPlus
clientRemove (P2P.ProtocolVersion ver) k cu su bypass = case ver of clientRemove (P2P.ProtocolVersion ver) k cu su bypass = case ver of
3 -> v3 k cu su bypass 3 -> v3 V3 k cu su bypass
2 -> v2 k cu su bypass 2 -> v2 V2 k cu su bypass
1 -> plus <$> v1 k cu su bypass 1 -> plus <$> v1 V1 k cu su bypass
0 -> plus <$> v0 k cu su bypass 0 -> plus <$> v0 V0 k cu su bypass
_ -> error "unsupported protocol version" _ -> error "unsupported protocol version"
where where
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
@ -236,7 +242,9 @@ type RemoveBeforeAPI
:> Post '[JSON] RemoveResult :> Post '[JSON] RemoveResult
serveRemoveBefore serveRemoveBefore
:: P2PHttpServerState :: APIVersion v
=> P2PHttpServerState
-> v
-> B64Key -> B64Key
-> B64UUID ClientSide -> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
@ -254,7 +262,7 @@ clientRemoveBefore
-> Timestamp -> Timestamp
-> ClientM RemoveResult -> ClientM RemoveResult
clientRemoveBefore (P2P.ProtocolVersion ver) = case ver of clientRemoveBefore (P2P.ProtocolVersion ver) = case ver of
3 -> v3 3 -> v3 V3
_ -> error "unsupported protocol version" _ -> error "unsupported protocol version"
where where
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
@ -270,7 +278,9 @@ type GetTimestampAPI
:> Post '[JSON] GetTimestampResult :> Post '[JSON] GetTimestampResult
serveGetTimestamp serveGetTimestamp
:: P2PHttpServerState :: APIVersion v
=> P2PHttpServerState
-> v
-> B64UUID ClientSide -> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
@ -284,7 +294,7 @@ clientGetTimestamp
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> ClientM GetTimestampResult -> ClientM GetTimestampResult
clientGetTimestamp (P2P.ProtocolVersion ver) = case ver of clientGetTimestamp (P2P.ProtocolVersion ver) = case ver of
3 -> v3 3 -> v3 V3
_ -> error "unsupported protocol version" _ -> error "unsupported protocol version"
where where
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
@ -305,8 +315,10 @@ type PutAPI result
:> Post '[JSON] result :> Post '[JSON] result
servePut servePut
:: P2PHttpServerState :: APIVersion v
=> P2PHttpServerState
-> (PutResultPlus -> t) -> (PutResultPlus -> t)
-> v
-> Maybe Integer -> Maybe Integer
-> B64Key -> B64Key
-> B64UUID ClientSide -> B64UUID ClientSide
@ -332,10 +344,10 @@ clientPut
-> S.SourceT IO B.ByteString -> S.SourceT IO B.ByteString
-> ClientM PutResultPlus -> ClientM PutResultPlus
clientPut (P2P.ProtocolVersion ver) sz k cu su bypass af o l src = case ver of clientPut (P2P.ProtocolVersion ver) sz k cu su bypass af o l src = case ver of
3 -> v3 sz k cu su bypass af o l src 3 -> v3 V3 sz k cu su bypass af o l src
2 -> v2 sz k cu su bypass af o l src 2 -> v2 V2 sz k cu su bypass af o l src
1 -> plus <$> v1 sz k cu su bypass af o l src 1 -> plus <$> v1 V1 sz k cu su bypass af o l src
0 -> plus <$> v0 k cu su bypass af o l src 0 -> plus <$> v0 V0 k cu su bypass af o l src
_ -> error "unsupported protocol version" _ -> error "unsupported protocol version"
where where
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
@ -353,8 +365,10 @@ type PutOffsetAPI result
:> Post '[JSON] result :> Post '[JSON] result
servePutOffset servePutOffset
:: P2PHttpServerState :: APIVersion v
=> P2PHttpServerState
-> (PutOffsetResultPlus -> t) -> (PutOffsetResultPlus -> t)
-> v
-> B64Key -> B64Key
-> B64UUID ClientSide -> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
@ -370,8 +384,8 @@ clientPutOffset
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> ClientM PutOffsetResultPlus -> ClientM PutOffsetResultPlus
clientPutOffset (P2P.ProtocolVersion ver) = case ver of clientPutOffset (P2P.ProtocolVersion ver) = case ver of
3 -> v3 3 -> v3 V3
2 -> v2 2 -> v2 V2
_ -> error "unsupported protocol version" _ -> error "unsupported protocol version"
where where
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
@ -390,7 +404,9 @@ type LockContentAPI
:> Post '[JSON] LockResult :> Post '[JSON] LockResult
serveLockContent serveLockContent
:: P2PHttpServerState :: APIVersion v
=> P2PHttpServerState
-> v
-> B64Key -> B64Key
-> B64UUID ClientSide -> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
@ -406,10 +422,10 @@ clientLockContent
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> ClientM LockResult -> ClientM LockResult
clientLockContent (P2P.ProtocolVersion ver) = case ver of clientLockContent (P2P.ProtocolVersion ver) = case ver of
3 -> v3 3 -> v3 V3
2 -> v2 2 -> v2 V2
1 -> v1 1 -> v1 V1
0 -> v0 0 -> v0 V0
_ -> error "unsupported protocol version" _ -> error "unsupported protocol version"
where where
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
@ -432,7 +448,9 @@ type KeepLockedAPI
:> Post '[JSON] LockResult :> Post '[JSON] LockResult
serveKeepLocked serveKeepLocked
:: P2PHttpServerState :: APIVersion v
=> P2PHttpServerState
-> v
-> LockID -> LockID
-> B64UUID ClientSide -> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
@ -441,7 +459,7 @@ serveKeepLocked
-> Maybe KeepAlive -> Maybe KeepAlive
-> S.SourceT IO UnlockRequest -> S.SourceT IO UnlockRequest
-> Handler LockResult -> Handler LockResult
serveKeepLocked st lckid cu su _ _ _ unlockrequeststream = do serveKeepLocked st apiver lckid cu su _ _ _ unlockrequeststream = do
_ <- liftIO $ S.unSourceT unlockrequeststream go _ <- liftIO $ S.unSourceT unlockrequeststream go
return (LockResult False Nothing) return (LockResult False Nothing)
where where
@ -463,10 +481,10 @@ clientKeepLocked
-> S.SourceT IO UnlockRequest -> S.SourceT IO UnlockRequest
-> ClientM LockResult -> ClientM LockResult
clientKeepLocked (P2P.ProtocolVersion ver) = case ver of clientKeepLocked (P2P.ProtocolVersion ver) = case ver of
3 -> v3 3 -> v3 V3
2 -> v2 2 -> v2 V2
1 -> v1 1 -> v1 V1
0 -> v0 0 -> v0 V0
_ -> error "unsupported protocol version" _ -> error "unsupported protocol version"
where where
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
@ -524,6 +542,14 @@ testClientLock = do
[] []
keeplocked keeplocked
type PV3 = Capture "v3" V3
type PV2 = Capture "v2" V2
type PV1 = Capture "v1" V1
type PV0 = Capture "v0" V0
type ClientUUID req = QueryParam' '[req] "clientuuid" (B64UUID ClientSide) type ClientUUID req = QueryParam' '[req] "clientuuid" (B64UUID ClientSide)
type ServerUUID req = QueryParam' '[req] "serveruuid" (B64UUID ServerSide) type ServerUUID req = QueryParam' '[req] "serveruuid" (B64UUID ServerSide)

32
P2P/Http/Types.hs
View file

@ -24,7 +24,20 @@ import qualified Data.Text.Encoding as TE
import Text.Read (readMaybe) import Text.Read (readMaybe)
import Data.Aeson hiding (Key) import Data.Aeson hiding (Key)
import Control.DeepSeq import Control.DeepSeq
import GHC.Generics import GHC.Generics (Generic)
data V3 = V3 deriving (Show)
data V2 = V2 deriving (Show)
data V1 = V1 deriving (Show)
data V0 = V0 deriving (Show)
class APIVersion v where
protocolVersion :: v -> P2P.ProtocolVersion
instance APIVersion V3 where protocolVersion _ = P2P.ProtocolVersion 3
instance APIVersion V2 where protocolVersion _ = P2P.ProtocolVersion 2
instance APIVersion V1 where protocolVersion _ = P2P.ProtocolVersion 1
instance APIVersion V0 where protocolVersion _ = P2P.ProtocolVersion 0
-- Keys, UUIDs, and filenames are base64 encoded since Servant uses -- Keys, UUIDs, and filenames are base64 encoded since Servant uses
-- Text and so needs UTF-8. -- Text and so needs UTF-8.
@ -34,7 +47,7 @@ newtype B64Key = B64Key Key
newtype B64FilePath = B64FilePath RawFilePath newtype B64FilePath = B64FilePath RawFilePath
deriving (Show) deriving (Show)
newtype B64UUID t = B64UUID UUID newtype B64UUID t = B64UUID { fromB64UUID :: UUID }
deriving (Show, Ord, Eq, Generic, NFData) deriving (Show, Ord, Eq, Generic, NFData)
-- Phantom types for B64UIID -- Phantom types for B64UIID
@ -107,6 +120,21 @@ instance ToHttpApiData KeepAlive where
instance FromHttpApiData KeepAlive where instance FromHttpApiData KeepAlive where
parseUrlPiece = Right . KeepAlive parseUrlPiece = Right . KeepAlive
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 V3 where parseUrlPiece = parseAPIVersion V3 "v3"
instance FromHttpApiData V2 where parseUrlPiece = parseAPIVersion V2 "v2"
instance FromHttpApiData V1 where parseUrlPiece = parseAPIVersion V1 "v1"
instance FromHttpApiData V0 where parseUrlPiece = parseAPIVersion V0 "v0"
parseAPIVersion :: v -> T.Text -> T.Text -> Either T.Text v
parseAPIVersion v need t
| t == need = Right v
| otherwise = Left "bad version"
instance ToHttpApiData B64Key where instance ToHttpApiData B64Key where
toUrlPiece (B64Key k) = TE.decodeUtf8Lenient $ toUrlPiece (B64Key k) = TE.decodeUtf8Lenient $
toB64 (serializeKey' k) toB64 (serializeKey' k)

4
doc/design/p2p_protocol_over_http/draft1.mdwn
View file

@ -38,8 +38,8 @@ to P2P protocol versions.
The protocol version comes before the request. Eg: `/git-annex/v3/put` The protocol version comes before the request. Eg: `/git-annex/v3/put`
If the server does not support a particular protocol version, the If the server does not support a particular protocol version, the
request will fail with a 404, and the client should fall back to an earlier request will fail with a 400 Bad Request, and the client should fall
protocol version. back to an earlier protocol version.
## common request parameters ## common request parameters