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

servePut and clientPut implementation

Browse source 
Made the data-length header required even for v0. This simplifies the
implementation, and doesn't preclude extra verification being done for
v0.

The connectionWaitVar is an ugly hack. In servePut, nothing waits
on the waitvar, and I could not find a good way to make anything wait on
it.
This commit is contained in:
Joey Hess 2024-07-22 10:20:18 -04:00
parent eb4fb388bd
commit 4826a3745d
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
10 changed files with 222 additions and 185 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Annex/Proxy.hs
View file

@ -59,8 +59,8 @@ proxySpecialRemoteSide clientmaxversion r = mkRemoteSide r $ do
let remoteconn = P2PConnection let remoteconn = P2PConnection
{ connRepo = Nothing { connRepo = Nothing
, connCheckAuth = const False , connCheckAuth = const False
, connIhdl = P2PHandleTMVar ihdl iwaitv , connIhdl = P2PHandleTMVar ihdl (Just iwaitv)
, connOhdl = P2PHandleTMVar ohdl owaitv , connOhdl = P2PHandleTMVar ohdl (Just owaitv)
, connIdent = ConnIdent (Just (Remote.name r)) , connIdent = ConnIdent (Just (Remote.name r))
} }
let closeremoteconn = do let closeremoteconn = do

19
Command/P2PHttp.hs
View file

@ -73,7 +73,7 @@ seek o = getAnnexWorkerPool $ \workerpool -> do
-- XXX remove this -- XXX remove this
when (isNothing (portOption o)) $ do when (isNothing (portOption o)) $ do
liftIO $ putStrLn "test begins" liftIO $ putStrLn "test begins"
testGet testPut
giveup "TEST DONE" giveup "TEST DONE"
withLocalP2PConnections workerpool $ \acquireconn -> liftIO $ do withLocalP2PConnections workerpool $ \acquireconn -> liftIO $ do
authenv <- getAuthEnv authenv <- getAuthEnv
@ -172,6 +172,23 @@ testGet = do
Nothing Nothing
liftIO $ print res liftIO $ print res
testPut = do
mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
res <- clientPut (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3)
(B64Key (fromJust $ deserializeKey ("WORM-s30-m1720547401--foo")))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
(B64UUID (toUUID ("cu" :: String)))
[]
Nothing
Nothing
(AssociatedFile (Just "foo"))
"foocontent"
30
(liftIO (print "validity check") >> return True)
liftIO $ print res
testRemove = do testRemove = do
mgr <- httpManager <$> getUrlOptions mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/" burl <- liftIO $ parseBaseUrl "http://localhost:8080/"

191
P2P/Http.hs
View file

@ -27,6 +27,7 @@ import P2P.Protocol hiding (Offset, Bypass, auth)
import P2P.IO import P2P.IO
import P2P.Annex import P2P.Annex
import Annex.WorkerPool import Annex.WorkerPool
import Annex.Concurrent
import Types.WorkerPool import Types.WorkerPool
import Types.Direction import Types.Direction
import Utility.Metered import Utility.Metered
@ -37,6 +38,7 @@ import qualified Servant.Types.SourceT as S
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as LI import qualified Data.ByteString.Lazy.Internal as LI
import Data.Char
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent import Control.Concurrent
@ -57,14 +59,10 @@ type P2PHttpAPI
:<|> "git-annex" :> SU :> PV0 :> "remove" :> RemoveAPI RemoveResult :<|> "git-annex" :> SU :> PV0 :> "remove" :> RemoveAPI RemoveResult
:<|> "git-annex" :> SU :> PV3 :> "remove-before" :> RemoveBeforeAPI :<|> "git-annex" :> SU :> PV3 :> "remove-before" :> RemoveBeforeAPI
:<|> "git-annex" :> SU :> PV3 :> "gettimestamp" :> GetTimestampAPI :<|> "git-annex" :> SU :> PV3 :> "gettimestamp" :> GetTimestampAPI
:<|> "git-annex" :> SU :> PV3 :> "put" :> DataLengthHeader :<|> "git-annex" :> SU :> PV3 :> "put" :> PutAPI PutResultPlus
:> PutAPI PutResultPlus :<|> "git-annex" :> SU :> PV2 :> "put" :> PutAPI PutResultPlus
:<|> "git-annex" :> SU :> PV2 :> "put" :> DataLengthHeader :<|> "git-annex" :> SU :> PV1 :> "put" :> PutAPI PutResult
:> PutAPI PutResultPlus :<|> "git-annex" :> SU :> PV0 :> "put" :> PutAPI PutResult
:<|> "git-annex" :> SU :> PV1 :> "put" :> DataLengthHeader
:> PutAPI PutResult
:<|> "git-annex" :> SU :> PV0 :> "put"
:> PutAPI PutResult
:<|> "git-annex" :> SU :> PV3 :> "putoffset" :<|> "git-annex" :> SU :> PV3 :> "putoffset"
:> PutOffsetAPI PutOffsetResultPlus :> PutOffsetAPI PutOffsetResultPlus
:<|> "git-annex" :> SU :> PV2 :> "putoffset" :<|> "git-annex" :> SU :> PV2 :> "putoffset"
@ -106,7 +104,7 @@ serveP2pHttp st
:<|> servePut st id :<|> servePut st id
:<|> servePut st id :<|> servePut st id
:<|> servePut st dePlus :<|> servePut st dePlus
:<|> (\su v -> servePut st dePlus su v Nothing) :<|> servePut st dePlus
:<|> servePutOffset st id :<|> servePutOffset st id
:<|> servePutOffset st id :<|> servePutOffset st id
:<|> servePutOffset st dePlus :<|> servePutOffset st dePlus
@ -136,7 +134,7 @@ serveGetGeneric
-> Handler (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString)) -> Handler (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString))
serveGetGeneric st su@(B64UUID u) k = serveGetGeneric st su@(B64UUID u) k =
-- Use V0 because it does not alter the returned data to indicate -- Use V0 because it does not alter the returned data to indicate
-- InValid content. -- Invalid content.
serveGet st su V0 k cu [] Nothing Nothing serveGet st su V0 k cu [] Nothing Nothing
where where
-- Reuse server UUID as client UUID. -- Reuse server UUID as client UUID.
@ -167,7 +165,7 @@ serveGet
-> Maybe Auth -> Maybe Auth
-> Handler (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString)) -> Handler (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString))
serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do
conn <- getP2PConnection apiver st cu su bypass sec auth ReadAction conn <- getP2PConnection apiver st cu su bypass sec auth ReadAction id
bsv <- liftIO newEmptyTMVarIO bsv <- liftIO newEmptyTMVarIO
endv <- liftIO newEmptyTMVarIO endv <- liftIO newEmptyTMVarIO
validityv <- liftIO newEmptyTMVarIO validityv <- liftIO newEmptyTMVarIO
@ -181,11 +179,10 @@ serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do
return $ \v -> do return $ \v -> do
liftIO $ atomically $ putTMVar validityv v liftIO $ atomically $ putTMVar validityv v
return True return True
v <- enteringStage (TransferStage Upload) $ enteringStage (TransferStage Upload) $
runFullProto (clientRunState conn) (clientP2PConnection conn) $ runFullProto (clientRunState conn) (clientP2PConnection conn) $
void $ receiveContent Nothing nullMeterUpdate void $ receiveContent Nothing nullMeterUpdate
sizer storer getreq sizer storer getreq
return v
void $ liftIO $ forkIO $ waitfinal endv finalv conn annexworker void $ liftIO $ forkIO $ waitfinal endv finalv conn annexworker
(Len len, bs) <- liftIO $ atomically $ takeTMVar bsv (Len len, bs) <- liftIO $ atomically $ takeTMVar bsv
bv <- liftIO $ newMVar (L.toChunks bs) bv <- liftIO $ newMVar (L.toChunks bs)
@ -240,7 +237,7 @@ serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do
-- Make sure the annexworker is not left blocked on endv -- Make sure the annexworker is not left blocked on endv
-- if the client disconnected early. -- if the client disconnected early.
void $ liftIO $ atomically $ tryPutTMVar endv () void $ liftIO $ atomically $ tryPutTMVar endv ()
void $ void $ tryNonAsync $ wait annexworker void $ tryNonAsync $ wait annexworker
void $ tryNonAsync $ releaseP2PConnection conn void $ tryNonAsync $ releaseP2PConnection conn
sizer = pure $ Len $ case startat of sizer = pure $ Len $ case startat of
@ -505,7 +502,8 @@ clientGetTimestamp clientenv (ProtocolVersion ver) cu su bypass auth =
v3 :<|> _ = client p2pHttpAPI v3 :<|> _ = client p2pHttpAPI
type PutAPI result type PutAPI result
= KeyParam = DataLengthHeaderRequired
:> KeyParam
:> CU Required :> CU Required
:> BypassUUIDs :> BypassUUIDs
:> AssociatedFileParam :> AssociatedFileParam
@ -521,7 +519,7 @@ servePut
-> (PutResultPlus -> t) -> (PutResultPlus -> t)
-> B64UUID ServerSide -> B64UUID ServerSide
-> v -> v
-> Maybe DataLength -> DataLength
-> B64Key -> B64Key
-> B64UUID ClientSide -> B64UUID ClientSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
@ -531,35 +529,154 @@ servePut
-> IsSecure -> IsSecure
-> Maybe Auth -> Maybe Auth
-> Handler t -> Handler t
servePut st resultmangle su apiver datalen k cu bypass af offset stream sec auth = do servePut st resultmangle su apiver (DataLength len) (B64Key k) cu bypass baf moffset stream sec auth = do
res <- withP2PConnection apiver st cu su bypass sec auth WriteAction validityv <- liftIO newEmptyTMVarIO
$ \conn -> let validitycheck = local $ runValidityCheck $
liftIO $ proxyClientNetProto conn undefined liftIO $ atomically $ readTMVar validityv
content <- liftIO $ S.unSourceT stream (gather validityv)
conn <- getP2PConnection apiver st cu su bypass sec auth WriteAction $
\st -> st { connectionWaitVar = False }
res <- liftIO $ inAnnexWorker st $
enteringStage (TransferStage Download) $
runFullProto (clientRunState conn) (clientP2PConnection conn) $
protoaction content validitycheck
case res of case res of
Right (stored, plusuuids) -> return $ resultmangle $ Right (Right (Just plusuuids)) -> return $ resultmangle $
PutResultPlus stored plusuuids PutResultPlus True (map B64UUID plusuuids)
Right (Right Nothing) -> return $ resultmangle $
PutResultPlus False []
Right (Left protofail) -> throwError $
err500 { errBody = encodeBL (describeProtoFailure protofail) }
Left err -> throwError $ Left err -> throwError $
err500 { errBody = encodeBL err } err500 { errBody = encodeBL (show err) }
where
protoaction content validitycheck = put' k af $ \offset' ->
let offsetdelta = offset' - offset
in case compare offset' offset of
EQ -> sendContent' nullMeterUpdate (Len len)
content validitycheck
GT -> sendContent' nullMeterUpdate
(Len (len - fromIntegral offsetdelta))
(L.drop (fromIntegral offsetdelta) content)
validitycheck
LT -> sendContent' nullMeterUpdate
(Len 0)
mempty
(return Invalid)
offset = case moffset of
Just (Offset o) -> o
Nothing -> 0
af = AssociatedFile $ case baf of
Just (B64FilePath f) -> Just f
Nothing -> Nothing
-- Streams the ByteString from the client. Avoids returning a longer
-- or shorter than expected ByteString by truncating or padding;
-- in such cases the data is not Valid.
gather validityv = unsafeInterleaveIO . go 0
where
go n S.Stop
| n == len = do
atomically $ writeTMVar validityv Valid
return LI.Empty
| otherwise = do
atomically $ writeTMVar validityv Invalid
padout n
go n (S.Error _err) = do
atomically $ writeTMVar validityv Invalid
padout n
go n (S.Skip s) = go n s
go n (S.Effect ms) = ms >>= go n
go n (S.Yield v s) =
let !n' = n + fromIntegral (B.length v)
in if n' > len
then do
atomically $ writeTMVar validityv Invalid
return $ LI.Chunk
(B.take (fromIntegral (len - n')) v)
LI.Empty
else LI.Chunk v <$> unsafeInterleaveIO (go n' s)
padout n =return $ LI.Chunk
(B.replicate (fromIntegral (len-n))
(fromIntegral (ord 'X')))
LI.Empty
clientPut clientPut
:: ProtocolVersion :: ClientEnv
-> DataLength -> ProtocolVersion
-> B64Key -> B64Key
-> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
-> B64UUID ClientSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> Maybe B64FilePath
-> Maybe Offset
-> S.SourceT IO B.ByteString
-> Maybe Auth -> Maybe Auth
-> ClientM PutResultPlus -> Maybe Offset
clientPut (ProtocolVersion ver) sz k cu su bypass af o src auth = case ver of -> AssociatedFile
3 -> v3 su V3 (Just sz) k cu bypass af o src auth -> FilePath
2 -> v2 su V2 (Just sz) k cu bypass af o src auth -> FileSize
1 -> plus <$> v1 su V1 (Just sz) k cu bypass af o src auth -> Annex Bool
0 -> plus <$> v0 su V0 k cu bypass af o src auth -> Annex PutResultPlus
_ -> error "unsupported protocol version" clientPut clientenv (ProtocolVersion ver) k su cu bypass auth moffset af contentfile contentfilesize validitycheck = do
checkv <- liftIO newEmptyTMVarIO
checkresultv <- liftIO newEmptyTMVarIO
let checker = do
liftIO $ atomically $ takeTMVar checkv
validitycheck >>= liftIO . atomically . putTMVar checkresultv
checkerthread <- liftIO . async =<< forkState checker
liftIO (withClientM (cli (stream checkv checkresultv)) clientenv return) >>= \case
Left err -> do
void $ liftIO $ atomically $ tryPutTMVar checkv ()
join $ liftIO (wait checkerthread)
throwM err
Right res -> do
join $ liftIO (wait checkerthread)
return res
where where
stream checkv checkresultv = S.SourceT $ \a -> do
bl <- L.readFile contentfile
v <- newMVar (0, L.toChunks bl)
a (go v)
where
go v = S.fromActionStep B.null $ do
res <- modifyMVar v $ pure . \case
(n, []) -> ((n, []), (n, Nothing))
(n, (b:bs)) ->
let !n' = n + B.length b
in ((n', bs), (n, Just b))
case res of
(_, Just b) -> return b
(n, Nothing) -> do
void $ liftIO $ atomically $
tryPutTMVar checkv ()
valid <- liftIO $ atomically $
readTMVar checkresultv
if not valid
then if n == fromIntegral contentfilesize
then do
modifyMVar_ v $ \(_n, l) ->
pure (n+1, l)
return "X"
else return B.empty
else return B.empty
baf = case af of
AssociatedFile Nothing -> Nothing
AssociatedFile (Just f) -> Just (B64FilePath f)
len = DataLength $ case moffset of
Nothing -> contentfilesize
Just (Offset o) -> contentfilesize - fromIntegral o
cli src = case ver of
3 -> v3 su V3 len k cu bypass baf moffset src auth
2 -> v2 su V2 len k cu bypass baf moffset src auth
1 -> plus <$> v1 su V1 len k cu bypass baf moffset src auth
0 -> plus <$> v0 su V0 len k cu bypass baf moffset src auth
_ -> error "unsupported protocol version"
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
@ -757,6 +874,8 @@ type OffsetParam = QueryParam "offset" Offset
type DataLengthHeader = Header DataLengthHeader' DataLength type DataLengthHeader = Header DataLengthHeader' DataLength
type DataLengthHeaderRequired = Header' '[Required] DataLengthHeader' DataLength
type DataLengthHeader' = "X-git-annex-data-length" type DataLengthHeader' = "X-git-annex-data-length"
type LockIDParam = QueryParam' '[Required] "lockid" LockID type LockIDParam = QueryParam' '[Required] "lockid" LockID

19
P2P/Http/State.hs
View file

@ -65,7 +65,7 @@ withP2PConnection
-> (P2PConnectionPair -> Handler (Either ProtoFailure a)) -> (P2PConnectionPair -> Handler (Either ProtoFailure a))
-> Handler a -> Handler a
withP2PConnection apiver st cu su bypass sec auth actionclass connaction = do withP2PConnection apiver st cu su bypass sec auth actionclass connaction = do
conn <- getP2PConnection apiver st cu su bypass sec auth actionclass conn <- getP2PConnection apiver st cu su bypass sec auth actionclass id
connaction' conn connaction' conn
`finally` liftIO (releaseP2PConnection conn) `finally` liftIO (releaseP2PConnection conn)
where where
@ -84,8 +84,9 @@ getP2PConnection
-> IsSecure -> IsSecure
-> Maybe Auth -> Maybe Auth
-> ActionClass -> ActionClass
-> (ConnectionParams -> ConnectionParams)
-> Handler P2PConnectionPair -> Handler P2PConnectionPair
getP2PConnection apiver st cu su bypass sec auth actionclass = getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams =
case (getServerMode st sec auth, actionclass) of case (getServerMode st sec auth, actionclass) of
(Just P2P.ServeReadWrite, _) -> go P2P.ServeReadWrite (Just P2P.ServeReadWrite, _) -> go P2P.ServeReadWrite
(Just P2P.ServeAppendOnly, RemoveAction) -> throwError err403 (Just P2P.ServeAppendOnly, RemoveAction) -> throwError err403
@ -101,12 +102,13 @@ getP2PConnection apiver st cu su bypass sec auth actionclass =
throwError err503 throwError err503
Right v -> return v Right v -> return v
where where
cp = ConnectionParams cp = fconnparams $ ConnectionParams
{ connectionProtocolVersion = protocolVersion apiver { connectionProtocolVersion = protocolVersion apiver
, connectionServerUUID = fromB64UUID su , connectionServerUUID = fromB64UUID su
, connectionClientUUID = fromB64UUID cu , connectionClientUUID = fromB64UUID cu
, connectionBypass = map fromB64UUID bypass , connectionBypass = map fromB64UUID bypass
, connectionServerMode = servermode , connectionServerMode = servermode
, connectionWaitVar = True
} }
basicAuthRequired :: ServerError basicAuthRequired :: ServerError
@ -121,6 +123,7 @@ data ConnectionParams = ConnectionParams
, connectionClientUUID :: UUID , connectionClientUUID :: UUID
, connectionBypass :: [UUID] , connectionBypass :: [UUID]
, connectionServerMode :: P2P.ServerMode , connectionServerMode :: P2P.ServerMode
, connectionWaitVar :: Bool
} }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
@ -191,8 +194,14 @@ mkP2PConnectionPair connparams relv startworker = do
hdl2 <- newEmptyTMVarIO hdl2 <- newEmptyTMVarIO
wait1 <- newEmptyTMVarIO wait1 <- newEmptyTMVarIO
wait2 <- newEmptyTMVarIO wait2 <- newEmptyTMVarIO
let h1 = P2PHandleTMVar hdl1 wait1 let h1 = P2PHandleTMVar hdl1 $
let h2 = P2PHandleTMVar hdl2 wait2 if connectionWaitVar connparams
then Just wait1
else Nothing
let h2 = P2PHandleTMVar hdl2 $
if connectionWaitVar connparams
then Just wait2
else Nothing
let serverconn = P2PConnection Nothing let serverconn = P2PConnection Nothing
(const True) h1 h2 (const True) h1 h2
(ConnIdent (Just "http server")) (ConnIdent (Just "http server"))

9
P2P/IO.hs
View file

@ -80,11 +80,12 @@ mkRunState mk = do
data P2PHandle data P2PHandle
= P2PHandle Handle = P2PHandle Handle
| P2PHandleTMVar (TMVar (Either L.ByteString Message)) (TMVar ()) | P2PHandleTMVar (TMVar (Either L.ByteString Message)) (Maybe (TMVar ()))
signalFullyConsumedByteString :: P2PHandle -> IO () signalFullyConsumedByteString :: P2PHandle -> IO ()
signalFullyConsumedByteString (P2PHandle _) = return () signalFullyConsumedByteString (P2PHandle _) = return ()
signalFullyConsumedByteString (P2PHandleTMVar _ waitv) = signalFullyConsumedByteString (P2PHandleTMVar _ Nothing) = return ()
signalFullyConsumedByteString (P2PHandleTMVar _ (Just waitv)) =
atomically $ putTMVar waitv () atomically $ putTMVar waitv ()
data P2PConnection = P2PConnection data P2PConnection = P2PConnection
@ -216,7 +217,7 @@ runNet runst conn runner f = case f of
ifM (atomically (tryPutTMVar mv (Right m))) ifM (atomically (tryPutTMVar mv (Right m)))
( return $ Right () ( return $ Right ()
, return $ Left $ toException $ , return $ Left $ toException $
P2PTMVarException "TMVar left full" P2PTMVarException ("TMVar left full " ++ show m)
) )
case v of case v of
Left e -> return $ Left $ ProtoFailureException e Left e -> return $ Left $ ProtoFailureException e
@ -256,7 +257,7 @@ runNet runst conn runner f = case f of
liftIO $ atomically $ putTMVar mv (Left b) liftIO $ atomically $ putTMVar mv (Left b)
-- Wait for the whole bytestring to -- Wait for the whole bytestring to
-- be processed. -- be processed.
liftIO $ atomically $ takeTMVar waitv liftIO $ maybe noop (atomically . takeTMVar) waitv
runner next runner next
ReceiveBytes len p next -> ReceiveBytes len p next ->
case connIhdl conn of case connIhdl conn of

29
P2P/Protocol.hs
View file

@ -467,11 +467,15 @@ get dest key iv af m p =
storer = storeContentTo dest iv storer = storeContentTo dest iv
put :: Key -> AssociatedFile -> MeterUpdate -> Proto (Maybe [UUID]) put :: Key -> AssociatedFile -> MeterUpdate -> Proto (Maybe [UUID])
put key af p = do put key af p = put' key af $ \offset ->
sendContent key af Nothing offset p
put' :: Key -> AssociatedFile -> (Offset -> Proto (Maybe [UUID])) -> Proto (Maybe [UUID])
put' key af sender = do
net $ sendMessage (PUT (ProtoAssociatedFile af) key) net $ sendMessage (PUT (ProtoAssociatedFile af) key)
r <- net receiveMessage r <- net receiveMessage
case r of case r of
Just (PUT_FROM offset) -> sendContent key af Nothing offset p Just (PUT_FROM offset) -> sender offset
Just ALREADY_HAVE -> return (Just []) Just ALREADY_HAVE -> return (Just [])
Just (ALREADY_HAVE_PLUS uuids) -> return (Just uuids) Just (ALREADY_HAVE_PLUS uuids) -> return (Just uuids)
_ -> do _ -> do
@ -684,14 +688,19 @@ sendContent key af o offset@(Offset n) p = go =<< local (contentSize key)
-- Content not available to send. Indicate this by sending -- Content not available to send. Indicate this by sending
-- empty data and indlicate it's invalid. -- empty data and indlicate it's invalid.
go Nothing = sender (Len 0) L.empty (return Invalid) go Nothing = sender (Len 0) L.empty (return Invalid)
sender len content validitycheck = do
let p' = offsetMeterUpdate p (toBytesProcessed n) sender = sendContent' p'
net $ sendMessage (DATA len)
net $ sendBytes len content p' p' = offsetMeterUpdate p (toBytesProcessed n)
ver <- net getProtocolVersion
when (ver >= ProtocolVersion 1) $ sendContent' :: MeterUpdate -> Len -> L.ByteString -> Proto Validity -> Proto (Maybe [UUID])
net . sendMessage . VALIDITY =<< validitycheck sendContent' p len content validitycheck = do
checkSuccessPlus net $ sendMessage (DATA len)
net $ sendBytes len content p
ver <- net getProtocolVersion
when (ver >= ProtocolVersion 1) $
net . sendMessage . VALIDITY =<< validitycheck
checkSuccessPlus
receiveContent receiveContent
:: Observable t :: Observable t

14
doc/design/p2p_protocol.mdwn
View file

@ -182,7 +182,7 @@ whitespace.)
The server may respond with ALREADY-HAVE if it already The server may respond with ALREADY-HAVE if it already
had the content of that key. had the content of that key.
In protocol version 2, the server can optionally reply with In protocol version 2 and above, the server can optionally reply with
ALREADY-HAVE-PLUS. The subsequent list of UUIDs are additional ALREADY-HAVE-PLUS. The subsequent list of UUIDs are additional
UUIDs where the content is stored, in addition to the UUID where UUIDs where the content is stored, in addition to the UUID where
the client was going to send it. the client was going to send it.
@ -197,9 +197,9 @@ the client to start. This allows resuming transfers.
The client then sends a DATA message with content of the file from The client then sends a DATA message with content of the file from
the offset to the end of file. the offset to the end of file.
In protocol version 1, after the data, the client sends an additional In protocol version 1 and above, after the data, the client sends an
message, to indicate if the content of the file has changed while it additional message, to indicate if the content of the file has changed
was being sent. while it was being sent.
INVALID INVALID
VALID VALID
@ -207,8 +207,8 @@ was being sent.
If the server successfully receives the data and stores the content, If the server successfully receives the data and stores the content,
it replies with SUCCESS. Otherwise, FAILURE. it replies with SUCCESS. Otherwise, FAILURE.
In protocol version 2, the server can optionally reply with SUCCESS-PLUS In protocol version 2 and above, the server can optionally reply with
and a list of UUIDs where the content was stored. SUCCESS-PLUS and a list of UUIDs where the content was stored.
## Getting content from the server ## Getting content from the server
@ -223,7 +223,7 @@ See description of AssociatedFile above.
The server then sends a DATA message with the content of the file The server then sends a DATA message with the content of the file
from the offset to end of file. from the offset to end of file.
In protocol version 1, after the data, the server sends an additional In protocol version 1 and above, after the data, the server sends an additional
message, to indicate if the content of the file has changed while it message, to indicate if the content of the file has changed while it
was being sent. was being sent.

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

@ -39,8 +39,6 @@ over HTTPS.
Each request in the protocol is versioned. The versions correspond Each request in the protocol is versioned. The versions correspond
to P2P protocol versions. to P2P protocol versions.
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 400 Bad Request, and the client should fall request will fail with a 400 Bad Request, and the client should fall
back to an earlier protocol version. back to an earlier protocol version.
@ -369,8 +367,7 @@ Same as v3, except the JSON will not include "plusuuids".
### POST /git-annex/$uuid/v0/put ### POST /git-annex/$uuid/v0/put
Same as v1, except there is no X-git-annex-data-length header. Same as v1, except additional checking is done to validate the data.
Additional checking client-side will be required to validate the data.
### POST /git-annex/$uuid/v3/putoffset ### POST /git-annex/$uuid/v3/putoffset

5
doc/todo/git-annex_proxies.mdwn
View file

@ -28,10 +28,7 @@ Planned schedule of work:
## work notes ## work notes
* Implement: servePut, servePutOffset, serveLockContent * Implement: servePutOffset, serveLockContent
* I have a file `servant.hs` in the httpproto branch that works through some
of the bytestring streaming issues.
* A Locker should expire the lock on its own after 10 minutes initially. * A Locker should expire the lock on its own after 10 minutes initially.

112
servant.hs
View file

@ -1,112 +0,0 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
module Main (main) where
import Control.Concurrent
(threadDelay)
import Control.Monad.IO.Class
(MonadIO (..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Internal as BLI
import Data.Maybe
(fromMaybe)
import Network.HTTP.Client
(defaultManagerSettings, newManager)
import Network.Wai
(Application)
import System.Environment
(getArgs, lookupEnv)
import Text.Read
(readMaybe)
import Servant
import Servant.Client.Streaming
import qualified Servant.Types.SourceT as S
import Control.Concurrent.MVar
import System.IO.Unsafe
import qualified Network.Wai.Handler.Warp as Warp
type API = "readme" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
:<|> "writeme" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> Post '[JSON] Bool
api :: Proxy API
api = Proxy
server :: Server API
server = readme :<|> writeme where
readme = liftIO $ do
putStrLn "/proxy"
return $ S.SourceT $ \k -> do
k =<< readfilelazy "README.md"
k =<< readfilelazy "another"
writeme :: SourceIO BS.ByteString -> Handler Bool
writeme src = do
liftIO $ print "gathering lazy bytestring"
b <- liftIO $ S.unSourceT src gatherbytestring
liftIO $ print "got lazy bytestring, writing to file"
liftIO$ BL.writeFile "writem" b
liftIO$ print "write complete"
return True
app :: Application
app = serve api server
cli :: ClientM (S.SourceT IO BS.ByteString)
cli :<|> writecli = client api
main :: IO ()
main = do
args <- getArgs
case args of
("server":_) -> do
putStrLn "Starting cookbook-basic-streaming at http://localhost:8000"
port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"
Warp.run port app
("client":ns:_) -> do
mgr <- newManager defaultManagerSettings
burl <- parseBaseUrl "http://localhost:8000/"
withClientM (writecli getit) (mkClientEnv mgr burl) $ \me -> case me of
Left err -> print err
Right src -> print src
_ -> do
putStrLn "Try:"
putStrLn "cabal new-run cookbook-basic-streaming server"
putStrLn "cabal new-run cookbook-basic-streaming client 10"
putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"
where
getit = S.SourceT $ \k -> do
k =<< readfilelazy "/home/joey/README.md"
readfilelazy :: FilePath -> IO (S.StepT IO BS.ByteString)
readfilelazy file = do
bl <- BL.readFile file
v <- newMVar (BL.toChunks bl)
return (go v)
where
go :: MVar [BS.ByteString] -> S.StepT IO BS.ByteString
go v = S.fromActionStep BS.null $ do
print "chunk"
modifyMVar v $ pure . \case
[] -> ([], BS.empty)
(b:bs) -> (bs, b)
gatherbytestring :: S.StepT IO BS.ByteString -> IO BL.ByteString
gatherbytestring x = do
l <- unsafeInterleaveIO $ go x
return l
where
go S.Stop = return BLI.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
BLI.Chunk v <$> unsafeInterleaveIO (go s)