mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-10 19:16:57 +00:00
sh
8833e5c1b5
* xftp: add PostgreSQL backend design spec
* update doc
* adjust styling
* add implementation plan
* refactor: move usedStorage from FileStore to XFTPEnv
* refactor: add getUsedStorage, getFileCount, expiredFiles store functions
* refactor: change file store operations from STM to IO
* refactor: extract FileStoreClass typeclass, move STM impl to Store.STM
* refactor: make XFTPEnv and server polymorphic over FileStoreClass
* feat: add PostgreSQL store skeleton with schema migration
* feat: implement PostgresFileStore operations
* feat: add PostgreSQL INI config, store dispatch, startup validation
* feat: add database import/export CLI commands
* test: add PostgreSQL backend tests
* fix: map ForeignKeyViolation to AUTH in addRecipient
When a file is concurrently deleted while addRecipient runs, the FK
constraint on recipients.sender_id raises ForeignKeyViolation. Previously
this propagated as INTERNAL; now it returns AUTH (file not found).
* fix: only decrement usedStorage for uploaded files on expiration
expireServerFiles unconditionally subtracted file_size from usedStorage
for every expired file, including files that were never uploaded (no
file_path). Since reserve only increments usedStorage during upload,
expiring never-uploaded files caused usedStorage to drift negative.
* fix: handle setFilePath error in receiveServerFile
setFilePath result was discarded with void. If it failed (file deleted
concurrently, or double-upload where file_path IS NULL guard rejected
the second write), the server still reported FROk, incremented stats,
and left usedStorage permanently inflated. Now the error is checked:
on failure, reserved storage is released and AUTH is returned.
* fix: escape double quotes in COPY CSV status field
The status field (e.g. "blocked,reason=spam,notice={...}") is quoted in
CSV for COPY protocol, but embedded double quotes from BlockingInfo
notice (JSON) were not escaped. This could break CSV parsing during
import. Now double quotes are escaped as "" per CSV spec.
* fix: reject upload to blocked file in Postgres setFilePath
In Postgres mode, getFile returns a snapshot TVar for fileStatus. If a
file is blocked between getFile and setFilePath, the stale status check
passes but the upload should be rejected. Added status = 'active' to
the UPDATE WHERE clause so blocked files cannot receive uploads.
* fix: add CHECK constraint on file_size > 0
Prevents negative or zero file_size values at the database level.
Without this, corrupted data from import or direct DB access could
cause incorrect storage accounting (getUsedStorage sums file_size,
and expiredFiles casts to Word32 which wraps negative values).
* fix: check for existing data before database import
importFileStore now checks if the target database already contains
files and aborts with an error. Previously, importing into a non-empty
database would fail mid-COPY on duplicate primary keys, leaving the
database in a partially imported state.
* fix: clean up disk file when setFilePath fails in receiveServerFile
When setFilePath fails (file deleted or blocked concurrently, or
duplicate upload), the uploaded file was left orphaned on disk with
no DB record pointing to it. Now the file is removed on failure,
matching the cleanup in the receiveChunk error path.
* fix: check storeAction result in deleteOrBlockServerFile_
The store action result (deleteFile/blockFile) was discarded with void.
If the DB row was already deleted by a concurrent operation, the
function still decremented usedStorage, causing drift. Now the error
propagates via ExceptT, skipping the usedStorage adjustment.
* fix: check deleteFile result in expireServerFiles
deleteFile result was discarded with void. If a concurrent delete
already removed the file, deleteFile returned AUTH but usedStorage
was still decremented — causing double-decrement drift. Now the
usedStorage adjustment and filesExpired stat only run on success.
* refactor: merge STM store into Store.hs, parameterize server tests
- Move STMFileStore and its FileStoreClass instance from Store/STM.hs
back into Store.hs — the separate file was unnecessary indirection
for the always-present default implementation.
- Parameterize xftpFileTests over store backend using HSpec SpecWith
pattern (following SMP's serverTests approach). The same 11 tests
now run against both memory and PostgreSQL backends via a bracket
parameter, eliminating all *Pg test duplicates.
- Extract shared run* functions (runTestFileChunkDeliveryAddRecipients,
runTestWrongChunkSize, runTestFileChunkExpiration, runTestFileStorageQuota)
from inlined test bodies.
* refactor: clean up per good-code review
- Remove internal helpers from Postgres.hs export list (withDB, withDB',
handleDuplicate, assertUpdated, withLog are not imported externally)
- Replace local isNothing_ with Data.Maybe.isNothing in Env.hs
- Consolidate duplicate/unused imports in XFTPStoreTests.hs
- Add file_path IS NULL and status guards to STM setFilePath, matching
the Postgres implementation semantics
* test: parameterize XFTP server, agent and CLI tests over store backend
- xftpTest/xftpTest2/xftpTest4/xftpTestN now take XFTPTestBracket as
first argument, enabling the same test to run against both memory
and PostgreSQL backends.
- xftpFileTests (server tests), xftpAgentFileTests (agent tests), and
xftpCLIFileTests (CLI tests) are SpecWith-parameterized suites that
receive the bracket from HSpec's before combinator.
- Test.hs runs each parameterized suite twice: once with
xftpMemoryBracket, once with xftpPostgresBracket (CPP-guarded).
- STM-specific tests (store log restore/replay) stay in memory-only
xftpAgentTests. SNI/CORS tests stay in memory-only xftpServerTests.
* refactor: remove dead test wrappers after parameterization
Remove old non-parameterized test wrapper functions that were
superseded by the store-backend-parameterized test suites.
All test bodies (run* and _ functions) are preserved and called
from the parameterized specs. Clean up unused imports.
* feat: add manual tests and guide
* refactor: merge file_size CHECK into initial migration
* refactor: extract rowToFileRec shared by getFile sender/recipient paths
* refactor: parameterize XFTPServerConfig over store type
Embed XFTPStoreConfig s as serverStoreCfg field, matching SMP's
ServerConfig. runXFTPServer and newXFTPServerEnv now take a single
XFTPServerConfig s. Restore verifyCmd local helper structure.
* refactor: minimize diff in tests
Restore xftpServerTests and xftpAgentTests bodies to match master
byte-for-byte (only type signatures change for XFTPTestBracket
parameterization); inline the runTestXXX helpers that were split
on this branch.
* refactor: restore getFile position to match master
* refactor: rename withSTMFile back to withFile
* refactor: close store log inside closeFileStore for STM backend
Move STM store log close responsibility into closeFileStore to
match PostgresFileStore, removing the asymmetry where only PG's
close was self-contained.
STMFileStore holds the log in a TVar populated by newXFTPServerEnv
after readWriteFileStore; stopServer no longer needs the explicit
withFileLog closeStoreLog call. Writes still go through XFTPEnv.storeLog
via withFileLog (unchanged).
* refactor: rename XFTPTestBracket to XFTPTestServer
* fix: move file_size check from PG schema to store log import
* refactor: use SQL-standard type names in XFTP schema
* perf: batch expired file deletions with deleteFiles
* refactor: stream export instead of loading recipients into memory
* refactor: parameterize XFTP store with FSType singleton dispatch
* refactor: minimize diff per review feedback
* refactor: use types over strings, deduplicate parser
* refactor: always parse database store type, fail at startup
* fix compilation without postgresql
* refactor: always parse database store type, fail at startup
3250 lines
128 KiB
Haskell
3250 lines
128 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
-- | Per-function tests for the xftp-web TypeScript XFTP client library.
|
|
-- Each test calls the Haskell function and the corresponding TypeScript function
|
|
-- via node, then asserts byte-identical output.
|
|
--
|
|
-- Prerequisites: cd xftp-web && npm install && npm run build
|
|
-- Run: cabal test --test-option=--match="/XFTP Web Client/"
|
|
module XFTPWebTests (xftpWebTests) where
|
|
|
|
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
|
|
import Control.Monad (replicateM, when)
|
|
import Crypto.Error (throwCryptoError)
|
|
import qualified Crypto.PubKey.Curve25519 as X25519
|
|
import qualified Crypto.PubKey.Ed25519 as Ed25519
|
|
import qualified Data.ByteArray as BA
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import Data.Int (Int64)
|
|
import Data.List (intercalate)
|
|
import qualified Data.List.NonEmpty as NE
|
|
import Data.Word (Word8, Word16, Word32)
|
|
import System.Random (randomIO)
|
|
import Data.X509.Validation (Fingerprint (..))
|
|
import Simplex.FileTransfer.Client (prepareChunkSizes)
|
|
import Simplex.FileTransfer.Client.Main (decodeWebURI, encodeWebURI)
|
|
import Simplex.FileTransfer.Description (FileDescription (..), FileSize (..), ValidFileDescription, pattern ValidFileDescription)
|
|
import Simplex.FileTransfer.Protocol (FileParty (..), xftpBlockSize)
|
|
import Simplex.FileTransfer.Transport (XFTPClientHello (..))
|
|
import Simplex.FileTransfer.Types (FileHeader (..))
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
|
import Simplex.Messaging.Encoding
|
|
import Simplex.Messaging.Encoding.String (strDecode, strEncode)
|
|
import Simplex.Messaging.Transport.Server (loadFileFingerprint)
|
|
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive)
|
|
import System.Environment (getEnvironment)
|
|
import System.Exit (ExitCode (..))
|
|
import System.Process (CreateProcess (..), StdStream (..), createProcess, proc, waitForProcess)
|
|
import Test.Hspec hiding (fit, it)
|
|
import Util
|
|
import Simplex.FileTransfer.Server.Env (XFTPServerConfig)
|
|
import Simplex.FileTransfer.Server.Store (STMFileStore)
|
|
import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpTestPort)
|
|
import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAgent)
|
|
import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpSendFile, xftpStartWorkers)
|
|
import Simplex.Messaging.Agent.Protocol (AEvent (..))
|
|
import SMPAgentClient (agentCfg, initAgentServers, testDB)
|
|
import XFTPCLI (recipientFiles, senderFiles, testBracket)
|
|
import qualified Simplex.Messaging.Crypto.File as CF
|
|
|
|
xftpWebDir :: FilePath
|
|
xftpWebDir = "xftp-web"
|
|
|
|
-- | Redirect console.log/warn to stderr so library debug output doesn't pollute stdout binary data.
|
|
redirectConsole :: String
|
|
redirectConsole = "console.log = console.warn = (...a) => process.stderr.write(a.map(String).join(' ') + '\\n');"
|
|
|
|
-- | Run an inline ES module script via node, return stdout as ByteString.
|
|
callNode :: String -> IO B.ByteString
|
|
callNode script = do
|
|
baseEnv <- getEnvironment
|
|
let nodeEnv = ("NODE_TLS_REJECT_UNAUTHORIZED", "0") : baseEnv
|
|
(_, Just hout, Just herr, ph) <-
|
|
createProcess
|
|
(proc "node" ["--input-type=module", "-e", redirectConsole <> script])
|
|
{ std_out = CreatePipe,
|
|
std_err = CreatePipe,
|
|
cwd = Just xftpWebDir,
|
|
env = Just nodeEnv
|
|
}
|
|
errVar <- newEmptyMVar
|
|
_ <- forkIO $ B.hGetContents herr >>= putMVar errVar
|
|
out <- B.hGetContents hout
|
|
err <- takeMVar errVar
|
|
ec <- waitForProcess ph
|
|
when (ec /= ExitSuccess) $
|
|
expectationFailure $
|
|
"node " <> show ec <> "\nstderr: " <> map (toEnum . fromIntegral) (B.unpack err)
|
|
pure out
|
|
|
|
-- | Format a ByteString as a JS Uint8Array constructor.
|
|
jsUint8 :: B.ByteString -> String
|
|
jsUint8 bs = "new Uint8Array([" <> intercalate "," (map show (B.unpack bs)) <> "])"
|
|
|
|
-- Import helpers for inline scripts.
|
|
impEnc, impPad, impDig, impKey, impSb :: String
|
|
impEnc = "import * as E from './dist/protocol/encoding.js';"
|
|
impPad = "import * as P from './dist/crypto/padding.js';"
|
|
impDig =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as D from './dist/crypto/digest.js';"
|
|
<> "await sodium.ready;"
|
|
impKey =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as K from './dist/crypto/keys.js';"
|
|
<> "await sodium.ready;"
|
|
impSb =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as S from './dist/crypto/secretbox.js';"
|
|
<> "await sodium.ready;"
|
|
impFile :: String
|
|
impFile =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as F from './dist/crypto/file.js';"
|
|
<> "await sodium.ready;"
|
|
impCmd :: String
|
|
impCmd =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as E from './dist/protocol/encoding.js';"
|
|
<> "import * as Cmd from './dist/protocol/commands.js';"
|
|
<> "await sodium.ready;"
|
|
impTx :: String
|
|
impTx =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as E from './dist/protocol/encoding.js';"
|
|
<> "import * as K from './dist/crypto/keys.js';"
|
|
<> "import * as Tx from './dist/protocol/transmission.js';"
|
|
<> "await sodium.ready;"
|
|
impHs :: String
|
|
impHs =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as E from './dist/protocol/encoding.js';"
|
|
<> "import * as K from './dist/crypto/keys.js';"
|
|
<> "import * as Hs from './dist/protocol/handshake.js';"
|
|
<> "await sodium.ready;"
|
|
impId :: String
|
|
impId =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as E from './dist/protocol/encoding.js';"
|
|
<> "import * as K from './dist/crypto/keys.js';"
|
|
<> "import * as Id from './dist/crypto/identity.js';"
|
|
<> "await sodium.ready;"
|
|
impDesc :: String
|
|
impDesc = "import * as Desc from './dist/protocol/description.js';"
|
|
impChk :: String
|
|
impChk =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as Desc from './dist/protocol/description.js';"
|
|
<> "import * as Chk from './dist/protocol/chunks.js';"
|
|
<> "await sodium.ready;"
|
|
impCli :: String
|
|
impCli =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as K from './dist/crypto/keys.js';"
|
|
<> "import * as Cli from './dist/protocol/client.js';"
|
|
<> "await sodium.ready;"
|
|
impDl :: String
|
|
impDl =
|
|
"import sodium from 'libsodium-wrappers-sumo';"
|
|
<> "import * as K from './dist/crypto/keys.js';"
|
|
<> "import * as F from './dist/crypto/file.js';"
|
|
<> "import * as Cli from './dist/protocol/client.js';"
|
|
<> "import * as Dl from './dist/download.js';"
|
|
<> "import * as Cmd from './dist/protocol/commands.js';"
|
|
<> "import * as Tx from './dist/protocol/transmission.js';"
|
|
<> "await sodium.ready;"
|
|
|
|
impAddr :: String
|
|
impAddr = "import * as Addr from './dist/protocol/address.js';"
|
|
|
|
-- | Wrap expression in process.stdout.write(Buffer.from(...)).
|
|
jsOut :: String -> String
|
|
jsOut expr = "process.stdout.write(Buffer.from(" <> expr <> "));"
|
|
|
|
xftpWebTests :: IO () -> Spec
|
|
xftpWebTests dbCleanup = do
|
|
distExists <- runIO $ doesDirectoryExist (xftpWebDir <> "/dist")
|
|
if distExists
|
|
then do
|
|
tsEncodingTests
|
|
tsPaddingTests
|
|
tsDigestTests
|
|
tsKeyTests
|
|
tsSecretboxTests
|
|
tsFileCryptoTests
|
|
tsCommandTests
|
|
tsTransmissionTests
|
|
tsHandshakeTests
|
|
tsIdentityTests
|
|
tsDescriptionTests
|
|
tsChunkTests
|
|
tsClientTests
|
|
tsDownloadTests
|
|
tsAddressTests
|
|
tsIntegrationTests dbCleanup
|
|
else
|
|
it "skipped (run 'cd xftp-web && npm install && npm run build' first)" $
|
|
pendingWith "TS project not compiled"
|
|
|
|
-- ── protocol/encoding ──────────────────────────────────────────────
|
|
|
|
tsEncodingTests :: Spec
|
|
tsEncodingTests = describe "protocol/encoding" $ do
|
|
describe "encode" $ do
|
|
it "encodeWord16" $ do
|
|
let val = 42 :: Word16
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeWord16(" <> show val <> ")")
|
|
actual `shouldBe` smpEncode val
|
|
|
|
it "encodeWord16 max" $ do
|
|
let val = 65535 :: Word16
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeWord16(" <> show val <> ")")
|
|
actual `shouldBe` smpEncode val
|
|
|
|
it "encodeWord32" $ do
|
|
let val = 100000 :: Word32
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeWord32(" <> show val <> ")")
|
|
actual `shouldBe` smpEncode val
|
|
|
|
it "encodeInt64" $ do
|
|
let val = 1234567890123456789 :: Int64
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeInt64(" <> show val <> "n)")
|
|
actual `shouldBe` smpEncode val
|
|
|
|
it "encodeInt64 negative" $ do
|
|
let val = -42 :: Int64
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeInt64(" <> show val <> "n)")
|
|
actual `shouldBe` smpEncode val
|
|
|
|
it "encodeInt64 zero" $ do
|
|
let val = 0 :: Int64
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeInt64(" <> show val <> "n)")
|
|
actual `shouldBe` smpEncode val
|
|
|
|
it "encodeBytes" $ do
|
|
let val = "hello" :: B.ByteString
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeBytes(" <> jsUint8 val <> ")")
|
|
actual `shouldBe` smpEncode val
|
|
|
|
it "encodeBytes empty" $ do
|
|
let val = "" :: B.ByteString
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeBytes(" <> jsUint8 val <> ")")
|
|
actual `shouldBe` smpEncode val
|
|
|
|
it "encodeLarge" $ do
|
|
let val = "test data for large encoding" :: B.ByteString
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeLarge(" <> jsUint8 val <> ")")
|
|
actual `shouldBe` smpEncode (Large val)
|
|
|
|
it "encodeTail" $ do
|
|
let val = "raw tail bytes" :: B.ByteString
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeTail(" <> jsUint8 val <> ")")
|
|
actual `shouldBe` smpEncode (Tail val)
|
|
|
|
it "encodeBool True" $ do
|
|
actual <- callNode $ impEnc <> jsOut "E.encodeBool(true)"
|
|
actual `shouldBe` smpEncode True
|
|
|
|
it "encodeBool False" $ do
|
|
actual <- callNode $ impEnc <> jsOut "E.encodeBool(false)"
|
|
actual `shouldBe` smpEncode False
|
|
|
|
it "encodeString" $ do
|
|
let val = "hello" :: String
|
|
actual <- callNode $ impEnc <> jsOut "E.encodeString('hello')"
|
|
actual `shouldBe` smpEncode val
|
|
|
|
it "encodeMaybe Nothing" $ do
|
|
actual <- callNode $ impEnc <> jsOut "E.encodeMaybe(E.encodeBytes, null)"
|
|
actual `shouldBe` smpEncode (Nothing :: Maybe B.ByteString)
|
|
|
|
it "encodeMaybe Just" $ do
|
|
let val = "hello" :: B.ByteString
|
|
actual <- callNode $ impEnc <> jsOut ("E.encodeMaybe(E.encodeBytes, " <> jsUint8 val <> ")")
|
|
actual `shouldBe` smpEncode (Just val)
|
|
|
|
it "encodeList" $ do
|
|
let vals = ["ab", "cd", "ef"] :: [B.ByteString]
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const xs = ["
|
|
<> intercalate "," (map jsUint8 vals)
|
|
<> "];"
|
|
<> jsOut "E.encodeList(E.encodeBytes, xs)"
|
|
actual `shouldBe` smpEncodeList vals
|
|
|
|
it "encodeList empty" $ do
|
|
let vals = [] :: [B.ByteString]
|
|
actual <-
|
|
callNode $
|
|
impEnc <> jsOut "E.encodeList(E.encodeBytes, [])"
|
|
actual `shouldBe` smpEncodeList vals
|
|
|
|
it "encodeNonEmpty" $ do
|
|
let vals = ["ab", "cd"] :: [B.ByteString]
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const xs = ["
|
|
<> intercalate "," (map jsUint8 vals)
|
|
<> "];"
|
|
<> jsOut "E.encodeNonEmpty(E.encodeBytes, xs)"
|
|
actual `shouldBe` smpEncode (NE.fromList vals)
|
|
|
|
describe "decode round-trips" $ do
|
|
it "decodeWord16" $ do
|
|
let encoded = smpEncode (42 :: Word16)
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeWord16(E.decodeWord16(d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeWord32" $ do
|
|
let encoded = smpEncode (100000 :: Word32)
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeWord32(E.decodeWord32(d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeInt64" $ do
|
|
let encoded = smpEncode (1234567890123456789 :: Int64)
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeInt64(E.decodeInt64(d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeInt64 negative" $ do
|
|
let encoded = smpEncode (-42 :: Int64)
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeInt64(E.decodeInt64(d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeBytes" $ do
|
|
let encoded = smpEncode ("hello" :: B.ByteString)
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeBytes(E.decodeBytes(d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeLarge" $ do
|
|
let encoded = smpEncode (Large "large data")
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeLarge(E.decodeLarge(d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeBool" $ do
|
|
let encoded = smpEncode True
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeBool(E.decodeBool(d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeString" $ do
|
|
let encoded = smpEncode ("hello" :: String)
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeString(E.decodeString(d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeMaybe Just" $ do
|
|
let encoded = smpEncode (Just ("hello" :: B.ByteString))
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeMaybe(E.encodeBytes, E.decodeMaybe(E.decodeBytes, d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeMaybe Nothing" $ do
|
|
let encoded = smpEncode (Nothing :: Maybe B.ByteString)
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeMaybe(E.encodeBytes, E.decodeMaybe(E.decodeBytes, d))"
|
|
actual `shouldBe` encoded
|
|
|
|
it "decodeList" $ do
|
|
let encoded = smpEncodeList (["ab", "cd", "ef"] :: [B.ByteString])
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "E.encodeList(E.encodeBytes, E.decodeList(E.decodeBytes, d))"
|
|
actual `shouldBe` encoded
|
|
|
|
-- ── crypto/padding ─────────────────────────────────────────────────
|
|
|
|
tsPaddingTests :: Spec
|
|
tsPaddingTests = describe "crypto/padding" $ do
|
|
it "pad" $ do
|
|
let msg = "hello" :: B.ByteString
|
|
paddedLen = 256 :: Int
|
|
expected = either (error . show) id $ C.pad msg paddedLen
|
|
actual <- callNode $ impPad <> jsOut ("P.pad(" <> jsUint8 msg <> ", " <> show paddedLen <> ")")
|
|
actual `shouldBe` expected
|
|
|
|
it "pad minimal" $ do
|
|
let msg = "ab" :: B.ByteString
|
|
paddedLen = 16 :: Int
|
|
expected = either (error . show) id $ C.pad msg paddedLen
|
|
actual <- callNode $ impPad <> jsOut ("P.pad(" <> jsUint8 msg <> ", " <> show paddedLen <> ")")
|
|
actual `shouldBe` expected
|
|
|
|
it "Haskell pad -> TS unPad" $ do
|
|
let msg = "cross-language test" :: B.ByteString
|
|
paddedLen = 128 :: Int
|
|
padded = either (error . show) id $ C.pad msg paddedLen
|
|
actual <- callNode $ impPad <> jsOut ("P.unPad(" <> jsUint8 padded <> ")")
|
|
actual `shouldBe` msg
|
|
|
|
it "TS pad -> Haskell unPad" $ do
|
|
let msg = "ts to haskell" :: B.ByteString
|
|
paddedLen = 64 :: Int
|
|
tsPadded <- callNode $ impPad <> jsOut ("P.pad(" <> jsUint8 msg <> ", " <> show paddedLen <> ")")
|
|
let actual = either (error . show) id $ C.unPad tsPadded
|
|
actual `shouldBe` msg
|
|
|
|
it "padLazy" $ do
|
|
let msg = "hello" :: B.ByteString
|
|
msgLen = fromIntegral (B.length msg) :: Int64
|
|
paddedLen = 64 :: Int64
|
|
expected = either (error . show) id $ LC.pad (LB.fromStrict msg) msgLen paddedLen
|
|
actual <-
|
|
callNode $
|
|
impPad <> jsOut ("P.padLazy(" <> jsUint8 msg <> ", " <> show msgLen <> "n, " <> show paddedLen <> "n)")
|
|
actual `shouldBe` LB.toStrict expected
|
|
|
|
it "Haskell padLazy -> TS unPadLazy" $ do
|
|
let msg = "cross-language lazy" :: B.ByteString
|
|
msgLen = fromIntegral (B.length msg) :: Int64
|
|
paddedLen = 64 :: Int64
|
|
padded = either (error . show) id $ LC.pad (LB.fromStrict msg) msgLen paddedLen
|
|
actual <- callNode $ impPad <> jsOut ("P.unPadLazy(" <> jsUint8 (LB.toStrict padded) <> ")")
|
|
actual `shouldBe` msg
|
|
|
|
it "TS padLazy -> Haskell unPadLazy" $ do
|
|
let msg = "ts to haskell lazy" :: B.ByteString
|
|
msgLen = fromIntegral (B.length msg) :: Int64
|
|
paddedLen = 128 :: Int64
|
|
tsPadded <-
|
|
callNode $
|
|
impPad <> jsOut ("P.padLazy(" <> jsUint8 msg <> ", " <> show msgLen <> "n, " <> show paddedLen <> "n)")
|
|
let actual = either (error . show) id $ LC.unPad (LB.fromStrict tsPadded)
|
|
actual `shouldBe` LB.fromStrict msg
|
|
|
|
it "splitLen" $ do
|
|
let msg = "test content" :: B.ByteString
|
|
msgLen = fromIntegral (B.length msg) :: Int64
|
|
paddedLen = 64 :: Int64
|
|
padded = either (error . show) id $ LC.pad (LB.fromStrict msg) msgLen paddedLen
|
|
actual <-
|
|
callNode $
|
|
impEnc
|
|
<> impPad
|
|
<> "const r = P.splitLen("
|
|
<> jsUint8 (LB.toStrict padded)
|
|
<> ");"
|
|
<> "const len = E.encodeInt64(r.len);"
|
|
<> jsOut "E.concatBytes(len, r.content)"
|
|
let (expectedLen, expectedContent) = either (error . show) id $ LC.splitLen padded
|
|
expectedBytes = smpEncode expectedLen <> LB.toStrict expectedContent
|
|
actual `shouldBe` expectedBytes
|
|
|
|
-- ── crypto/digest ──────────────────────────────────────────────────
|
|
|
|
tsDigestTests :: Spec
|
|
tsDigestTests = describe "crypto/digest" $ do
|
|
it "sha256" $ do
|
|
let input = "hello world" :: B.ByteString
|
|
actual <- callNode $ impDig <> jsOut ("D.sha256(" <> jsUint8 input <> ")")
|
|
actual `shouldBe` C.sha256Hash input
|
|
|
|
it "sha256 empty" $ do
|
|
let input = "" :: B.ByteString
|
|
actual <- callNode $ impDig <> jsOut ("D.sha256(" <> jsUint8 input <> ")")
|
|
actual `shouldBe` C.sha256Hash input
|
|
|
|
it "sha512" $ do
|
|
let input = "hello world" :: B.ByteString
|
|
actual <- callNode $ impDig <> jsOut ("D.sha512(" <> jsUint8 input <> ")")
|
|
actual `shouldBe` C.sha512Hash input
|
|
|
|
it "sha512 empty" $ do
|
|
let input = "" :: B.ByteString
|
|
actual <- callNode $ impDig <> jsOut ("D.sha512(" <> jsUint8 input <> ")")
|
|
actual `shouldBe` C.sha512Hash input
|
|
|
|
it "sha256 binary" $ do
|
|
let input = B.pack [0, 1, 2, 255, 254, 128]
|
|
actual <- callNode $ impDig <> jsOut ("D.sha256(" <> jsUint8 input <> ")")
|
|
actual `shouldBe` C.sha256Hash input
|
|
|
|
-- ── crypto/keys ──────────────────────────────────────────────────
|
|
|
|
tsKeyTests :: Spec
|
|
tsKeyTests = describe "crypto/keys" $ do
|
|
describe "DER encoding" $ do
|
|
it "encodePubKeyEd25519" $ do
|
|
let rawPub = B.pack [1 .. 32]
|
|
derPrefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70, 0x03, 0x21, 0x00]
|
|
expectedDer = derPrefix <> rawPub
|
|
actual <- callNode $ impKey <> jsOut ("K.encodePubKeyEd25519(" <> jsUint8 rawPub <> ")")
|
|
actual `shouldBe` expectedDer
|
|
|
|
it "decodePubKeyEd25519" $ do
|
|
let rawPub = B.pack [1 .. 32]
|
|
derPrefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70, 0x03, 0x21, 0x00]
|
|
der = derPrefix <> rawPub
|
|
actual <- callNode $ impKey <> jsOut ("K.decodePubKeyEd25519(" <> jsUint8 der <> ")")
|
|
actual `shouldBe` rawPub
|
|
|
|
it "encodePubKeyX25519" $ do
|
|
let rawPub = B.pack [1 .. 32]
|
|
derPrefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x6e, 0x03, 0x21, 0x00]
|
|
expectedDer = derPrefix <> rawPub
|
|
actual <- callNode $ impKey <> jsOut ("K.encodePubKeyX25519(" <> jsUint8 rawPub <> ")")
|
|
actual `shouldBe` expectedDer
|
|
|
|
it "encodePrivKeyEd25519" $ do
|
|
let seed = B.pack [1 .. 32]
|
|
derPrefix = B.pack [0x30, 0x2e, 0x02, 0x01, 0x00, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70, 0x04, 0x22, 0x04, 0x20]
|
|
expectedDer = derPrefix <> seed
|
|
actual <-
|
|
callNode $
|
|
impKey
|
|
<> "const kp = K.ed25519KeyPairFromSeed("
|
|
<> jsUint8 seed
|
|
<> ");"
|
|
<> jsOut "K.encodePrivKeyEd25519(kp.privateKey)"
|
|
actual `shouldBe` expectedDer
|
|
|
|
it "encodePrivKeyX25519" $ do
|
|
let rawPriv = B.pack [1 .. 32]
|
|
derPrefix = B.pack [0x30, 0x2e, 0x02, 0x01, 0x00, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x6e, 0x04, 0x22, 0x04, 0x20]
|
|
expectedDer = derPrefix <> rawPriv
|
|
actual <- callNode $ impKey <> jsOut ("K.encodePrivKeyX25519(" <> jsUint8 rawPriv <> ")")
|
|
actual `shouldBe` expectedDer
|
|
|
|
it "DER round-trip Ed25519 pubkey" $ do
|
|
actual <-
|
|
callNode $
|
|
impKey
|
|
<> "const kp = K.generateEd25519KeyPair();"
|
|
<> "const der = K.encodePubKeyEd25519(kp.publicKey);"
|
|
<> "const decoded = K.decodePubKeyEd25519(der);"
|
|
<> "const match = decoded.length === kp.publicKey.length && decoded.every((b,i) => b === kp.publicKey[i]);"
|
|
<> jsOut "new Uint8Array([match ? 1 : 0])"
|
|
actual `shouldBe` B.pack [1]
|
|
|
|
it "encodePubKeyEd25519 matches Haskell" $ do
|
|
let seed = B.pack [1 .. 32]
|
|
sk = throwCryptoError $ Ed25519.secretKey seed
|
|
pk = Ed25519.toPublic sk
|
|
rawPub = BA.convert pk :: B.ByteString
|
|
haskellDer = C.encodePubKey (C.PublicKeyEd25519 pk)
|
|
tsDer <- callNode $ impKey <> jsOut ("K.encodePubKeyEd25519(" <> jsUint8 rawPub <> ")")
|
|
tsDer `shouldBe` haskellDer
|
|
|
|
it "encodePubKeyX25519 matches Haskell" $ do
|
|
let rawPriv = B.pack [1 .. 32]
|
|
sk = throwCryptoError $ X25519.secretKey rawPriv
|
|
pk = X25519.toPublic sk
|
|
rawPub = BA.convert pk :: B.ByteString
|
|
haskellDer = C.encodePubKey (C.PublicKeyX25519 pk)
|
|
tsDer <- callNode $ impKey <> jsOut ("K.encodePubKeyX25519(" <> jsUint8 rawPub <> ")")
|
|
tsDer `shouldBe` haskellDer
|
|
|
|
it "encodePrivKeyEd25519 matches Haskell" $ do
|
|
let seed = B.pack [1 .. 32]
|
|
sk = throwCryptoError $ Ed25519.secretKey seed
|
|
haskellDer = C.encodePrivKey (C.PrivateKeyEd25519 sk)
|
|
tsDer <-
|
|
callNode $
|
|
impKey
|
|
<> "const kp = K.ed25519KeyPairFromSeed("
|
|
<> jsUint8 seed
|
|
<> ");"
|
|
<> jsOut "K.encodePrivKeyEd25519(kp.privateKey)"
|
|
tsDer `shouldBe` haskellDer
|
|
|
|
it "encodePrivKeyX25519 matches Haskell" $ do
|
|
let rawPriv = B.pack [1 .. 32]
|
|
sk = throwCryptoError $ X25519.secretKey rawPriv
|
|
haskellDer = C.encodePrivKey (C.PrivateKeyX25519 sk)
|
|
tsDer <- callNode $ impKey <> jsOut ("K.encodePrivKeyX25519(" <> jsUint8 rawPriv <> ")")
|
|
tsDer `shouldBe` haskellDer
|
|
|
|
describe "Ed25519 sign/verify" $ do
|
|
it "sign determinism" $ do
|
|
let seed = B.pack [1 .. 32]
|
|
sk = throwCryptoError $ Ed25519.secretKey seed
|
|
pk = Ed25519.toPublic sk
|
|
msg = "deterministic test" :: B.ByteString
|
|
sig = Ed25519.sign sk pk msg
|
|
rawSig = BA.convert sig :: B.ByteString
|
|
actual <-
|
|
callNode $
|
|
impKey
|
|
<> "const kp = K.ed25519KeyPairFromSeed("
|
|
<> jsUint8 seed
|
|
<> ");"
|
|
<> jsOut ("K.sign(kp.privateKey, " <> jsUint8 msg <> ")")
|
|
actual `shouldBe` rawSig
|
|
|
|
it "Haskell sign -> TS verify" $ do
|
|
let seed = B.pack [1 .. 32]
|
|
sk = throwCryptoError $ Ed25519.secretKey seed
|
|
pk = Ed25519.toPublic sk
|
|
msg = "cross-language sign test" :: B.ByteString
|
|
sig = Ed25519.sign sk pk msg
|
|
rawPub = BA.convert pk :: B.ByteString
|
|
rawSig = BA.convert sig :: B.ByteString
|
|
actual <-
|
|
callNode $
|
|
impKey
|
|
<> "const ok = K.verify("
|
|
<> jsUint8 rawPub
|
|
<> ", "
|
|
<> jsUint8 rawSig
|
|
<> ", "
|
|
<> jsUint8 msg
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([ok ? 1 : 0])"
|
|
actual `shouldBe` B.pack [1]
|
|
|
|
it "TS sign -> Haskell verify" $ do
|
|
let seed = B.pack [1 .. 32]
|
|
sk = throwCryptoError $ Ed25519.secretKey seed
|
|
pk = Ed25519.toPublic sk
|
|
msg = "ts-to-haskell sign" :: B.ByteString
|
|
rawSig <-
|
|
callNode $
|
|
impKey
|
|
<> "const kp = K.ed25519KeyPairFromSeed("
|
|
<> jsUint8 seed
|
|
<> ");"
|
|
<> jsOut ("K.sign(kp.privateKey, " <> jsUint8 msg <> ")")
|
|
let sig = throwCryptoError $ Ed25519.signature rawSig
|
|
Ed25519.verify pk msg sig `shouldBe` True
|
|
|
|
it "verify rejects wrong message" $ do
|
|
let seed = B.pack [1 .. 32]
|
|
sk = throwCryptoError $ Ed25519.secretKey seed
|
|
pk = Ed25519.toPublic sk
|
|
msg = "original message" :: B.ByteString
|
|
wrongMsg = "wrong message" :: B.ByteString
|
|
sig = Ed25519.sign sk pk msg
|
|
rawPub = BA.convert pk :: B.ByteString
|
|
rawSig = BA.convert sig :: B.ByteString
|
|
actual <-
|
|
callNode $
|
|
impKey
|
|
<> "const ok = K.verify("
|
|
<> jsUint8 rawPub
|
|
<> ", "
|
|
<> jsUint8 rawSig
|
|
<> ", "
|
|
<> jsUint8 wrongMsg
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([ok ? 1 : 0])"
|
|
actual `shouldBe` B.pack [0]
|
|
|
|
describe "X25519 DH" $ do
|
|
it "DH cross-language" $ do
|
|
let seed1 = B.pack [1 .. 32]
|
|
seed2 = B.pack [33 .. 64]
|
|
sk1 = throwCryptoError $ X25519.secretKey seed1
|
|
sk2 = throwCryptoError $ X25519.secretKey seed2
|
|
pk2 = X25519.toPublic sk2
|
|
dhHs = X25519.dh pk2 sk1
|
|
rawPk2 = BA.convert pk2 :: B.ByteString
|
|
rawDh = BA.convert dhHs :: B.ByteString
|
|
actual <-
|
|
callNode $
|
|
impKey <> jsOut ("K.dh(" <> jsUint8 rawPk2 <> ", " <> jsUint8 seed1 <> ")")
|
|
actual `shouldBe` rawDh
|
|
|
|
it "DH commutativity" $ do
|
|
let seed1 = B.pack [1 .. 32]
|
|
seed2 = B.pack [33 .. 64]
|
|
sk1 = throwCryptoError $ X25519.secretKey seed1
|
|
pk1 = X25519.toPublic sk1
|
|
sk2 = throwCryptoError $ X25519.secretKey seed2
|
|
pk2 = X25519.toPublic sk2
|
|
rawPk1 = BA.convert pk1 :: B.ByteString
|
|
rawPk2 = BA.convert pk2 :: B.ByteString
|
|
dh1 <-
|
|
callNode $
|
|
impKey <> jsOut ("K.dh(" <> jsUint8 rawPk2 <> ", " <> jsUint8 seed1 <> ")")
|
|
dh2 <-
|
|
callNode $
|
|
impKey <> jsOut ("K.dh(" <> jsUint8 rawPk1 <> ", " <> jsUint8 seed2 <> ")")
|
|
dh1 `shouldBe` dh2
|
|
|
|
describe "keyHash" $ do
|
|
it "keyHash matches Haskell sha256Hash of DER" $ do
|
|
let rawPub = B.pack [1 .. 32]
|
|
derPrefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70, 0x03, 0x21, 0x00]
|
|
der = derPrefix <> rawPub
|
|
expectedHash = C.sha256Hash der
|
|
actual <-
|
|
callNode $
|
|
impKey
|
|
<> "const der = K.encodePubKeyEd25519("
|
|
<> jsUint8 rawPub
|
|
<> ");"
|
|
<> jsOut "K.keyHash(der)"
|
|
actual `shouldBe` expectedHash
|
|
|
|
-- ── crypto/secretbox ──────────────────────────────────────────────
|
|
|
|
tsSecretboxTests :: Spec
|
|
tsSecretboxTests = describe "crypto/secretbox" $ do
|
|
let key32 = B.pack [1 .. 32]
|
|
nonce24 = B.pack [1 .. 24]
|
|
cbNonceVal = C.cbNonce nonce24
|
|
sbKeyVal = C.unsafeSbKey key32
|
|
|
|
describe "NaCl secretbox (tag prepended)" $ do
|
|
it "cbEncrypt matches Haskell sbEncrypt_" $ do
|
|
let msg = "hello NaCl secretbox" :: B.ByteString
|
|
paddedLen = 256 :: Int
|
|
hsResult = either (error . show) id $ C.sbEncrypt_ key32 cbNonceVal msg paddedLen
|
|
tsResult <-
|
|
callNode $
|
|
impSb <> jsOut ("S.cbEncrypt(" <> jsUint8 key32 <> "," <> jsUint8 nonce24 <> "," <> jsUint8 msg <> "," <> show paddedLen <> ")")
|
|
tsResult `shouldBe` hsResult
|
|
|
|
it "Haskell sbEncrypt_ -> TS cbDecrypt" $ do
|
|
let msg = "cross-language decrypt" :: B.ByteString
|
|
paddedLen = 128 :: Int
|
|
cipher = either (error . show) id $ C.sbEncrypt_ key32 cbNonceVal msg paddedLen
|
|
tsResult <-
|
|
callNode $
|
|
impSb <> jsOut ("S.cbDecrypt(" <> jsUint8 key32 <> "," <> jsUint8 nonce24 <> "," <> jsUint8 cipher <> ")")
|
|
tsResult `shouldBe` msg
|
|
|
|
it "TS cbEncrypt -> Haskell sbDecrypt_" $ do
|
|
let msg = "ts-to-haskell NaCl" :: B.ByteString
|
|
paddedLen = 64 :: Int
|
|
tsCipher <-
|
|
callNode $
|
|
impSb <> jsOut ("S.cbEncrypt(" <> jsUint8 key32 <> "," <> jsUint8 nonce24 <> "," <> jsUint8 msg <> "," <> show paddedLen <> ")")
|
|
let hsResult = either (error . show) id $ C.sbDecrypt_ key32 cbNonceVal tsCipher
|
|
hsResult `shouldBe` msg
|
|
|
|
describe "streaming tail-tag" $ do
|
|
it "sbEncryptTailTag matches Haskell" $ do
|
|
let msg = "hello streaming" :: B.ByteString
|
|
msgLen = fromIntegral (B.length msg) :: Int64
|
|
paddedLen = 64 :: Int64
|
|
hsResult =
|
|
either (error . show) id $
|
|
LC.sbEncryptTailTag sbKeyVal cbNonceVal (LB.fromStrict msg) msgLen paddedLen
|
|
tsResult <-
|
|
callNode $
|
|
impSb
|
|
<> jsOut
|
|
( "S.sbEncryptTailTag("
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 msg
|
|
<> ","
|
|
<> show msgLen
|
|
<> "n,"
|
|
<> show paddedLen
|
|
<> "n)"
|
|
)
|
|
tsResult `shouldBe` LB.toStrict hsResult
|
|
|
|
it "Haskell encrypt -> TS decrypt (tail tag)" $ do
|
|
let msg = "haskell-to-ts streaming" :: B.ByteString
|
|
msgLen = fromIntegral (B.length msg) :: Int64
|
|
paddedLen = 128 :: Int64
|
|
cipher =
|
|
either (error . show) id $
|
|
LC.sbEncryptTailTag sbKeyVal cbNonceVal (LB.fromStrict msg) msgLen paddedLen
|
|
tsResult <-
|
|
callNode $
|
|
impSb
|
|
<> "const r = S.sbDecryptTailTag("
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> show paddedLen
|
|
<> "n,"
|
|
<> jsUint8 (LB.toStrict cipher)
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([r.valid ? 1 : 0, ...r.content])"
|
|
let (validByte, content) = B.splitAt 1 tsResult
|
|
validByte `shouldBe` B.pack [1]
|
|
content `shouldBe` msg
|
|
|
|
it "TS encrypt -> Haskell decrypt (tail tag)" $ do
|
|
let msg = "ts-to-haskell streaming" :: B.ByteString
|
|
msgLen = fromIntegral (B.length msg) :: Int64
|
|
paddedLen = 64 :: Int64
|
|
tsCipher <-
|
|
callNode $
|
|
impSb
|
|
<> jsOut
|
|
( "S.sbEncryptTailTag("
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 msg
|
|
<> ","
|
|
<> show msgLen
|
|
<> "n,"
|
|
<> show paddedLen
|
|
<> "n)"
|
|
)
|
|
let (valid, plaintext) =
|
|
either (error . show) id $
|
|
LC.sbDecryptTailTag sbKeyVal cbNonceVal paddedLen (LB.fromStrict tsCipher)
|
|
valid `shouldBe` True
|
|
LB.toStrict plaintext `shouldBe` msg
|
|
|
|
it "tag tampering detection" $ do
|
|
let msg = "tamper test" :: B.ByteString
|
|
msgLen = fromIntegral (B.length msg) :: Int64
|
|
paddedLen = 64 :: Int64
|
|
tsResult <-
|
|
callNode $
|
|
impSb
|
|
<> "const enc = S.sbEncryptTailTag("
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 msg
|
|
<> ","
|
|
<> show msgLen
|
|
<> "n,"
|
|
<> show paddedLen
|
|
<> "n);"
|
|
<> "enc[enc.length - 1] ^= 1;"
|
|
<> "const r = S.sbDecryptTailTag("
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> show paddedLen
|
|
<> "n, enc);"
|
|
<> jsOut "new Uint8Array([r.valid ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [0]
|
|
|
|
describe "internal consistency" $ do
|
|
it "streaming matches NaCl secretbox (TS-only)" $ do
|
|
let msg = "salsa20 validation" :: B.ByteString
|
|
msgLen = fromIntegral (B.length msg) :: Int64
|
|
paddedLen = 64 :: Int64
|
|
tsResult <-
|
|
callNode $
|
|
impPad
|
|
<> impSb
|
|
<> "const msg = "
|
|
<> jsUint8 msg
|
|
<> ";"
|
|
<> "const key = "
|
|
<> jsUint8 key32
|
|
<> ";"
|
|
<> "const nonce = "
|
|
<> jsUint8 nonce24
|
|
<> ";"
|
|
<> "const padded = P.padLazy(msg, "
|
|
<> show msgLen
|
|
<> "n, "
|
|
<> show paddedLen
|
|
<> "n);"
|
|
<> "const nacl = S.cryptoBox(key, nonce, padded);"
|
|
<> "const stream = S.sbEncryptTailTag(key, nonce, msg, "
|
|
<> show msgLen
|
|
<> "n, "
|
|
<> show paddedLen
|
|
<> "n);"
|
|
<> "const naclTag = nacl.subarray(0, 16);"
|
|
<> "const naclCipher = nacl.subarray(16);"
|
|
<> "const streamCipher = stream.subarray(0, "
|
|
<> show paddedLen
|
|
<> ");"
|
|
<> "const streamTag = stream.subarray("
|
|
<> show paddedLen
|
|
<> ");"
|
|
<> "const cipherMatch = naclCipher.length === streamCipher.length && naclCipher.every((b,i) => b === streamCipher[i]);"
|
|
<> "const tagMatch = naclTag.length === streamTag.length && naclTag.every((b,i) => b === streamTag[i]);"
|
|
<> jsOut "new Uint8Array([cipherMatch ? 1 : 0, tagMatch ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1, 1]
|
|
|
|
it "multi-chunk matches single-shot (TS-only)" $ do
|
|
let msg = B.pack [1 .. 200]
|
|
tsResult <-
|
|
callNode $
|
|
impSb
|
|
<> "const key = "
|
|
<> jsUint8 key32
|
|
<> ";"
|
|
<> "const nonce = "
|
|
<> jsUint8 nonce24
|
|
<> ";"
|
|
<> "const msg = "
|
|
<> jsUint8 msg
|
|
<> ";"
|
|
<> "const st1 = S.sbInit(key, nonce);"
|
|
<> "const c1 = S.sbEncryptChunk(st1, msg);"
|
|
<> "const t1 = S.sbAuth(st1);"
|
|
<> "const st2 = S.sbInit(key, nonce);"
|
|
<> "const parts = [msg.subarray(0,50), msg.subarray(50,100), msg.subarray(100,150), msg.subarray(150)];"
|
|
<> "const c2parts = parts.map(p => S.sbEncryptChunk(st2, p));"
|
|
<> "const c2 = new Uint8Array(200); let off = 0; c2parts.forEach(p => { c2.set(p, off); off += p.length; });"
|
|
<> "const t2 = S.sbAuth(st2);"
|
|
<> "const cipherMatch = c1.length === c2.length && c1.every((b,i) => b === c2[i]);"
|
|
<> "const tagMatch = t1.length === t2.length && t1.every((b,i) => b === t2[i]);"
|
|
<> jsOut "new Uint8Array([cipherMatch ? 1 : 0, tagMatch ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1, 1]
|
|
|
|
-- ── crypto/file ─────────────────────────────────────────────────
|
|
|
|
tsFileCryptoTests :: Spec
|
|
tsFileCryptoTests = describe "crypto/file" $ do
|
|
let key32 = B.pack [1 .. 32]
|
|
nonce24 = B.pack [1 .. 24]
|
|
cbNonceVal = C.cbNonce nonce24
|
|
sbKeyVal = C.unsafeSbKey key32
|
|
|
|
describe "FileHeader encoding" $ do
|
|
it "encodeFileHeader matches Haskell" $ do
|
|
let hdr = FileHeader "test.txt" Nothing
|
|
hsEncoded = smpEncode hdr
|
|
tsEncoded <- callNode $ impFile <> jsOut "F.encodeFileHeader({fileName: 'test.txt', fileExtra: null})"
|
|
tsEncoded `shouldBe` hsEncoded
|
|
|
|
it "encodeFileHeader with fileExtra" $ do
|
|
let hdr = FileHeader "document.pdf" (Just "v2")
|
|
hsEncoded = smpEncode hdr
|
|
tsEncoded <- callNode $ impFile <> jsOut "F.encodeFileHeader({fileName: 'document.pdf', fileExtra: 'v2'})"
|
|
tsEncoded `shouldBe` hsEncoded
|
|
|
|
it "Haskell encode -> TS parseFileHeader" $ do
|
|
let hdr = FileHeader "photo.jpg" (Just "extra")
|
|
encoded = smpEncode hdr
|
|
trailing = B.pack [10, 20, 30, 40, 50]
|
|
input = encoded <> trailing
|
|
tsResult <-
|
|
callNode $
|
|
impFile
|
|
<> "const r = F.parseFileHeader("
|
|
<> jsUint8 input
|
|
<> ");"
|
|
<> "const hdrBytes = F.encodeFileHeader(r.header);"
|
|
<> jsOut "new Uint8Array([...hdrBytes, ...r.rest])"
|
|
tsResult `shouldBe` input
|
|
|
|
describe "file encryption" $ do
|
|
it "encryptFile matches Haskell" $ do
|
|
let source = "Hello, this is test file content!" :: B.ByteString
|
|
hdr = FileHeader "test.txt" Nothing
|
|
fileHdr = smpEncode hdr
|
|
fileSize' = fromIntegral (B.length fileHdr + B.length source) :: Int64
|
|
encSize = 256 :: Int64
|
|
sb = either (error . show) id $ LC.sbInit sbKeyVal cbNonceVal
|
|
lenStr = smpEncode fileSize'
|
|
(hdrEnc, sb1) = LC.sbEncryptChunk sb (lenStr <> fileHdr)
|
|
(srcEnc, sb2) = LC.sbEncryptChunk sb1 source
|
|
padLen = encSize - 16 - fileSize' - 8
|
|
padding = B.replicate (fromIntegral padLen) 0x23
|
|
(padEnc, sb3) = LC.sbEncryptChunk sb2 padding
|
|
tag = BA.convert (LC.sbAuth sb3) :: B.ByteString
|
|
hsEncrypted = B.concat [hdrEnc, srcEnc, padEnc, tag]
|
|
tsEncrypted <-
|
|
callNode $
|
|
impFile
|
|
<> "const source = "
|
|
<> jsUint8 source
|
|
<> ";"
|
|
<> "const fileHdr = F.encodeFileHeader({fileName: 'test.txt', fileExtra: null});"
|
|
<> jsOut
|
|
( "F.encryptFile(source, fileHdr, "
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> show fileSize'
|
|
<> "n,"
|
|
<> show encSize
|
|
<> "n)"
|
|
)
|
|
tsEncrypted `shouldBe` hsEncrypted
|
|
|
|
it "Haskell encrypt -> TS decryptChunks" $ do
|
|
let source = "cross-language file test data" :: B.ByteString
|
|
hdr = FileHeader "data.bin" (Just "meta")
|
|
fileHdr = smpEncode hdr
|
|
fileSize' = fromIntegral (B.length fileHdr + B.length source) :: Int64
|
|
encSize = 128 :: Int64
|
|
sb = either (error . show) id $ LC.sbInit sbKeyVal cbNonceVal
|
|
lenStr = smpEncode fileSize'
|
|
(hdrEnc, sb1) = LC.sbEncryptChunk sb (lenStr <> fileHdr)
|
|
(srcEnc, sb2) = LC.sbEncryptChunk sb1 source
|
|
padLen = encSize - 16 - fileSize' - 8
|
|
padding = B.replicate (fromIntegral padLen) 0x23
|
|
(padEnc, sb3) = LC.sbEncryptChunk sb2 padding
|
|
tag = BA.convert (LC.sbAuth sb3) :: B.ByteString
|
|
encrypted = B.concat [hdrEnc, srcEnc, padEnc, tag]
|
|
tsResult <-
|
|
callNode $
|
|
impFile
|
|
<> "const r = F.decryptChunks("
|
|
<> show encSize
|
|
<> "n, ["
|
|
<> jsUint8 encrypted
|
|
<> "], "
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ");"
|
|
<> "const hdrBytes = F.encodeFileHeader(r.header);"
|
|
<> jsOut "new Uint8Array([...hdrBytes, ...r.content])"
|
|
tsResult `shouldBe` (fileHdr <> source)
|
|
|
|
it "TS encryptFile -> Haskell decrypt" $ do
|
|
let source = "ts-to-haskell file" :: B.ByteString
|
|
hdr = FileHeader "note.txt" Nothing
|
|
fileHdr = smpEncode hdr
|
|
fileSize' = fromIntegral (B.length fileHdr + B.length source) :: Int64
|
|
encSize = 128 :: Int64
|
|
paddedLen = encSize - 16
|
|
tsEncrypted <-
|
|
callNode $
|
|
impFile
|
|
<> "const source = "
|
|
<> jsUint8 source
|
|
<> ";"
|
|
<> "const fileHdr = F.encodeFileHeader({fileName: 'note.txt', fileExtra: null});"
|
|
<> jsOut
|
|
( "F.encryptFile(source, fileHdr, "
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> show fileSize'
|
|
<> "n,"
|
|
<> show encSize
|
|
<> "n)"
|
|
)
|
|
let (valid, plaintext) =
|
|
either (error . show) id $
|
|
LC.sbDecryptTailTag sbKeyVal cbNonceVal paddedLen (LB.fromStrict tsEncrypted)
|
|
valid `shouldBe` True
|
|
LB.toStrict plaintext `shouldBe` (fileHdr <> source)
|
|
|
|
it "multi-chunk decrypt" $ do
|
|
let source = "multi-chunk file content" :: B.ByteString
|
|
hdr = FileHeader "multi.bin" Nothing
|
|
fileHdr = smpEncode hdr
|
|
fileSize' = fromIntegral (B.length fileHdr + B.length source) :: Int64
|
|
encSize = 128 :: Int64
|
|
sb = either (error . show) id $ LC.sbInit sbKeyVal cbNonceVal
|
|
lenStr = smpEncode fileSize'
|
|
(hdrEnc, sb1) = LC.sbEncryptChunk sb (lenStr <> fileHdr)
|
|
(srcEnc, sb2) = LC.sbEncryptChunk sb1 source
|
|
padLen = encSize - 16 - fileSize' - 8
|
|
padding = B.replicate (fromIntegral padLen) 0x23
|
|
(padEnc, sb3) = LC.sbEncryptChunk sb2 padding
|
|
tag = BA.convert (LC.sbAuth sb3) :: B.ByteString
|
|
encrypted = B.concat [hdrEnc, srcEnc, padEnc, tag]
|
|
(chunk1, rest) = B.splitAt 50 encrypted
|
|
(chunk2, chunk3) = B.splitAt 50 rest
|
|
tsResult <-
|
|
callNode $
|
|
impFile
|
|
<> "const r = F.decryptChunks("
|
|
<> show encSize
|
|
<> "n, ["
|
|
<> jsUint8 chunk1
|
|
<> ","
|
|
<> jsUint8 chunk2
|
|
<> ","
|
|
<> jsUint8 chunk3
|
|
<> "], "
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ");"
|
|
<> "const hdrBytes = F.encodeFileHeader(r.header);"
|
|
<> jsOut "new Uint8Array([...hdrBytes, ...r.content])"
|
|
tsResult `shouldBe` (fileHdr <> source)
|
|
|
|
it "auth tag tampering detection" $ do
|
|
let source = "tamper detection file" :: B.ByteString
|
|
hdr = FileHeader "secret.dat" Nothing
|
|
fileHdr = smpEncode hdr
|
|
fileSize' = fromIntegral (B.length fileHdr + B.length source) :: Int64
|
|
encSize = 128 :: Int64
|
|
sb = either (error . show) id $ LC.sbInit sbKeyVal cbNonceVal
|
|
lenStr = smpEncode fileSize'
|
|
(hdrEnc, sb1) = LC.sbEncryptChunk sb (lenStr <> fileHdr)
|
|
(srcEnc, sb2) = LC.sbEncryptChunk sb1 source
|
|
padLen = encSize - 16 - fileSize' - 8
|
|
padding = B.replicate (fromIntegral padLen) 0x23
|
|
(padEnc, sb3) = LC.sbEncryptChunk sb2 padding
|
|
tag = BA.convert (LC.sbAuth sb3) :: B.ByteString
|
|
encrypted = B.concat [hdrEnc, srcEnc, padEnc, tag]
|
|
tsResult <-
|
|
callNode $
|
|
impFile
|
|
<> "const enc = "
|
|
<> jsUint8 encrypted
|
|
<> ";"
|
|
<> "enc[enc.length - 1] ^= 1;"
|
|
<> "let ok = 0;"
|
|
<> "try { F.decryptChunks("
|
|
<> show encSize
|
|
<> "n, [enc], "
|
|
<> jsUint8 key32
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> "); ok = 1; } catch(e) { ok = 0; }"
|
|
<> jsOut "new Uint8Array([ok])"
|
|
tsResult `shouldBe` B.pack [0]
|
|
|
|
-- ── protocol/commands ────────────────────────────────────────────
|
|
|
|
tsCommandTests :: Spec
|
|
tsCommandTests = describe "protocol/commands" $ do
|
|
let sndKey = B.pack [1 .. 8]
|
|
rcvKey1 = B.pack [11 .. 18]
|
|
rcvKey2 = B.pack [21 .. 28]
|
|
digest = B.pack [31 .. 38]
|
|
size32 = 12345 :: Word32
|
|
authKey = B.pack [41 .. 48]
|
|
dhKey = B.pack [51 .. 58]
|
|
|
|
describe "encode" $ do
|
|
it "encodeFileInfo" $ do
|
|
let expected = smpEncode sndKey <> smpEncode size32 <> smpEncode digest
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const fi = {sndKey: "
|
|
<> jsUint8 sndKey
|
|
<> ", size: "
|
|
<> show size32
|
|
<> ", digest: "
|
|
<> jsUint8 digest
|
|
<> "};"
|
|
<> jsOut "Cmd.encodeFileInfo(fi)"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "encodeFNEW with auth" $ do
|
|
let fileInfo = smpEncode sndKey <> smpEncode size32 <> smpEncode digest
|
|
rcvKeys = smpEncodeList [rcvKey1, rcvKey2]
|
|
auth = B.singleton 0x31 <> smpEncode authKey
|
|
expected = "FNEW " <> fileInfo <> rcvKeys <> auth
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const fi = {sndKey: "
|
|
<> jsUint8 sndKey
|
|
<> ", size: "
|
|
<> show size32
|
|
<> ", digest: "
|
|
<> jsUint8 digest
|
|
<> "};"
|
|
<> "const rks = ["
|
|
<> jsUint8 rcvKey1
|
|
<> ","
|
|
<> jsUint8 rcvKey2
|
|
<> "];"
|
|
<> jsOut ("Cmd.encodeFNEW(fi, rks, " <> jsUint8 authKey <> ")")
|
|
tsResult `shouldBe` expected
|
|
|
|
it "encodeFNEW without auth" $ do
|
|
let fileInfo = smpEncode sndKey <> smpEncode size32 <> smpEncode digest
|
|
rcvKeys = smpEncodeList [rcvKey1]
|
|
expected = "FNEW " <> fileInfo <> rcvKeys <> "0"
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const fi = {sndKey: "
|
|
<> jsUint8 sndKey
|
|
<> ", size: "
|
|
<> show size32
|
|
<> ", digest: "
|
|
<> jsUint8 digest
|
|
<> "};"
|
|
<> "const rks = ["
|
|
<> jsUint8 rcvKey1
|
|
<> "];"
|
|
<> jsOut "Cmd.encodeFNEW(fi, rks, null)"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "encodeFADD" $ do
|
|
let expected = "FADD " <> smpEncodeList [rcvKey1, rcvKey2]
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> jsOut ("Cmd.encodeFADD([" <> jsUint8 rcvKey1 <> "," <> jsUint8 rcvKey2 <> "])")
|
|
tsResult `shouldBe` expected
|
|
|
|
it "encodeFPUT" $ do
|
|
tsResult <- callNode $ impCmd <> jsOut "Cmd.encodeFPUT()"
|
|
tsResult `shouldBe` "FPUT"
|
|
|
|
it "encodeFDEL" $ do
|
|
tsResult <- callNode $ impCmd <> jsOut "Cmd.encodeFDEL()"
|
|
tsResult `shouldBe` "FDEL"
|
|
|
|
it "encodeFGET" $ do
|
|
let expected = "FGET " <> smpEncode dhKey
|
|
tsResult <-
|
|
callNode $
|
|
impCmd <> jsOut ("Cmd.encodeFGET(" <> jsUint8 dhKey <> ")")
|
|
tsResult `shouldBe` expected
|
|
|
|
it "encodePING" $ do
|
|
tsResult <- callNode $ impCmd <> jsOut "Cmd.encodePING()"
|
|
tsResult `shouldBe` "PING"
|
|
|
|
describe "decode" $ do
|
|
it "decodeResponse OK" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const r = Cmd.decodeResponse("
|
|
<> jsUint8 ("OK" :: B.ByteString)
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([r.type === 'FROk' ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
it "decodeResponse PONG" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const r = Cmd.decodeResponse("
|
|
<> jsUint8 ("PONG" :: B.ByteString)
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([r.type === 'FRPong' ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
it "decodeResponse ERR AUTH" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const r = Cmd.decodeResponse("
|
|
<> jsUint8 ("ERR AUTH" :: B.ByteString)
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([r.type === 'FRErr' && r.err.type === 'AUTH' ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
it "decodeResponse ERR CMD SYNTAX" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const r = Cmd.decodeResponse("
|
|
<> jsUint8 ("ERR CMD SYNTAX" :: B.ByteString)
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([r.type === 'FRErr' && r.err.type === 'CMD' && r.err.cmdErr === 'SYNTAX' ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
it "decodeResponse SIDS" $ do
|
|
let senderId = B.pack [1 .. 24]
|
|
rId1 = B.pack [25 .. 48]
|
|
rId2 = B.pack [49 .. 72]
|
|
sidsBytes = "SIDS " <> smpEncode senderId <> smpEncodeList [rId1, rId2]
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const r = Cmd.decodeResponse("
|
|
<> jsUint8 sidsBytes
|
|
<> ");"
|
|
<> "if (r.type !== 'FRSndIds') throw new Error('wrong type');"
|
|
<> jsOut "E.concatBytes(r.senderId, ...r.recipientIds)"
|
|
tsResult `shouldBe` (senderId <> rId1 <> rId2)
|
|
|
|
it "decodeResponse RIDS" $ do
|
|
let rId1 = B.pack [1 .. 16]
|
|
rId2 = B.pack [17 .. 32]
|
|
ridsBytes = "RIDS " <> smpEncodeList [rId1, rId2]
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const r = Cmd.decodeResponse("
|
|
<> jsUint8 ridsBytes
|
|
<> ");"
|
|
<> "if (r.type !== 'FRRcvIds') throw new Error('wrong type');"
|
|
<> jsOut "E.concatBytes(...r.recipientIds)"
|
|
tsResult `shouldBe` (rId1 <> rId2)
|
|
|
|
it "decodeResponse FILE" $ do
|
|
let rawPub = B.pack [1 .. 32]
|
|
x25519Der = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x6e, 0x03, 0x21, 0x00]
|
|
derKey = x25519Der <> rawPub
|
|
nonce = B.pack [201 .. 224]
|
|
fileBytes = "FILE " <> smpEncode derKey <> nonce
|
|
tsResult <-
|
|
callNode $
|
|
impCmd
|
|
<> "const r = Cmd.decodeResponse("
|
|
<> jsUint8 fileBytes
|
|
<> ");"
|
|
<> "if (r.type !== 'FRFile') throw new Error('wrong type: ' + r.type);"
|
|
<> jsOut "E.concatBytes(r.rcvDhKey, r.nonce)"
|
|
tsResult `shouldBe` (rawPub <> nonce)
|
|
|
|
-- ── protocol/transmission ──────────────────────────────────────────
|
|
|
|
tsTransmissionTests :: Spec
|
|
tsTransmissionTests = describe "protocol/transmission" $ do
|
|
describe "blockPad / blockUnpad" $ do
|
|
it "blockPad matches C.pad" $ do
|
|
let msg = "hello pad test" :: B.ByteString
|
|
blockSize = 256 :: Int
|
|
hsPadded = either (error . show) id $ C.pad msg blockSize
|
|
tsPadded <-
|
|
callNode $
|
|
impTx <> jsOut ("Tx.blockPad(" <> jsUint8 msg <> ", " <> show blockSize <> ")")
|
|
tsPadded `shouldBe` hsPadded
|
|
|
|
it "Haskell C.pad -> TS blockUnpad" $ do
|
|
let msg = "cross-language unpad" :: B.ByteString
|
|
blockSize = 128 :: Int
|
|
hsPadded = either (error . show) id $ C.pad msg blockSize
|
|
tsResult <-
|
|
callNode $
|
|
impTx <> jsOut ("Tx.blockUnpad(" <> jsUint8 hsPadded <> ")")
|
|
tsResult `shouldBe` msg
|
|
|
|
it "TS blockPad -> Haskell C.unPad" $ do
|
|
let msg = "ts-to-haskell pad" :: B.ByteString
|
|
blockSize = 128 :: Int
|
|
tsPadded <-
|
|
callNode $
|
|
impTx <> jsOut ("Tx.blockPad(" <> jsUint8 msg <> ", " <> show blockSize <> ")")
|
|
let hsResult = either (error . show) id $ C.unPad tsPadded
|
|
hsResult `shouldBe` msg
|
|
|
|
describe "transmission encoding" $ do
|
|
it "encodeTransmission unsigned (PING)" $ do
|
|
let sessionId = B.pack [201 .. 232]
|
|
corrId = "abc" :: B.ByteString
|
|
entityId = "" :: B.ByteString
|
|
cmdBytes = "PING" :: B.ByteString
|
|
-- implySessId = False: sessionId on wire
|
|
tWire = smpEncode sessionId <> smpEncode corrId <> smpEncode entityId <> cmdBytes
|
|
authenticator = smpEncode ("" :: B.ByteString)
|
|
encoded = authenticator <> tWire
|
|
batch = B.singleton 1 <> smpEncode (Large encoded)
|
|
expected = either (error . show) id $ C.pad batch 16384
|
|
tsResult <-
|
|
callNode $
|
|
impTx
|
|
<> jsOut
|
|
( "Tx.encodeTransmission("
|
|
<> jsUint8 sessionId
|
|
<> ", "
|
|
<> jsUint8 corrId
|
|
<> ", "
|
|
<> jsUint8 entityId
|
|
<> ", "
|
|
<> jsUint8 cmdBytes
|
|
<> ")"
|
|
)
|
|
tsResult `shouldBe` expected
|
|
|
|
it "encodeAuthTransmission signed" $ do
|
|
let seed = B.pack [1 .. 32]
|
|
sk = throwCryptoError $ Ed25519.secretKey seed
|
|
pk = Ed25519.toPublic sk
|
|
sessionId = B.pack [101 .. 132]
|
|
corrId = "xyz" :: B.ByteString
|
|
entityId = B.pack [1 .. 24]
|
|
cmdBytes = "FPUT" :: B.ByteString
|
|
tInner = smpEncode corrId <> smpEncode entityId <> cmdBytes
|
|
tForAuth = smpEncode sessionId <> tInner
|
|
sig = Ed25519.sign sk pk tForAuth
|
|
rawSig = BA.convert sig :: B.ByteString
|
|
authenticator = smpEncode rawSig
|
|
-- implySessId = False: tToSend = tForAuth (sessionId on wire)
|
|
encoded = authenticator <> tForAuth
|
|
batch = B.singleton 1 <> smpEncode (Large encoded)
|
|
expected = either (error . show) id $ C.pad batch 16384
|
|
tsResult <-
|
|
callNode $
|
|
impTx
|
|
<> "const kp = K.ed25519KeyPairFromSeed("
|
|
<> jsUint8 seed
|
|
<> ");"
|
|
<> jsOut
|
|
( "Tx.encodeAuthTransmission("
|
|
<> jsUint8 sessionId
|
|
<> ", "
|
|
<> jsUint8 corrId
|
|
<> ", "
|
|
<> jsUint8 entityId
|
|
<> ", "
|
|
<> jsUint8 cmdBytes
|
|
<> ", kp.privateKey)"
|
|
)
|
|
tsResult `shouldBe` expected
|
|
|
|
it "decodeTransmission" $ do
|
|
let sessionId = B.pack [201 .. 232]
|
|
corrId = "r01" :: B.ByteString
|
|
entityId = B.pack [1 .. 16]
|
|
cmdBytes = "OK" :: B.ByteString
|
|
-- implySessId = False: sessionId on wire
|
|
tWire = smpEncode sessionId <> smpEncode corrId <> smpEncode entityId <> cmdBytes
|
|
authenticator = smpEncode ("" :: B.ByteString)
|
|
encoded = authenticator <> tWire
|
|
batch = B.singleton 1 <> smpEncode (Large encoded)
|
|
block = either (error . show) id $ C.pad batch 256
|
|
tsResult <-
|
|
callNode $
|
|
impTx
|
|
<> "const t = Tx.decodeTransmission("
|
|
<> jsUint8 sessionId
|
|
<> ", "
|
|
<> jsUint8 block
|
|
<> ");"
|
|
<> jsOut "E.concatBytes(t.corrId, t.entityId, t.command)"
|
|
tsResult `shouldBe` (corrId <> entityId <> cmdBytes)
|
|
|
|
-- ── protocol/handshake ────────────────────────────────────────────
|
|
|
|
tsHandshakeTests :: Spec
|
|
tsHandshakeTests = describe "protocol/handshake" $ do
|
|
describe "version range" $ do
|
|
it "encodeVersionRange" $ do
|
|
let expected = smpEncode (1 :: Word16) <> smpEncode (3 :: Word16)
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> jsOut "Hs.encodeVersionRange({minVersion: 1, maxVersion: 3})"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "decodeVersionRange" $ do
|
|
let vrBytes = smpEncode (2 :: Word16) <> smpEncode (5 :: Word16)
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const d = new E.Decoder("
|
|
<> jsUint8 vrBytes
|
|
<> ");"
|
|
<> "const vr = Hs.decodeVersionRange(d);"
|
|
<> jsOut "E.concatBytes(E.encodeWord16(vr.minVersion), E.encodeWord16(vr.maxVersion))"
|
|
tsResult `shouldBe` vrBytes
|
|
|
|
it "compatibleVRange (compatible)" $ do
|
|
-- intersection of [1,3] and [2,5] = [2,3]
|
|
let expected = smpEncode (2 :: Word16) <> smpEncode (3 :: Word16)
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const r = Hs.compatibleVRange({minVersion:1,maxVersion:3},{minVersion:2,maxVersion:5});"
|
|
<> "if (!r) throw new Error('expected compatible');"
|
|
<> jsOut "Hs.encodeVersionRange(r)"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "compatibleVRange (incompatible)" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const r = Hs.compatibleVRange({minVersion:1,maxVersion:2},{minVersion:3,maxVersion:5});"
|
|
<> jsOut "new Uint8Array([r === null ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
describe "client handshake" $ do
|
|
it "encodeClientHandshake" $ do
|
|
let kh = B.pack [1 .. 32]
|
|
body = smpEncode (3 :: Word16) <> smpEncode kh
|
|
expected = either (error . show) id $ C.pad body 16384
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> jsOut ("Hs.encodeClientHandshake({xftpVersion:3,keyHash:" <> jsUint8 kh <> "})")
|
|
tsResult `shouldBe` expected
|
|
|
|
describe "client hello" $ do
|
|
it "encodeClientHello (Nothing)" $ do
|
|
let expected = smpEncode (XFTPClientHello {webChallenge = Nothing})
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> jsOut "Hs.encodeClientHello({webChallenge: null})"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "encodeClientHello (Just challenge)" $ do
|
|
let challenge = B.pack [1 .. 32]
|
|
expected = either (error . show) id $ C.pad (smpEncode (XFTPClientHello {webChallenge = Just challenge})) xftpBlockSize
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> jsOut ("Hs.encodeClientHello({webChallenge:" <> jsUint8 challenge <> "})")
|
|
tsResult `shouldBe` expected
|
|
|
|
describe "server handshake" $ do
|
|
it "decodeServerHandshake" $ do
|
|
let sessId = B.pack [1 .. 32]
|
|
cert1 = B.pack [101 .. 200] -- 100 bytes
|
|
cert2 = B.pack [201 .. 232] -- 32 bytes
|
|
signedKeyBytes = B.pack [1 .. 120]
|
|
-- Encode server handshake body matching Haskell wire format:
|
|
-- smpEncode (versionRange, sessionId, certChainPubKey)
|
|
-- where certChainPubKey = (NonEmpty Large certChain, Large signedKey)
|
|
body =
|
|
smpEncode (1 :: Word16)
|
|
<> smpEncode (3 :: Word16)
|
|
<> smpEncode sessId
|
|
<> smpEncode (NE.fromList [Large cert1, Large cert2])
|
|
<> smpEncode (Large signedKeyBytes)
|
|
serverBlock = either (error . show) id $ C.pad body 16384
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const hs = Hs.decodeServerHandshake("
|
|
<> jsUint8 serverBlock
|
|
<> ");"
|
|
<> jsOut
|
|
( "E.concatBytes("
|
|
<> "E.encodeWord16(hs.xftpVersionRange.minVersion),"
|
|
<> "E.encodeWord16(hs.xftpVersionRange.maxVersion),"
|
|
<> "hs.sessionId,"
|
|
<> "...hs.certChainDer,"
|
|
<> "hs.signedKeyDer)"
|
|
)
|
|
-- Expected: vmin(2) + vmax(2) + sessId(32) + cert1(100) + cert2(32) + signedKey(120) = 288 bytes
|
|
tsResult
|
|
`shouldBe` ( smpEncode (1 :: Word16)
|
|
<> smpEncode (3 :: Word16)
|
|
<> sessId
|
|
<> cert1
|
|
<> cert2
|
|
<> signedKeyBytes
|
|
)
|
|
|
|
it "decodeServerHandshake with webIdentityProof" $ do
|
|
let sessId = B.pack [1 .. 32]
|
|
cert1 = B.pack [101 .. 200]
|
|
cert2 = B.pack [201 .. 232]
|
|
signedKeyBytes = B.pack [1 .. 120]
|
|
sigBytes = B.pack [1 .. 64]
|
|
body =
|
|
smpEncode (1 :: Word16)
|
|
<> smpEncode (3 :: Word16)
|
|
<> smpEncode sessId
|
|
<> smpEncode (NE.fromList [Large cert1, Large cert2])
|
|
<> smpEncode (Large signedKeyBytes)
|
|
<> smpEncode sigBytes
|
|
serverBlock = either (error . show) id $ C.pad body 16384
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const hs = Hs.decodeServerHandshake("
|
|
<> jsUint8 serverBlock
|
|
<> ");"
|
|
<> jsOut "hs.webIdentityProof || new Uint8Array(0)"
|
|
tsResult `shouldBe` sigBytes
|
|
|
|
it "decodeServerHandshake without webIdentityProof" $ do
|
|
let sessId = B.pack [1 .. 32]
|
|
cert1 = B.pack [101 .. 200]
|
|
cert2 = B.pack [201 .. 232]
|
|
signedKeyBytes = B.pack [1 .. 120]
|
|
body =
|
|
smpEncode (1 :: Word16)
|
|
<> smpEncode (3 :: Word16)
|
|
<> smpEncode sessId
|
|
<> smpEncode (NE.fromList [Large cert1, Large cert2])
|
|
<> smpEncode (Large signedKeyBytes)
|
|
<> smpEncode ("" :: B.ByteString)
|
|
serverBlock = either (error . show) id $ C.pad body 16384
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const hs = Hs.decodeServerHandshake("
|
|
<> jsUint8 serverBlock
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([hs.webIdentityProof === null ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
describe "certificate utilities" $ do
|
|
it "caFingerprint" $ do
|
|
let cert1 = B.pack [101 .. 200]
|
|
cert2 = B.pack [201 .. 232]
|
|
expected = C.sha256Hash cert2
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const chain = ["
|
|
<> jsUint8 cert1
|
|
<> ","
|
|
<> jsUint8 cert2
|
|
<> "];"
|
|
<> jsOut "Hs.caFingerprint(chain)"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "caFingerprint 3 certs" $ do
|
|
let cert1 = B.pack [1 .. 10]
|
|
cert2 = B.pack [11 .. 20]
|
|
cert3 = B.pack [21 .. 30]
|
|
expected = C.sha256Hash cert2
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const chain = ["
|
|
<> jsUint8 cert1
|
|
<> ","
|
|
<> jsUint8 cert2
|
|
<> ","
|
|
<> jsUint8 cert3
|
|
<> "];"
|
|
<> jsOut "Hs.caFingerprint(chain)"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "chainIdCaCerts 2 certs" $ do
|
|
let cert1 = B.pack [1 .. 10]
|
|
cert2 = B.pack [11 .. 20]
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const cc = Hs.chainIdCaCerts(["
|
|
<> jsUint8 cert1
|
|
<> ","
|
|
<> jsUint8 cert2
|
|
<> "]);"
|
|
<> "if (cc.type !== 'valid') throw new Error('expected valid');"
|
|
<> jsOut "E.concatBytes(cc.leafCert, cc.idCert, cc.caCert)"
|
|
tsResult `shouldBe` (cert1 <> cert2 <> cert2)
|
|
|
|
it "chainIdCaCerts 3 certs" $ do
|
|
let cert1 = B.pack [1 .. 10]
|
|
cert2 = B.pack [11 .. 20]
|
|
cert3 = B.pack [21 .. 30]
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const cc = Hs.chainIdCaCerts(["
|
|
<> jsUint8 cert1
|
|
<> ","
|
|
<> jsUint8 cert2
|
|
<> ","
|
|
<> jsUint8 cert3
|
|
<> "]);"
|
|
<> "if (cc.type !== 'valid') throw new Error('expected valid');"
|
|
<> jsOut "E.concatBytes(cc.leafCert, cc.idCert, cc.caCert)"
|
|
tsResult `shouldBe` (cert1 <> cert2 <> cert3)
|
|
|
|
it "chainIdCaCerts 4 certs" $ do
|
|
let cert1 = B.pack [1 .. 10]
|
|
cert2 = B.pack [11 .. 20]
|
|
cert3 = B.pack [21 .. 30]
|
|
cert4 = B.pack [31 .. 40]
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const cc = Hs.chainIdCaCerts(["
|
|
<> jsUint8 cert1
|
|
<> ","
|
|
<> jsUint8 cert2
|
|
<> ","
|
|
<> jsUint8 cert3
|
|
<> ","
|
|
<> jsUint8 cert4
|
|
<> "]);"
|
|
<> "if (cc.type !== 'valid') throw new Error('expected valid');"
|
|
<> jsOut "E.concatBytes(cc.leafCert, cc.idCert, cc.caCert)"
|
|
tsResult `shouldBe` (cert1 <> cert2 <> cert4)
|
|
|
|
describe "SignedExact parsing" $ do
|
|
it "extractSignedKey" $ do
|
|
-- Generate signing key (Ed25519)
|
|
let signSeed = B.pack [1 .. 32]
|
|
signSk = throwCryptoError $ Ed25519.secretKey signSeed
|
|
signPk = Ed25519.toPublic signSk
|
|
signPkRaw = BA.convert signPk :: B.ByteString
|
|
-- Generate DH key (X25519)
|
|
dhSeed = B.pack [41 .. 72]
|
|
dhSk = throwCryptoError $ X25519.secretKey dhSeed
|
|
dhPk = X25519.toPublic dhSk
|
|
dhPkRaw = BA.convert dhPk :: B.ByteString
|
|
-- SubjectPublicKeyInfo DER for X25519 (44 bytes)
|
|
x25519Prefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x6e, 0x03, 0x21, 0x00]
|
|
spkiDer = x25519Prefix <> dhPkRaw
|
|
-- Sign the SPKI with Ed25519
|
|
sig = Ed25519.sign signSk signPk spkiDer
|
|
sigRaw = BA.convert sig :: B.ByteString
|
|
-- AlgorithmIdentifier for Ed25519 (7 bytes)
|
|
algId = B.pack [0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70]
|
|
-- BIT STRING wrapper (3 + 64 = 67 bytes)
|
|
bitString = B.pack [0x03, 0x41, 0x00] <> sigRaw
|
|
-- Outer SEQUENCE: content = 44 + 7 + 67 = 118 = 0x76
|
|
content = spkiDer <> algId <> bitString
|
|
signedExactDer = B.pack [0x30, 0x76] <> content
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const sk = Hs.extractSignedKey("
|
|
<> jsUint8 signedExactDer
|
|
<> ");"
|
|
<> jsOut "E.concatBytes(sk.dhKey, sk.signature)"
|
|
-- dhKey (32) + signature (64) = 96 bytes
|
|
tsResult `shouldBe` (dhPkRaw <> sigRaw)
|
|
|
|
it "extractSignedKey signature verifies" $ do
|
|
let signSeed = B.pack [1 .. 32]
|
|
signSk = throwCryptoError $ Ed25519.secretKey signSeed
|
|
signPk = Ed25519.toPublic signSk
|
|
signPkRaw = BA.convert signPk :: B.ByteString
|
|
dhSeed = B.pack [41 .. 72]
|
|
dhSk = throwCryptoError $ X25519.secretKey dhSeed
|
|
dhPk = X25519.toPublic dhSk
|
|
dhPkRaw = BA.convert dhPk :: B.ByteString
|
|
x25519Prefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x6e, 0x03, 0x21, 0x00]
|
|
spkiDer = x25519Prefix <> dhPkRaw
|
|
sig = Ed25519.sign signSk signPk spkiDer
|
|
sigRaw = BA.convert sig :: B.ByteString
|
|
algId = B.pack [0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70]
|
|
bitString = B.pack [0x03, 0x41, 0x00] <> sigRaw
|
|
content = spkiDer <> algId <> bitString
|
|
signedExactDer = B.pack [0x30, 0x76] <> content
|
|
tsResult <-
|
|
callNode $
|
|
impHs
|
|
<> "const sk = Hs.extractSignedKey("
|
|
<> jsUint8 signedExactDer
|
|
<> ");"
|
|
<> "const ok = K.verify("
|
|
<> jsUint8 signPkRaw
|
|
<> ", sk.signature, sk.objectDer);"
|
|
<> jsOut "new Uint8Array([ok ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
-- ── crypto/identity ──────────────────────────────────────────────
|
|
|
|
-- Construct a minimal X.509 certificate DER with an Ed25519 public key.
|
|
-- Structurally valid for DER navigation but not a real certificate.
|
|
mkFakeCertDer :: B.ByteString -> B.ByteString
|
|
mkFakeCertDer pubKey32 =
|
|
let spki = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70, 0x03, 0x21, 0x00] <> pubKey32
|
|
tbsContents =
|
|
B.concat
|
|
[ B.pack [0xa0, 0x03, 0x02, 0x01, 0x02],
|
|
B.pack [0x02, 0x01, 0x01],
|
|
B.pack [0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70],
|
|
B.pack [0x30, 0x00],
|
|
B.pack [0x30, 0x00],
|
|
B.pack [0x30, 0x00],
|
|
spki
|
|
]
|
|
tbs = B.pack [0x30, fromIntegral $ B.length tbsContents] <> tbsContents
|
|
certContents =
|
|
B.concat
|
|
[ tbs,
|
|
B.pack [0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70],
|
|
B.pack [0x03, 0x41, 0x00] <> B.replicate 64 0
|
|
]
|
|
certLen = B.length certContents
|
|
in B.pack [0x30, 0x81, fromIntegral certLen] <> certContents
|
|
|
|
tsIdentityTests :: Spec
|
|
tsIdentityTests = describe "crypto/identity" $ do
|
|
describe "extractCertPublicKeyInfo" $ do
|
|
it "extracts SPKI from X.509 DER" $ do
|
|
let pubKey = B.pack [1 .. 32]
|
|
certDer = mkFakeCertDer pubKey
|
|
expectedSpki = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70, 0x03, 0x21, 0x00] <> pubKey
|
|
tsResult <-
|
|
callNode $
|
|
impId
|
|
<> jsOut ("Id.extractCertPublicKeyInfo(" <> jsUint8 certDer <> ")")
|
|
tsResult `shouldBe` expectedSpki
|
|
|
|
it "extractCertPublicKeyInfo + decodePubKey returns raw 32-byte key" $ do
|
|
let pubKey = B.pack [1 .. 32]
|
|
certDer = mkFakeCertDer pubKey
|
|
tsResult <-
|
|
callNode $
|
|
impId
|
|
<> jsOut ("K.decodePubKeyEd25519(Id.extractCertPublicKeyInfo(" <> jsUint8 certDer <> "))")
|
|
tsResult `shouldBe` pubKey
|
|
|
|
describe "verifyIdentityProof" $ do
|
|
it "valid proof returns true" $ do
|
|
let signSeed = B.pack [1 .. 32]
|
|
signSk = throwCryptoError $ Ed25519.secretKey signSeed
|
|
signPk = Ed25519.toPublic signSk
|
|
signPkRaw = BA.convert signPk :: B.ByteString
|
|
leafCertDer = mkFakeCertDer signPkRaw
|
|
idCertDer = B.pack [1 .. 50]
|
|
keyHash = C.sha256Hash idCertDer
|
|
-- DH key SignedExact
|
|
dhSeed = B.pack [41 .. 72]
|
|
dhSk = throwCryptoError $ X25519.secretKey dhSeed
|
|
dhPk = X25519.toPublic dhSk
|
|
dhPkRaw = BA.convert dhPk :: B.ByteString
|
|
x25519Prefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x6e, 0x03, 0x21, 0x00]
|
|
spkiDer = x25519Prefix <> dhPkRaw
|
|
dhSig = Ed25519.sign signSk signPk spkiDer
|
|
dhSigRaw = BA.convert dhSig :: B.ByteString
|
|
algId = B.pack [0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70]
|
|
bitString = B.pack [0x03, 0x41, 0x00] <> dhSigRaw
|
|
signedKeyDer = B.pack [0x30, 0x76] <> spkiDer <> algId <> bitString
|
|
-- Challenge signature
|
|
challenge = B.pack [101 .. 132]
|
|
sessionId = B.pack [201 .. 232]
|
|
challengeSig = Ed25519.sign signSk signPk (challenge <> sessionId)
|
|
challengeSigRaw = BA.convert challengeSig :: B.ByteString
|
|
tsResult <-
|
|
callNode $
|
|
impId
|
|
<> "const ok = Id.verifyIdentityProof({"
|
|
<> "certChainDer: ["
|
|
<> jsUint8 leafCertDer
|
|
<> ","
|
|
<> jsUint8 idCertDer
|
|
<> "],"
|
|
<> "signedKeyDer: "
|
|
<> jsUint8 signedKeyDer
|
|
<> ","
|
|
<> "sigBytes: "
|
|
<> jsUint8 challengeSigRaw
|
|
<> ","
|
|
<> "challenge: "
|
|
<> jsUint8 challenge
|
|
<> ","
|
|
<> "sessionId: "
|
|
<> jsUint8 sessionId
|
|
<> ","
|
|
<> "keyHash: "
|
|
<> jsUint8 keyHash
|
|
<> "});"
|
|
<> jsOut "new Uint8Array([ok ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
it "wrong keyHash returns false" $ do
|
|
let signSeed = B.pack [1 .. 32]
|
|
signSk = throwCryptoError $ Ed25519.secretKey signSeed
|
|
signPk = Ed25519.toPublic signSk
|
|
signPkRaw = BA.convert signPk :: B.ByteString
|
|
leafCertDer = mkFakeCertDer signPkRaw
|
|
idCertDer = B.pack [1 .. 50]
|
|
wrongKeyHash = B.replicate 32 0xff
|
|
-- DH key SignedExact
|
|
dhSeed = B.pack [41 .. 72]
|
|
dhSk = throwCryptoError $ X25519.secretKey dhSeed
|
|
dhPk = X25519.toPublic dhSk
|
|
dhPkRaw = BA.convert dhPk :: B.ByteString
|
|
x25519Prefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x6e, 0x03, 0x21, 0x00]
|
|
spkiDer = x25519Prefix <> dhPkRaw
|
|
dhSig = Ed25519.sign signSk signPk spkiDer
|
|
dhSigRaw = BA.convert dhSig :: B.ByteString
|
|
algId = B.pack [0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70]
|
|
bitString = B.pack [0x03, 0x41, 0x00] <> dhSigRaw
|
|
signedKeyDer = B.pack [0x30, 0x76] <> spkiDer <> algId <> bitString
|
|
challenge = B.pack [101 .. 132]
|
|
sessionId = B.pack [201 .. 232]
|
|
challengeSig = Ed25519.sign signSk signPk (challenge <> sessionId)
|
|
challengeSigRaw = BA.convert challengeSig :: B.ByteString
|
|
tsResult <-
|
|
callNode $
|
|
impId
|
|
<> "const ok = Id.verifyIdentityProof({"
|
|
<> "certChainDer: ["
|
|
<> jsUint8 leafCertDer
|
|
<> ","
|
|
<> jsUint8 idCertDer
|
|
<> "],"
|
|
<> "signedKeyDer: "
|
|
<> jsUint8 signedKeyDer
|
|
<> ","
|
|
<> "sigBytes: "
|
|
<> jsUint8 challengeSigRaw
|
|
<> ","
|
|
<> "challenge: "
|
|
<> jsUint8 challenge
|
|
<> ","
|
|
<> "sessionId: "
|
|
<> jsUint8 sessionId
|
|
<> ","
|
|
<> "keyHash: "
|
|
<> jsUint8 wrongKeyHash
|
|
<> "});"
|
|
<> jsOut "new Uint8Array([ok ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [0]
|
|
|
|
it "wrong challenge sig returns false" $ do
|
|
let signSeed = B.pack [1 .. 32]
|
|
signSk = throwCryptoError $ Ed25519.secretKey signSeed
|
|
signPk = Ed25519.toPublic signSk
|
|
signPkRaw = BA.convert signPk :: B.ByteString
|
|
leafCertDer = mkFakeCertDer signPkRaw
|
|
idCertDer = B.pack [1 .. 50]
|
|
keyHash = C.sha256Hash idCertDer
|
|
-- DH key SignedExact
|
|
dhSeed = B.pack [41 .. 72]
|
|
dhSk = throwCryptoError $ X25519.secretKey dhSeed
|
|
dhPk = X25519.toPublic dhSk
|
|
dhPkRaw = BA.convert dhPk :: B.ByteString
|
|
x25519Prefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x6e, 0x03, 0x21, 0x00]
|
|
spkiDer = x25519Prefix <> dhPkRaw
|
|
dhSig = Ed25519.sign signSk signPk spkiDer
|
|
dhSigRaw = BA.convert dhSig :: B.ByteString
|
|
algId = B.pack [0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70]
|
|
bitString = B.pack [0x03, 0x41, 0x00] <> dhSigRaw
|
|
signedKeyDer = B.pack [0x30, 0x76] <> spkiDer <> algId <> bitString
|
|
challenge = B.pack [101 .. 132]
|
|
sessionId = B.pack [201 .. 232]
|
|
wrongChallenge = B.pack [1 .. 32]
|
|
wrongSig = Ed25519.sign signSk signPk (wrongChallenge <> sessionId)
|
|
wrongSigRaw = BA.convert wrongSig :: B.ByteString
|
|
tsResult <-
|
|
callNode $
|
|
impId
|
|
<> "const ok = Id.verifyIdentityProof({"
|
|
<> "certChainDer: ["
|
|
<> jsUint8 leafCertDer
|
|
<> ","
|
|
<> jsUint8 idCertDer
|
|
<> "],"
|
|
<> "signedKeyDer: "
|
|
<> jsUint8 signedKeyDer
|
|
<> ","
|
|
<> "sigBytes: "
|
|
<> jsUint8 wrongSigRaw
|
|
<> ","
|
|
<> "challenge: "
|
|
<> jsUint8 challenge
|
|
<> ","
|
|
<> "sessionId: "
|
|
<> jsUint8 sessionId
|
|
<> ","
|
|
<> "keyHash: "
|
|
<> jsUint8 keyHash
|
|
<> "});"
|
|
<> jsOut "new Uint8Array([ok ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [0]
|
|
|
|
it "wrong DH key sig returns false" $ do
|
|
let signSeed = B.pack [1 .. 32]
|
|
signSk = throwCryptoError $ Ed25519.secretKey signSeed
|
|
signPk = Ed25519.toPublic signSk
|
|
signPkRaw = BA.convert signPk :: B.ByteString
|
|
leafCertDer = mkFakeCertDer signPkRaw
|
|
idCertDer = B.pack [1 .. 50]
|
|
keyHash = C.sha256Hash idCertDer
|
|
-- DH key signed by a DIFFERENT key
|
|
otherSeed = B.pack [51 .. 82]
|
|
otherSk = throwCryptoError $ Ed25519.secretKey otherSeed
|
|
otherPk = Ed25519.toPublic otherSk
|
|
dhSeed = B.pack [41 .. 72]
|
|
dhSk = throwCryptoError $ X25519.secretKey dhSeed
|
|
dhPk = X25519.toPublic dhSk
|
|
dhPkRaw = BA.convert dhPk :: B.ByteString
|
|
x25519Prefix = B.pack [0x30, 0x2a, 0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x6e, 0x03, 0x21, 0x00]
|
|
spkiDer = x25519Prefix <> dhPkRaw
|
|
dhSig = Ed25519.sign otherSk otherPk spkiDer
|
|
dhSigRaw = BA.convert dhSig :: B.ByteString
|
|
algId = B.pack [0x30, 0x05, 0x06, 0x03, 0x2b, 0x65, 0x70]
|
|
bitString = B.pack [0x03, 0x41, 0x00] <> dhSigRaw
|
|
signedKeyDer = B.pack [0x30, 0x76] <> spkiDer <> algId <> bitString
|
|
challenge = B.pack [101 .. 132]
|
|
sessionId = B.pack [201 .. 232]
|
|
challengeSig = Ed25519.sign signSk signPk (challenge <> sessionId)
|
|
challengeSigRaw = BA.convert challengeSig :: B.ByteString
|
|
tsResult <-
|
|
callNode $
|
|
impId
|
|
<> "const ok = Id.verifyIdentityProof({"
|
|
<> "certChainDer: ["
|
|
<> jsUint8 leafCertDer
|
|
<> ","
|
|
<> jsUint8 idCertDer
|
|
<> "],"
|
|
<> "signedKeyDer: "
|
|
<> jsUint8 signedKeyDer
|
|
<> ","
|
|
<> "sigBytes: "
|
|
<> jsUint8 challengeSigRaw
|
|
<> ","
|
|
<> "challenge: "
|
|
<> jsUint8 challenge
|
|
<> ","
|
|
<> "sessionId: "
|
|
<> jsUint8 sessionId
|
|
<> ","
|
|
<> "keyHash: "
|
|
<> jsUint8 keyHash
|
|
<> "});"
|
|
<> jsOut "new Uint8Array([ok ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [0]
|
|
|
|
-- ── protocol/description ──────────────────────────────────────────
|
|
|
|
tsDescriptionTests :: Spec
|
|
tsDescriptionTests = describe "protocol/description" $ do
|
|
describe "base64url" $ do
|
|
it "encode matches Haskell strEncode" $ do
|
|
let bs = B.pack [0 .. 31]
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> jsOut ("new TextEncoder().encode(Desc.base64urlEncode(" <> jsUint8 bs <> "))")
|
|
tsResult `shouldBe` strEncode bs
|
|
|
|
it "decode recovers original" $ do
|
|
let bs = B.pack [0 .. 31]
|
|
encoded = strEncode bs
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const s = new TextDecoder().decode("
|
|
<> jsUint8 encoded
|
|
<> ");"
|
|
<> jsOut "Desc.base64urlDecode(s)"
|
|
tsResult `shouldBe` bs
|
|
|
|
it "round-trip 256 bytes" $ do
|
|
let bs = B.pack [0 .. 255]
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const data = "
|
|
<> jsUint8 bs
|
|
<> ";"
|
|
<> "const encoded = Desc.base64urlEncode(data);"
|
|
<> jsOut "Desc.base64urlDecode(encoded)"
|
|
tsResult `shouldBe` bs
|
|
|
|
describe "FileSize" $ do
|
|
it "encodeFileSize" $ do
|
|
let sizes = [500, 1024, 2048, 1048576, 8388608, 1073741824, 27262976 :: Int64]
|
|
expected = B.intercalate "," $ map (strEncode . FileSize) sizes
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const sizes = [500, 1024, 2048, 1048576, 8388608, 1073741824, 27262976];"
|
|
<> jsOut "new TextEncoder().encode(sizes.map(Desc.encodeFileSize).join(','))"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "decodeFileSize" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const strs = ['500','1kb','2kb','1mb','8mb','1gb'];"
|
|
<> jsOut "new TextEncoder().encode(strs.map(s => String(Desc.decodeFileSize(s))).join(','))"
|
|
tsResult `shouldBe` "500,1024,2048,1048576,8388608,1073741824"
|
|
|
|
describe "FileDescription" $ do
|
|
it "fixture YAML round-trip" $ do
|
|
fixture <- B.readFile "tests/fixtures/file_description.yaml"
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const yaml = new TextDecoder().decode("
|
|
<> jsUint8 fixture
|
|
<> ");"
|
|
<> "const fd = Desc.decodeFileDescription(yaml);"
|
|
<> "const reEncoded = Desc.encodeFileDescription(fd);"
|
|
<> jsOut "new TextEncoder().encode(reEncoded)"
|
|
tsResult `shouldBe` fixture
|
|
|
|
it "fixture parsed structure" $ do
|
|
fixture <- B.readFile "tests/fixtures/file_description.yaml"
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const yaml = new TextDecoder().decode("
|
|
<> jsUint8 fixture
|
|
<> ");"
|
|
<> "const fd = Desc.decodeFileDescription(yaml);"
|
|
<> "const r = ["
|
|
<> "fd.party,"
|
|
<> "String(fd.size),"
|
|
<> "String(fd.chunkSize),"
|
|
<> "String(fd.chunks.length),"
|
|
<> "String(fd.chunks[0].replicas.length),"
|
|
<> "String(fd.chunks[3].chunkSize),"
|
|
<> "fd.redirect === null ? 'null' : 'redirect'"
|
|
<> "].join(',');"
|
|
<> jsOut "new TextEncoder().encode(r)"
|
|
tsResult `shouldBe` "recipient,27262976,8388608,4,2,2097152,null"
|
|
|
|
it "encode with redirect round-trips" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const fd = {"
|
|
<> " party: 'sender',"
|
|
<> " size: 1024,"
|
|
<> " digest: new Uint8Array([1,2,3]),"
|
|
<> " key: new Uint8Array(32),"
|
|
<> " nonce: new Uint8Array(24),"
|
|
<> " chunkSize: 1024,"
|
|
<> " chunks: [{chunkNo: 1, chunkSize: 1024, digest: new Uint8Array([4,5,6]),"
|
|
<> " replicas: [{server: 'xftp://abc=@example.com', replicaId: new Uint8Array([7,8,9]),"
|
|
<> " replicaKey: new Uint8Array([10,11,12])}]}],"
|
|
<> " redirect: {size: 512, digest: new Uint8Array([13,14,15])}"
|
|
<> "};"
|
|
<> "const yaml = Desc.encodeFileDescription(fd);"
|
|
<> "const fd2 = Desc.decodeFileDescription(yaml);"
|
|
<> "const r = ["
|
|
<> "fd2.party,"
|
|
<> "String(fd2.redirect !== null),"
|
|
<> "String(fd2.redirect?.size),"
|
|
<> "Desc.base64urlEncode(fd2.redirect?.digest || new Uint8Array())"
|
|
<> "].join(',');"
|
|
<> jsOut "new TextEncoder().encode(r)"
|
|
tsResult `shouldBe` "sender,true,512,DQ4P"
|
|
|
|
it "fdSeparator" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> jsOut "new TextEncoder().encode(Desc.fdSeparator)"
|
|
tsResult `shouldBe` "################################\n"
|
|
|
|
it "web URI encoding matches Haskell" $ do
|
|
yaml <- B.readFile "tests/fixtures/file_description.yaml"
|
|
fd <- either fail pure (strDecode yaml :: Either String (FileDescription 'FRecipient))
|
|
let hsEncoded = encodeWebURI fd
|
|
-- Haskell round-trip
|
|
ValidFileDescription fd' <- either (fail . ("decode: " <>)) pure $ decodeWebURI hsEncoded
|
|
fd `shouldBe` fd'
|
|
-- Cross-language: TS reads same fixture, encodes, should match
|
|
tsEncoded <-
|
|
callNode $
|
|
"import {readFileSync} from 'node:fs';\
|
|
\import * as Agent from './dist/agent.js';\
|
|
\import * as Desc from './dist/protocol/description.js';\
|
|
\const yaml = readFileSync('../tests/fixtures/file_description.yaml', 'utf8');\
|
|
\const fd = Desc.decodeFileDescription(yaml);\
|
|
\const uri = Agent.encodeDescriptionURI(fd);\
|
|
\process.stdout.write(Buffer.from(uri));"
|
|
hsEncoded `shouldBe` tsEncoded
|
|
|
|
describe "validation" $ do
|
|
it "valid description" $ do
|
|
fixture <- B.readFile "tests/fixtures/file_description.yaml"
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const yaml = new TextDecoder().decode("
|
|
<> jsUint8 fixture
|
|
<> ");"
|
|
<> "const fd = Desc.decodeFileDescription(yaml);"
|
|
<> "const r = Desc.validateFileDescription(fd);"
|
|
<> jsOut "new TextEncoder().encode(r === null ? 'ok' : r)"
|
|
tsResult `shouldBe` "ok"
|
|
|
|
it "non-sequential chunks" $ do
|
|
fixture <- B.readFile "tests/fixtures/file_description.yaml"
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const yaml = new TextDecoder().decode("
|
|
<> jsUint8 fixture
|
|
<> ");"
|
|
<> "const fd = Desc.decodeFileDescription(yaml);"
|
|
<> "fd.chunks[1].chunkNo = 5;"
|
|
<> "const r = Desc.validateFileDescription(fd);"
|
|
<> jsOut "new TextEncoder().encode(r || 'ok')"
|
|
tsResult `shouldBe` "chunk numbers are not sequential"
|
|
|
|
it "mismatched size" $ do
|
|
fixture <- B.readFile "tests/fixtures/file_description.yaml"
|
|
tsResult <-
|
|
callNode $
|
|
impDesc
|
|
<> "const yaml = new TextDecoder().decode("
|
|
<> jsUint8 fixture
|
|
<> ");"
|
|
<> "const fd = Desc.decodeFileDescription(yaml);"
|
|
<> "fd.size = 999;"
|
|
<> "const r = Desc.validateFileDescription(fd);"
|
|
<> jsOut "new TextEncoder().encode(r || 'ok')"
|
|
tsResult `shouldBe` "chunks total size is different than file size"
|
|
|
|
-- ── protocol/chunks ───────────────────────────────────────────────
|
|
|
|
tsChunkTests :: Spec
|
|
tsChunkTests = describe "protocol/chunks" $ do
|
|
describe "prepareChunkSizes" $ do
|
|
it "matches Haskell for various sizes" $ do
|
|
let sizes = [100, 65536, 130000, 200000, 500000, 800000, 5000000, 27262976 :: Int64]
|
|
hsResults = map prepareChunkSizes sizes
|
|
expected = B.intercalate "|" $ map (\cs -> B.intercalate "," $ map (strEncode . FileSize) cs) hsResults
|
|
tsResult <-
|
|
callNode $
|
|
impChk
|
|
<> "const sizes = [100, 65536, 130000, 200000, 500000, 800000, 5000000, 27262976];"
|
|
<> "const results = sizes.map(s => Chk.prepareChunkSizes(s).map(Desc.encodeFileSize).join(','));"
|
|
<> jsOut "new TextEncoder().encode(results.join('|'))"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "zero size" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impChk
|
|
<> jsOut "new TextEncoder().encode(Chk.prepareChunkSizes(0).join(','))"
|
|
tsResult `shouldBe` ""
|
|
|
|
describe "singleChunkSize" $ do
|
|
it "finds smallest fitting chunk size" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impChk
|
|
<> "const sizes = [100, 65536, 262144, 300000, 1048576, 4194304, 5000000];"
|
|
<> "const results = sizes.map(s => {"
|
|
<> " const r = Chk.singleChunkSize(s);"
|
|
<> " return r === null ? 'null' : Desc.encodeFileSize(r);"
|
|
<> "});"
|
|
<> jsOut "new TextEncoder().encode(results.join(','))"
|
|
tsResult `shouldBe` "64kb,64kb,256kb,1mb,1mb,4mb,null"
|
|
|
|
describe "prepareChunkSpecs" $ do
|
|
it "generates correct offsets" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impChk
|
|
<> "const specs = Chk.prepareChunkSpecs([4194304, 4194304, 1048576]);"
|
|
<> "const r = specs.map(s => s.chunkOffset + ':' + s.chunkSize).join(',');"
|
|
<> jsOut "new TextEncoder().encode(r)"
|
|
tsResult `shouldBe` "0:4194304,4194304:4194304,8388608:1048576"
|
|
|
|
describe "getChunkDigest" $ do
|
|
it "matches Haskell sha256Hash" $ do
|
|
let chunk = B.pack [0 .. 63]
|
|
expected = C.sha256Hash chunk
|
|
tsResult <-
|
|
callNode $
|
|
impChk
|
|
<> jsOut ("Chk.getChunkDigest(" <> jsUint8 chunk <> ")")
|
|
tsResult `shouldBe` expected
|
|
|
|
describe "constants" $ do
|
|
it "serverChunkSizes" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impChk
|
|
<> jsOut "new TextEncoder().encode(Chk.serverChunkSizes.map(Desc.encodeFileSize).join(','))"
|
|
tsResult `shouldBe` "64kb,256kb,1mb,4mb"
|
|
|
|
it "fileSizeLen and authTagSize" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impChk
|
|
<> jsOut "new TextEncoder().encode(Chk.fileSizeLen + ',' + Chk.authTagSize)"
|
|
tsResult `shouldBe` "8,16"
|
|
|
|
-- ── protocol/client ─────────────────────────────────────────────
|
|
|
|
tsClientTests :: Spec
|
|
tsClientTests = describe "protocol/client" $ do
|
|
-- Fixed X25519 key pairs for deterministic tests
|
|
let privARaw = B.pack [1 .. 32]
|
|
privA = throwCryptoError $ X25519.secretKey privARaw
|
|
pubA = X25519.toPublic privA
|
|
pubARaw = BA.convert pubA :: B.ByteString
|
|
privBRaw = B.pack [33 .. 64]
|
|
privB = throwCryptoError $ X25519.secretKey privBRaw
|
|
pubB = X25519.toPublic privB
|
|
pubBRaw = BA.convert pubB :: B.ByteString
|
|
nonce24 = B.pack [0 .. 23]
|
|
|
|
describe "cbAuthenticate" $ do
|
|
it "matches Haskell output" $ do
|
|
let msg = "hello world authenticator test"
|
|
C.CbAuthenticator expected =
|
|
C.cbAuthenticate
|
|
(C.PublicKeyX25519 pubA)
|
|
(C.PrivateKeyX25519 privB)
|
|
(C.cbNonce nonce24)
|
|
msg
|
|
tsResult <-
|
|
callNode $
|
|
impCli
|
|
<> "const auth = Cli.cbAuthenticate("
|
|
<> jsUint8 pubARaw
|
|
<> ","
|
|
<> jsUint8 privBRaw
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 msg
|
|
<> ");"
|
|
<> jsOut "auth"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "is 80 bytes" $ do
|
|
let msg = "size test"
|
|
C.CbAuthenticator expected =
|
|
C.cbAuthenticate
|
|
(C.PublicKeyX25519 pubA)
|
|
(C.PrivateKeyX25519 privB)
|
|
(C.cbNonce nonce24)
|
|
msg
|
|
B.length expected `shouldBe` 80
|
|
|
|
describe "cbVerify" $ do
|
|
it "validates Haskell authenticator" $ do
|
|
let msg = "test message for verify"
|
|
C.CbAuthenticator authBytes_ =
|
|
C.cbAuthenticate
|
|
(C.PublicKeyX25519 pubA)
|
|
(C.PrivateKeyX25519 privB)
|
|
(C.cbNonce nonce24)
|
|
msg
|
|
tsResult <-
|
|
callNode $
|
|
impCli
|
|
<> "const valid = Cli.cbVerify("
|
|
<> jsUint8 pubBRaw
|
|
<> ","
|
|
<> jsUint8 privARaw
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 authBytes_
|
|
<> ","
|
|
<> jsUint8 msg
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([valid ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
it "rejects wrong message" $ do
|
|
let msg = "correct message"
|
|
wrongMsg = "wrong message"
|
|
C.CbAuthenticator authBytes_ =
|
|
C.cbAuthenticate
|
|
(C.PublicKeyX25519 pubA)
|
|
(C.PrivateKeyX25519 privB)
|
|
(C.cbNonce nonce24)
|
|
msg
|
|
tsResult <-
|
|
callNode $
|
|
impCli
|
|
<> "const valid = Cli.cbVerify("
|
|
<> jsUint8 pubBRaw
|
|
<> ","
|
|
<> jsUint8 privARaw
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 authBytes_
|
|
<> ","
|
|
<> jsUint8 wrongMsg
|
|
<> ");"
|
|
<> jsOut "new Uint8Array([valid ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [0]
|
|
|
|
it "round-trip: TS authenticate, Haskell verify" $ do
|
|
let msg = "round trip test"
|
|
tsAuth <-
|
|
callNode $
|
|
impCli
|
|
<> "const auth = Cli.cbAuthenticate("
|
|
<> jsUint8 pubARaw
|
|
<> ","
|
|
<> jsUint8 privBRaw
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 msg
|
|
<> ");"
|
|
<> jsOut "auth"
|
|
let hsValid =
|
|
C.cbVerify
|
|
(C.PublicKeyX25519 pubB)
|
|
(C.PrivateKeyX25519 privA)
|
|
(C.cbNonce nonce24)
|
|
(C.CbAuthenticator tsAuth)
|
|
msg
|
|
hsValid `shouldBe` True
|
|
|
|
describe "transport chunk encryption" $ do
|
|
let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
|
|
dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
|
|
|
|
it "encryptTransportChunk matches Haskell" $ do
|
|
let plaintext = B.pack [100 .. 199]
|
|
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
|
|
(cipher, state1) = LC.sbEncryptChunk state0 plaintext
|
|
tag = BA.convert $ LC.sbAuth state1 :: B.ByteString
|
|
expected = cipher <> tag
|
|
tsResult <-
|
|
callNode $
|
|
impCli
|
|
<> "const enc = Cli.encryptTransportChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 plaintext
|
|
<> ");"
|
|
<> jsOut "enc"
|
|
tsResult `shouldBe` expected
|
|
|
|
it "decryptTransportChunk decrypts Haskell-encrypted data" $ do
|
|
let plaintext = B.pack ([200 .. 255] <> [0 .. 99])
|
|
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
|
|
(cipher, state1) = LC.sbEncryptChunk state0 plaintext
|
|
tag = BA.convert $ LC.sbAuth state1 :: B.ByteString
|
|
encData = cipher <> tag
|
|
tsResult <-
|
|
callNode $
|
|
impCli
|
|
<> "const r = Cli.decryptTransportChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 encData
|
|
<> ");"
|
|
<> "if (!r.valid) throw new Error('invalid');"
|
|
<> jsOut "r.content"
|
|
tsResult `shouldBe` plaintext
|
|
|
|
it "round-trip encrypt then decrypt" $ do
|
|
let plaintext = B.pack [42, 42, 42, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9]
|
|
tsResult <-
|
|
callNode $
|
|
impCli
|
|
<> "const plain = "
|
|
<> jsUint8 plaintext
|
|
<> ";"
|
|
<> "const enc = Cli.encryptTransportChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ",plain);"
|
|
<> "const r = Cli.decryptTransportChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ",enc);"
|
|
<> "if (!r.valid) throw new Error('invalid');"
|
|
<> jsOut "r.content"
|
|
tsResult `shouldBe` plaintext
|
|
|
|
it "rejects tampered ciphertext" $ do
|
|
let plaintext = B.pack [10 .. 40]
|
|
tsResult <-
|
|
callNode $
|
|
impCli
|
|
<> "const enc = Cli.encryptTransportChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 plaintext
|
|
<> ");"
|
|
<> "enc[0] ^= 0xff;"
|
|
<> "const r = Cli.decryptTransportChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ",enc);"
|
|
<> jsOut "new Uint8Array([r.valid ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [0]
|
|
|
|
describe "constants" $ do
|
|
it "cbAuthenticatorSize" $ do
|
|
tsResult <-
|
|
callNode $
|
|
impCli <> jsOut "new TextEncoder().encode(String(Cli.cbAuthenticatorSize))"
|
|
tsResult `shouldBe` "80"
|
|
|
|
-- ── download (integration) ──────────────────────────────────────────
|
|
|
|
tsDownloadTests :: Spec
|
|
tsDownloadTests = describe "download" $ do
|
|
-- Fixed X25519 key pairs (same as client tests)
|
|
let privARaw = B.pack [1 .. 32]
|
|
privA = throwCryptoError $ X25519.secretKey privARaw
|
|
pubA = X25519.toPublic privA
|
|
pubARaw = BA.convert pubA :: B.ByteString
|
|
privBRaw = B.pack [33 .. 64]
|
|
privB = throwCryptoError $ X25519.secretKey privBRaw
|
|
pubB = X25519.toPublic privB
|
|
pubBRaw = BA.convert pubB :: B.ByteString
|
|
nonce24 = B.pack [0 .. 23]
|
|
-- File-level key/nonce (different from transport)
|
|
fileKey32 = B.pack [1 .. 32]
|
|
fileNonce24 = B.pack [1 .. 24]
|
|
fileCbNonce = C.cbNonce fileNonce24
|
|
fileSbKey = C.unsafeSbKey fileKey32
|
|
|
|
describe "processFileResponse" $ do
|
|
it "derives DH secret matching Haskell" $ do
|
|
-- Simulate: client has privA, server sends pubB
|
|
let hsDhSecret = C.dh' (C.PublicKeyX25519 pubB) (C.PrivateKeyX25519 privA)
|
|
hsDhBytes = case hsDhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
|
|
tsDhSecret <-
|
|
callNode $
|
|
impDl
|
|
<> "const dh = Dl.processFileResponse("
|
|
<> jsUint8 privARaw
|
|
<> ","
|
|
<> jsUint8 pubBRaw
|
|
<> ");"
|
|
<> jsOut "dh"
|
|
tsDhSecret `shouldBe` hsDhBytes
|
|
|
|
describe "decryptReceivedChunk" $ do
|
|
it "transport decrypt with digest verification" $ do
|
|
-- Haskell: transport-encrypt a chunk
|
|
let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
|
|
dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
|
|
chunkData = B.pack [50 .. 149]
|
|
chunkDigest = C.sha256Hash chunkData
|
|
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
|
|
(cipher, state1) = LC.sbEncryptChunk state0 chunkData
|
|
tag = BA.convert (LC.sbAuth state1) :: B.ByteString
|
|
encData = cipher <> tag
|
|
tsResult <-
|
|
callNode $
|
|
impDl
|
|
<> "const r = Dl.decryptReceivedChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 encData
|
|
<> ","
|
|
<> jsUint8 chunkDigest
|
|
<> ");"
|
|
<> jsOut "r"
|
|
tsResult `shouldBe` chunkData
|
|
|
|
it "rejects wrong digest" $ do
|
|
let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
|
|
dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
|
|
chunkData = B.pack [50 .. 149]
|
|
wrongDigest = B.replicate 32 0xff
|
|
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
|
|
(cipher, state1) = LC.sbEncryptChunk state0 chunkData
|
|
tag = BA.convert (LC.sbAuth state1) :: B.ByteString
|
|
encData = cipher <> tag
|
|
tsResult <-
|
|
callNode $
|
|
impDl
|
|
<> "let ok = false; try { Dl.decryptReceivedChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 encData
|
|
<> ","
|
|
<> jsUint8 wrongDigest
|
|
<> "); } catch(e) { ok = e.message.includes('digest'); }"
|
|
<> jsOut "new Uint8Array([ok ? 1 : 0])"
|
|
tsResult `shouldBe` B.pack [1]
|
|
|
|
it "allows null digest (skip verification)" $ do
|
|
let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
|
|
dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
|
|
chunkData = B.pack [10 .. 50]
|
|
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
|
|
(cipher, state1) = LC.sbEncryptChunk state0 chunkData
|
|
tag = BA.convert (LC.sbAuth state1) :: B.ByteString
|
|
encData = cipher <> tag
|
|
tsResult <-
|
|
callNode $
|
|
impDl
|
|
<> "const r = Dl.decryptReceivedChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 encData
|
|
<> ",null);"
|
|
<> jsOut "r"
|
|
tsResult `shouldBe` chunkData
|
|
|
|
describe "full pipeline" $ do
|
|
it "Haskell file-encrypt + transport-encrypt -> TS transport-decrypt + file-decrypt" $ do
|
|
-- Step 1: file-level encryption (matches Haskell encryptFile)
|
|
let source = "Integration test: full download pipeline!" :: B.ByteString
|
|
hdr = FileHeader "pipeline.txt" Nothing
|
|
fileHdr = smpEncode hdr
|
|
fileSize' = fromIntegral (B.length fileHdr + B.length source) :: Int64
|
|
encSize = 256 :: Int64
|
|
sb = either (error . show) id $ LC.sbInit fileSbKey fileCbNonce
|
|
lenStr = smpEncode fileSize'
|
|
(hdrEnc, sb1) = LC.sbEncryptChunk sb (lenStr <> fileHdr)
|
|
(srcEnc, sb2) = LC.sbEncryptChunk sb1 source
|
|
padLen = encSize - 16 - fileSize' - 8
|
|
padding = B.replicate (fromIntegral padLen) 0x23
|
|
(padEnc, sb3) = LC.sbEncryptChunk sb2 padding
|
|
fileTag = BA.convert (LC.sbAuth sb3) :: B.ByteString
|
|
fileEncrypted = B.concat [hdrEnc, srcEnc, padEnc, fileTag]
|
|
-- Step 2: transport-level encryption (simulates server sending chunk)
|
|
let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
|
|
dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
|
|
ts0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
|
|
(transportCipher, ts1) = LC.sbEncryptChunk ts0 fileEncrypted
|
|
transportTag = BA.convert (LC.sbAuth ts1) :: B.ByteString
|
|
transportEncData = transportCipher <> transportTag
|
|
-- Step 3: TS decrypts transport, then file-level
|
|
tsResult <-
|
|
callNode $
|
|
impDl
|
|
<> "const chunk = Dl.decryptReceivedChunk("
|
|
<> jsUint8 dhSecretBytes
|
|
<> ","
|
|
<> jsUint8 nonce24
|
|
<> ","
|
|
<> jsUint8 transportEncData
|
|
<> ",null);"
|
|
<> "const r = F.decryptChunks("
|
|
<> show encSize
|
|
<> "n,[chunk],"
|
|
<> jsUint8 fileKey32
|
|
<> ","
|
|
<> jsUint8 fileNonce24
|
|
<> ");"
|
|
<> "const hdrBytes = F.encodeFileHeader(r.header);"
|
|
<> jsOut "new Uint8Array([...hdrBytes, ...r.content])"
|
|
tsResult `shouldBe` (fileHdr <> source)
|
|
|
|
it "multi-chunk file: Haskell encrypt -> TS decrypt" $ do
|
|
-- File content that spans two chunks when file-encrypted
|
|
let source = B.pack (take 200 $ cycle [0 .. 255])
|
|
hdr = FileHeader "multi.bin" Nothing
|
|
fileHdr = smpEncode hdr
|
|
fileSize' = fromIntegral (B.length fileHdr + B.length source) :: Int64
|
|
encSize = 512 :: Int64
|
|
sb = either (error . show) id $ LC.sbInit fileSbKey fileCbNonce
|
|
lenStr = smpEncode fileSize'
|
|
(hdrEnc, sb1) = LC.sbEncryptChunk sb (lenStr <> fileHdr)
|
|
(srcEnc, sb2) = LC.sbEncryptChunk sb1 source
|
|
padLen = encSize - 16 - fileSize' - 8
|
|
padding = B.replicate (fromIntegral padLen) 0x23
|
|
(padEnc, sb3) = LC.sbEncryptChunk sb2 padding
|
|
fileTag = BA.convert (LC.sbAuth sb3) :: B.ByteString
|
|
fileEncrypted = B.concat [hdrEnc, srcEnc, padEnc, fileTag]
|
|
-- Split file-encrypted data into two "chunks" and transport-encrypt each
|
|
let splitPt = B.length fileEncrypted `div` 2
|
|
fileChunk1 = B.take splitPt fileEncrypted
|
|
fileChunk2 = B.drop splitPt fileEncrypted
|
|
-- Transport encrypt chunk 1 (with separate DH / nonce per chunk)
|
|
dhSecret1 = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
|
|
dhSecret1Bytes = case dhSecret1 of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
|
|
nonce1 = nonce24
|
|
t1s0 = either (error . show) id $ LC.cbInit dhSecret1 (C.cbNonce nonce1)
|
|
(t1cipher, t1s1) = LC.sbEncryptChunk t1s0 fileChunk1
|
|
t1tag = BA.convert (LC.sbAuth t1s1) :: B.ByteString
|
|
transportEnc1 = t1cipher <> t1tag
|
|
-- Transport encrypt chunk 2 (different nonce)
|
|
nonce2 = B.pack [24 .. 47]
|
|
dhSecret2 = C.dh' (C.PublicKeyX25519 pubB) (C.PrivateKeyX25519 privA)
|
|
dhSecret2Bytes = case dhSecret2 of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
|
|
t2s0 = either (error . show) id $ LC.cbInit dhSecret2 (C.cbNonce nonce2)
|
|
(t2cipher, t2s1) = LC.sbEncryptChunk t2s0 fileChunk2
|
|
t2tag = BA.convert (LC.sbAuth t2s1) :: B.ByteString
|
|
transportEnc2 = t2cipher <> t2tag
|
|
-- TS: transport-decrypt each chunk, then file-level decrypt the concatenation
|
|
tsResult <-
|
|
callNode $
|
|
impDl
|
|
<> "const c1 = Dl.decryptReceivedChunk("
|
|
<> jsUint8 dhSecret1Bytes
|
|
<> ","
|
|
<> jsUint8 nonce1
|
|
<> ","
|
|
<> jsUint8 transportEnc1
|
|
<> ",null);"
|
|
<> "const c2 = Dl.decryptReceivedChunk("
|
|
<> jsUint8 dhSecret2Bytes
|
|
<> ","
|
|
<> jsUint8 nonce2
|
|
<> ","
|
|
<> jsUint8 transportEnc2
|
|
<> ",null);"
|
|
<> "const r = F.decryptChunks("
|
|
<> show encSize
|
|
<> "n,[c1,c2],"
|
|
<> jsUint8 fileKey32
|
|
<> ","
|
|
<> jsUint8 fileNonce24
|
|
<> ");"
|
|
<> "const hdrBytes = F.encodeFileHeader(r.header);"
|
|
<> jsOut "new Uint8Array([...hdrBytes, ...r.content])"
|
|
tsResult `shouldBe` (fileHdr <> source)
|
|
|
|
describe "FGET + FRFile round-trip" $ do
|
|
it "encode FGET -> decode FRFile -> process -> transport decrypt" $ do
|
|
-- Client side: generate FGET command
|
|
let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
|
|
chunkData = "FGET round-trip test data" :: B.ByteString
|
|
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
|
|
(cipher, state1) = LC.sbEncryptChunk state0 chunkData
|
|
tag = BA.convert (LC.sbAuth state1) :: B.ByteString
|
|
encData = cipher <> tag
|
|
-- Simulate server response: FILE <serverPubKey> <nonce>
|
|
-- Server sends pubA (client has privB to do DH)
|
|
serverPubDer = C.encodePubKey (C.PublicKeyX25519 pubA)
|
|
fileResponseBytes = "FILE " <> smpEncode serverPubDer <> nonce24
|
|
-- TS: parse FRFile response, derive DH secret, decrypt transport chunk
|
|
tsResult <-
|
|
callNode $
|
|
impDl
|
|
<> "const resp = Cmd.decodeResponse("
|
|
<> jsUint8 fileResponseBytes
|
|
<> ");"
|
|
<> "if (resp.type !== 'FRFile') throw new Error('expected FRFile');"
|
|
<> "const dhSecret = Dl.processFileResponse("
|
|
<> jsUint8 privBRaw
|
|
<> ",resp.rcvDhKey);"
|
|
<> "const r = Dl.decryptReceivedChunk(dhSecret,"
|
|
<> "resp.nonce,"
|
|
<> jsUint8 encData
|
|
<> ",null);"
|
|
<> jsOut "r"
|
|
tsResult `shouldBe` chunkData
|
|
|
|
describe "processDownloadedFile" $ do
|
|
it "decrypts file from transport-decrypted chunks" $ do
|
|
let source = "processDownloadedFile test" :: B.ByteString
|
|
hdr = FileHeader "download.txt" (Just "v1")
|
|
fileHdr = smpEncode hdr
|
|
fileSize' = fromIntegral (B.length fileHdr + B.length source) :: Int64
|
|
encSize = 256 :: Int64
|
|
sb = either (error . show) id $ LC.sbInit fileSbKey fileCbNonce
|
|
lenStr = smpEncode fileSize'
|
|
(hdrEnc, sb1) = LC.sbEncryptChunk sb (lenStr <> fileHdr)
|
|
(srcEnc, sb2) = LC.sbEncryptChunk sb1 source
|
|
padLen = encSize - 16 - fileSize' - 8
|
|
padding = B.replicate (fromIntegral padLen) 0x23
|
|
(padEnc, sb3) = LC.sbEncryptChunk sb2 padding
|
|
fileTag = BA.convert (LC.sbAuth sb3) :: B.ByteString
|
|
fileEncrypted = B.concat [hdrEnc, srcEnc, padEnc, fileTag]
|
|
-- TS: call processDownloadedFile with a minimal FileDescription-like object
|
|
tsResult <-
|
|
callNode $
|
|
impDl
|
|
<> "const fd = {size: "
|
|
<> show encSize
|
|
<> ","
|
|
<> "key: "
|
|
<> jsUint8 fileKey32
|
|
<> ","
|
|
<> "nonce: "
|
|
<> jsUint8 fileNonce24
|
|
<> "};"
|
|
<> "const r = Dl.processDownloadedFile(fd, ["
|
|
<> jsUint8 fileEncrypted
|
|
<> "]);"
|
|
<> "const hdrBytes = F.encodeFileHeader(r.header);"
|
|
<> jsOut "new Uint8Array([...hdrBytes, ...r.content])"
|
|
tsResult `shouldBe` (fileHdr <> source)
|
|
|
|
-- ── protocol/address ──────────────────────────────────────────────
|
|
|
|
tsAddressTests :: Spec
|
|
tsAddressTests = describe "protocol/address" $ do
|
|
it "parseXFTPServer with port" $ do
|
|
let addr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" :: String
|
|
expectedKH :: B.ByteString
|
|
expectedKH = either error id $ strDecode "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
|
|
result <-
|
|
callNode $
|
|
impAddr
|
|
<> "const s = Addr.parseXFTPServer('"
|
|
<> addr
|
|
<> "');"
|
|
<> jsOut "new Uint8Array([...s.keyHash, ...new TextEncoder().encode(s.host + ':' + s.port)])"
|
|
let (kh, hostPort) = B.splitAt 32 result
|
|
kh `shouldBe` expectedKH
|
|
hostPort `shouldBe` "localhost:8000"
|
|
|
|
it "parseXFTPServer default port" $ do
|
|
result <-
|
|
callNode $
|
|
impAddr
|
|
<> "const s = Addr.parseXFTPServer('xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@example.com');"
|
|
<> jsOut "new TextEncoder().encode(s.host + ':' + s.port)"
|
|
result `shouldBe` "example.com:443"
|
|
|
|
it "parseXFTPServer multi-host takes first" $ do
|
|
result <-
|
|
callNode $
|
|
impAddr
|
|
<> "const s = Addr.parseXFTPServer('xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@host1.com:5000,host2.com');"
|
|
<> jsOut "new TextEncoder().encode(s.host + ':' + s.port)"
|
|
result `shouldBe` "host1.com:5000"
|
|
|
|
-- ── integration ───────────────────────────────────────────────────
|
|
|
|
tsIntegrationTests :: IO () -> Spec
|
|
tsIntegrationTests dbCleanup = describe "integration" $
|
|
around_ testBracket . after_ dbCleanup $ do
|
|
it "web handshake with Ed25519 identity verification" $
|
|
webHandshakeTest testXFTPServerConfigEd25519SNI "tests/fixtures/ed25519/ca.crt"
|
|
it "web handshake with Ed448 identity verification" $
|
|
webHandshakeTest testXFTPServerConfigSNI "tests/fixtures/ca.crt"
|
|
it "connectXFTP + pingXFTP" $
|
|
pingTest testXFTPServerConfigEd25519SNI "tests/fixtures/ed25519/ca.crt"
|
|
it "full round-trip: create, upload, download, ack, addRecipients, delete" $
|
|
fullRoundTripTest testXFTPServerConfigEd25519SNI "tests/fixtures/ed25519/ca.crt"
|
|
it "agent URI round-trip" agentURIRoundTripTest
|
|
it "agent upload + download round-trip" $
|
|
agentUploadDownloadTest testXFTPServerConfigEd25519SNI "tests/fixtures/ed25519/ca.crt"
|
|
it "agent delete + verify gone" $
|
|
agentDeleteTest testXFTPServerConfigEd25519SNI "tests/fixtures/ed25519/ca.crt"
|
|
it "agent redirect: upload with redirect, download" $
|
|
agentRedirectTest testXFTPServerConfigEd25519SNI "tests/fixtures/ed25519/ca.crt"
|
|
it "cross-language: TS upload, Haskell download" $
|
|
tsUploadHaskellDownloadTest testXFTPServerConfigSNI "tests/fixtures/ca.crt"
|
|
it "cross-language: TS upload with redirect, Haskell download" $
|
|
tsUploadRedirectHaskellDownloadTest testXFTPServerConfigSNI "tests/fixtures/ca.crt"
|
|
it "cross-language: Haskell upload, TS download" $
|
|
haskellUploadTsDownloadTest testXFTPServerConfigSNI
|
|
|
|
webHandshakeTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
|
webHandshakeTest cfg caFile = do
|
|
withXFTPServerCfg cfg $ \_ -> do
|
|
Fingerprint fp <- loadFileFingerprint caFile
|
|
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
|
|
addr = "xftp://" <> fpStr <> "@localhost:" <> xftpTestPort
|
|
result <-
|
|
callNode $
|
|
"import http2 from 'node:http2';\
|
|
\import crypto from 'node:crypto';\
|
|
\import sodium from 'libsodium-wrappers-sumo';\
|
|
\import * as Addr from './dist/protocol/address.js';\
|
|
\import * as Hs from './dist/protocol/handshake.js';\
|
|
\import * as Id from './dist/crypto/identity.js';\
|
|
\await sodium.ready;\
|
|
\const server = Addr.parseXFTPServer('"
|
|
<> addr
|
|
<> "');\
|
|
\const readBody = s => new Promise((ok, err) => {\
|
|
\const c = [];\
|
|
\s.on('data', d => c.push(d));\
|
|
\s.on('end', () => ok(Buffer.concat(c)));\
|
|
\s.on('error', err);\
|
|
\});\
|
|
\const client = http2.connect('https://' + server.host + ':' + server.port, {rejectUnauthorized: false});\
|
|
\const challenge = new Uint8Array(crypto.randomBytes(32));\
|
|
\const s1 = client.request({':method': 'POST', ':path': '/', 'xftp-web-hello': '1'});\
|
|
\s1.end(Buffer.from(Hs.encodeClientHello({webChallenge: challenge})));\
|
|
\const hs = Hs.decodeServerHandshake(new Uint8Array(await readBody(s1)));\
|
|
\const idOk = hs.webIdentityProof\
|
|
\ ? Id.verifyIdentityProof({certChainDer: hs.certChainDer, signedKeyDer: hs.signedKeyDer,\
|
|
\sigBytes: hs.webIdentityProof, challenge, sessionId: hs.sessionId, keyHash: server.keyHash})\
|
|
\ : false;\
|
|
\const ver = hs.xftpVersionRange.maxVersion;\
|
|
\const s2 = client.request({':method': 'POST', ':path': '/', 'xftp-handshake': '1'});\
|
|
\s2.end(Buffer.from(Hs.encodeClientHandshake({xftpVersion: ver, keyHash: server.keyHash})));\
|
|
\const ack = await readBody(s2);\
|
|
\client.close();"
|
|
<> jsOut "new Uint8Array([idOk ? 1 : 0, ack.length === 0 ? 1 : 0])"
|
|
result `shouldBe` B.pack [1, 1]
|
|
|
|
pingTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
|
pingTest cfg caFile = do
|
|
withXFTPServerCfg cfg $ \_ -> do
|
|
Fingerprint fp <- loadFileFingerprint caFile
|
|
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
|
|
addr = "xftp://" <> fpStr <> "@localhost:" <> xftpTestPort
|
|
result <-
|
|
callNode $
|
|
"import sodium from 'libsodium-wrappers-sumo';\
|
|
\import * as Addr from './dist/protocol/address.js';\
|
|
\import {newXFTPAgent, closeXFTPAgent} from './dist/client.js';\
|
|
\import {pingXFTP} from './dist/client.js';\
|
|
\await sodium.ready;\
|
|
\const server = Addr.parseXFTPServer('"
|
|
<> addr
|
|
<> "');\
|
|
\const agent = newXFTPAgent();\
|
|
\await pingXFTP(agent, server);\
|
|
\closeXFTPAgent(agent);"
|
|
<> jsOut "new Uint8Array([1])"
|
|
result `shouldBe` B.pack [1]
|
|
|
|
fullRoundTripTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
|
fullRoundTripTest cfg caFile = do
|
|
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
|
withXFTPServerCfg cfg $ \_ -> do
|
|
Fingerprint fp <- loadFileFingerprint caFile
|
|
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
|
|
addr = "xftp://" <> fpStr <> "@localhost:" <> xftpTestPort
|
|
result <-
|
|
callNode $
|
|
"import sodium from 'libsodium-wrappers-sumo';\
|
|
\import crypto from 'node:crypto';\
|
|
\import * as Addr from './dist/protocol/address.js';\
|
|
\import * as K from './dist/crypto/keys.js';\
|
|
\import {sha256} from './dist/crypto/digest.js';\
|
|
\import {newXFTPAgent, closeXFTPAgent, createXFTPChunk, uploadXFTPChunk, downloadXFTPChunk,\
|
|
\ addXFTPRecipients, deleteXFTPChunk} from './dist/client.js';\
|
|
\await sodium.ready;\
|
|
\const server = Addr.parseXFTPServer('"
|
|
<> addr
|
|
<> "');\
|
|
\const agent = newXFTPAgent();\
|
|
\const sndKp = K.generateEd25519KeyPair();\
|
|
\const rcvKp1 = K.generateEd25519KeyPair();\
|
|
\const rcvKp2 = K.generateEd25519KeyPair();\
|
|
\const chunkData = new Uint8Array(crypto.randomBytes(65536));\
|
|
\const digest = sha256(chunkData);\
|
|
\const file = {\
|
|
\ sndKey: K.encodePubKeyEd25519(sndKp.publicKey),\
|
|
\ size: chunkData.length,\
|
|
\ digest\
|
|
\};\
|
|
\const rcvKeys = [K.encodePubKeyEd25519(rcvKp1.publicKey)];\
|
|
\const {senderId, recipientIds} = await createXFTPChunk(agent, server, sndKp.privateKey, file, rcvKeys, null);\
|
|
\await uploadXFTPChunk(agent, server, sndKp.privateKey, senderId, chunkData);\
|
|
\const dl1 = await downloadXFTPChunk(agent, server, rcvKp1.privateKey, recipientIds[0], digest);\
|
|
\const match1 = dl1.length === chunkData.length && dl1.every((b, i) => b === chunkData[i]);\
|
|
\const newIds = await addXFTPRecipients(agent, server, sndKp.privateKey, senderId,\
|
|
\ [K.encodePubKeyEd25519(rcvKp2.publicKey)]);\
|
|
\const dl2 = await downloadXFTPChunk(agent, server, rcvKp2.privateKey, newIds[0], digest);\
|
|
\const match2 = dl2.length === chunkData.length && dl2.every((b, i) => b === chunkData[i]);\
|
|
\await deleteXFTPChunk(agent, server, sndKp.privateKey, senderId);\
|
|
\closeXFTPAgent(agent);"
|
|
<> jsOut "new Uint8Array([match1 ? 1 : 0, match2 ? 1 : 0])"
|
|
result `shouldBe` B.pack [1, 1]
|
|
|
|
agentURIRoundTripTest :: Expectation
|
|
agentURIRoundTripTest = do
|
|
result <-
|
|
callNode $
|
|
"import sodium from 'libsodium-wrappers-sumo';\
|
|
\import * as Agent from './dist/agent.js';\
|
|
\import * as Desc from './dist/protocol/description.js';\
|
|
\await sodium.ready;\
|
|
\const fd = {\
|
|
\ party: 'recipient',\
|
|
\ size: 65536,\
|
|
\ digest: new Uint8Array(64).fill(0xab),\
|
|
\ key: new Uint8Array(32).fill(0x01),\
|
|
\ nonce: new Uint8Array(24).fill(0x02),\
|
|
\ chunkSize: 65536,\
|
|
\ chunks: [{\
|
|
\ chunkNo: 1,\
|
|
\ chunkSize: 65536,\
|
|
\ digest: new Uint8Array(32).fill(0xcd),\
|
|
\ replicas: [{\
|
|
\ server: 'xftp://AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=@example.com:443',\
|
|
\ replicaId: new Uint8Array([1,2,3]),\
|
|
\ replicaKey: new Uint8Array([48,46,2,1,0,48,5,6,3,43,101,112,4,34,4,32,\
|
|
\ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32])\
|
|
\ }]\
|
|
\ }],\
|
|
\ redirect: null\
|
|
\};\
|
|
\const uri = Agent.encodeDescriptionURI(fd);\
|
|
\const fd2 = Agent.decodeDescriptionURI(uri);\
|
|
\const yaml1 = Desc.encodeFileDescription(fd);\
|
|
\const yaml2 = Desc.encodeFileDescription(fd2);\
|
|
\const match = yaml1 === yaml2 ? 1 : 0;"
|
|
<> jsOut "new Uint8Array([match])"
|
|
result `shouldBe` B.pack [1]
|
|
|
|
agentUploadDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
|
agentUploadDownloadTest cfg caFile = do
|
|
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
|
withXFTPServerCfg cfg $ \_ -> do
|
|
Fingerprint fp <- loadFileFingerprint caFile
|
|
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
|
|
addr = "xftp://" <> fpStr <> "@localhost:" <> xftpTestPort
|
|
result <-
|
|
callNode $
|
|
"import sodium from 'libsodium-wrappers-sumo';\
|
|
\import crypto from 'node:crypto';\
|
|
\import * as Addr from './dist/protocol/address.js';\
|
|
\import * as Agent from './dist/agent.js';\
|
|
\await sodium.ready;\
|
|
\const server = Addr.parseXFTPServer('"
|
|
<> addr
|
|
<> "');\
|
|
\const agent = Agent.newXFTPAgent();\
|
|
\const originalData = new Uint8Array(crypto.randomBytes(50000));\
|
|
\const encrypted = Agent.encryptFileForUpload(originalData, 'test-file.bin');\
|
|
\const {rcvDescription, sndDescription, uri} = await Agent.uploadFile(agent, [server], encrypted);\
|
|
\const fd = Agent.decodeDescriptionURI(uri);\
|
|
\const {header, content} = await Agent.downloadFile(agent, fd);\
|
|
\Agent.closeXFTPAgent(agent);\
|
|
\const nameMatch = header.fileName === 'test-file.bin' ? 1 : 0;\
|
|
\const sizeMatch = content.length === originalData.length ? 1 : 0;\
|
|
\let dataMatch = 1;\
|
|
\for (let i = 0; i < content.length; i++) {\
|
|
\ if (content[i] !== originalData[i]) { dataMatch = 0; break; }\
|
|
\};"
|
|
<> jsOut "new Uint8Array([nameMatch, sizeMatch, dataMatch])"
|
|
result `shouldBe` B.pack [1, 1, 1]
|
|
|
|
agentDeleteTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
|
agentDeleteTest cfg caFile = do
|
|
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
|
withXFTPServerCfg cfg $ \_ -> do
|
|
Fingerprint fp <- loadFileFingerprint caFile
|
|
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
|
|
addr = "xftp://" <> fpStr <> "@localhost:" <> xftpTestPort
|
|
result <-
|
|
callNode $
|
|
"import sodium from 'libsodium-wrappers-sumo';\
|
|
\import crypto from 'node:crypto';\
|
|
\import * as Addr from './dist/protocol/address.js';\
|
|
\import * as Agent from './dist/agent.js';\
|
|
\await sodium.ready;\
|
|
\const server = Addr.parseXFTPServer('"
|
|
<> addr
|
|
<> "');\
|
|
\const agent = Agent.newXFTPAgent();\
|
|
\const originalData = new Uint8Array(crypto.randomBytes(50000));\
|
|
\const encrypted = Agent.encryptFileForUpload(originalData, 'del-test.bin');\
|
|
\const {rcvDescription, sndDescription} = await Agent.uploadFile(agent, [server], encrypted);\
|
|
\await Agent.deleteFile(agent, sndDescription);\
|
|
\let deleted = 0;\
|
|
\try {\
|
|
\ await Agent.downloadFile(agent, rcvDescription);\
|
|
\} catch (e) {\
|
|
\ deleted = 1;\
|
|
\}\
|
|
\Agent.closeXFTPAgent(agent);"
|
|
<> jsOut "new Uint8Array([deleted])"
|
|
result `shouldBe` B.pack [1]
|
|
|
|
agentRedirectTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
|
agentRedirectTest cfg caFile = do
|
|
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
|
withXFTPServerCfg cfg $ \_ -> do
|
|
Fingerprint fp <- loadFileFingerprint caFile
|
|
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
|
|
addr = "xftp://" <> fpStr <> "@localhost:" <> xftpTestPort
|
|
result <-
|
|
callNode $
|
|
"import sodium from 'libsodium-wrappers-sumo';\
|
|
\import crypto from 'node:crypto';\
|
|
\import * as Addr from './dist/protocol/address.js';\
|
|
\import * as Agent from './dist/agent.js';\
|
|
\await sodium.ready;\
|
|
\const server = Addr.parseXFTPServer('"
|
|
<> addr
|
|
<> "');\
|
|
\const agent = Agent.newXFTPAgent();\
|
|
\const originalData = new Uint8Array(crypto.randomBytes(100000));\
|
|
\const encrypted = Agent.encryptFileForUpload(originalData, 'redirect-test.bin');\
|
|
\const {rcvDescription, uri} = await Agent.uploadFile(agent, [server], encrypted, {redirectThreshold: 50});\
|
|
\const fd = Agent.decodeDescriptionURI(uri);\
|
|
\const hasRedirect = fd.redirect !== null ? 1 : 0;\
|
|
\const {header, content} = await Agent.downloadFile(agent, fd);\
|
|
\Agent.closeXFTPAgent(agent);\
|
|
\const nameMatch = header.fileName === 'redirect-test.bin' ? 1 : 0;\
|
|
\const sizeMatch = content.length === originalData.length ? 1 : 0;\
|
|
\let dataMatch = 1;\
|
|
\for (let i = 0; i < content.length; i++) {\
|
|
\ if (content[i] !== originalData[i]) { dataMatch = 0; break; }\
|
|
\};"
|
|
<> jsOut "new Uint8Array([hasRedirect, nameMatch, sizeMatch, dataMatch])"
|
|
result `shouldBe` B.pack [1, 1, 1, 1]
|
|
|
|
tsUploadHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
|
tsUploadHaskellDownloadTest cfg caFile = do
|
|
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
|
createDirectoryIfMissing False recipientFiles
|
|
withXFTPServerCfg cfg $ \_ -> do
|
|
Fingerprint fp <- loadFileFingerprint caFile
|
|
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
|
|
addr = "xftp://" <> fpStr <> "@localhost:" <> xftpTestPort
|
|
(yamlDesc, originalData) <-
|
|
callNode2 $
|
|
"import sodium from 'libsodium-wrappers-sumo';\
|
|
\import crypto from 'node:crypto';\
|
|
\import * as Addr from './dist/protocol/address.js';\
|
|
\import * as Agent from './dist/agent.js';\
|
|
\import {encodeFileDescription} from './dist/protocol/description.js';\
|
|
\await sodium.ready;\
|
|
\const server = Addr.parseXFTPServer('"
|
|
<> addr
|
|
<> "');\
|
|
\const agent = Agent.newXFTPAgent();\
|
|
\const originalData = new Uint8Array(crypto.randomBytes(50000));\
|
|
\const encrypted = Agent.encryptFileForUpload(originalData, 'ts-to-hs.bin');\
|
|
\const {rcvDescription} = await Agent.uploadFile(agent, [server], encrypted);\
|
|
\Agent.closeXFTPAgent(agent);\
|
|
\const yaml = encodeFileDescription(rcvDescription);"
|
|
<> jsOut2 "Buffer.from(yaml)" "Buffer.from(originalData)"
|
|
let vfd :: ValidFileDescription 'FRecipient = either error id $ strDecode yamlDesc
|
|
withAgent 1 agentCfg initAgentServers testDB $ \rcp -> do
|
|
runRight_ $ xftpStartWorkers rcp (Just recipientFiles)
|
|
_ <- runRight $ xftpReceiveFile rcp 1 vfd Nothing True
|
|
rfProgress rcp 50000
|
|
(_, _, RFDONE outPath) <- rfGet rcp
|
|
downloadedData <- B.readFile outPath
|
|
downloadedData `shouldBe` originalData
|
|
|
|
tsUploadRedirectHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
|
tsUploadRedirectHaskellDownloadTest cfg caFile = do
|
|
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
|
createDirectoryIfMissing False recipientFiles
|
|
withXFTPServerCfg cfg $ \_ -> do
|
|
Fingerprint fp <- loadFileFingerprint caFile
|
|
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
|
|
addr = "xftp://" <> fpStr <> "@localhost:" <> xftpTestPort
|
|
(yamlDesc, originalData) <-
|
|
callNode2 $
|
|
"import sodium from 'libsodium-wrappers-sumo';\
|
|
\import crypto from 'node:crypto';\
|
|
\import * as Addr from './dist/protocol/address.js';\
|
|
\import * as Agent from './dist/agent.js';\
|
|
\import {encodeFileDescription} from './dist/protocol/description.js';\
|
|
\await sodium.ready;\
|
|
\const server = Addr.parseXFTPServer('"
|
|
<> addr
|
|
<> "');\
|
|
\const agent = Agent.newXFTPAgent();\
|
|
\const originalData = new Uint8Array(crypto.randomBytes(100000));\
|
|
\const encrypted = Agent.encryptFileForUpload(originalData, 'ts-redirect-to-hs.bin');\
|
|
\const {rcvDescription} = await Agent.uploadFile(agent, [server], encrypted, {redirectThreshold: 50});\
|
|
\Agent.closeXFTPAgent(agent);\
|
|
\const yaml = encodeFileDescription(rcvDescription);"
|
|
<> jsOut2 "Buffer.from(yaml)" "Buffer.from(originalData)"
|
|
let vfd@(ValidFileDescription fd) :: ValidFileDescription 'FRecipient = either error id $ strDecode yamlDesc
|
|
redirect fd `shouldSatisfy` (/= Nothing)
|
|
withAgent 1 agentCfg initAgentServers testDB $ \rcp -> do
|
|
runRight_ $ xftpStartWorkers rcp (Just recipientFiles)
|
|
_ <- runRight $ xftpReceiveFile rcp 1 vfd Nothing True
|
|
outPath <- waitRfDone rcp
|
|
downloadedData <- B.readFile outPath
|
|
downloadedData `shouldBe` originalData
|
|
|
|
haskellUploadTsDownloadTest :: XFTPServerConfig STMFileStore -> Expectation
|
|
haskellUploadTsDownloadTest cfg = do
|
|
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
|
createDirectoryIfMissing False senderFiles
|
|
let filePath = senderFiles <> "/hs-to-ts.bin"
|
|
originalData <- B.pack <$> replicateM 50000 (randomIO :: IO Word8)
|
|
B.writeFile filePath originalData
|
|
withXFTPServerCfg cfg $ \_ -> do
|
|
vfd <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
|
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
|
|
_ <- runRight $ xftpSendFile sndr 1 (CF.plain filePath) 1
|
|
sfProgress sndr 50000
|
|
(_, _, SFDONE _ [rfd]) <- sfGet sndr
|
|
pure rfd
|
|
let yamlDesc = strEncode vfd
|
|
tmpYaml = "tests/tmp/hs-to-ts-desc.yaml"
|
|
tmpData = "tests/tmp/hs-to-ts-data.bin"
|
|
B.writeFile tmpYaml yamlDesc
|
|
B.writeFile tmpData originalData
|
|
result <-
|
|
callNode $
|
|
"import fs from 'node:fs';\
|
|
\import sodium from 'libsodium-wrappers-sumo';\
|
|
\import * as Agent from './dist/agent.js';\
|
|
\import {decodeFileDescription, validateFileDescription} from './dist/protocol/description.js';\
|
|
\await sodium.ready;\
|
|
\const yaml = fs.readFileSync('../tests/tmp/hs-to-ts-desc.yaml', 'utf-8');\
|
|
\const expected = new Uint8Array(fs.readFileSync('../tests/tmp/hs-to-ts-data.bin'));\
|
|
\const fd = decodeFileDescription(yaml);\
|
|
\const err = validateFileDescription(fd);\
|
|
\if (err) throw new Error(err);\
|
|
\const agent = Agent.newXFTPAgent();\
|
|
\const {header, content} = await Agent.downloadFile(agent, fd);\
|
|
\Agent.closeXFTPAgent(agent);\
|
|
\const nameMatch = header.fileName === 'hs-to-ts.bin' ? 1 : 0;\
|
|
\const sizeMatch = content.length === expected.length ? 1 : 0;\
|
|
\let dataMatch = 1;\
|
|
\for (let i = 0; i < content.length; i++) {\
|
|
\ if (content[i] !== expected[i]) { dataMatch = 0; break; }\
|
|
\};"
|
|
<> jsOut "new Uint8Array([nameMatch, sizeMatch, dataMatch])"
|
|
result `shouldBe` B.pack [1, 1, 1]
|
|
|
|
rfProgress :: AgentClient -> Int64 -> IO ()
|
|
rfProgress c _expected = loop 0
|
|
where
|
|
loop prev = do
|
|
(_, _, RFPROG rcvd total) <- rfGet c
|
|
when (rcvd < total && rcvd > prev) $ loop rcvd
|
|
|
|
sfProgress :: AgentClient -> Int64 -> IO ()
|
|
sfProgress c _expected = loop 0
|
|
where
|
|
loop prev = do
|
|
(_, _, SFPROG sent total) <- sfGet c
|
|
when (sent < total && sent > prev) $ loop sent
|
|
|
|
waitRfDone :: AgentClient -> IO FilePath
|
|
waitRfDone c = do
|
|
ev <- rfGet c
|
|
case ev of
|
|
(_, _, RFDONE outPath) -> pure outPath
|
|
(_, _, RFPROG _ _) -> waitRfDone c
|
|
(_, _, RFERR e) -> error $ "RFERR: " <> show e
|
|
_ -> error $ "Unexpected event: " <> show ev
|
|
|
|
callNode2 :: String -> IO (B.ByteString, B.ByteString)
|
|
callNode2 script = do
|
|
out <- callNode script
|
|
let (len1Bytes, rest1) = B.splitAt 4 out
|
|
len1 = fromIntegral (B.index len1Bytes 0) + fromIntegral (B.index len1Bytes 1) * 256 + fromIntegral (B.index len1Bytes 2) * 65536 + fromIntegral (B.index len1Bytes 3) * 16777216
|
|
(data1, rest2) = B.splitAt len1 rest1
|
|
(len2Bytes, rest3) = B.splitAt 4 rest2
|
|
len2 = fromIntegral (B.index len2Bytes 0) + fromIntegral (B.index len2Bytes 1) * 256 + fromIntegral (B.index len2Bytes 2) * 65536 + fromIntegral (B.index len2Bytes 3) * 16777216
|
|
data2 = B.take len2 rest3
|
|
pure (data1, data2)
|
|
|
|
jsOut2 :: String -> String -> String
|
|
jsOut2 a b = "const __a = " <> a <> "; const __b = " <> b <> "; const __buf = Buffer.alloc(8 + __a.length + __b.length); __buf.writeUInt32LE(__a.length, 0); __a.copy(__buf, 4); __buf.writeUInt32LE(__b.length, 4 + __a.length); __b.copy(__buf, 8 + __a.length); process.stdout.write(__buf);"
|