dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-05-25 12:04:32 +00:00
Code Issues Packages Projects Releases Wiki Activity

xftp: add basic auth (#653)

Browse Source
This commit is contained in:
Evgeny Poberezkin
2023-02-24 13:40:26 +00:00
committed by GitHub
parent 202922bceb
commit 8c8a984c1c
7 changed files with 94 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/FileTransfer/Client.hs
+5 -3
View File
@@ -33,7 +33,8 @@ import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Protocol
( Protocol (..),
( BasicAuth,
Protocol (..),
ProtocolServer (..),
RecipientId,
SenderId,
@@ -128,9 +129,10 @@ createXFTPChunk ::
C.APrivateSignKey ->
FileInfo ->
NonEmpty C.APublicVerifyKey ->
Maybe BasicAuth ->
ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
createXFTPChunk c spKey file rsps =
sendXFTPCommand c spKey "" (FNEW file rsps) Nothing >>= \case
createXFTPChunk c spKey file rsps auth_ =
sendXFTPCommand c spKey "" (FNEW file rsps auth_) Nothing >>= \case
(FRSndIds sId rIds, body) -> noFile body (sId, rIds)
(r, _) -> throwError . PCEUnexpectedResponse $ bshow r
src/Simplex/FileTransfer/Client/Main.hs
+7 -7
View File
@@ -37,7 +37,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer)
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer, XFTPServerWithAuth)
import Simplex.Messaging.Server.CLI (getCliCommand')
import Simplex.Messaging.Util (ifM, whenM)
import System.Exit (exitFailure)
@@ -79,7 +79,7 @@ data SendOptions = SendOptions
{ filePath :: FilePath,
outputDir :: Maybe FilePath,
numRecipients :: Int,
xftpServers :: [XFTPServer],
xftpServers :: [XFTPServerWithAuth],
retryCount :: Int,
tempPath :: Maybe FilePath
}
@@ -113,7 +113,7 @@ data RandomFileOptions = RandomFileOptions
defaultRetryCount :: Int
defaultRetryCount = 3
defaultXFTPServers :: NonEmpty XFTPServer
defaultXFTPServers :: NonEmpty XFTPServerWithAuth
defaultXFTPServers = L.fromList ["xftp://vr0bXzm4iKkLvleRMxLznTS-lHjXEyXunxn_7VJckk4=@localhost:443"]
cliCommandP :: Parser CliCommand
@@ -275,14 +275,14 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
-- TODO unshuffle chunks
pure $ map snd sentChunks
where
uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServer -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServerWithAuth -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
uploadFileChunk a gen srvs (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do
(sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
xftpServer <- liftIO $ getXFTPServer gen srvs
ProtoServerWithAuth xftpServer auth <- liftIO $ getXFTPServer gen srvs
c <- withRetry retryCount $ getXFTPServerClient a xftpServer
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo $ L.map fst rKeys
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo (L.map fst rKeys) auth
withRetry retryCount $ uploadXFTPChunk c spKey sndId chunkSpec
let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
replicas = [SentFileChunkReplica {server = xftpServer, recipients}]
@@ -293,7 +293,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
hSeek h AbsoluteSeek $ fromIntegral chunkOffset
digest <- LC.sha512Hash <$> LB.hGet h (fromIntegral chunkSize)
pure FileInfo {sndKey, size = fromIntegral chunkSize, digest}
getXFTPServer :: TVar StdGen -> NonEmpty XFTPServer -> IO XFTPServer
getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
getXFTPServer gen = \case
srv :| [] -> pure srv
servers -> do
src/Simplex/FileTransfer/Protocol.hs
+5 -4
View File
@@ -31,7 +31,8 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol
( CommandError (..),
( BasicAuth,
CommandError (..),
Protocol (..),
ProtocolEncoding (..),
ProtocolErrorType (..),
@@ -157,7 +158,7 @@ instance Protocol XFTPErrorType FileResponse where
_ -> Nothing
data FileCommand (p :: FileParty) where
FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FPSender
FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
FPUT :: FileCommand FPSender
FDEL :: FileCommand FPSender
@@ -183,7 +184,7 @@ type XFTPFileId = ByteString
instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where
type Tag (FileCommand p) = FileCommandTag p
encodeProtocol _v = \case
FNEW file rKeys -> e (FNEW_, ' ', file, rKeys)
FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_)
FADD rKeys -> e (FADD_, ' ', rKeys)
FPUT -> e FPUT_
FDEL -> e FDEL_
@@ -220,7 +221,7 @@ instance ProtocolEncoding XFTPErrorType FileCmd where
protocolP _v = \case
FCT SSender tag ->
FileCmd SSender <$> case tag of
FNEW_ -> FNEW <$> _smpP <*> smpP
FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
FADD_ -> FADD <$> _smpP
FPUT_ -> pure FPUT
FDEL_ -> pure FDEL
src/Simplex/FileTransfer/Server.hs
+35 -23
View File
@@ -24,6 +24,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import qualified Data.Text as T
@@ -42,7 +43,7 @@ import Simplex.FileTransfer.Transport
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RecipientId)
import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicVerifyKey, RecipientId)
import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Stats
@@ -196,7 +197,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed
verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
verifyXFTPTransmission sig_ signed fId cmd =
case cmd of
FileCmd SSender (FNEW file rcps) -> pure $ XFTPReqNew file rcps `verifyWith` sndKey file
FileCmd SSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file
FileCmd SRecipient PING -> pure $ VRVerified XFTPReqPing
FileCmd party _ -> verifyCmd party
where
@@ -212,34 +213,45 @@ verifyXFTPTransmission sig_ signed fId cmd =
processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
processXFTPRequest HTTP2Body {bodyPart} = \case
XFTPReqNew file rcps -> do
st <- asks store
-- TODO validate body empty
-- TODO retry on duplicate IDs?
sId <- getFileId
rIds <- mapM (const getFileId) rcps
let rIdsKeys = L.zipWith FileRecipient rIds rcps
ts <- liftIO getSystemTime
withFileLog $ \sl -> do
logAddFile sl sId file ts
logAddRecipients sl sId rIdsKeys
r <- runExceptT $ do
ExceptT $ atomically $ addFile st sId file ts
forM rIdsKeys $ \rcp ->
ExceptT $ atomically $ addRecipient st sId rcp
noFile $ either FRErr (const $ FRSndIds sId rIds) r
XFTPReqNew file rcps auth ->
noFile
=<< ifM
allowNew
(createFile file rcps)
(pure $ FRErr AUTH)
where
allowNew = do
XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config
pure $ allowNewFiles && maybe True ((== auth) . Just) newFileBasicAuth
XFTPReqCmd fId fr (FileCmd _ cmd) -> case cmd of
FADD _rcps -> noFile FROk
FPUT -> (,Nothing) <$> receiveServerFile fr
FDEL -> (,Nothing) <$> deleteServerFile fr
FPUT -> noFile =<< receiveServerFile fr
FDEL -> noFile =<< deleteServerFile fr
FGET rDhKey -> sendServerFile fr rDhKey
FACK -> (,Nothing) <$> ackFileReception fId fr
-- it should never get to the options below, they are passed in other constructors of XFTPRequest
FNEW _ _ -> noFile $ FRErr INTERNAL
FACK -> noFile =<< ackFileReception fId fr
-- it should never get to the commands below, they are passed in other constructors of XFTPRequest
FNEW {} -> noFile $ FRErr INTERNAL
PING -> noFile FRPong
XFTPReqPing -> noFile FRPong
where
noFile resp = pure (resp, Nothing)
createFile :: FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
createFile file rcps = do
st <- asks store
-- TODO validate body empty
-- TODO retry on duplicate IDs?
sId <- getFileId
rIds <- mapM (const getFileId) rcps
let rIdsKeys = L.zipWith FileRecipient rIds rcps
ts <- liftIO getSystemTime
withFileLog $ \sl -> do
logAddFile sl sId file ts
logAddRecipients sl sId rIdsKeys
r <- runExceptT $ do
ExceptT $ atomically $ addFile st sId file ts
forM rIdsKeys $ \rcp ->
ExceptT $ atomically $ addRecipient st sId rcp
pure $ either FRErr (const $ FRSndIds sId rIds) r
receiveServerFile :: FileRec -> M FileResponse
receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of
-- TODO do not allow repeated file upload
src/Simplex/FileTransfer/Server/Env.hs
+1 -1
View File
@@ -87,6 +87,6 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
pure XFTPEnv {config, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
data XFTPRequest
= XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey)
= XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth)
| XFTPReqCmd XFTPFileId FileRec FileCmd
| XFTPReqPing
src/Simplex/Messaging/Protocol.hs
+4 -1
View File
@@ -76,6 +76,7 @@ module Simplex.Messaging.Protocol
pattern NtfServer,
XFTPServer,
pattern XFTPServer,
XFTPServerWithAuth,
ProtoServerWithAuth (..),
BasicAuth (..),
SrvLoc (..),
@@ -167,7 +168,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
import Simplex.Messaging.Util (bshow, (<$?>), eitherToMaybe)
import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>))
import Simplex.Messaging.Version
import Test.QuickCheck (Arbitrary (..))
@@ -632,6 +633,8 @@ pattern XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash
{-# COMPLETE XFTPServer #-}
type XFTPServerWithAuth = ProtoServerWithAuth 'PXFTP
sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
{-# INLINE sameSrvAddr' #-}