3b37b9e53f
This came down to SendBytes waiting on the waitv. Nothing ever filled it. Only Annex.Proxy needs the waitv, and it handles filling it. So make it optional.
744 lines
19 KiB
Haskell
744 lines
19 KiB
Haskell
{- P2P protocol over HTTP
|
|
-
|
|
- https://git-annex.branchable.com/design/p2p_protocol_over_http/
|
|
-
|
|
- Copyright 2024 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module P2P.Http (
|
|
module P2P.Http,
|
|
module P2P.Http.Types,
|
|
module P2P.Http.State,
|
|
) where
|
|
|
|
import Annex.Common
|
|
import P2P.Http.Types
|
|
import P2P.Http.State
|
|
import P2P.Protocol hiding (Offset, Bypass, auth)
|
|
import P2P.IO
|
|
import P2P.Annex
|
|
import Annex.WorkerPool
|
|
import Types.WorkerPool
|
|
import Types.Direction
|
|
import Utility.Metered
|
|
|
|
import Servant
|
|
import Servant.Client.Streaming
|
|
import Servant.API
|
|
import qualified Servant.Types.SourceT as S
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Data.ByteString.Lazy.Internal as LI
|
|
import Control.Concurrent.STM
|
|
import Control.Concurrent.Async
|
|
import Control.Concurrent
|
|
import System.IO.Unsafe
|
|
|
|
type P2PHttpAPI
|
|
= "git-annex" :> PV3 :> "key" :> CaptureKey :> GetAPI
|
|
:<|> "git-annex" :> PV2 :> "key" :> CaptureKey :> GetAPI
|
|
:<|> "git-annex" :> PV1 :> "key" :> CaptureKey :> GetAPI
|
|
:<|> "git-annex" :> PV0 :> "key" :> CaptureKey :> GetAPI
|
|
:<|> "git-annex" :> PV3 :> "checkpresent" :> CheckPresentAPI
|
|
:<|> "git-annex" :> PV2 :> "checkpresent" :> CheckPresentAPI
|
|
:<|> "git-annex" :> PV1 :> "checkpresent" :> CheckPresentAPI
|
|
:<|> "git-annex" :> PV0 :> "checkpresent" :> CheckPresentAPI
|
|
:<|> "git-annex" :> PV3 :> "remove" :> RemoveAPI RemoveResultPlus
|
|
:<|> "git-annex" :> PV2 :> "remove" :> RemoveAPI RemoveResultPlus
|
|
:<|> "git-annex" :> PV1 :> "remove" :> RemoveAPI RemoveResult
|
|
:<|> "git-annex" :> PV0 :> "remove" :> RemoveAPI RemoveResult
|
|
:<|> "git-annex" :> PV3 :> "remove-before" :> RemoveBeforeAPI
|
|
:<|> "git-annex" :> PV3 :> "gettimestamp" :> GetTimestampAPI
|
|
:<|> "git-annex" :> PV3 :> "put" :> DataLengthHeader
|
|
:> PutAPI PutResultPlus
|
|
:<|> "git-annex" :> PV2 :> "put" :> DataLengthHeader
|
|
:> PutAPI PutResultPlus
|
|
:<|> "git-annex" :> PV1 :> "put" :> DataLengthHeader
|
|
:> PutAPI PutResult
|
|
:<|> "git-annex" :> PV0 :> "put"
|
|
:> PutAPI PutResult
|
|
:<|> "git-annex" :> PV3 :> "putoffset"
|
|
:> PutOffsetAPI PutOffsetResultPlus
|
|
:<|> "git-annex" :> PV2 :> "putoffset"
|
|
:> PutOffsetAPI PutOffsetResultPlus
|
|
:<|> "git-annex" :> PV1 :> "putoffset"
|
|
:> PutOffsetAPI PutOffsetResult
|
|
:<|> "git-annex" :> PV3 :> "lockcontent" :> LockContentAPI
|
|
:<|> "git-annex" :> PV2 :> "lockcontent" :> LockContentAPI
|
|
:<|> "git-annex" :> PV1 :> "lockcontent" :> LockContentAPI
|
|
:<|> "git-annex" :> PV0 :> "lockcontent" :> LockContentAPI
|
|
:<|> "git-annex" :> PV3 :> "keeplocked" :> KeepLockedAPI
|
|
:<|> "git-annex" :> PV2 :> "keeplocked" :> KeepLockedAPI
|
|
:<|> "git-annex" :> PV1 :> "keeplocked" :> KeepLockedAPI
|
|
:<|> "git-annex" :> PV0 :> "keeplocked" :> KeepLockedAPI
|
|
:<|> "git-annex" :> "key" :> CaptureKey :> GetGenericAPI
|
|
|
|
p2pHttpAPI :: Proxy P2PHttpAPI
|
|
p2pHttpAPI = Proxy
|
|
|
|
p2pHttpApp :: P2PHttpServerState -> Application
|
|
p2pHttpApp = serve p2pHttpAPI . serveP2pHttp
|
|
|
|
serveP2pHttp :: P2PHttpServerState -> Server P2PHttpAPI
|
|
serveP2pHttp st
|
|
= serveGet st
|
|
:<|> serveGet st
|
|
:<|> serveGet st
|
|
:<|> serveGet st
|
|
:<|> serveCheckPresent st
|
|
:<|> serveCheckPresent st
|
|
:<|> serveCheckPresent st
|
|
:<|> serveCheckPresent st
|
|
:<|> serveRemove st id
|
|
:<|> serveRemove st id
|
|
:<|> serveRemove st dePlus
|
|
:<|> serveRemove st dePlus
|
|
:<|> serveRemoveBefore st
|
|
:<|> serveGetTimestamp st
|
|
:<|> servePut st id
|
|
:<|> servePut st id
|
|
:<|> servePut st dePlus
|
|
:<|> (\v -> servePut st dePlus v Nothing)
|
|
:<|> servePutOffset st id
|
|
:<|> servePutOffset st id
|
|
:<|> servePutOffset st dePlus
|
|
:<|> serveLockContent st
|
|
:<|> serveLockContent st
|
|
:<|> serveLockContent st
|
|
:<|> serveLockContent st
|
|
:<|> serveKeepLocked st
|
|
:<|> serveKeepLocked st
|
|
:<|> serveKeepLocked st
|
|
:<|> serveKeepLocked st
|
|
:<|> serveGetGeneric st
|
|
|
|
type GetGenericAPI = StreamGet NoFraming OctetStream (SourceIO B.ByteString)
|
|
|
|
serveGetGeneric :: P2PHttpServerState -> B64Key -> Handler (S.SourceT IO B.ByteString)
|
|
serveGetGeneric = undefined -- TODO
|
|
|
|
type GetAPI
|
|
= ClientUUID Required
|
|
:> ServerUUID Required
|
|
:> BypassUUIDs
|
|
:> AssociatedFileParam
|
|
:> OffsetParam
|
|
:> IsSecure
|
|
:> AuthHeader
|
|
:> StreamGet NoFraming OctetStream
|
|
(Headers '[DataLengthHeader] (SourceIO B.ByteString))
|
|
|
|
serveGet
|
|
:: APIVersion v
|
|
=> P2PHttpServerState
|
|
-> v
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe B64FilePath
|
|
-> Maybe Offset
|
|
-> IsSecure
|
|
-> Maybe Auth
|
|
-> Handler (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString))
|
|
serveGet st apiver (B64Key k) cu su bypass baf startat sec auth = do
|
|
(runst, conn, releaseconn) <-
|
|
getP2PConnection apiver st cu su bypass sec auth ReadAction
|
|
bsv <- liftIO newEmptyTMVarIO
|
|
endv <- liftIO newEmptyTMVarIO
|
|
validityv <- liftIO newEmptyTMVarIO
|
|
aid <- liftIO $ async $ inAnnexWorker st $ do
|
|
let storer _offset len = sendContentWith $ \bs -> do
|
|
liftIO $ atomically $ putTMVar bsv (len, bs)
|
|
liftIO $ atomically $ takeTMVar endv
|
|
return $ \v -> do
|
|
liftIO $ atomically $ putTMVar validityv v
|
|
return True
|
|
enteringStage (TransferStage Upload) $
|
|
runFullProto runst conn $
|
|
void $ receiveContent Nothing nullMeterUpdate
|
|
sizer storer getreq
|
|
(Len len, bs) <- liftIO $ atomically $ takeTMVar bsv
|
|
bv <- liftIO $ newMVar (L.toChunks bs)
|
|
let streamer = S.SourceT $ \s -> s =<< return
|
|
(stream (releaseconn, bv, endv, validityv, aid))
|
|
return $ addHeader len streamer
|
|
where
|
|
stream (releaseconn, bv, endv, validityv, aid) =
|
|
S.fromActionStep B.null $
|
|
modifyMVar bv $ nextchunk $
|
|
cleanup (releaseconn, endv, validityv, aid)
|
|
|
|
nextchunk atend (b:bs)
|
|
| not (B.null b) = return (bs, b)
|
|
| otherwise = nextchunk atend bs
|
|
nextchunk atend [] = do
|
|
endbit <- atend
|
|
return ([], endbit)
|
|
|
|
cleanup (releaseconn, endv, validityv, aid) =
|
|
ifM (atomically $ isEmptyTMVar endv)
|
|
( do
|
|
atomically $ putTMVar endv ()
|
|
validity <- atomically $ takeTMVar validityv
|
|
wait aid >>= \case
|
|
Left ex -> throwM ex
|
|
Right (Left err) -> error $
|
|
describeProtoFailure err
|
|
Right (Right ()) -> return ()
|
|
() <- releaseconn
|
|
-- When the key's content is invalid,
|
|
-- indicate that to the client by padding
|
|
-- the response, so it is not the same
|
|
-- length indicated by the DataLengthHeader.
|
|
return $ case validity of
|
|
Nothing -> mempty
|
|
Just Valid -> mempty
|
|
Just Invalid -> "XXXXXXX"
|
|
-- FIXME: need to count bytes and emit
|
|
-- something to make it invalid
|
|
, pure mempty
|
|
)
|
|
|
|
sizer = pure $ Len $ case startat of
|
|
Just (Offset o) -> fromIntegral o
|
|
Nothing -> 0
|
|
|
|
getreq offset = P2P.Protocol.GET offset (ProtoAssociatedFile af) k
|
|
|
|
af = AssociatedFile $ case baf of
|
|
Just (B64FilePath f) -> Just f
|
|
Nothing -> Nothing
|
|
|
|
clientGet
|
|
:: ClientEnv
|
|
-> ProtocolVersion
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe B64FilePath
|
|
-> Maybe Offset
|
|
-> Maybe Auth
|
|
-> IO ()
|
|
clientGet clientenv ver k cu su bypass af o auth =
|
|
withClientM (clientGet' ver k cu su bypass af o auth) clientenv $ \case
|
|
Left err -> throwM err
|
|
Right respheaders -> do
|
|
let dl = case lookupResponseHeader @DataLengthHeader' respheaders of
|
|
Header h -> h
|
|
_ -> error "missing data length header"
|
|
liftIO $ print ("datalength", dl :: Integer)
|
|
b <- S.unSourceT (getResponse respheaders) gatherbytestring
|
|
liftIO $ print "got it all, writing to file 'got'"
|
|
L.writeFile "got" b
|
|
|
|
gatherbytestring :: S.StepT IO B.ByteString -> IO L.ByteString
|
|
gatherbytestring x = do
|
|
l <- unsafeInterleaveIO $ go x
|
|
return l
|
|
where
|
|
go S.Stop = return LI.Empty
|
|
go (S.Error err) = error $ show ("ERROR", err)
|
|
go (S.Skip s) = do
|
|
go s
|
|
go (S.Effect ms) = do
|
|
ms >>= go
|
|
go (S.Yield v s) = do
|
|
liftIO $ print ("chunk", B.length v)
|
|
LI.Chunk v <$> unsafeInterleaveIO (go s)
|
|
|
|
clientGet'
|
|
:: ProtocolVersion
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe B64FilePath
|
|
-> Maybe Offset
|
|
-> Maybe Auth
|
|
-> ClientM (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString))
|
|
clientGet' (ProtocolVersion ver) = case ver of
|
|
3 -> v3 V3
|
|
2 -> v2 V2
|
|
1 -> v1 V1
|
|
0 -> v0 V0
|
|
_ -> error "unsupported protocol version"
|
|
where
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
|
|
|
type CheckPresentAPI
|
|
= KeyParam
|
|
:> ClientUUID Required
|
|
:> ServerUUID Required
|
|
:> BypassUUIDs
|
|
:> IsSecure
|
|
:> AuthHeader
|
|
:> Post '[JSON] CheckPresentResult
|
|
|
|
serveCheckPresent
|
|
:: APIVersion v
|
|
=> P2PHttpServerState
|
|
-> v
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> IsSecure
|
|
-> Maybe Auth
|
|
-> Handler CheckPresentResult
|
|
serveCheckPresent st apiver (B64Key k) cu su bypass sec auth = do
|
|
res <- withP2PConnection apiver st cu su bypass sec auth ReadAction
|
|
$ \runst conn ->
|
|
liftIO $ runNetProto runst conn $ checkPresent k
|
|
case res of
|
|
Right b -> return (CheckPresentResult b)
|
|
Left err -> throwError $ err500 { errBody = encodeBL err }
|
|
|
|
clientCheckPresent
|
|
:: ClientEnv
|
|
-> ProtocolVersion
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe Auth
|
|
-> IO Bool
|
|
clientCheckPresent clientenv (ProtocolVersion ver) key cu su bypass auth =
|
|
withClientM (cli key cu su bypass auth) clientenv $ \case
|
|
Left err -> throwM err
|
|
Right (CheckPresentResult res) -> return res
|
|
where
|
|
cli = case ver of
|
|
3 -> v3 V3
|
|
2 -> v2 V2
|
|
1 -> v1 V1
|
|
0 -> v0 V0
|
|
_ -> error "unsupported protocol version"
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
|
|
|
type RemoveAPI result
|
|
= KeyParam
|
|
:> ClientUUID Required
|
|
:> ServerUUID Required
|
|
:> BypassUUIDs
|
|
:> IsSecure
|
|
:> AuthHeader
|
|
:> Post '[JSON] result
|
|
|
|
serveRemove
|
|
:: APIVersion v
|
|
=> P2PHttpServerState
|
|
-> (RemoveResultPlus -> t)
|
|
-> v
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> IsSecure
|
|
-> Maybe Auth
|
|
-> Handler t
|
|
serveRemove st resultmangle apiver (B64Key k) cu su bypass sec auth = do
|
|
res <- withP2PConnection apiver st cu su bypass sec auth RemoveAction
|
|
$ \runst conn ->
|
|
liftIO $ runNetProto runst conn $ remove Nothing k
|
|
case res of
|
|
(Right b, plusuuids) -> return $ resultmangle $
|
|
RemoveResultPlus b (map B64UUID (fromMaybe [] plusuuids))
|
|
(Left err, _) -> throwError $
|
|
err500 { errBody = encodeBL err }
|
|
|
|
clientRemove
|
|
:: ClientEnv
|
|
-> ProtocolVersion
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe Auth
|
|
-> IO RemoveResultPlus
|
|
clientRemove clientenv (ProtocolVersion ver) key cu su bypass auth =
|
|
withClientM cli clientenv $ \case
|
|
Left err -> throwM err
|
|
Right res -> return res
|
|
where
|
|
cli = case ver of
|
|
3 -> v3 V3 key cu su bypass auth
|
|
2 -> v2 V2 key cu su bypass auth
|
|
1 -> plus <$> v1 V1 key cu su bypass auth
|
|
0 -> plus <$> v0 V0 key cu su bypass auth
|
|
_ -> error "unsupported protocol version"
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
|
|
|
type RemoveBeforeAPI
|
|
= KeyParam
|
|
:> ClientUUID Required
|
|
:> ServerUUID Required
|
|
:> BypassUUIDs
|
|
:> QueryParam' '[Required] "timestamp" Timestamp
|
|
:> IsSecure
|
|
:> AuthHeader
|
|
:> Post '[JSON] RemoveResultPlus
|
|
|
|
serveRemoveBefore
|
|
:: APIVersion v
|
|
=> P2PHttpServerState
|
|
-> v
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Timestamp
|
|
-> IsSecure
|
|
-> Maybe Auth
|
|
-> Handler RemoveResultPlus
|
|
serveRemoveBefore st apiver (B64Key k) cu su bypass (Timestamp ts) sec auth = do
|
|
res <- withP2PConnection apiver st cu su bypass sec auth RemoveAction
|
|
$ \runst conn ->
|
|
liftIO $ runNetProto runst conn $
|
|
removeBeforeRemoteEndTime ts k
|
|
case res of
|
|
(Right b, plusuuids) -> return $
|
|
RemoveResultPlus b (map B64UUID (fromMaybe [] plusuuids))
|
|
(Left err, _) -> throwError $
|
|
err500 { errBody = encodeBL err }
|
|
|
|
clientRemoveBefore
|
|
:: ClientEnv
|
|
-> ProtocolVersion
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Timestamp
|
|
-> Maybe Auth
|
|
-> IO RemoveResultPlus
|
|
clientRemoveBefore clientenv (ProtocolVersion ver) key cu su bypass ts auth =
|
|
withClientM (cli key cu su bypass ts auth) clientenv $ \case
|
|
Left err -> throwM err
|
|
Right res -> return res
|
|
where
|
|
cli = case ver of
|
|
3 -> v3 V3
|
|
_ -> error "unsupported protocol version"
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
v3 :<|> _ = client p2pHttpAPI
|
|
|
|
type GetTimestampAPI
|
|
= ClientUUID Required
|
|
:> ServerUUID Required
|
|
:> BypassUUIDs
|
|
:> IsSecure
|
|
:> AuthHeader
|
|
:> Post '[JSON] GetTimestampResult
|
|
|
|
serveGetTimestamp
|
|
:: APIVersion v
|
|
=> P2PHttpServerState
|
|
-> v
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> IsSecure
|
|
-> Maybe Auth
|
|
-> Handler GetTimestampResult
|
|
serveGetTimestamp st apiver cu su bypass sec auth = do
|
|
res <- withP2PConnection apiver st cu su bypass sec auth ReadAction
|
|
$ \runst conn ->
|
|
liftIO $ runNetProto runst conn getTimestamp
|
|
case res of
|
|
Right ts -> return $ GetTimestampResult (Timestamp ts)
|
|
Left err -> throwError $
|
|
err500 { errBody = encodeBL err }
|
|
|
|
clientGetTimestamp
|
|
:: ClientEnv
|
|
-> ProtocolVersion
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe Auth
|
|
-> IO GetTimestampResult
|
|
clientGetTimestamp clientenv (ProtocolVersion ver) cu su bypass auth =
|
|
withClientM (cli cu su bypass auth) clientenv $ \case
|
|
Left err -> throwM err
|
|
Right res -> return res
|
|
where
|
|
cli = case ver of
|
|
3 -> v3 V3
|
|
_ -> error "unsupported protocol version"
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|>
|
|
v3 :<|> _ = client p2pHttpAPI
|
|
|
|
type PutAPI result
|
|
= KeyParam
|
|
:> ClientUUID Required
|
|
:> ServerUUID Required
|
|
:> BypassUUIDs
|
|
:> AssociatedFileParam
|
|
:> OffsetParam
|
|
:> Header' '[Required] "X-git-annex-data-length" DataLength
|
|
:> StreamBody NoFraming OctetStream (SourceIO B.ByteString)
|
|
:> Post '[JSON] result
|
|
|
|
servePut
|
|
:: APIVersion v
|
|
=> P2PHttpServerState
|
|
-> (PutResultPlus -> t)
|
|
-> v
|
|
-> Maybe Integer
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe B64FilePath
|
|
-> Maybe Offset
|
|
-> DataLength
|
|
-> S.SourceT IO B.ByteString
|
|
-> Handler t
|
|
servePut = undefined -- TODO
|
|
|
|
clientPut
|
|
:: ProtocolVersion
|
|
-> Maybe Integer
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe B64FilePath
|
|
-> Maybe Offset
|
|
-> DataLength
|
|
-> S.SourceT IO B.ByteString
|
|
-> ClientM PutResultPlus
|
|
clientPut (ProtocolVersion ver) sz k cu su bypass af o l src = case ver of
|
|
3 -> v3 V3 sz k cu su bypass af o l src
|
|
2 -> v2 V2 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 V0 k cu su bypass af o l src
|
|
_ -> error "unsupported protocol version"
|
|
where
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|>
|
|
_ :<|>
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
|
|
|
type PutOffsetAPI result
|
|
= KeyParam
|
|
:> ClientUUID Required
|
|
:> ServerUUID Required
|
|
:> BypassUUIDs
|
|
:> Post '[JSON] result
|
|
|
|
servePutOffset
|
|
:: APIVersion v
|
|
=> P2PHttpServerState
|
|
-> (PutOffsetResultPlus -> t)
|
|
-> v
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Handler t
|
|
servePutOffset = undefined -- TODO
|
|
|
|
clientPutOffset
|
|
:: ProtocolVersion
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> ClientM PutOffsetResultPlus
|
|
clientPutOffset (ProtocolVersion ver) = case ver of
|
|
3 -> v3 V3
|
|
2 -> v2 V2
|
|
_ -> error "unsupported protocol version"
|
|
where
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|>
|
|
_ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
v3 :<|> v2 :<|> _ = client p2pHttpAPI
|
|
|
|
type LockContentAPI
|
|
= KeyParam
|
|
:> ClientUUID Required
|
|
:> ServerUUID Required
|
|
:> BypassUUIDs
|
|
:> Post '[JSON] LockResult
|
|
|
|
serveLockContent
|
|
:: APIVersion v
|
|
=> P2PHttpServerState
|
|
-> v
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Handler LockResult
|
|
serveLockContent = undefined -- TODO
|
|
|
|
clientLockContent
|
|
:: ProtocolVersion
|
|
-> B64Key
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> ClientM LockResult
|
|
clientLockContent (ProtocolVersion ver) = case ver of
|
|
3 -> v3 V3
|
|
2 -> v2 V2
|
|
1 -> v1 V1
|
|
0 -> v0 V0
|
|
_ -> error "unsupported protocol version"
|
|
where
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|>
|
|
_ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|>
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
|
|
|
type KeepLockedAPI
|
|
= LockIDParam
|
|
:> ClientUUID Required
|
|
:> ServerUUID Required
|
|
:> BypassUUIDs
|
|
:> Header "Connection" ConnectionKeepAlive
|
|
:> Header "Keep-Alive" KeepAlive
|
|
:> StreamBody NewlineFraming JSON (SourceIO UnlockRequest)
|
|
:> Post '[JSON] LockResult
|
|
|
|
serveKeepLocked
|
|
:: APIVersion v
|
|
=> P2PHttpServerState
|
|
-> v
|
|
-> LockID
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe ConnectionKeepAlive
|
|
-> Maybe KeepAlive
|
|
-> S.SourceT IO UnlockRequest
|
|
-> Handler LockResult
|
|
serveKeepLocked st apiver lckid cu su _ _ _ unlockrequeststream = do
|
|
_ <- liftIO $ S.unSourceT unlockrequeststream go
|
|
return (LockResult False Nothing)
|
|
where
|
|
go S.Stop = dropLock lckid st
|
|
go (S.Error _err) = dropLock lckid st
|
|
go (S.Skip s) = go s
|
|
go (S.Effect ms) = ms >>= go
|
|
go (S.Yield (UnlockRequest False) s) = go s
|
|
go (S.Yield (UnlockRequest True) _) = dropLock lckid st
|
|
|
|
clientKeepLocked'
|
|
:: ProtocolVersion
|
|
-> LockID
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> Maybe ConnectionKeepAlive
|
|
-> Maybe KeepAlive
|
|
-> S.SourceT IO UnlockRequest
|
|
-> ClientM LockResult
|
|
clientKeepLocked' (ProtocolVersion ver) = case ver of
|
|
3 -> v3 V3
|
|
2 -> v2 V2
|
|
1 -> v1 V1
|
|
0 -> v0 V0
|
|
_ -> error "unsupported protocol version"
|
|
where
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|>
|
|
_ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|>
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
|
|
|
clientKeepLocked
|
|
:: ClientEnv
|
|
-> ProtocolVersion
|
|
-> LockID
|
|
-> B64UUID ClientSide
|
|
-> B64UUID ServerSide
|
|
-> [B64UUID Bypass]
|
|
-> TMVar Bool
|
|
-> IO ()
|
|
clientKeepLocked clientenv protover lckid cu su bypass keeplocked = do
|
|
let cli = clientKeepLocked' protover lckid cu su bypass
|
|
(Just connectionKeepAlive) (Just keepAlive)
|
|
(S.fromStepT unlocksender)
|
|
withClientM cli clientenv $ \case
|
|
Left err -> throwM err
|
|
Right (LockResult _ _) ->
|
|
liftIO $ print "end of lock connection to server"
|
|
where
|
|
unlocksender =
|
|
S.Yield (UnlockRequest False) $ S.Effect $ do
|
|
liftIO $ print "sent keep locked request"
|
|
return $ S.Effect $ do
|
|
stilllock <- liftIO $ atomically $ takeTMVar keeplocked
|
|
if stilllock
|
|
then return unlocksender
|
|
else do
|
|
liftIO $ print "sending unlock request"
|
|
return $ S.Yield (UnlockRequest True) S.Stop
|
|
|
|
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 ServerUUID req = QueryParam' '[req] "serveruuid" (B64UUID ServerSide)
|
|
|
|
type BypassUUIDs = QueryParams "bypass" (B64UUID Bypass)
|
|
|
|
type CaptureKey = Capture "key" B64Key
|
|
|
|
type KeyParam = QueryParam' '[Required] "key" B64Key
|
|
|
|
type AssociatedFileParam = QueryParam "associatedfile" B64FilePath
|
|
|
|
type OffsetParam = QueryParam "offset" Offset
|
|
|
|
type DataLengthHeader = Header DataLengthHeader' Integer
|
|
|
|
type DataLengthHeader' = "X-git-annex-data-length"
|
|
|
|
type LockIDParam = QueryParam' '[Required] "lockid" LockID
|
|
|
|
type AuthHeader = Header "Authorization" Auth
|