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:
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 Utility.MonotonicClock
|
||||||
|
|
||||||
import Servant
|
import Servant
|
||||||
|
import Servant.Client.Streaming
|
||||||
import qualified Servant.Types.SourceT as S
|
import qualified Servant.Types.SourceT as S
|
||||||
import Servant.API.WebSocket
|
import Servant.API.WebSocket
|
||||||
import qualified Network.WebSockets as Websocket
|
import qualified Network.WebSockets as Websocket
|
||||||
|
@ -32,8 +33,7 @@ import Text.Read
|
||||||
import Data.Aeson hiding (Key)
|
import Data.Aeson hiding (Key)
|
||||||
|
|
||||||
type P2PHttpAPI
|
type P2PHttpAPI
|
||||||
= "git-annex" :> "key" :> CaptureKey :> GetAPI '[]
|
= "git-annex" :> "v3" :> "key" :> CaptureKey
|
||||||
:<|> "git-annex" :> "v3" :> "key" :> CaptureKey
|
|
||||||
:> GetAPI '[DataLengthHeader]
|
:> GetAPI '[DataLengthHeader]
|
||||||
:<|> "git-annex" :> "v2" :> "key" :> CaptureKey
|
:<|> "git-annex" :> "v2" :> "key" :> CaptureKey
|
||||||
:> GetAPI '[DataLengthHeader]
|
:> GetAPI '[DataLengthHeader]
|
||||||
|
@ -45,10 +45,11 @@ type P2PHttpAPI
|
||||||
:<|> "git-annex" :> "v2" :> "checkpresent" :> CheckPresentAPI
|
:<|> "git-annex" :> "v2" :> "checkpresent" :> CheckPresentAPI
|
||||||
:<|> "git-annex" :> "v1" :> "checkpresent" :> CheckPresentAPI
|
:<|> "git-annex" :> "v1" :> "checkpresent" :> CheckPresentAPI
|
||||||
:<|> "git-annex" :> "v0" :> "checkpresent" :> CheckPresentAPI
|
:<|> "git-annex" :> "v0" :> "checkpresent" :> CheckPresentAPI
|
||||||
:<|> "git-annex" :> "v3" :> "lockcontent" :> LockContentAPI
|
-- XXX disabled until I can implement HasClient ClientM WebSocket
|
||||||
:<|> "git-annex" :> "v2" :> "lockcontent" :> LockContentAPI
|
-- :<|> "git-annex" :> "v3" :> "lockcontent" :> LockContentAPI
|
||||||
:<|> "git-annex" :> "v1" :> "lockcontent" :> LockContentAPI
|
-- :<|> "git-annex" :> "v2" :> "lockcontent" :> LockContentAPI
|
||||||
:<|> "git-annex" :> "v0" :> "lockcontent" :> LockContentAPI
|
-- :<|> "git-annex" :> "v1" :> "lockcontent" :> LockContentAPI
|
||||||
|
-- :<|> "git-annex" :> "v0" :> "lockcontent" :> LockContentAPI
|
||||||
:<|> "git-annex" :> "v3" :> "remove" :> RemoveAPI RemoveResultPlus
|
:<|> "git-annex" :> "v3" :> "remove" :> RemoveAPI RemoveResultPlus
|
||||||
:<|> "git-annex" :> "v2" :> "remove" :> RemoveAPI RemoveResultPlus
|
:<|> "git-annex" :> "v2" :> "remove" :> RemoveAPI RemoveResultPlus
|
||||||
:<|> "git-annex" :> "v1" :> "remove" :> RemoveAPI RemoveResult
|
:<|> "git-annex" :> "v1" :> "remove" :> RemoveAPI RemoveResult
|
||||||
|
@ -69,6 +70,7 @@ type P2PHttpAPI
|
||||||
:> PutOffsetAPI PutOffsetResultPlus
|
:> PutOffsetAPI PutOffsetResultPlus
|
||||||
:<|> "git-annex" :> "v1" :> "putoffset"
|
:<|> "git-annex" :> "v1" :> "putoffset"
|
||||||
:> PutOffsetAPI PutOffsetResult
|
:> PutOffsetAPI PutOffsetResult
|
||||||
|
:<|> "git-annex" :> "key" :> CaptureKey :> GetAPI '[]
|
||||||
|
|
||||||
p2pHttpAPI :: Proxy P2PHttpAPI
|
p2pHttpAPI :: Proxy P2PHttpAPI
|
||||||
p2pHttpAPI = Proxy
|
p2pHttpAPI = Proxy
|
||||||
|
@ -78,8 +80,7 @@ p2pHttp = serve p2pHttpAPI serveP2pHttp
|
||||||
|
|
||||||
serveP2pHttp :: Server P2PHttpAPI
|
serveP2pHttp :: Server P2PHttpAPI
|
||||||
serveP2pHttp
|
serveP2pHttp
|
||||||
= serveGet0
|
= serveGet
|
||||||
:<|> serveGet
|
|
||||||
:<|> serveGet
|
:<|> serveGet
|
||||||
:<|> serveGet
|
:<|> serveGet
|
||||||
:<|> serveGet0
|
:<|> serveGet0
|
||||||
|
@ -87,10 +88,10 @@ serveP2pHttp
|
||||||
:<|> serveCheckPresent
|
:<|> serveCheckPresent
|
||||||
:<|> serveCheckPresent
|
:<|> serveCheckPresent
|
||||||
:<|> serveCheckPresent
|
:<|> serveCheckPresent
|
||||||
:<|> serveLockContent
|
-- :<|> serveLockContent
|
||||||
:<|> serveLockContent
|
-- :<|> serveLockContent
|
||||||
:<|> serveLockContent
|
-- :<|> serveLockContent
|
||||||
:<|> serveLockContent
|
-- :<|> serveLockContent
|
||||||
:<|> serveRemove id
|
:<|> serveRemove id
|
||||||
:<|> serveRemove id
|
:<|> serveRemove id
|
||||||
:<|> serveRemove dePlus
|
:<|> serveRemove dePlus
|
||||||
|
@ -100,10 +101,11 @@ serveP2pHttp
|
||||||
:<|> servePut id
|
:<|> servePut id
|
||||||
:<|> servePut id
|
:<|> servePut id
|
||||||
:<|> servePut dePlus
|
:<|> servePut dePlus
|
||||||
:<|> servePut0
|
:<|> servePut dePlus Nothing
|
||||||
:<|> servePutOffset id
|
:<|> servePutOffset id
|
||||||
:<|> servePutOffset id
|
:<|> servePutOffset id
|
||||||
:<|> servePutOffset dePlus
|
:<|> servePutOffset dePlus
|
||||||
|
:<|> serveGet0
|
||||||
|
|
||||||
type GetAPI headers
|
type GetAPI headers
|
||||||
= ClientUUID Optional
|
= ClientUUID Optional
|
||||||
|
@ -134,6 +136,24 @@ serveGet0
|
||||||
-> Handler (Headers '[] (S.SourceT IO B.ByteString))
|
-> Handler (Headers '[] (S.SourceT IO B.ByteString))
|
||||||
serveGet0 = undefined
|
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
|
type CheckPresentAPI
|
||||||
= KeyParam
|
= KeyParam
|
||||||
:> ClientUUID Required
|
:> ClientUUID Required
|
||||||
|
@ -149,6 +169,23 @@ serveCheckPresent
|
||||||
-> Handler CheckPresentResult
|
-> Handler CheckPresentResult
|
||||||
serveCheckPresent = undefined
|
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
|
type LockContentAPI
|
||||||
= KeyParam
|
= KeyParam
|
||||||
:> ClientUUID Required
|
:> ClientUUID Required
|
||||||
|
@ -165,6 +202,9 @@ serveLockContent
|
||||||
-> Handler ()
|
-> Handler ()
|
||||||
serveLockContent = undefined
|
serveLockContent = undefined
|
||||||
|
|
||||||
|
-- TODO
|
||||||
|
--clientLockContent
|
||||||
|
|
||||||
type RemoveAPI result
|
type RemoveAPI result
|
||||||
= KeyParam
|
= KeyParam
|
||||||
:> ClientUUID Required
|
:> ClientUUID Required
|
||||||
|
@ -180,6 +220,24 @@ serveRemove
|
||||||
-> [B64UUID Bypass]
|
-> [B64UUID Bypass]
|
||||||
-> Handler t
|
-> Handler t
|
||||||
serveRemove = undefined
|
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
|
type RemoveBeforeAPI
|
||||||
= KeyParam
|
= KeyParam
|
||||||
|
@ -198,6 +256,24 @@ serveRemoveBefore
|
||||||
-> Handler RemoveResult
|
-> Handler RemoveResult
|
||||||
serveRemoveBefore = undefined
|
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
|
type GetTimestampAPI
|
||||||
= ClientUUID Required
|
= ClientUUID Required
|
||||||
:> ServerUUID Required
|
:> ServerUUID Required
|
||||||
|
@ -211,6 +287,22 @@ serveGetTimestamp
|
||||||
-> Handler GetTimestampResult
|
-> Handler GetTimestampResult
|
||||||
serveGetTimestamp = undefined
|
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
|
type PutAPI result
|
||||||
= KeyParam
|
= KeyParam
|
||||||
:> ClientUUID Required
|
:> ClientUUID Required
|
||||||
|
@ -236,8 +328,10 @@ servePut
|
||||||
-> Handler t
|
-> Handler t
|
||||||
servePut = undefined
|
servePut = undefined
|
||||||
|
|
||||||
servePut0
|
clientPut
|
||||||
:: B64Key
|
:: P2P.ProtocolVersion
|
||||||
|
-> Maybe Integer
|
||||||
|
-> B64Key
|
||||||
-> B64UUID ClientSide
|
-> B64UUID ClientSide
|
||||||
-> B64UUID ServerSide
|
-> B64UUID ServerSide
|
||||||
-> [B64UUID Bypass]
|
-> [B64UUID Bypass]
|
||||||
|
@ -245,8 +339,20 @@ servePut0
|
||||||
-> Maybe Offset
|
-> Maybe Offset
|
||||||
-> DataLength
|
-> DataLength
|
||||||
-> S.SourceT IO B.ByteString
|
-> S.SourceT IO B.ByteString
|
||||||
-> Handler PutResult
|
-> ClientM PutResultPlus
|
||||||
servePut0 = undefined
|
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
|
type PutOffsetAPI result
|
||||||
= KeyParam
|
= KeyParam
|
||||||
|
@ -264,6 +370,27 @@ servePutOffset
|
||||||
-> Handler t
|
-> Handler t
|
||||||
servePutOffset = undefined
|
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)
|
type ClientUUID req = QueryParam' '[req] "clientuuid" (B64UUID ClientSide)
|
||||||
|
|
||||||
data ClientSide
|
data ClientSide
|
||||||
|
@ -315,17 +442,25 @@ newtype Offset = Offset P2P.Offset
|
||||||
|
|
||||||
newtype Timestamp = Timestamp MonotonicTimestamp
|
newtype Timestamp = Timestamp MonotonicTimestamp
|
||||||
|
|
||||||
class DePlus plus unplus where
|
class Plus plus unplus where
|
||||||
dePlus :: plus -> unplus
|
dePlus :: plus -> unplus
|
||||||
|
plus :: unplus -> plus
|
||||||
|
|
||||||
instance DePlus RemoveResultPlus RemoveResult where
|
instance Plus RemoveResultPlus RemoveResult where
|
||||||
dePlus (RemoveResultPlus b _) = RemoveResult b
|
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
|
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
|
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
|
instance FromHttpApiData B64Key where
|
||||||
parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
|
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)
|
Just b -> maybe (Left "key parse error") (Right . B64Key)
|
||||||
(deserializeKey' b)
|
(deserializeKey' b)
|
||||||
|
|
||||||
|
instance ToHttpApiData (B64UUID t) where
|
||||||
|
toUrlPiece (B64UUID u) = TE.decodeUtf8Lenient $
|
||||||
|
toB64 (fromUUID u)
|
||||||
|
|
||||||
instance FromHttpApiData (B64UUID t) where
|
instance FromHttpApiData (B64UUID t) where
|
||||||
parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
|
parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
|
||||||
Nothing -> Left "unable to base64 decode UUID"
|
Nothing -> Left "unable to base64 decode UUID"
|
||||||
|
@ -340,21 +479,33 @@ instance FromHttpApiData (B64UUID t) where
|
||||||
u@(UUID _) -> Right (B64UUID u)
|
u@(UUID _) -> Right (B64UUID u)
|
||||||
NoUUID -> Left "empty UUID"
|
NoUUID -> Left "empty UUID"
|
||||||
|
|
||||||
|
instance ToHttpApiData B64FilePath where
|
||||||
|
toUrlPiece (B64FilePath f) = TE.decodeUtf8Lenient $ toB64 f
|
||||||
|
|
||||||
instance FromHttpApiData B64FilePath where
|
instance FromHttpApiData B64FilePath where
|
||||||
parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
|
parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
|
||||||
Nothing -> Left "unable to base64 decode filename"
|
Nothing -> Left "unable to base64 decode filename"
|
||||||
Just b -> Right (B64FilePath b)
|
Just b -> Right (B64FilePath b)
|
||||||
|
|
||||||
|
instance ToHttpApiData Offset where
|
||||||
|
toUrlPiece (Offset (P2P.Offset n)) = T.pack (show n)
|
||||||
|
|
||||||
instance FromHttpApiData Offset where
|
instance FromHttpApiData Offset where
|
||||||
parseUrlPiece t = case readMaybe (T.unpack t) of
|
parseUrlPiece t = case readMaybe (T.unpack t) of
|
||||||
Nothing -> Left "offset parse error"
|
Nothing -> Left "offset parse error"
|
||||||
Just n -> Right (Offset (P2P.Offset n))
|
Just n -> Right (Offset (P2P.Offset n))
|
||||||
|
|
||||||
|
instance ToHttpApiData Timestamp where
|
||||||
|
toUrlPiece (Timestamp (MonotonicTimestamp n)) = T.pack (show n)
|
||||||
|
|
||||||
instance FromHttpApiData Timestamp where
|
instance FromHttpApiData Timestamp where
|
||||||
parseUrlPiece t = case readMaybe (T.unpack t) of
|
parseUrlPiece t = case readMaybe (T.unpack t) of
|
||||||
Nothing -> Left "timestamp parse error"
|
Nothing -> Left "timestamp parse error"
|
||||||
Just n -> Right (Timestamp (MonotonicTimestamp n))
|
Just n -> Right (Timestamp (MonotonicTimestamp n))
|
||||||
|
|
||||||
|
instance ToHttpApiData DataLength where
|
||||||
|
toUrlPiece (DataLength n) = T.pack (show n)
|
||||||
|
|
||||||
instance FromHttpApiData DataLength where
|
instance FromHttpApiData DataLength where
|
||||||
parseUrlPiece t = case readMaybe (T.unpack t) of
|
parseUrlPiece t = case readMaybe (T.unpack t) of
|
||||||
Nothing -> Left "X-git-annex-data-length parse error"
|
Nothing -> Left "X-git-annex-data-length parse error"
|
||||||
|
|
Loading…
Reference in a new issue