administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

stdlib: add Net.Http.Server (minimal HTTP/1.1 + WebSocket)

Browse source 
Single-threaded HTTP/1.1 server lifted from the Luhmann web server and
generalised: THttpRequest/THttpResponse/IRequestHandler/THttpServer plus
ParseRequest/UrlDecode. WebSocket upgrades are handled via Net.WebSockets and
Broadcast(payload) pushes a text frame to every connected socket (the
reload-specific BroadcastReload became a generic Broadcast). Built on
Net.Sockets. Private split helpers are prefixed to avoid colliding with a
consumer's same-named functions. Tests cover parsing, URL decoding, a loopback
request round-trip, and a WebSocket upgrade + broadcast (43 tests total).
This commit is contained in:
Graeme Geldenhuys 2026-06-23 00:07:46 +01:00
parent e52909576a
commit cc43c4a0c5
3 changed files with 645 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

503
stdlib/src/main/pascal/net.http.server.pas Normal file
View file

@ -0,0 +1,503 @@
{
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 - a minimal single-threaded HTTP/1.1 server (no TLS).
Connections are accepted and serviced one at a time. A request is parsed
into a THttpRequest; the application supplies an IRequestHandler whose Handle
fills a THttpResponse. Suitable for a local tool, an internal service, or a
test fixture — not a high-concurrency front end.
WebSocket upgrades are recognised automatically (cf. Net.WebSockets): when a
request carries a Sec-WebSocket-Key the server completes the handshake, keeps
the socket open, and tracks it. Broadcast then pushes a text frame to every
such socket — e.g. a live-reload or notification channel.
The handler is passed as an interface PARAMETER (not stored as a field), to
suit backends where an interface field called via Self is problematic. }
unit Net.Http.Server;
interface
uses
Classes,
Generics.Collections;
type
{ A parsed HTTP request. Query parameters are decoded into a name->value
map; the first value wins on a repeated key. }
THttpRequest = class
public
Method: string; { GET, POST, ... }
Path: string; { decoded path, e.g. /fruit/apple.html }
Query: TOrderedDictionary<string, string>;
RawHeaders: TStringList;
WebSocketKey: string; { Sec-WebSocket-Key, '' if not an upgrade }
constructor Create;
destructor Destroy; override;
function QueryParam(const AName: string): string;
function IsWebSocketUpgrade: Boolean;
end;
{ A response to send. Body may be binary (treated as raw bytes). }
THttpResponse = class
public
Status: Integer;
ContentType: string;
Body: string;
constructor Create;
procedure SetText(AStatus: Integer; const AContentType, ABody: string);
end;
{ The application implements this; the server calls Handle per request. }
IRequestHandler = interface
procedure Handle(ARequest: THttpRequest; AResponse: THttpResponse);
end;
THttpServer = class
private
FListenFd: Integer;
FPort: Integer;
FRunning: Boolean;
{ Connected WebSocket fds (upgraded connections kept open). }
FWsClients: TList<Integer>;
function ReadRequest(AConnFd: Integer): string;
procedure SendResponse(AConnFd: Integer; AResp: THttpResponse);
procedure DoWebSocketHandshake(AConnFd: Integer; const AKey: string);
procedure ServeConn(AConnFd: Integer; AHandler: IRequestHandler);
public
constructor Create(APort: Integer);
destructor Destroy; override;
{ Bind and listen on 127.0.0.1:Port. Returns False on failure. }
function Start: Boolean;
{ Put the listen socket into non-blocking mode so PollOnce never blocks. }
procedure SetNonBlocking;
{ Accept and service the next connection, dispatching to AHandler.
Blocks until a connection arrives. }
procedure ServeOnce(AHandler: IRequestHandler);
{ Non-blocking variant: if a connection is pending, service it and return
True; otherwise return False immediately. }
function PollOnce(AHandler: IRequestHandler): Boolean;
{ Push a WebSocket text frame to every connected upgrade socket. Dead
sockets are dropped. Use this for live-reload / push channels. }
procedure Broadcast(const APayload: string);
property Port: Integer read FPort;
end;
{ Parse a raw request head into a THttpRequest (caller owns the result). }
function ParseRequest(const ARaw: string): THttpRequest;
{ Percent-decode a URL component. }
function UrlDecode(const S: string): string;
implementation
uses
SysUtils,
StrUtils,
Net.Sockets,
Net.WebSockets;
const
RECV_BUF = 8192;
{ ---- private string helpers (kept here so StrUtils stays Classes-free) ---- }
function StripTrailingCR(const S: string): string;
begin
if (Length(S) > 0) and (Byte(S[Length(S) - 1]) = 13) then { trailing CR }
Result := Copy(S, 0, Length(S) - 1)
else
Result := S;
end;
{ Split S on LF, stripping a trailing CR from each line (so CRLF and LF both
work). Caller owns the returned list. }
function HttpSplitLines(const S: string): TStringList;
var
I, N, Start: Integer;
begin
Result := TStringList.Create();
N := Length(S);
Start := 0;
I := 0;
while I < N do
begin
if Byte(S[I]) = 10 then { LF }
begin
Result.Add(StripTrailingCR(Copy(S, Start, I - Start)));
Start := I + 1;
end;
I := I + 1;
end;
Result.Add(StripTrailingCR(Copy(S, Start, N - Start)));
end;
{ Split S on a single delimiter byte. Caller owns the returned list. }
function HttpSplitChar(const S: string; ADelim: Byte): TStringList;
var
I, N, Start: Integer;
begin
Result := TStringList.Create();
N := Length(S);
Start := 0;
I := 0;
while I < N do
begin
if Byte(S[I]) = ADelim then
begin
Result.Add(Copy(S, Start, I - Start));
Start := I + 1;
end;
I := I + 1;
end;
Result.Add(Copy(S, Start, N - Start));
end;
{ ---- THttpRequest ---- }
constructor THttpRequest.Create;
begin
Method := '';
Path := '';
Query := TOrderedDictionary<string, string>.Create();
RawHeaders := TStringList.Create();
WebSocketKey := '';
end;
destructor THttpRequest.Destroy;
begin
Query.Free();
RawHeaders.Free();
inherited Destroy;
end;
function THttpRequest.QueryParam(const AName: string): string;
begin
if not Query.TryGetValue(AName, Result) then
Result := '';
end;
function THttpRequest.IsWebSocketUpgrade: Boolean;
begin
Result := WebSocketKey <> '';
end;
{ ---- THttpResponse ---- }
constructor THttpResponse.Create;
begin
Status := 200;
ContentType := 'text/html; charset=utf-8';
Body := '';
end;
procedure THttpResponse.SetText(AStatus: Integer; const AContentType, ABody: string);
begin
Status := AStatus;
ContentType := AContentType;
Body := ABody;
end;
{ ---- parsing ---- }
function HexVal(AByte: Byte): Integer;
begin
if (AByte >= 48) and (AByte <= 57) then Result := AByte - 48
else if (AByte >= 65) and (AByte <= 70) then Result := AByte - 55
else if (AByte >= 97) and (AByte <= 102) then Result := AByte - 87
else Result := 0;
end;
function UrlDecode(const S: string): string;
var
SB: TStringBuilder;
I, N: Integer;
B: Byte;
begin
SB := TStringBuilder.Create();
N := Length(S);
I := 0;
while I < N do
begin
B := Byte(S[I]);
if (B = 37) and (I + 2 < N) then { '%' }
begin
SB.AppendByte(HexVal(Byte(S[I+1])) * 16 + HexVal(Byte(S[I+2])));
I := I + 3;
end
else if B = 43 then { '+' -> space }
begin
SB.AppendByte(32);
I := I + 1;
end
else
begin
SB.AppendByte(B);
I := I + 1;
end;
end;
Result := SB.ToString();
SB.Free();
end;
procedure ParseQuery(const AQueryStr: string; ADest: TOrderedDictionary<string, string>);
var
Pairs: TStringList;
I, Eq: Integer;
Pair, Key, Val: string;
begin
Pairs := HttpSplitChar(AQueryStr, 38); { '&' }
for I := 0 to Pairs.Count - 1 do
begin
Pair := Pairs.Get(I);
if Pair = '' then
Continue;
Eq := PosEx('=', Pair, 0);
if Eq < 0 then
begin
Key := UrlDecode(Pair);
Val := '';
end
else
begin
Key := UrlDecode(Copy(Pair, 0, Eq));
Val := UrlDecode(Copy(Pair, Eq + 1, Length(Pair) - Eq - 1));
end;
if not ADest.ContainsKey(Key) then
ADest.Add(Key, Val);
end;
Pairs.Free();
end;
function ParseRequest(const ARaw: string): THttpRequest;
var
Lines: TStringList;
ReqLine, Target, PathPart, QueryPart, Hdr, HdrLower: string;
Parts: TStringList;
I, Q, Colon: Integer;
begin
Result := THttpRequest.Create();
Lines := HttpSplitLines(ARaw);
if Lines.Count = 0 then
begin
Lines.Free();
Exit;
end;
ReqLine := Lines.Get(0);
Parts := HttpSplitChar(ReqLine, 32); { space }
if Parts.Count >= 2 then
begin
Result.Method := Parts.Get(0);
Target := Parts.Get(1);
end;
Parts.Free();
{ Split target into path and query. }
Q := PosEx('?', Target, 0);
if Q < 0 then
begin
PathPart := Target;
QueryPart := '';
end
else
begin
PathPart := Copy(Target, 0, Q);
QueryPart := Copy(Target, Q + 1, Length(Target) - Q - 1);
end;
Result.Path := UrlDecode(PathPart);
if QueryPart <> '' then
ParseQuery(QueryPart, Result.Query);
{ Headers. }
for I := 1 to Lines.Count - 1 do
begin
Hdr := Lines.Get(I);
if Trim(Hdr) = '' then
Break;
Result.RawHeaders.Add(Hdr);
HdrLower := LowerCase(Hdr);
if StartsStr('sec-websocket-key:', HdrLower) then
begin
Colon := PosEx(':', Hdr, 0);
Result.WebSocketKey := Trim(Copy(Hdr, Colon + 1, Length(Hdr) - Colon - 1));
end;
end;
Lines.Free();
end;
{ ---- THttpServer ---- }
constructor THttpServer.Create(APort: Integer);
begin
FPort := APort;
FListenFd := -1;
FRunning := False;
FWsClients := TList<Integer>.Create();
end;
destructor THttpServer.Destroy;
begin
if FListenFd >= 0 then
Close(FListenFd);
FWsClients.Free();
inherited Destroy;
end;
function THttpServer.Start: Boolean;
begin
FListenFd := TcpListenLocal(FPort, 64);
Result := FListenFd >= 0;
FRunning := Result;
end;
function THttpServer.ReadRequest(AConnFd: Integer): string;
var
Chunk, Acc: string;
SB: TStringBuilder;
begin
{ Read until the end of the header block (CRLFCRLF). Request bodies are not
surfaced by this server, so we stop at the head. }
SB := TStringBuilder.Create();
while True do
begin
Chunk := RecvString(AConnFd, RECV_BUF);
if Chunk = '' then
Break;
SB.Append(Chunk);
Acc := SB.ToString();
if PosEx(#13#10#13#10, Acc, 0) >= 0 then
Break;
if Length(Acc) > 65536 then
Break; { guard against a runaway head }
end;
Result := SB.ToString();
SB.Free();
end;
function StatusText(AStatus: Integer): string;
begin
if AStatus = 200 then Result := 'OK'
else if AStatus = 400 then Result := 'Bad Request'
else if AStatus = 404 then Result := 'Not Found'
else if AStatus = 500 then Result := 'Internal Server Error'
else Result := 'OK';
end;
procedure THttpServer.SendResponse(AConnFd: Integer; AResp: THttpResponse);
var
Head: string;
begin
Head := 'HTTP/1.1 ' + IntToStr(AResp.Status) + ' ' + StatusText(AResp.Status) + #13#10 +
'Content-Type: ' + AResp.ContentType + #13#10 +
'Content-Length: ' + IntToStr(Length(AResp.Body)) + #13#10 +
'Connection: close' + #13#10 +
#13#10;
SendAll(AConnFd, Head);
if Length(AResp.Body) > 0 then
SendAll(AConnFd, AResp.Body);
end;
procedure THttpServer.DoWebSocketHandshake(AConnFd: Integer; const AKey: string);
var
Head: string;
begin
Head := 'HTTP/1.1 101 Switching Protocols' + #13#10 +
'Upgrade: websocket' + #13#10 +
'Connection: Upgrade' + #13#10 +
'Sec-WebSocket-Accept: ' + WebSocketAccept(AKey) + #13#10 +
#13#10;
SendAll(AConnFd, Head);
{ Keep the connection open and remember it for push frames. The fd is left
open deliberately (ServeConn does not close it in the websocket case). }
FWsClients.Add(AConnFd);
end;
procedure THttpServer.SetNonBlocking;
begin
if FListenFd >= 0 then
MakeNonBlocking(FListenFd);
end;
procedure THttpServer.ServeConn(AConnFd: Integer; AHandler: IRequestHandler);
var
Raw: string;
Req: THttpRequest;
Resp: THttpResponse;
begin
Raw := ReadRequest(AConnFd);
Req := ParseRequest(Raw);
if Req.IsWebSocketUpgrade() then
begin
DoWebSocketHandshake(AConnFd, Req.WebSocketKey);
{ do NOT close AConnFd: it is now a live websocket }
Req.Free();
Exit;
end;
Resp := THttpResponse.Create();
AHandler.Handle(Req, Resp);
SendResponse(AConnFd, Resp);
Resp.Free();
Req.Free();
Close(AConnFd);
end;
procedure THttpServer.ServeOnce(AHandler: IRequestHandler);
var
ConnFd: Integer;
begin
ConnFd := AcceptConn(FListenFd);
if ConnFd < 0 then
Exit;
ServeConn(ConnFd, AHandler);
end;
function THttpServer.PollOnce(AHandler: IRequestHandler): Boolean;
var
ConnFd: Integer;
begin
ConnFd := AcceptConn(FListenFd);
if ConnFd < 0 then
begin
Result := False;
Exit;
end;
ServeConn(ConnFd, AHandler);
Result := True;
end;
procedure THttpServer.Broadcast(const APayload: string);
var
I, Fd: Integer;
Dead: TList<Integer>;
Frame: string;
begin
Frame := EncodeTextFrame(APayload);
Dead := TList<Integer>.Create();
for I := 0 to FWsClients.Count - 1 do
begin
Fd := FWsClients.Get(I);
if not SendAll(Fd, Frame) then
Dead.Add(Fd);
end;
{ drop sockets that failed to receive }
for I := 0 to Dead.Count - 1 do
begin
Fd := Dead.Get(I);
Close(Fd);
FWsClients.Delete(FWsClients.IndexOf(Fd));
end;
Dead.Free();
end;
end.

140
stdlib/src/test/pascal/httpserver.tests.pas Normal file
View file

@ -0,0 +1,140 @@
{
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.Http.Server: request parsing, URL decoding, and a loopback
request/response round-trip (incl. a WebSocket upgrade + broadcast).
Self-registers via the initialization section. }
unit HttpServer.Tests;
interface
uses
blaise.testing, Net.Http.Server, Net.Sockets, Net.WebSockets, StrUtils;
type
THttpServerTests = class(TTestCase)
published
procedure TestUrlDecode;
procedure TestParseGetWithQuery;
procedure TestParseWebSocketKey;
procedure TestRoundTrip;
procedure TestWebSocketUpgradeAndBroadcast;
end;
{ A trivial handler: echoes the path and the 'q' query param. }
TEchoHandler = class(IRequestHandler)
procedure Handle(ARequest: THttpRequest; AResponse: THttpResponse);
end;
implementation
procedure TEchoHandler.Handle(ARequest: THttpRequest; AResponse: THttpResponse);
begin
AResponse.SetText(200, 'text/plain',
ARequest.Path + '|' + ARequest.QueryParam('q'));
end;
procedure THttpServerTests.TestUrlDecode;
begin
AssertEquals('percent', 'a b', UrlDecode('a%20b'));
AssertEquals('plus', 'a b', UrlDecode('a+b'));
AssertEquals('plain', 'abc', UrlDecode('abc'));
end;
procedure THttpServerTests.TestParseGetWithQuery;
var Req: THttpRequest;
begin
Req := ParseRequest('GET /fruit/apple?q=red&n=2 HTTP/1.1'#13#10'Host: x'#13#10#13#10);
AssertEquals('method', 'GET', Req.Method);
AssertEquals('path', '/fruit/apple', Req.Path);
AssertEquals('q', 'red', Req.QueryParam('q'));
AssertEquals('n', '2', Req.QueryParam('n'));
AssertFalse('not ws', Req.IsWebSocketUpgrade());
Req.Free();
end;
procedure THttpServerTests.TestParseWebSocketKey;
var Req: THttpRequest;
begin
Req := ParseRequest(
'GET /reload HTTP/1.1'#13#10 +
'Upgrade: websocket'#13#10 +
'Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ=='#13#10#13#10);
AssertTrue('is ws', Req.IsWebSocketUpgrade());
AssertEquals('key', 'dGhlIHNhbXBsZSBub25jZQ==', Req.WebSocketKey);
Req.Free();
end;
procedure THttpServerTests.TestRoundTrip;
const
PORT = 28991;
var
Srv: THttpServer;
H: IRequestHandler;
Cli: Integer;
Resp: string;
begin
Srv := THttpServer.Create(PORT);
AssertTrue('start', Srv.Start());
H := TEchoHandler.Create();
Cli := TcpConnectLocal(PORT);
AssertTrue('connect', Cli >= 0);
AssertTrue('send', SendAll(Cli, 'GET /hi?q=net HTTP/1.1'#13#10'Host: x'#13#10#13#10));
Srv.ServeOnce(H);
Resp := RecvString(Cli, 1024);
AssertTrue('200', ContainsStr(Resp, '200 OK'));
AssertTrue('body', ContainsStr(Resp, '/hi|net'));
Close(Cli);
Srv.Free();
end;
procedure THttpServerTests.TestWebSocketUpgradeAndBroadcast;
const
PORT = 28992;
var
Srv: THttpServer;
H: IRequestHandler;
Cli: Integer;
Resp: string;
D: TWsFrame;
begin
Srv := THttpServer.Create(PORT);
AssertTrue('start', Srv.Start());
H := TEchoHandler.Create();
Cli := TcpConnectLocal(PORT);
AssertTrue('connect', Cli >= 0);
SendAll(Cli,
'GET /ws HTTP/1.1'#13#10 +
'Upgrade: websocket'#13#10 +
'Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ=='#13#10#13#10);
Srv.ServeOnce(H); { completes handshake, keeps socket }
Resp := RecvString(Cli, 1024);
AssertTrue('101', ContainsStr(Resp, '101 Switching Protocols'));
AssertTrue('accept', ContainsStr(Resp, 's3pPLMBiTxaQ9kYGzzhZRbK+xOo='));
Srv.Broadcast('reload');
Resp := RecvString(Cli, 64);
D := DecodeFrame(Resp);
AssertTrue('frame valid', D.Valid);
AssertEquals('opcode', WS_OP_TEXT, D.Opcode);
AssertEquals('payload', 'reload', D.Payload);
Close(Cli);
Srv.Free();
end;
initialization
RegisterTest(THttpServerTests);
end.

3
stdlib/src/test/pascal/test.registry.pas
View file

@ -25,7 +25,8 @@ uses
Base64.Tests,
Crypto.Tests,
Sockets.Tests,
WebSockets.Tests;
WebSockets.Tests,
HttpServer.Tests;
implementation