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.
This commit is contained in:
Joey Hess
parent
d782b136e0
commit
20df236a13
4 changed files with 79 additions and 45 deletions
13
P2P/Http.hs
13
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue