diff --git a/stdlib/src/main/pascal/net.websockets.pas b/stdlib/src/main/pascal/net.websockets.pas new file mode 100644 index 0000000..ee44a3c --- /dev/null +++ b/stdlib/src/main/pascal/net.websockets.pas @@ -0,0 +1,181 @@ +{ + Blaise - An Object Pascal Compiler + Copyright (c) 2026 Graeme Geldenhuys + SPDX-License-Identifier: Apache-2.0 WITH Swift-exception + Licensed under the Apache License v2.0 with Runtime Library Exception. + See LICENSE file in the project root for full license terms. +} + +{ Blaise stdlib - WebSocket (RFC 6455) framing and handshake helpers. + + This unit is transport-agnostic: it turns bytes into frames and back, and + computes the handshake accept key. It does NOT own a socket — pair it with + Net.Sockets (or any byte stream) to drive a connection. + + * WebSocketAccept — the Sec-WebSocket-Accept value for a client key. + * EncodeTextFrame — build a server->client text frame (RFC 6455 5.2), + unmasked, payloads up to 2^31-1. + * DecodeFrame — parse one frame from a buffer, unmasking the payload + (client->server frames are always masked). + + Server frames are sent unmasked; client frames must be masked. DecodeFrame + handles both. Continuation/fragmentation is reported via the FIN flag but + not reassembled here (callers needing message reassembly concatenate the + payloads of a FIN=False frame followed by opcode-0 continuation frames). } + +unit Net.WebSockets; + +interface + +const + { RFC 6455 opcodes } + WS_OP_CONTINUATION = $0; + WS_OP_TEXT = $1; + WS_OP_BINARY = $2; + WS_OP_CLOSE = $8; + WS_OP_PING = $9; + WS_OP_PONG = $A; + +type + { One decoded frame. Payload holds the unmasked bytes (as a string). } + TWsFrame = record + Valid: Boolean; { False if the buffer held no complete frame } + Fin: Boolean; { final fragment of a message } + Opcode: Integer; + Payload: string; + { Number of bytes consumed from the input buffer for this frame; callers + streaming a socket advance their buffer by this much. } + Consumed: Integer; + end; + +{ Compute Sec-WebSocket-Accept for a client's Sec-WebSocket-Key (the value + echoed back in the 101 handshake response). } +function WebSocketAccept(const AKey: string): string; + +{ Build an unmasked text frame carrying APayload (server->client). } +function EncodeTextFrame(const APayload: string): string; + +{ Build an unmasked frame with an explicit opcode (e.g. WS_OP_BINARY, + WS_OP_PING, WS_OP_CLOSE). Server frames are never masked. } +function EncodeFrame(AOpcode: Integer; const APayload: string): string; + +{ Parse the first frame in ABuffer. Returns Valid=False (Consumed=0) if the + buffer does not yet hold a complete frame — read more bytes and retry. } +function DecodeFrame(const ABuffer: string): TWsFrame; + +implementation + +uses + Security.Crypto, Encoding.Base64, StrUtils; + +const + { the RFC 6455 magic GUID appended to the key before hashing } + WS_GUID = '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'; + +function WebSocketAccept(const AKey: string): string; +begin + Result := Base64Encode(Sha1(AKey + WS_GUID)); +end; + +function EncodeFrame(AOpcode: Integer; const APayload: string): string; +var + SB: TStringBuilder; + Len: Integer; +begin + SB := TStringBuilder.Create(); + SB.AppendByte($80 or (AOpcode and $0F)); { FIN + opcode, unmasked } + Len := Length(APayload); + if Len < 126 then + SB.AppendByte(Len) + else if Len <= 65535 then + begin + SB.AppendByte(126); + SB.AppendByte((Len shr 8) and $FF); + SB.AppendByte(Len and $FF); + end + else + begin + { 64-bit length; top 4 bytes are 0 since strings here fit in 2^31-1. } + SB.AppendByte(127); + SB.AppendByte(0); SB.AppendByte(0); SB.AppendByte(0); SB.AppendByte(0); + SB.AppendByte((Len shr 24) and $FF); + SB.AppendByte((Len shr 16) and $FF); + SB.AppendByte((Len shr 8) and $FF); + SB.AppendByte(Len and $FF); + end; + SB.Append(APayload); + Result := SB.ToString(); + SB.Free(); +end; + +function EncodeTextFrame(const APayload: string): string; +begin + Result := EncodeFrame(WS_OP_TEXT, APayload); +end; + +function DecodeFrame(const ABuffer: string): TWsFrame; +var + N, Pos, I: Integer; + B0, B1: Byte; + Masked: Boolean; + PayLen: Int64; + Mask: array[0..3] of Byte; + SB: TStringBuilder; +begin + Result.Valid := False; + Result.Consumed := 0; + Result.Payload := ''; + + N := Length(ABuffer); + if N < 2 then Exit; { need at least the 2-byte header } + + B0 := Byte(ABuffer[0]); + B1 := Byte(ABuffer[1]); + Result.Fin := (B0 and $80) <> 0; + Result.Opcode := B0 and $0F; + Masked := (B1 and $80) <> 0; + PayLen := B1 and $7F; + Pos := 2; + + if PayLen = 126 then + begin + if N < Pos + 2 then Exit; + PayLen := (Int64(Byte(ABuffer[Pos])) shl 8) or Int64(Byte(ABuffer[Pos + 1])); + Pos := Pos + 2; + end + else if PayLen = 127 then + begin + if N < Pos + 8 then Exit; + { 64-bit length; we only support the low 31 bits (string length). } + PayLen := 0; + for I := 0 to 7 do + PayLen := (PayLen shl 8) or Int64(Byte(ABuffer[Pos + I])); + Pos := Pos + 8; + end; + + if Masked then + begin + if N < Pos + 4 then Exit; + for I := 0 to 3 do + Mask[I] := Byte(ABuffer[Pos + I]); + Pos := Pos + 4; + end; + + if N < Pos + PayLen then Exit; { payload not fully arrived } + + SB := TStringBuilder.Create(); + for I := 0 to Integer(PayLen) - 1 do + begin + if Masked then + SB.AppendByte(Byte(ABuffer[Pos + I]) xor Mask[I and 3]) + else + SB.AppendByte(Byte(ABuffer[Pos + I])); + end; + Result.Payload := SB.ToString(); + SB.Free(); + + Result.Consumed := Pos + Integer(PayLen); + Result.Valid := True; +end; + +end. diff --git a/stdlib/src/test/pascal/test.registry.pas b/stdlib/src/test/pascal/test.registry.pas index a0893f1..695dee5 100644 --- a/stdlib/src/test/pascal/test.registry.pas +++ b/stdlib/src/test/pascal/test.registry.pas @@ -24,7 +24,8 @@ uses Json.Tests, Base64.Tests, Crypto.Tests, - Sockets.Tests; + Sockets.Tests, + WebSockets.Tests; implementation diff --git a/stdlib/src/test/pascal/websockets.tests.pas b/stdlib/src/test/pascal/websockets.tests.pas new file mode 100644 index 0000000..9ebabda --- /dev/null +++ b/stdlib/src/test/pascal/websockets.tests.pas @@ -0,0 +1,120 @@ +{ + Blaise - An Object Pascal Compiler + Copyright (c) 2026 Graeme Geldenhuys + SPDX-License-Identifier: Apache-2.0 WITH Swift-exception + Licensed under the Apache License v2.0 with Runtime Library Exception. + See LICENSE file in the project root for full license terms. +} + +{ Tests for Net.WebSockets: handshake accept key and frame encode/decode. + Self-registers via the initialization section. } + +unit WebSockets.Tests; + +interface + +uses + blaise.testing, Net.WebSockets; + +type + TWebSocketsTests = class(TTestCase) + published + procedure TestAccept; + procedure TestEncodeShortText; + procedure TestEncode126; + procedure TestRoundTripUnmasked; + procedure TestRoundTripMasked; + procedure TestPartialBufferIsInvalid; + end; + +implementation + +procedure TWebSocketsTests.TestAccept; +begin + { RFC 6455 6.1 worked example. } + AssertEquals('accept', 's3pPLMBiTxaQ9kYGzzhZRbK+xOo=', + WebSocketAccept('dGhlIHNhbXBsZSBub25jZQ==')); +end; + +procedure TWebSocketsTests.TestEncodeShortText; +var F: string; +begin + F := EncodeTextFrame('hi'); + AssertEquals('len', 4, Integer(Length(F))); + AssertEquals('b0 fin+text', $81, Integer(Byte(F[0]))); + AssertEquals('b1 len', 2, Integer(Byte(F[1]))); + AssertEquals('payload h', 104, Integer(Byte(F[2]))); { 'h' } +end; + +procedure TWebSocketsTests.TestEncode126; +var + Payload, F: string; + I: Integer; +begin + { 200 bytes -> extended 16-bit length form (126 marker + 2 bytes). } + Payload := ''; + for I := 1 to 200 do Payload := Payload + 'x'; + F := EncodeTextFrame(Payload); + AssertEquals('b1 marker', 126, Integer(Byte(F[1]))); + AssertEquals('len hi', 0, Integer(Byte(F[2]))); + AssertEquals('len lo', 200, Integer(Byte(F[3]))); + AssertEquals('total', 4 + 200, Integer(Length(F))); +end; + +procedure TWebSocketsTests.TestRoundTripUnmasked; +var + F: string; + D: TWsFrame; +begin + F := EncodeTextFrame('hello world'); + D := DecodeFrame(F); + AssertTrue('valid', D.Valid); + AssertTrue('fin', D.Fin); + AssertEquals('opcode', WS_OP_TEXT, D.Opcode); + AssertEquals('payload', 'hello world', D.Payload); + AssertEquals('consumed', Length(F), D.Consumed); +end; + +procedure TWebSocketsTests.TestRoundTripMasked; +var + Buf: string; + D: TWsFrame; + SB: TStringBuilder; + Mask: array[0..3] of Byte; + Plain: string; + I: Integer; +begin + { Hand-build a masked client text frame "ping" (clients must mask). } + Plain := 'ping'; + Mask[0] := 10; Mask[1] := 20; Mask[2] := 30; Mask[3] := 40; + SB := TStringBuilder.Create(); + SB.AppendByte($81); { FIN + text } + SB.AppendByte($80 or Length(Plain)); { MASK + len } + for I := 0 to 3 do SB.AppendByte(Mask[I]); + for I := 0 to Length(Plain) - 1 do + SB.AppendByte(Byte(Plain[I]) xor Mask[I and 3]); + Buf := SB.ToString(); + SB.Free(); + + D := DecodeFrame(Buf); + AssertTrue('valid', D.Valid); + AssertEquals('unmasked payload', Plain, D.Payload); + AssertEquals('consumed', Length(Buf), D.Consumed); +end; + +procedure TWebSocketsTests.TestPartialBufferIsInvalid; +var + F, Partial: string; + D: TWsFrame; +begin + F := EncodeTextFrame('hello world'); + Partial := Copy(F, 0, 3); { header + 1 payload byte, incomplete } + D := DecodeFrame(Partial); + AssertFalse('not valid', D.Valid); + AssertEquals('consumed 0', 0, D.Consumed); +end; + +initialization + RegisterTest(TWebSocketsTests); + +end.