servant client mostly implemented
lockcontent had to be disabled until I can implement HasClient ClientM WebSocket and in clientGet, it's not clear how to use the v1 and v0 versions, which don't have a DataLengthHeader
This commit is contained in:
Joey Hess
parent
9a726cedf6
commit
bfa8c39adb
1 changed files with 172 additions and 21 deletions
193
P2P/Http.hs
193
P2P/Http.hs
|
|
@ -20,6 +20,7 @@ import Utility.Base64
|
|||
import Utility.MonotonicClock
|
||||
|
||||
import Servant
|
||||
import Servant.Client.Streaming
|
||||
import qualified Servant.Types.SourceT as S
|
||||
import Servant.API.WebSocket
|
||||
import qualified Network.WebSockets as Websocket
|
||||
|
|
@ -32,8 +33,7 @@ import Text.Read
|
|||
import Data.Aeson hiding (Key)
|
||||
|
||||
type P2PHttpAPI
|
||||
= "git-annex" :> "key" :> CaptureKey :> GetAPI '[]
|
||||
:<|> "git-annex" :> "v3" :> "key" :> CaptureKey
|
||||
= "git-annex" :> "v3" :> "key" :> CaptureKey
|
||||
:> GetAPI '[DataLengthHeader]
|
||||
:<|> "git-annex" :> "v2" :> "key" :> CaptureKey
|
||||
:> GetAPI '[DataLengthHeader]
|
||||
|
|
@ -45,10 +45,11 @@ type P2PHttpAPI
|
|||
:<|> "git-annex" :> "v2" :> "checkpresent" :> CheckPresentAPI
|
||||
:<|> "git-annex" :> "v1" :> "checkpresent" :> CheckPresentAPI
|
||||
:<|> "git-annex" :> "v0" :> "checkpresent" :> CheckPresentAPI
|
||||
:<|> "git-annex" :> "v3" :> "lockcontent" :> LockContentAPI
|
||||
:<|> "git-annex" :> "v2" :> "lockcontent" :> LockContentAPI
|
||||
:<|> "git-annex" :> "v1" :> "lockcontent" :> LockContentAPI
|
||||
:<|> "git-annex" :> "v0" :> "lockcontent" :> LockContentAPI
|
||||
-- XXX disabled until I can implement HasClient ClientM WebSocket
|
||||
-- :<|> "git-annex" :> "v3" :> "lockcontent" :> LockContentAPI
|
||||
-- :<|> "git-annex" :> "v2" :> "lockcontent" :> LockContentAPI
|
||||
-- :<|> "git-annex" :> "v1" :> "lockcontent" :> LockContentAPI
|
||||
-- :<|> "git-annex" :> "v0" :> "lockcontent" :> LockContentAPI
|
||||
:<|> "git-annex" :> "v3" :> "remove" :> RemoveAPI RemoveResultPlus
|
||||
:<|> "git-annex" :> "v2" :> "remove" :> RemoveAPI RemoveResultPlus
|
||||
:<|> "git-annex" :> "v1" :> "remove" :> RemoveAPI RemoveResult
|
||||
|
|
@ -69,6 +70,7 @@ type P2PHttpAPI
|
|||
:> PutOffsetAPI PutOffsetResultPlus
|
||||
:<|> "git-annex" :> "v1" :> "putoffset"
|
||||
:> PutOffsetAPI PutOffsetResult
|
||||
:<|> "git-annex" :> "key" :> CaptureKey :> GetAPI '[]
|
||||
|
||||
p2pHttpAPI :: Proxy P2PHttpAPI
|
||||
p2pHttpAPI = Proxy
|
||||
|
|
@ -78,8 +80,7 @@ p2pHttp = serve p2pHttpAPI serveP2pHttp
|
|||
|
||||
serveP2pHttp :: Server P2PHttpAPI
|
||||
serveP2pHttp
|
||||
= serveGet0
|
||||
:<|> serveGet
|
||||
= serveGet
|
||||
:<|> serveGet
|
||||
:<|> serveGet
|
||||
:<|> serveGet0
|
||||
|
|
@ -87,10 +88,10 @@ serveP2pHttp
|
|||
:<|> serveCheckPresent
|
||||
:<|> serveCheckPresent
|
||||
:<|> serveCheckPresent
|
||||
:<|> serveLockContent
|
||||
:<|> serveLockContent
|
||||
:<|> serveLockContent
|
||||
:<|> serveLockContent
|
||||
-- :<|> serveLockContent
|
||||
-- :<|> serveLockContent
|
||||
-- :<|> serveLockContent
|
||||
-- :<|> serveLockContent
|
||||
:<|> serveRemove id
|
||||
:<|> serveRemove id
|
||||
:<|> serveRemove dePlus
|
||||
|
|
@ -100,10 +101,11 @@ serveP2pHttp
|
|||
:<|> servePut id
|
||||
:<|> servePut id
|
||||
:<|> servePut dePlus
|
||||
:<|> servePut0
|
||||
:<|> servePut dePlus Nothing
|
||||
:<|> servePutOffset id
|
||||
:<|> servePutOffset id
|
||||
:<|> servePutOffset dePlus
|
||||
:<|> serveGet0
|
||||
|
||||
type GetAPI headers
|
||||
= ClientUUID Optional
|
||||
|
|
@ -134,6 +136,24 @@ serveGet0
|
|||
-> Handler (Headers '[] (S.SourceT IO B.ByteString))
|
||||
serveGet0 = undefined
|
||||
|
||||
clientGet
|
||||
:: P2P.ProtocolVersion
|
||||
-> B64Key
|
||||
-> Maybe (B64UUID ClientSide)
|
||||
-> Maybe (B64UUID ServerSide)
|
||||
-> [B64UUID Bypass]
|
||||
-> Maybe B64FilePath
|
||||
-> Maybe Offset
|
||||
-> ClientM (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString))
|
||||
clientGet (P2P.ProtocolVersion ver) k cu su bypass af o = case ver of
|
||||
3 -> v3 k cu su bypass af o
|
||||
2 -> v2 k cu su bypass af o
|
||||
1 -> error "XXX" -- TODO v1
|
||||
0 -> error "XXX" -- TODO v0
|
||||
_ -> error "unsupported protocol version"
|
||||
where
|
||||
_ :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
||||
|
||||
type CheckPresentAPI
|
||||
= KeyParam
|
||||
:> ClientUUID Required
|
||||
|
|
@ -149,6 +169,23 @@ serveCheckPresent
|
|||
-> Handler CheckPresentResult
|
||||
serveCheckPresent = undefined
|
||||
|
||||
clientCheckPresent
|
||||
:: P2P.ProtocolVersion
|
||||
-> B64Key
|
||||
-> B64UUID ClientSide
|
||||
-> B64UUID ServerSide
|
||||
-> [B64UUID Bypass]
|
||||
-> ClientM CheckPresentResult
|
||||
clientCheckPresent (P2P.ProtocolVersion ver) = case ver of
|
||||
3 -> v3
|
||||
2 -> v2
|
||||
1 -> v1
|
||||
0 -> v0
|
||||
_ -> error "unsupported protocol version"
|
||||
where
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
||||
|
||||
type LockContentAPI
|
||||
= KeyParam
|
||||
:> ClientUUID Required
|
||||
|
|
@ -165,6 +202,9 @@ serveLockContent
|
|||
-> Handler ()
|
||||
serveLockContent = undefined
|
||||
|
||||
-- TODO
|
||||
--clientLockContent
|
||||
|
||||
type RemoveAPI result
|
||||
= KeyParam
|
||||
:> ClientUUID Required
|
||||
|
|
@ -181,6 +221,24 @@ serveRemove
|
|||
-> Handler t
|
||||
serveRemove = undefined
|
||||
|
||||
clientRemove
|
||||
:: P2P.ProtocolVersion
|
||||
-> B64Key
|
||||
-> B64UUID ClientSide
|
||||
-> B64UUID ServerSide
|
||||
-> [B64UUID Bypass]
|
||||
-> ClientM RemoveResultPlus
|
||||
clientRemove (P2P.ProtocolVersion ver) k cu su bypass = case ver of
|
||||
3 -> v3 k cu su bypass
|
||||
2 -> v2 k cu su bypass
|
||||
1 -> plus <$> v1 k cu su bypass
|
||||
0 -> plus <$> v0 k cu su bypass
|
||||
_ -> error "unsupported protocol version"
|
||||
where
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
||||
|
||||
type RemoveBeforeAPI
|
||||
= KeyParam
|
||||
:> ClientUUID Required
|
||||
|
|
@ -198,6 +256,24 @@ serveRemoveBefore
|
|||
-> Handler RemoveResult
|
||||
serveRemoveBefore = undefined
|
||||
|
||||
clientRemoveBefore
|
||||
:: P2P.ProtocolVersion
|
||||
-> B64Key
|
||||
-> B64UUID ClientSide
|
||||
-> B64UUID ServerSide
|
||||
-> [B64UUID Bypass]
|
||||
-> Timestamp
|
||||
-> ClientM RemoveResult
|
||||
clientRemoveBefore (P2P.ProtocolVersion ver) = case ver of
|
||||
3 -> v3
|
||||
_ -> error "unsupported protocol version"
|
||||
where
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
v3 :<|> _ = client p2pHttpAPI
|
||||
|
||||
|
||||
type GetTimestampAPI
|
||||
= ClientUUID Required
|
||||
:> ServerUUID Required
|
||||
|
|
@ -211,6 +287,22 @@ serveGetTimestamp
|
|||
-> Handler GetTimestampResult
|
||||
serveGetTimestamp = undefined
|
||||
|
||||
clientGetTimestamp
|
||||
:: P2P.ProtocolVersion
|
||||
-> B64UUID ClientSide
|
||||
-> B64UUID ServerSide
|
||||
-> [B64UUID Bypass]
|
||||
-> ClientM GetTimestampResult
|
||||
clientGetTimestamp (P2P.ProtocolVersion ver) = case ver of
|
||||
3 -> v3
|
||||
_ -> error "unsupported protocol version"
|
||||
where
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|>
|
||||
v3 :<|> _ = client p2pHttpAPI
|
||||
|
||||
type PutAPI result
|
||||
= KeyParam
|
||||
:> ClientUUID Required
|
||||
|
|
@ -236,8 +328,10 @@ servePut
|
|||
-> Handler t
|
||||
servePut = undefined
|
||||
|
||||
servePut0
|
||||
:: B64Key
|
||||
clientPut
|
||||
:: P2P.ProtocolVersion
|
||||
-> Maybe Integer
|
||||
-> B64Key
|
||||
-> B64UUID ClientSide
|
||||
-> B64UUID ServerSide
|
||||
-> [B64UUID Bypass]
|
||||
|
|
@ -245,8 +339,20 @@ servePut0
|
|||
-> Maybe Offset
|
||||
-> DataLength
|
||||
-> S.SourceT IO B.ByteString
|
||||
-> Handler PutResult
|
||||
servePut0 = undefined
|
||||
-> ClientM PutResultPlus
|
||||
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
|
||||
2 -> v2 sz k cu su bypass af o l src
|
||||
1 -> plus <$> v1 sz k cu su bypass af o l src
|
||||
0 -> plus <$> v0 k cu su bypass af o l src
|
||||
_ -> error "unsupported protocol version"
|
||||
where
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|>
|
||||
_ :<|>
|
||||
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
||||
|
||||
type PutOffsetAPI result
|
||||
= KeyParam
|
||||
|
|
@ -264,6 +370,27 @@ servePutOffset
|
|||
-> Handler t
|
||||
servePutOffset = undefined
|
||||
|
||||
clientPutOffset
|
||||
:: P2P.ProtocolVersion
|
||||
-> B64Key
|
||||
-> B64UUID ClientSide
|
||||
-> B64UUID ServerSide
|
||||
-> [B64UUID Bypass]
|
||||
-> ClientM PutOffsetResultPlus
|
||||
clientPutOffset (P2P.ProtocolVersion ver) = case ver of
|
||||
3 -> v3
|
||||
2 -> v2
|
||||
_ -> error "unsupported protocol version"
|
||||
where
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
_ :<|>
|
||||
_ :<|>
|
||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||
v3 :<|> v2 :<|> _ = client p2pHttpAPI
|
||||
|
||||
|
||||
type ClientUUID req = QueryParam' '[req] "clientuuid" (B64UUID ClientSide)
|
||||
|
||||
data ClientSide
|
||||
|
|
@ -315,17 +442,25 @@ newtype Offset = Offset P2P.Offset
|
|||
|
||||
newtype Timestamp = Timestamp MonotonicTimestamp
|
||||
|
||||
class DePlus plus unplus where
|
||||
class Plus plus unplus where
|
||||
dePlus :: plus -> unplus
|
||||
plus :: unplus -> plus
|
||||
|
||||
instance DePlus RemoveResultPlus RemoveResult where
|
||||
instance Plus RemoveResultPlus RemoveResult where
|
||||
dePlus (RemoveResultPlus b _) = RemoveResult b
|
||||
plus (RemoveResult b) = RemoveResultPlus b mempty
|
||||
|
||||
instance DePlus PutResultPlus PutResult where
|
||||
instance Plus PutResultPlus PutResult where
|
||||
dePlus (PutResultPlus b _) = PutResult b
|
||||
plus (PutResult b) = PutResultPlus b mempty
|
||||
|
||||
instance DePlus PutOffsetResultPlus PutOffsetResult where
|
||||
instance Plus PutOffsetResultPlus PutOffsetResult where
|
||||
dePlus (PutOffsetResultPlus o _) = PutOffsetResult o
|
||||
plus (PutOffsetResult o) = PutOffsetResultPlus o mempty
|
||||
|
||||
instance ToHttpApiData B64Key where
|
||||
toUrlPiece (B64Key k) = TE.decodeUtf8Lenient $
|
||||
toB64 (serializeKey' k)
|
||||
|
||||
instance FromHttpApiData B64Key where
|
||||
parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
|
||||
|
|
@ -333,6 +468,10 @@ instance FromHttpApiData B64Key where
|
|||
Just b -> maybe (Left "key parse error") (Right . B64Key)
|
||||
(deserializeKey' b)
|
||||
|
||||
instance ToHttpApiData (B64UUID t) where
|
||||
toUrlPiece (B64UUID u) = TE.decodeUtf8Lenient $
|
||||
toB64 (fromUUID u)
|
||||
|
||||
instance FromHttpApiData (B64UUID t) where
|
||||
parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
|
||||
Nothing -> Left "unable to base64 decode UUID"
|
||||
|
|
@ -340,21 +479,33 @@ instance FromHttpApiData (B64UUID t) where
|
|||
u@(UUID _) -> Right (B64UUID u)
|
||||
NoUUID -> Left "empty UUID"
|
||||
|
||||
instance ToHttpApiData B64FilePath where
|
||||
toUrlPiece (B64FilePath f) = TE.decodeUtf8Lenient $ toB64 f
|
||||
|
||||
instance FromHttpApiData B64FilePath where
|
||||
parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
|
||||
Nothing -> Left "unable to base64 decode filename"
|
||||
Just b -> Right (B64FilePath b)
|
||||
|
||||
instance ToHttpApiData Offset where
|
||||
toUrlPiece (Offset (P2P.Offset n)) = T.pack (show n)
|
||||
|
||||
instance FromHttpApiData Offset where
|
||||
parseUrlPiece t = case readMaybe (T.unpack t) of
|
||||
Nothing -> Left "offset parse error"
|
||||
Just n -> Right (Offset (P2P.Offset n))
|
||||
|
||||
instance ToHttpApiData Timestamp where
|
||||
toUrlPiece (Timestamp (MonotonicTimestamp n)) = T.pack (show n)
|
||||
|
||||
instance FromHttpApiData Timestamp where
|
||||
parseUrlPiece t = case readMaybe (T.unpack t) of
|
||||
Nothing -> Left "timestamp parse error"
|
||||
Just n -> Right (Timestamp (MonotonicTimestamp n))
|
||||
|
||||
instance ToHttpApiData DataLength where
|
||||
toUrlPiece (DataLength n) = T.pack (show n)
|
||||
|
||||
instance FromHttpApiData DataLength where
|
||||
parseUrlPiece t = case readMaybe (T.unpack t) of
|
||||
Nothing -> Left "X-git-annex-data-length parse error"
|
||||
|
|
|
|||
Loading…
Reference in a new issue