xftp-server: add inactiveClientExpiration (#936)

* xftp-server: add inactiveClientExpiration

* fix test config

* add test

* add xftpPing

* switch to PCEUnexpectedResponse

* remove watchdog when server quits

* rename, loop

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander BondarenkoandEvgeny Poberezkin authored and GitHub committed 2023-12-27 20:31:19 +00:00
1 parent bb4de2e63c
commit 7eb7bd5e81
7 files changed
+94 -16

No files matched your search

+18 -4
View File
@@ -132,11 +132,15 @@ xftpClientError = \case
HCIOError e -> PCEIOError e
sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
sendXFTPCommand c@XFTPClient {http2Client = HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
t <-
liftEither . first PCETransportError $
xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
let req = H.requestStreaming N.methodPost "/" [] $ streamBody t
sendXFTPTransmission c t chunkSpec_
sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
sendXFTPTransmission XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} t chunkSpec_ = do
let req = H.requestStreaming N.methodPost "/" [] streamBody
reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_
HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req reqTimeout
when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
@@ -148,8 +152,8 @@ sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}}
_ -> pure (r, body)
Left e -> throwError $ PCEResponseError e
where
streamBody :: ByteString -> (Builder -> IO ()) -> IO () -> IO ()
streamBody t send done = do
streamBody :: (Builder -> IO ()) -> IO () -> IO ()
streamBody send done = do
send $ byteString t
forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} ->
withFile filePath ReadMode $ \h -> do
@@ -207,6 +211,16 @@ deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okRes
ackXFTPChunk :: XFTPClient -> C.APrivateSignKey -> RecipientId -> ExceptT XFTPClientError IO ()
ackXFTPChunk c rpKey rId = sendXFTPCommand c rpKey rId FACK Nothing >>= okResponse
pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO ()
pingXFTP c@XFTPClient {http2Client = HTTP2Client {sessionId}} = do
t <-
liftEither . first PCETransportError $
xftpEncodeTransmission sessionId Nothing ("", "", FileCmd SFRecipient PING)
(r, _) <- sendXFTPTransmission c t Nothing
case r of
FRPong -> pure ()
_ -> throwError $ PCEUnexpectedResponse $ bshow r
okResponse :: (FileResponse, HTTP2Body) -> ExceptT XFTPClientError IO ()
okResponse = \case
(FROk, body) -> noFile body ()