diff --git a/.gitignore b/.gitignore
index 8d90cf0..1ad9789 100644
--- a/.gitignore
+++ b/.gitignore
@@ -4,3 +4,6 @@ setEnv.sh
webServer.log
.claude
locust/__pycache__
+
+# Jasper local read-only class mirror of a connected stone (per user/stone)
+.gemstone/
diff --git a/Films/rowan/components/Core.ston b/Films/rowan/components/Core.ston
new file mode 100644
index 0000000..52a5c3d
--- /dev/null
+++ b/Films/rowan/components/Core.ston
@@ -0,0 +1,9 @@
+RwLoadComponent {
+ #name : 'Core',
+ #projectNames : [ ],
+ #componentNames : [ ],
+ #packageNames : [
+ 'Films-Core'
+ ],
+ #comment : 'The Films demo: the Film data class and the FilmsApi OpenAPI-documented app.'
+}
diff --git a/Films/rowan/project.ston b/Films/rowan/project.ston
new file mode 100644
index 0000000..c263458
--- /dev/null
+++ b/Films/rowan/project.ston
@@ -0,0 +1,12 @@
+RwProjectSpecificationV3 {
+ #specName : 'project',
+ #projectVersion : '1.0.0',
+ #projectSpecPath : 'rowan',
+ #componentsPath : 'rowan/components',
+ #packagesPath : 'src',
+ #projectsPath : 'rowan/projects',
+ #specsPath : 'rowan/specs',
+ #packageFormat : 'tonel',
+ #packageConvention : 'RowanHybrid',
+ #comment : 'Films: the OpenAPI demo app for WebGS (Film data class + FilmsApi). Loads into its own Films symbol dictionary, matching installFilmsApi.sh.'
+}
diff --git a/Films/rowan/projects/README.md b/Films/rowan/projects/README.md
new file mode 100644
index 0000000..e69de29
diff --git a/Films/rowan/specs/Films.ston b/Films/rowan/specs/Films.ston
new file mode 100644
index 0000000..f72a490
--- /dev/null
+++ b/Films/rowan/specs/Films.ston
@@ -0,0 +1,15 @@
+RwLoadSpecificationV2 {
+ #projectName : 'Films',
+ #projectSpecFile : 'rowan/project.ston',
+ #componentNames : [
+ 'Core'
+ ],
+ #platformProperties : {
+ 'gemstone' : {
+ 'allusers' : {
+ #defaultSymbolDictName : 'Films'
+ }
+ }
+ },
+ #comment : 'The Films OpenAPI demo app. Loads Film + FilmsApi into the Films symbol dictionary (matches installFilmsApi.sh). Requires WebGS to be loaded first.'
+}
diff --git a/Films/src/Films-Core/Film.class.st b/Films/src/Films-Core/Film.class.st
new file mode 100644
index 0000000..a56b6a2
--- /dev/null
+++ b/Films/src/Films-Core/Film.class.st
@@ -0,0 +1,81 @@
+Class {
+ #name : 'Film',
+ #superclass : 'Object',
+ #instVars : [
+ 'id',
+ 'title',
+ 'views'
+ ],
+ #classInstVars : [
+ 'films'
+ ],
+ #category : 'Films-Core'
+}
+
+{ #category : 'unclassified' }
+Film class >> data [
+
+ ^#(
+ #(1 'Barbie' 59019108)
+ #(2 'The Super Mario Bros. Film' 53333425)
+ #(3 'Spider-Man: Across the Spid…' 35372108)
+ #(4 'Guardians of the Galaxy Vol 3' 33302024)
+ #(5 'Oppenheimer' 30250590)
+ #(6 'The Little Mermaid' 27659745)
+ #(7 'Avatar: The Way of Water' 26258614)
+ #(8 'Ant-Man and the Wasp: Quant…' 19898415)
+ #(9 'John Wick: Chapter 4' 17359165)
+ #(10 'Sound of Freedom' 17085161)
+ )
+]
+
+{ #category : 'unclassified' }
+Film class >> films [
+
+ films ifNil: [
+ films := self data collect: [:row |
+ self new initialize: row; yourself.
+ ].
+ ].
+ ^films
+]
+
+{ #category : 'unclassified' }
+Film class >> withId: anInteger [
+
+ ^self films
+ detect: [:each | each id = anInteger]
+ ifNone: [nil]
+]
+
+{ #category : 'initialization' }
+Film >> initialize: anArray [
+
+ id := anArray at: 1.
+ title := anArray at: 2.
+ views := anArray at: 3.
+]
+
+{ #category : 'accessors' }
+Film >> id [
+
+ ^id
+]
+
+{ #category : 'accessors' }
+Film >> title [
+
+ ^title
+]
+
+{ #category : 'accessors' }
+Film >> views [
+
+ ^views
+]
+
+{ #category : 'accessors' }
+Film >> views: anInteger [
+
+ views := anInteger
+]
diff --git a/Films/src/Films-Core/FilmsApi.class.st b/Films/src/Films-Core/FilmsApi.class.st
new file mode 100644
index 0000000..8e583a4
--- /dev/null
+++ b/Films/src/Films-Core/FilmsApi.class.st
@@ -0,0 +1,130 @@
+"Demo app showing OpenAPI-documented routes via DocumentedRouter.
+
+Launch with: FilmsApi runHttp.
+Then visit: http://localhost:8888/docs"
+Class {
+ #name : 'FilmsApi',
+ #superclass : 'Object',
+ #category : 'Films-Core'
+}
+
+{ #category : 'launching' }
+FilmsApi class >> runHttp [
+"
+ FilmsApi runHttp.
+"
+
+ ^self runHttpOnPort: 8888
+]
+
+{ #category : 'launching' }
+FilmsApi class >> runHttpOnPort: anInteger [
+"
+ FilmsApi runHttpOnPort: 8888.
+"
+
+ HttpListener new
+ listenBacklog: 200;
+ port: anInteger;
+ server: HttpServer;
+ router: self defaultRouter;
+ run
+]
+
+{ #category : 'routes' }
+FilmsApi class >> defaultRouter [
+"
+ A configured DocumentedRouter with the Films endpoints registered and the
+ OpenAPI spec populated. Visit /openapi.json for the spec or /docs for Swagger UI.
+"
+
+ | router filmSchema |
+ router := DocumentedRouter new.
+ router spec
+ title: 'Films API';
+ version: '1.0.0';
+ description: 'A demo of OpenAPI-documented routes served by WebGS.';
+ server: 'http://localhost:8888' description: 'Local development server'.
+
+ filmSchema := OpenApiSchema object
+ property: 'id' type: 'integer';
+ property: 'title' type: 'string';
+ property: 'views' type: 'integer';
+ required: #('id' 'title' 'views');
+ yourself.
+ router spec schema: 'Film' definition: filmSchema.
+
+ router spec schema: 'Error' definition: (OpenApiSchema object
+ property: 'error' type: 'string';
+ required: #('error');
+ yourself).
+
+ self registerListRouteOn: router.
+ self registerGetByIdRouteOn: router.
+
+ ^router
+]
+
+{ #category : 'routes' }
+FilmsApi class >> registerGetByIdRouteOn: aRouter [
+
+ aRouter
+ get: '/films/:id'
+ do: [:request :response :id |
+ | film |
+ film := Film withId: id asInteger.
+ film ifNil: [
+ response
+ code: 404;
+ content: (Dictionary new
+ at: 'error' put: 'Film with id ' , id , ' not found';
+ yourself) asJson;
+ contentType: 'application/json; charset=UTF-8'.
+ ] ifNotNil: [
+ response
+ content: (self filmAsDictionary: film) asJson;
+ contentType: 'application/json; charset=UTF-8'.
+ ].
+ ]
+ operation: (OpenApiOperation new
+ summary: 'Get a film by id';
+ description: 'Returns a single film, or a 404 error if no film has the given id.';
+ operationId: 'getFilmById';
+ tag: 'films';
+ response: 200 description: 'The requested film' schema: (OpenApiSchema ref: 'Film');
+ response: 404 description: 'No film with that id' schema: (OpenApiSchema ref: 'Error');
+ yourself).
+]
+
+{ #category : 'routes' }
+FilmsApi class >> registerListRouteOn: aRouter [
+
+ aRouter
+ get: '/films'
+ do: [:request :response |
+ | rows |
+ rows := Film films collect: [:each | self filmAsDictionary: each].
+ response
+ content: rows asArray asJson;
+ contentType: 'application/json; charset=UTF-8'.
+ ]
+ operation: (OpenApiOperation new
+ summary: 'List all films';
+ description: 'Returns the full collection of films known to the server.';
+ operationId: 'listFilms';
+ tag: 'films';
+ response: 200
+ description: 'A list of films'
+ schema: (OpenApiSchema array: (OpenApiSchema ref: 'Film'));
+ yourself).
+]
+
+{ #category : 'utilities' }
+FilmsApi class >> filmAsDictionary: aFilm [
+
+ ^Dictionary new
+ at: 'id' put: aFilm id;
+ at: 'title' put: aFilm title;
+ at: 'views' put: aFilm views;
+ yourself
+]
diff --git a/Films/src/Films-Core/package.st b/Films/src/Films-Core/package.st
new file mode 100644
index 0000000..bfd1394
--- /dev/null
+++ b/Films/src/Films-Core/package.st
@@ -0,0 +1 @@
+Package { #name : 'Films-Core' }
\ No newline at end of file
diff --git a/Films/src/Films-Core/properties.st b/Films/src/Films-Core/properties.st
new file mode 100644
index 0000000..61bc452
--- /dev/null
+++ b/Films/src/Films-Core/properties.st
@@ -0,0 +1,4 @@
+{
+ #format : 'tonel',
+ #convention : 'RowanHybrid'
+}
diff --git a/Films/src/properties.st b/Films/src/properties.st
new file mode 100644
index 0000000..61bc452
--- /dev/null
+++ b/Films/src/properties.st
@@ -0,0 +1,4 @@
+{
+ #format : 'tonel',
+ #convention : 'RowanHybrid'
+}
diff --git a/installRowan.sh b/installRowan.sh
new file mode 100755
index 0000000..2d82b5d
--- /dev/null
+++ b/installRowan.sh
@@ -0,0 +1,76 @@
+#!/bin/bash -e
+#
+# Load WebGS into GemStone as a Rowan project (Tonel source under ./src, load
+# specs under ./rowan/specs). This is the Rowan replacement for the topaz
+# fileout performed by install.sh.
+#
+# The optional Films OpenAPI demo is a Rowan project of its own (./Films),
+# loaded into its own Films symbol dictionary — the Rowan replacement for
+# installFilmsApi.sh. Pass --with-films (or films) to load it too.
+#
+# Requires:
+# * A running, Rowan-enabled stone.
+# * GEMSTONE / PATH set (see README).
+# * .topazini (here or in $HOME), e.g.:
+# set user DataCurator pass swordfish gems gs64stone
+#
+# Usage:
+# ./installRowan.sh # WebGS framework + OpenAPI + Sample (== install.sh)
+# ./installRowan.sh --with-films # the above, plus the Films demo (== install.sh + installFilmsApi.sh)
+#
+cd "$(dirname "$0")"
+REPO="$PWD"
+PARENT="$(dirname "$REPO")"
+
+FILMS_LOAD=""
+FILMS_MSG=""
+case "${1:-}" in
+ --with-films|films|--films)
+ FILMS_LOAD="load value: 'file:$REPO/Films/rowan/specs/Films.ston' value: '$REPO' value: 'Films'."
+ FILMS_MSG="msg := msg , '; loaded Films (' , (rowan projectNamed: 'Films') packageNames size printString , ' packages) into symbolDict Films'."
+ ;;
+ "") ;;
+ *) echo "usage: $0 [--with-films]" >&2; exit 2 ;;
+esac
+
+topaz -lq << EOF
+iferr 1 stk
+iferr 2 output pop
+iferr 3 stk
+iferr 4 abort
+iferr 5 logout
+iferr 6 exit 1
+set cachename WebGS_Rowan
+login
+output push WebGS.out only
+fileformat utf8
+run
+| specClass load rowan msg |
+specClass := (System myUserProfile symbolList resolveSymbol: #'RwSpecification') ifNil: [
+ ^'ERROR: Rowan (RwSpecification) is not installed in this stone; cannot load WebGS as a Rowan project.'
+] value.
+load := [:url :home :name | | spec |
+ spec := specClass fromUrl: url.
+ spec projectsHome: home.
+ spec resolve load.
+ name].
+"WebGS project -> WebGS symbol dictionary (== install.sh)"
+load value: 'file:$REPO/rowan/specs/WebGS.ston' value: '$PARENT' value: 'WebGS'.
+$FILMS_LOAD
+System commit.
+rowan := (System myUserProfile symbolList resolveSymbol: #'Rowan') value.
+msg := 'Loaded WebGS (' , (rowan projectNamed: 'WebGS') packageNames size printString , ' packages) into symbolDict WebGS'.
+$FILMS_MSG
+msg
+%
+output pop
+errorCount
+logout
+exit 0
+EOF
+
+if [ "$?" == "0" ]; then
+ echo "Rowan load finished. Review WebGS.out for details."
+else
+ echo "Rowan load of WebGS failed. Please review WebGS.out and try again!"
+fi
diff --git a/rowan/components/Core.ston b/rowan/components/Core.ston
new file mode 100644
index 0000000..68b2633
--- /dev/null
+++ b/rowan/components/Core.ston
@@ -0,0 +1,11 @@
+RwLoadComponent {
+ #name : 'Core',
+ #projectNames : [ ],
+ #componentNames : [ ],
+ #packageNames : [
+ 'WebGS-Core',
+ 'WebGS-OpenApi',
+ 'WebGS-Sample'
+ ],
+ #comment : 'The WebGS HTTP server framework, its OpenAPI documentation support, and the Sample demo app (matches install.sh).'
+}
\ No newline at end of file
diff --git a/rowan/project.ston b/rowan/project.ston
new file mode 100644
index 0000000..0969d41
--- /dev/null
+++ b/rowan/project.ston
@@ -0,0 +1,12 @@
+RwProjectSpecificationV3 {
+ #specName : 'project',
+ #projectVersion : '1.0.0',
+ #projectSpecPath : 'rowan',
+ #componentsPath : 'rowan/components',
+ #packagesPath : 'src',
+ #projectsPath : 'rowan/projects',
+ #specsPath : 'rowan/specs',
+ #packageFormat : 'tonel',
+ #packageConvention : 'RowanHybrid',
+ #comment : 'WebGS: a framework for building web application back-ends in GemStone/S 64 Bit Smalltalk.'
+}
\ No newline at end of file
diff --git a/rowan/projects/README.md b/rowan/projects/README.md
new file mode 100644
index 0000000..e69de29
diff --git a/rowan/specs/WebGS.ston b/rowan/specs/WebGS.ston
new file mode 100644
index 0000000..e8466fa
--- /dev/null
+++ b/rowan/specs/WebGS.ston
@@ -0,0 +1,15 @@
+RwLoadSpecificationV2 {
+ #projectName : 'WebGS',
+ #projectSpecFile : 'rowan/project.ston',
+ #componentNames : [
+ 'Core'
+ ],
+ #platformProperties : {
+ 'gemstone' : {
+ 'allusers' : {
+ #defaultSymbolDictName : 'WebGS'
+ }
+ }
+ },
+ #comment : 'Base WebGS server: the HTTP framework plus OpenAPI support (matches install.sh).'
+}
diff --git a/src/WebGS-Core/AbstractHttpServer.class.st b/src/WebGS-Core/AbstractHttpServer.class.st
new file mode 100644
index 0000000..30baeb4
--- /dev/null
+++ b/src/WebGS-Core/AbstractHttpServer.class.st
@@ -0,0 +1,21 @@
+"Abstract superclass for object that handles socket after listener's accept"
+Class {
+ #name : 'AbstractHttpServer',
+ #superclass : 'Object',
+ #instVars : [
+ 'router'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'other' }
+AbstractHttpServer class >> serveClientSocket: aSocket router: aRouter [
+
+ self subclassResponsibility.
+]
+
+{ #category : 'Initializing' }
+AbstractHttpServer >> router: aRouter [
+
+ router := aRouter.
+]
diff --git a/src/WebGS-Core/DbTransientSocket.class.st b/src/WebGS-Core/DbTransientSocket.class.st
new file mode 100644
index 0000000..c308005
--- /dev/null
+++ b/src/WebGS-Core/DbTransientSocket.class.st
@@ -0,0 +1,163 @@
+"It is an error to try to persist a Socket so any object that references a Socket is similarly ineligible to be persisted. This class provides a wrapper for a Socket so the wrapper can be referenced."
+Class {
+ #name : 'DbTransientSocket',
+ #superclass : 'Object',
+ #instVars : [
+ 'socket'
+ ],
+ #gs_options : [ 'dbTransient' ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'other' }
+DbTransientSocket class >> new: aSocket [
+
+ ^self basicNew
+ initialize: aSocket;
+ yourself
+]
+
+{ #category : 'other' }
+DbTransientSocket >> accept [
+
+ | newSocket |
+ newSocket := socket accept.
+ newSocket ifNil: [self error: socket lastErrorString].
+ ^self class new: newSocket.
+]
+
+{ #category : 'other' }
+DbTransientSocket >> checkForErrors [
+ | errors |
+ (socket isKindOf: GsSecureSocket) ifFalse: [^self].
+ socket fetchLastIoErrorString ifNotNil: [:value |
+ Log instance log: #'error' string: errors.
+ EndOfStream signal: errors.
+ ].
+ (errors := socket class fetchErrorStringArray) notEmpty ifTrue: [
+ errors do: [:each |
+ ((each subStrings: $:) copyFrom: 1 to: 6) = #('error' '1410E114' 'SSL routines' 'SSL_peek' 'uninitialized' 'ssl/ssl_lib.c') ifTrue: [
+ Log instance log: #'warn' string: each.
+ ] ifFalse: [
+ Log instance log: #'error' string: each.
+ ].
+ ].
+ EndOfStream signal: errors.
+ ].
+]
+
+{ #category : 'other' }
+DbTransientSocket >> close [
+
+ socket ifNotNil: [
+ socket close.
+ socket := nil.
+ ].
+]
+
+{ #category : 'other' }
+DbTransientSocket >> initialize: aSocket [
+
+ (aSocket isKindOf: GsSocket) ifFalse: [self error: 'Should be a GsSocket!'].
+ socket := aSocket.
+]
+
+{ #category : 'other' }
+DbTransientSocket >> isConnected [
+
+ ^socket isConnected
+]
+
+{ #category : 'other' }
+DbTransientSocket >> lastErrorString [
+
+ ^socket lastErrorString
+]
+
+{ #category : 'other' }
+DbTransientSocket >> makeServer: backlogInteger atPort: portInteger [
+
+ | result |
+ result := socket makeServer: backlogInteger atPort: portInteger.
+ result ifNil: [^nil].
+ ^self
+]
+
+{ #category : 'other' }
+DbTransientSocket >> peerAddress [
+
+ ^socket peerAddress
+]
+
+{ #category : 'other' }
+DbTransientSocket >> peerName [
+
+ ^socket peerName
+]
+
+{ #category : 'other' }
+DbTransientSocket >> peerPort [
+
+ ^socket peerPort
+]
+
+{ #category : 'other' }
+DbTransientSocket >> port [
+
+ ^socket port
+]
+
+{ #category : 'other' }
+DbTransientSocket >> printOn: aStream [
+
+ aStream
+ nextPutAll: 'DbTransientSocket(';
+ nextPutAll: socket class name;
+ nextPutAll: ':';
+ print: socket asOop;
+ nextPut: $).
+]
+
+{ #category : 'other' }
+DbTransientSocket >> read: anInteger [
+
+ ^socket read: anInteger
+]
+
+{ #category : 'other' }
+DbTransientSocket >> read: wantInteger into: byteObject [
+
+ ^socket read: wantInteger into: byteObject
+]
+
+{ #category : 'other' }
+DbTransientSocket >> read: wantInteger into: byteObject startingAt: startingAtInteger [
+
+ ^socket read: wantInteger into: byteObject startingAt: startingAtInteger
+]
+
+{ #category : 'other' }
+DbTransientSocket >> readWillNotBlock [
+
+ ^socket readWillNotBlock
+]
+
+{ #category : 'other' }
+DbTransientSocket >> readWillNotBlockWithin: anInteger [
+
+ ^socket readWillNotBlockWithin: anInteger
+]
+
+{ #category : 'other' }
+DbTransientSocket >> secureAccept [
+
+ socket secureAccept ifFalse: [self error: socket lastErrorString].
+ ^true
+]
+
+{ #category : 'other' }
+DbTransientSocket >> write: aByteObject [
+
+ aByteObject isEmpty ifTrue: [^self].
+ ^socket write: aByteObject
+]
diff --git a/src/WebGS-Core/HttpListener.class.st b/src/WebGS-Core/HttpListener.class.st
new file mode 100644
index 0000000..ce54b59
--- /dev/null
+++ b/src/WebGS-Core/HttpListener.class.st
@@ -0,0 +1,170 @@
+"I listen for incoming requests and am configured with an AbstractHttpServer and Router."
+Class {
+ #name : 'HttpListener',
+ #superclass : 'Object',
+ #instVars : [
+ 'listenBacklog',
+ 'port',
+ 'socket',
+ 'server',
+ 'router'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'constructors' }
+HttpListener class >> new [
+
+ ^self basicNew
+ initialize;
+ yourself
+]
+
+{ #category : 'constructors' }
+HttpListener class >> run: aRouter [
+
+ ^self new
+ router: aRouter;
+ run;
+ yourself
+]
+
+{ #category : 'Initializing' }
+HttpListener >> initialize [
+
+ System sessionCacheStatAt: 0 put: 0. "request count"
+ System sessionCacheStatAt: 1 put: 0. "time in secure accept (us)"
+ System sessionCacheStatAt: 2 put: 0. "secure accept failure count"
+ System sessionCacheStatAt: 3 put: 0. "readWillNotBlock returned true but accept failure count"
+ System sessionCacheStatAt: 4 put: 0. "time in #'serveClientSocket:router:' (us)"
+ System sessionCacheStatAt: 5 put: 0. "#'serveClientSocket:router:' failure count"
+ System sessionCacheStatAt: 6 put: 0. "time in socket read (us)"
+ System sessionCacheStatAt: 7 put: 0. "time in socket write (us)"
+ listenBacklog := 5.
+ port := 8888.
+ server := HttpServer. "might be replaced with an HttpLoadBalancer"
+ System "some extra overhead, but we want to get exception stacks"
+ gemConfigurationAt: #GemExceptionSignalCapturesStack
+ put: true.
+]
+
+{ #category : 'Initializing' }
+HttpListener >> listenBacklog: anInteger [
+
+ listenBacklog := anInteger.
+]
+
+{ #category : 'Initializing' }
+HttpListener >> port: anInteger [
+
+ port := anInteger.
+]
+
+{ #category : 'Initializing' }
+HttpListener >> router: aRouter [
+
+ router := aRouter.
+]
+
+{ #category : 'Initializing' }
+HttpListener >> server: anAbstractHttpServer [
+ "anObject implements #'serveClientSocket:router:'"
+
+ server := anAbstractHttpServer.
+]
+
+{ #category : 'Override Defaults' }
+HttpListener >> newSocket [
+
+ ^GsSignalingSocket new
+]
+
+{ #category : 'Override Defaults' }
+HttpListener >> protocol [
+
+ ^'http'
+]
+
+{ #category : 'Web Server' }
+HttpListener >> createListener [
+ "set up the listening socket"
+
+ socket := DbTransientSocket new: self newSocket.
+ (socket makeServer: listenBacklog atPort: port) ifNil: [
+ | string |
+ string := socket lastErrorString.
+ socket close.
+ socket := nil.
+ self error: string.
+ ].
+ Log instance log: #'debug' string: 'HttpListener>>createListener - ' , socket printString.
+ ^socket port
+]
+
+{ #category : 'Web Server' }
+HttpListener >> mainLoop [
+
+ [
+ Log instance log: #'debug' string: 'HttpListener>>mainLoop - 1'.
+ [
+ System commitTransaction.
+ ] whileTrue: [
+ | flag |
+ flag := [
+ socket readWillNotBlockWithin: 60000. "60 seconds"
+ ] on: Error do: [:ex |
+ ex return: false.
+ ].
+ [flag] whileTrue: [
+ System sessionCacheStatAt: 0 incrementBy: 1. "request count"
+ [:newSocket | self mainLoopBody: newSocket] forkWith: { socket accept }.
+ flag := socket readWillNotBlock.
+ ].
+ ].
+ ] ensure: [
+ Log instance log: #'debug' string: 'HttpListener>>mainLoop - 2'.
+ socket close.
+ socket := nil.
+ server shutdown.
+ ].
+]
+
+{ #category : 'Web Server' }
+HttpListener >> mainLoopBody: aSocket [
+
+ | t1 t2 |
+ aSocket isNil ifTrue: [
+ Log instance log: #'warning' string: 'GsSocket>>readWillNotBlock returned true but accept failed!'.
+ System sessionCacheStatAt: 3 incrementBy: 1. "error count"
+ ^self
+ ].
+ Log instance log: #'debug' string: 'HttpListener>>mainLoopBody - ' , aSocket printString.
+ [
+ t1 := System timeNs.
+ server serveClientSocket: aSocket router: router. "<== work is done here"
+ t2 := System timeNs.
+ System sessionCacheStatAt: 4 incrementBy: (t2 - t1) // 1000. "time in #'serveClientSocket:router:' (us)"
+ ] on: Error do: [:ex |
+ Log instance log: #'error' string: ex description.
+ System sessionCacheStatAt: 5 incrementBy: 1. "error count"
+ ].
+]
+
+{ #category : 'Web Server' }
+HttpListener >> reportUrl [
+ "log some startup information"
+
+ | serverURL |
+ serverURL := self protocol , '://' , (GsSocket getHostNameByAddress: ((System descriptionOfSession: System session) at: 11)) , ':' , port printString , '/'.
+ Log instance log: #'startup' string: serverURL.
+]
+
+{ #category : 'Web Server' }
+HttpListener >> run [
+ "primary entry point; called immediately after initialization"
+
+ self
+ reportUrl;
+ createListener;
+ mainLoop. "<- work is done here"
+]
diff --git a/src/WebGS-Core/HttpLoadBalancer.class.st b/src/WebGS-Core/HttpLoadBalancer.class.st
new file mode 100644
index 0000000..1eefb28
--- /dev/null
+++ b/src/WebGS-Core/HttpLoadBalancer.class.st
@@ -0,0 +1,108 @@
+"sessions:
+ A collection of Association instances
+ key: GsExternalSession
+ value: aBoolean indicating whether session is available"
+Class {
+ #name : 'HttpLoadBalancer',
+ #superclass : 'AbstractHttpServer',
+ #instVars : [
+ 'gemCount',
+ 'mutex',
+ 'server',
+ 'sessions'
+ ],
+ #gs_options : [ 'dbTransient' ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'other' }
+HttpLoadBalancer class >> new [
+
+ self error: 'Use #startWithRouter: aRouter'.
+]
+
+{ #category : 'other' }
+HttpLoadBalancer class >> startServer: aServer withRouter: aRouter [
+
+ ^self
+ startServer: aServer
+ withRouter: aRouter
+ gemCount: 2
+]
+
+{ #category : 'other' }
+HttpLoadBalancer class >> startServer: aServer withRouter: aRouter gemCount: anInteger [
+
+ ^self basicNew
+ initialize;
+ server: aServer;
+ router: aRouter;
+ gemCount: anInteger;
+ loginSessions;
+ yourself
+]
+
+{ #category : 'Initializing' }
+HttpLoadBalancer >> gemCount: anInteger [
+
+ 0 < anInteger ifFalse: [self error: 'Load balancer requires some gems!'].
+ gemCount := anInteger.
+]
+
+{ #category : 'Initializing' }
+HttpLoadBalancer >> initialize [
+
+ Log instance log: #'debug' string: 'HttpLoadBalancer>>initialize'.
+ super initialize.
+ gemCount := 2.
+ mutex := Semaphore forMutualExclusion.
+ sessions := IdentitySet new.
+]
+
+{ #category : 'Initializing' }
+HttpLoadBalancer >> loginSessions [
+ "part of the initialization sequence"
+
+ Log instance log: #'debug' string: 'HttpLoadBalancer>>loginSessions'.
+ gemCount timesRepeat: [
+ sessions add: (WebExternalSession startServer: server withRouter: router).
+ ].
+]
+
+{ #category : 'Initializing' }
+HttpLoadBalancer >> server: aServer [
+
+ server := aServer.
+]
+
+{ #category : 'other' }
+HttpLoadBalancer >> getSession [
+ "find a listener that is idle and can be called"
+
+ Log instance log: #'debug' string: 'HttpLoadBalancer>>getSession'.
+ [true] whileTrue: [
+ mutex critical: [
+ | session |
+ session := sessions
+ detect: [:each | each isAvailable] "session is available"
+ ifNone: [nil].
+ session ifNotNil: [^session beNotAvailable]. "session is not available"
+ ].
+ (Delay forMilliseconds: 10) wait. "wait to see if something becomes available"
+ ].
+]
+
+{ #category : 'other' }
+HttpLoadBalancer >> serveClientSocket: aSocket router: aRouter [
+
+ Log instance log: #'debug' string: 'HttpLoadBalancer>>serveClientSocket: ' , aSocket printString.
+ ^self getSession serveClientSocket: aSocket
+]
+
+{ #category : 'other' }
+HttpLoadBalancer >> shutdown [
+
+ Log instance log: #'debug' string: 'HttpLoadBalancer>>shutdown'.
+ sessions do: [:each | each forceLogout].
+ sessions := IdentitySet new.
+]
diff --git a/src/WebGS-Core/HttpRequest.class.st b/src/WebGS-Core/HttpRequest.class.st
new file mode 100644
index 0000000..4dfa7f4
--- /dev/null
+++ b/src/WebGS-Core/HttpRequest.class.st
@@ -0,0 +1,646 @@
+Class {
+ #name : 'HttpRequest',
+ #superclass : 'Object',
+ #instVars : [
+ 'socket',
+ 'stream',
+ 'method',
+ 'uri',
+ 'path',
+ 'version',
+ 'headers',
+ 'arguments',
+ 'bodyContents',
+ 'sizeLeft',
+ 'multipartFormDataBoundary'
+ ],
+ #classInstVars : [
+ 'contentTypeHandlers'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'other' }
+HttpRequest class >> contentTypeHandlers [
+
+ " I return a dictionary with all configured Content-Type handlers.
+ Handlers are blocks that take a httpRequest and a string as arguments. "
+
+ contentTypeHandlers isNil ifTrue: [
+ self installContentTypeHandlers
+ ].
+
+ ^contentTypeHandlers
+]
+
+{ #category : 'other' }
+HttpRequest class >> fromBytes: aByteArray [
+ "Used exclusively by tests"
+
+ | listener server client string request |
+ listener := GsSocket new.
+ (listener makeServer: 1) ifNil: [
+ string := listener lastErrorString.
+ listener close.
+ listener error: string.
+ ].
+ client := GsSocket new. "browser sending the request"
+ (client connectTo: listener port on: 'localhost') ifFalse: [
+ string := client lastErrorString.
+ client close.
+ client error: string.
+ ].
+ (listener readWillNotBlockWithin: 1000) ifFalse: [
+ client close.
+ listener close.
+ self error: 'Listener did not receive request from client!'.
+ ].
+ (server := listener accept) ifNil: [
+ string := listener lastErrorString.
+ client close.
+ listener close.
+ listener error: string.
+ ].
+ listener close.
+ [:socket :bytes |
+ 1 to: bytes size by: 4000 do: [:i |
+ (socket writeWillNotBlockWithin: 1000) ifTrue: [
+ socket write: (bytes copyFrom: i to: (i + 3999 min: bytes size)).
+ ] ifFalse: [
+ self error: 'Unable to write data!'.
+ ].
+ ].
+ socket close.
+ ] forkWith: (Array with: client with: (ByteArray withAll: aByteArray)).
+ request := self readFromSocket: server.
+ ^request
+]
+
+{ #category : 'other' }
+HttpRequest class >> fromString: aString [
+ "Used exclusively by tests"
+
+ ^self fromBytes: aString encodeAsUTF8.
+]
+
+{ #category : 'other' }
+HttpRequest class >> installContentTypeHandlers [
+
+ " I set a dictionary with all configured Content-Type handlers.
+ Handlers are blocks that take a httpRequest and a string as arguments. "
+
+ contentTypeHandlers := Dictionary new
+ at: 'application/x-www-form-urlencoded' put: [ :httpReq :str | httpReq readArgumentsFrom: str ];
+ "at: 'application/json' put: [ :httpReq :str | httpReq parseContentsFrom: str interpreterClassName: #JSONReader action: #fromJSON: ];"
+ yourself
+]
+
+{ #category : 'other' }
+HttpRequest class >> new [
+
+ self error: 'use #''readFromSocket:'''.
+]
+
+{ #category : 'other' }
+HttpRequest class >> readFromSocket: aSocket [
+
+ ^self basicNew
+ initializeWithSocket: aSocket;
+ yourself.
+]
+
+{ #category : 'other' }
+HttpRequest class >> unsetContentTypeHandlers [
+
+ " I dischard old contentTypeHandlers. "
+
+ contentTypeHandlers := nil
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> _sizeLeft [
+
+ ^sizeLeft.
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> arguments [
+
+ ^arguments
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> argumentsAt: aKey [
+
+ ^arguments at: aKey
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> argumentsAt: aKey ifAbsent: aBlock [
+
+ ^arguments at: aKey ifAbsent: aBlock
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> argumentsAt: aKey ifAbsentPut: aBlock [
+
+ ^arguments at: aKey ifAbsentPut: aBlock
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> bodyContents [
+
+ ^bodyContents
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> contentType [
+
+ ^headers at: 'content-type' ifAbsent: nil
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> cookie [
+
+ ^self cookies
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> cookies [
+
+ | cookie string |
+ cookie := Dictionary new.
+ string := headers at: 'cookie' ifAbsent: [^cookie].
+ (string subStrings: $;) do: [:each |
+ | pieces |
+ pieces := each subStrings: $=.
+ cookie at: pieces first trimSeparators put: pieces last trimSeparators.
+ ].
+ ^cookie
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> headers [
+
+ ^headers
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> method [
+
+ ^method
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> multipartFormDataBoundary [
+
+ ^multipartFormDataBoundary
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> path [
+
+ ^path
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> uri [
+
+ ^uri
+]
+
+{ #category : 'Accessing' }
+HttpRequest >> version [
+
+ ^version
+]
+
+{ #category : 'other' }
+HttpRequest >> closeSocket [
+
+ socket ifNotNil: [
+ socket close.
+ socket := nil.
+ ].
+]
+
+{ #category : 'other' }
+HttpRequest >> initializeWithSocket: aSocket [
+
+ socket := aSocket.
+ arguments := Dictionary new.
+ headers := Dictionary new
+ at: 'X-Date' put: (HttpResponse webStringForDateTime: DateTime now);
+ at: 'X-Peer-Name' put: aSocket peerName;
+ at: 'X-Peer-Address' put: aSocket peerAddress;
+ at: 'X-Peer-Port' put: aSocket peerPort asString;
+ yourself.
+ self readRequest ifTrue: [socket := nil]. "did the read finish?"
+]
+
+{ #category : 'other' }
+HttpRequest >> isClientChrome [
+
+ ^(headers at: 'user-agent') includesString: 'Chrome'.
+]
+
+{ #category : 'other' }
+HttpRequest >> isClientFirefox [
+
+ ^(headers at: 'user-agent') includesString: 'Firefox'.
+]
+
+{ #category : 'other' }
+HttpRequest >> isClientIE [
+
+ | userAgent |
+ userAgent := headers at: 'user-agent'.
+ ^(userAgent includesString: 'MSIE') or: [userAgent includesString: 'Trident'].
+]
+
+{ #category : 'other' }
+HttpRequest >> isClientWindows [
+
+ ^(headers at: 'user-agent') includesString: 'Windows'
+]
+
+{ #category : 'other' }
+HttpRequest >> isMultiPart [
+
+ | contentType pieces string |
+ multipartFormDataBoundary ifNotNil: [^true].
+ contentType := headers at: 'content-type' ifAbsent: [^false].
+ (pieces := contentType subStrings: $;) first = 'multipart/form-data' ifFalse: [^false].
+ ((string := pieces at: 2) copyFrom: 1 to: 10) = ' boundary=' ifFalse: [self error: 'Unrecognized field in multipart/form-data'].
+ multipartFormDataBoundary := '--' , (string copyFrom: 11 to: string size).
+ ^true.
+]
+
+{ #category : 'other' }
+HttpRequest >> isWebSocketUpgrade [
+
+ | connection upgrade |
+ connection := headers at: 'connection' ifAbsent: [''].
+ upgrade := headers at: 'upgrade' ifAbsent: [''].
+ ^connection asLowercase = 'upgrade' and: [upgrade asLowercase = 'websocket']
+]
+
+{ #category : 'other' }
+HttpRequest >> needsSocket [
+
+ ^self isMultiPart or: [self isWebSocketUpgrade]
+]
+
+{ #category : 'other' }
+HttpRequest >> parseContentsFrom: aString interpreterClassName: aClassName action: aSelector [
+
+ " I resolve the interpreter class and send it aSelector, the result is saved in bodyContents attribute. "
+
+ | interpreterClass |
+ (interpreterClass := System myUserProfile resolveSymbol: aClassName) ifNil: [
+ self error: 'Can''t resolve symbol: ' , aClassName printString , ' - Handle of request content fail.'
+ ].
+
+ bodyContents := interpreterClass value perform: aSelector with: aString
+]
+
+{ #category : 'other' }
+HttpRequest >> printOn: aStream [
+
+ aStream nextPutAll: (method ifNil: ['???']).
+ aStream space.
+ aStream nextPutAll: (uri ifNil: ['???']).
+]
+
+{ #category : 'other' }
+HttpRequest >> readArgumentsFrom: aString [
+
+ (aString subStrings: $&) do: [:each |
+ | index key value values |
+ index := each indexOf: $=.
+ key := each copyFrom: 1 to: index - 1.
+ value := self translate: (each copyFrom: index + 1 to: each size).
+ (6 < key size and: [(key copyFrom: key size - 5 to: key size) = '%5B%5D']) ifTrue: [
+ key := key copyFrom: 1 to: key size - 6.
+ values := arguments at: key ifAbsent: [Array new].
+ values add: value.
+ value := values.
+ ].
+ key notEmpty ifTrue: [
+ (arguments includesKey: key) ifFalse: [
+ arguments at: key put: value.
+ ] ifTrue: [
+ | current |
+ ((current := arguments at: key) isKindOf: Array) ifTrue: [
+ current add: value.
+ ] ifFalse: [
+ arguments at: key put: (Array with: current with: value).
+ ].
+ ].
+ ].
+ ].
+]
+
+{ #category : 'other' }
+HttpRequest >> readContents [
+
+ " Read and parse the content itself.
+ In GET method there are interpreted as arguments.
+ For POST methos how I handle contents depends on Content-Type value.
+ For each Content-Type supported must be a handler configured.
+ If none, the original string contents is saved.
+ For handlers configuration see class method #contentTypeHandlers. "
+
+ | string pieces handler |
+
+ method = 'GET' ifTrue: [
+ pieces := uri subStrings: $?.
+ path := pieces at: 1.
+ string := 1 < pieces size
+ ifTrue: [pieces at: 2]
+ ifFalse: [''].
+ ^self readArgumentsFrom: string
+ ].
+ string := self upToEnd.
+ method = 'POST' ifTrue: [
+ handler := self class contentTypeHandlers
+ at: (headers at: 'content-type' ifAbsent: [ nil ])
+ ifAbsent: [ nil ].
+ handler isNil ifTrue: [
+ " No handler for current content-type, just set the string as bodyContents "
+ bodyContents := string.
+ ^self
+ ].
+
+ handler value: self value: string
+ ]
+]
+
+{ #category : 'other' }
+HttpRequest >> readHeaders [
+
+ | line |
+ [
+ line := self nextLine.
+ line notEmpty.
+ ] whileTrue: [
+ | index key value |
+ index := line indexOf: $:.
+ key := (line copyFrom: 1 to: index - 1) asLowercase.
+ value := (line copyFrom: index + 1 to: line size) trimBlanks.
+ key notEmpty ifTrue: [headers at: key asString put: value asString].
+ ].
+
+ sizeLeft := headers at: 'content-length' ifAbsent: [nil].
+ sizeLeft notNil ifTrue: [
+ | bytes |
+ bytes := stream upToEnd.
+ sizeLeft := sizeLeft asNumber - bytes size.
+ stream := ReadStream on: bytes.
+ ].
+]
+
+{ #category : 'other' }
+HttpRequest >> readLine1 [
+
+ method := [
+ self upToSpace asString.
+ ] on: EndOfStream do: [:ex |
+ Log instance haltIfRequested.
+ ex return: ''.
+ ].
+ Log instance log: #'debug' string: 'HttpRequest>>readLine1 got method of ' , method printString.
+ method isEmpty ifTrue: [^self].
+ (#('GET' 'HEAD' 'OPTIONS' 'POST' 'PUT') includes: method) ifFalse: [
+ self error: 'Expected a GET, HEAD, OPTIONS, or POST but got ' , method printString , ' (' , method size printString , ' characters)'
+ ].
+ uri := self upToSpace asString.
+ path := uri.
+ version := self nextLine asString.
+ Log instance log: #'request' string: method , ' ' , (uri copyFrom: 1 to: (40 min: uri size)).
+]
+
+{ #category : 'other' }
+HttpRequest >> readRequest [
+ "answer whether we are done reading"
+
+ self readLine1.
+ method isEmpty ifTrue: [^true].
+ self readHeaders.
+ self needsSocket ifTrue: [^false].
+ self readContents.
+ ^true.
+]
+
+{ #category : 'other' }
+HttpRequest >> translate: aString [
+
+ | readStream writeStream string |
+ readStream := ReadStream on: aString.
+ writeStream := WriteStream on: ByteArray new.
+ [
+ readStream atEnd not.
+ ] whileTrue: [
+ | char |
+ char := readStream next.
+ char = $+ ifTrue: [
+ writeStream nextPut: Character space codePoint.
+ ] ifFalse: [
+ char = $% ifTrue: [
+ | array value |
+ array := #($0 $1 $2 $3 $4 $5 $6 $7 $8 $9 $A $B $C $D $E $F).
+ value := (array indexOf: readStream next) - 1 * 16 + (array indexOf: readStream next) - 1.
+ writeStream nextPut: value.
+ ] ifFalse: [
+ writeStream nextPut: char codePoint.
+ ].
+ ]
+ ].
+ string := writeStream contents bytesIntoUnicode asString.
+ string = 'nil' ifTrue: [^nil].
+ string = 'null' ifTrue: [^nil].
+ string = 'true' ifTrue: [^true].
+ string = 'false' ifTrue: [^false].
+ ^string
+ copyReplaceAll: Character cr asString , Character lf asString
+ with: Character lf asString.
+]
+
+{ #category : 'stream' }
+HttpRequest >> _fillStream [
+
+ | bytes want |
+ (stream isNil or: [stream atEnd]) ifFalse: [^self]. "No need to get more yet"
+ bytes := ByteArray new.
+ want := sizeLeft ifNil: [4096].
+ 4096 < want ifTrue: [want := 4096].
+ [
+ Log instance log: #'debug' string: 'HttpRequest>>_fillStream - 1 - want = ' , want printString , '; have = ' , bytes size printString.
+ 0 < want and: [socket readWillNotBlockWithin: 1000].
+ ] whileTrue: [
+ | bytesRead t1 t2 |
+ t1 := System timeNs.
+ bytesRead := socket read: want into: bytes startingAt: bytes size + 1.
+ t2 := System timeNs.
+ System sessionCacheStatAt: 6 incrementBy: (t2 - t1) // 1000. "time in socket read (us)"
+ Log instance log: #'debug' string: 'HttpRequest>>_fillStream - 2 - bytesRead = ' , bytesRead printString.
+ bytesRead == 0 ifTrue: [
+ socket checkForErrors.
+ Log instance log: #'warning' string: 'nothing more to read'.
+ EndOfStream signal: 'nothing more to read'.
+ ].
+ ((sizeLeft notNil and: [sizeLeft <= bytes size]) or: [0 < (bytes indexOf: Character lf codePoint)]) ifTrue: [
+ stream := ReadStream on: bytes.
+ sizeLeft notNil ifTrue: [sizeLeft := sizeLeft - bytes size].
+ Log instance log: #'debug' string: 'HttpRequest>>_fillStream - 4'.
+ ^self
+ ].
+ ].
+ EndOfStream signal: 'Read ' , bytes size printString , ' bytes but wanted ' ,
+ (sizeLeft ifNil: ['a line'] ifNotNil: [sizeLeft printString]).
+]
+
+{ #category : 'stream' }
+HttpRequest >> nextLine [
+
+ | bytes |
+ bytes := self
+ upTo: Character lf
+ ifNotFoundWaitMs: 20.
+ (bytes notEmpty and: [bytes last == Character cr codePoint]) ifTrue: [
+ bytes size: bytes size - 1.
+ ].
+ ^bytes bytesIntoUnicode
+]
+
+{ #category : 'stream' }
+HttpRequest >> nextPartHeaders [
+
+ | string dict |
+ dict := Dictionary new.
+ [
+ string := self nextLine.
+ string notEmpty.
+ ] whileTrue: [
+ | index key value |
+ 0 == (index := string indexOf: $:) ifTrue: [self error: 'Expected header but got ' , string printString].
+ key := string copyFrom: 1 to: index - 1.
+ value := string copyFrom: index + 1 to: string size.
+ dict at: key put: value trimBlanks.
+ ].
+ ^dict.
+]
+
+{ #category : 'stream' }
+HttpRequest >> peekFor: aCharacter [
+
+ self _fillStream.
+ ^stream peekFor: aCharacter codePoint.
+]
+
+{ #category : 'stream' }
+HttpRequest >> upTo: aCharacter ifNotFoundWaitMs: anInteger [
+
+ | utf8 didFindCharacter |
+ self _fillStream.
+ utf8 := stream upTo: aCharacter codePoint. "stream consumes aCharacter but does not return it"
+ didFindCharacter := stream atEnd not "if there is more, then we stopped because we found aCharacter"
+ or: [ | x |
+ x := stream contents.
+ x notEmpty and: [
+ x last == aCharacter codePoint. "we read up to end and there was aCharacter at the end"
+ ].
+ ].
+ didFindCharacter ifTrue: [
+ ^utf8
+ ].
+ (Delay forMilliseconds: anInteger) wait. "give a bit of time for more data to arrive"
+ 200 < anInteger ifTrue: [self error: 'Tired of waiting for client to send full request!'].
+ ^utf8 , (self upTo: aCharacter ifNotFoundWaitMs: anInteger + 20).
+]
+
+{ #category : 'stream' }
+HttpRequest >> upToEnd [
+ "Called by #'readContents'"
+
+ | utf8 |
+ utf8 := stream upToEnd.
+ sizeLeft isNil ifTrue: [^utf8 asUnicodeString asString].
+ [
+ 0 < sizeLeft.
+ ]whileTrue: [
+ self _fillStream.
+ utf8 addAll: stream upToEnd.
+ ].
+ ^utf8 asUnicodeString asString
+]
+
+{ #category : 'stream' }
+HttpRequest >> upToNextPartAsUnicode [
+
+ | bytes |
+ bytes := ByteArray new.
+ self upToNextPartDo: [:data | bytes addAll: data].
+ ^bytes bytesIntoUnicode
+]
+
+{ #category : 'stream' }
+HttpRequest >> upToNextPartDo: aOneArgumentBlock [
+ "ByteArray passed to block"
+
+ | bytes count i j k |
+ bytes := ByteArray new.
+ count := 0.
+ k := 0.
+ [true] whileTrue: [
+ [
+ bytes addAll: stream upToEnd.
+ self _fillStream. "we could get an EndOfStream here"
+ bytes addAll: stream upToEnd.
+ ] on: Error do: [:ex |
+ Log instance haltIfRequested.
+ (ex isKindOf: EndOfStream) ifTrue: [ex return].
+ ex pass.
+ ].
+ i := bytes indexOfSubCollection: multipartFormDataBoundary startingAt: 1.
+ 0 < i ifTrue: [ "found boundary"
+ (1 < i and: [(bytes at: i - 1) == Character lf codePoint]) ifFalse: [
+ j := i - 1.
+ ] ifTrue: [
+ (2 < i and: [(bytes at: i - 2) == Character cr codePoint]) ifFalse: [
+ j := i - 2.
+ ] ifTrue: [
+ j := i - 3.
+ ].
+ ].
+ aOneArgumentBlock value: (bytes copyFrom: 1 to: j).
+ i := i + multipartFormDataBoundary size.
+ (i < bytes size and: [(bytes at: i) == Character cr codePoint]) ifTrue: [i := i + 1].
+ (i < bytes size and: [(bytes at: i) == Character lf codePoint]) ifTrue: [i := i + 1].
+ bytes := bytes copyFrom: i to: bytes size.
+ stream := ReadStream on: bytes.
+ ^self.
+ ].
+ i := bytes size - multipartFormDataBoundary size - 1.
+ 0 < i ifTrue: [ "didn't find boundary, but might have part of it"
+ aOneArgumentBlock value: (bytes copyFrom: 1 to: i).
+ k := k + i.
+ bytes := bytes copyFrom: i + 1 to: bytes size.
+ stream := ReadStream on: bytes copy. "#44335"
+ bytes size: 0.
+ count := 0.
+ ] ifFalse: [ "didn't have enough to even check for a boundary"
+ 20 < (count := count + 1) ifTrue: [self error: 'Timeout waiting on socket!'].
+ ].
+ ].
+]
+
+{ #category : 'stream' }
+HttpRequest >> upToSpace [
+
+ | bytes |
+ bytes := self
+ upTo: Character space
+ ifNotFoundWaitMs: 20.
+ ^bytes bytesIntoUnicode
+]
diff --git a/src/WebGS-Core/HttpResponse.class.st b/src/WebGS-Core/HttpResponse.class.st
new file mode 100644
index 0000000..d4aec84
--- /dev/null
+++ b/src/WebGS-Core/HttpResponse.class.st
@@ -0,0 +1,373 @@
+Class {
+ #name : 'HttpResponse',
+ #superclass : 'Object',
+ #instVars : [
+ 'code',
+ 'headers',
+ 'content',
+ 'sendContentsBlock'
+ ],
+ #classInstVars : [
+ 'cachedDateTime',
+ 'cachedWebStringForDateTime'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'other' }
+HttpResponse class >> new [
+
+ ^self basicNew
+ initialize;
+ yourself
+]
+
+{ #category : 'other' }
+HttpResponse class >> notFound: aString [
+
+ ^self new notFound: aString
+]
+
+{ #category : 'other' }
+HttpResponse class >> serverError: anException [
+
+ ^self new serverError: anException
+]
+
+{ #category : 'other' }
+HttpResponse class >> webStringForDateTime: aDateTime [
+
+ (cachedDateTime notNil
+ and: [aDateTime yearGmt == cachedDateTime year
+ and: [aDateTime dayOfYearGmt == cachedDateTime dayOfYearGmt
+ and: [(aDateTime millisecondsGmt // 1000) == (cachedDateTime millisecondsGmt // 1000)]]])
+ ifTrue: [^cachedWebStringForDateTime].
+ cachedDateTime := aDateTime.
+ cachedWebStringForDateTime := (WriteStream on: String new)
+ nextPutAll: (#('Sun' 'Mon' 'Tue' 'Wed' 'Thu' 'Fri' 'Sat') at: aDateTime dayOfWeekGmt); space;
+ nextPutAll: (aDateTime asStringGmtUsingFormat: #(1 2 3 $ 2 1 $: true true false false));
+ nextPutAll: ' GMT';
+ contents.
+ ^cachedWebStringForDateTime
+]
+
+{ #category : 'other' }
+HttpResponse >> _content [
+
+ ^content
+]
+
+{ #category : 'other' }
+HttpResponse >> accessControlAllowHeaders: aStringOrNil [
+
+ aStringOrNil ifNil: [
+ headers
+ removeKey: 'Access-Control-Allow-Headers'
+ ifAbsent: [].
+ ] ifNotNil: [
+ headers
+ at: 'Access-Control-Allow-Headers'
+ put: aStringOrNil.
+ ].
+]
+
+{ #category : 'other' }
+HttpResponse >> accessControlAllowOrigin: aStringOrNil [
+
+ aStringOrNil ifNil: [
+ headers
+ removeKey: 'Access-Control-Allow-Origin'
+ ifAbsent: [].
+ ] ifNotNil: [
+ headers
+ at: 'Access-Control-Allow-Origin'
+ put: aStringOrNil.
+ ].
+]
+
+{ #category : 'other' }
+HttpResponse >> beNoCache [
+
+ headers
+ at: 'Cache-Control'
+ put: 'no-cache'.
+]
+
+{ #category : 'other' }
+HttpResponse >> code [
+
+ ^code
+]
+
+{ #category : 'other' }
+HttpResponse >> code: anInteger [
+
+ code := anInteger.
+]
+
+{ #category : 'other' }
+HttpResponse >> content: anObject [
+
+ content := (anObject isKindOf: String)
+ ifTrue: [anObject]
+ ifFalse: [anObject asJson].
+ self isUTF8 ifFalse: [content := content encodeAsUTF8].
+ self contentLength: content size.
+]
+
+{ #category : 'other' }
+HttpResponse >> contentDisposition: aStringOrNil [
+
+ aStringOrNil ifNil: [
+ headers
+ removeKey: 'Content-Disposition'
+ ifAbsent: [].
+ ] ifNotNil: [
+ headers
+ at: 'Content-Disposition'
+ put: aStringOrNil.
+ ].
+]
+
+{ #category : 'other' }
+HttpResponse >> contentLength: anInteger [
+
+ (anInteger isKindOf: Integer) ifFalse: [self error: anInteger printString , ' is a(n) ' , anInteger class name].
+ headers
+ at: 'Content-Length'
+ put: anInteger printString.
+]
+
+{ #category : 'other' }
+HttpResponse >> contentType: aString [
+
+ headers
+ at: 'Content-Type'
+ put: aString.
+ (aString = 'image/png' or: [aString = 'image/x-icon']) ifTrue: [
+ headers
+ at: 'Cache-Control' put: 'max-age=86400';
+ at: 'Expires' put: (HttpResponse webStringForDateTime: (DateTime now addDays: 1));
+ yourself.
+ ].
+]
+
+{ #category : 'other' }
+HttpResponse >> hasContent [
+
+ ^content notNil or: [sendContentsBlock notNil].
+]
+
+{ #category : 'other' }
+HttpResponse >> headers [
+
+ ^headers
+]
+
+{ #category : 'other' }
+HttpResponse >> initialize [
+
+ headers := Dictionary new
+ at: 'Date' put: (HttpResponse webStringForDateTime: DateTime now);
+ at: 'Server' put: 'WebGS';
+ "at: 'Accept-Ranges' put: 'bytes';
+ at: 'Allow' put: 'GET, HEAD, OPTIONS, POST';
+ at: 'Cache-Control' put: 'no-cache';
+ at: 'Content-Encoding' put: 'none';
+ at: 'Content-Language' put: 'en';
+ at: 'Content-Type' put: 'text/plain; charset=UTF-8';
+ at: 'Access-Control-Allow-Origin' put: '*';
+ at: 'Access-Control-Allow-Methods' put: '*';
+ at: 'Access-Control-Allow-Headers' put: '*';
+ at: 'Access-Control-Max-Age' put: '86400'; "
+ yourself.
+ code := 200.
+]
+
+{ #category : 'other' }
+HttpResponse >> isUTF8 [
+
+ ^(headers at: 'Content-Type' ifAbsent: ['']) asLowercase includesString: 'utf-8'.
+]
+
+{ #category : 'other' }
+HttpResponse >> lastModified: aDateTime [
+
+ headers
+ at: 'Last-Modified'
+ put: (HttpResponse webStringForDateTime: aDateTime).
+]
+
+{ #category : 'other' }
+HttpResponse >> location: aString [
+
+ headers
+ at: 'Location'
+ put: aString.
+]
+
+{ #category : 'other' }
+HttpResponse >> maxAge: anInteger [
+
+ headers
+ at: 'Cache-Control'
+ put: 'max-age=' , anInteger printString.
+]
+
+{ #category : 'other' }
+HttpResponse >> notFound: aString [
+
+ self
+ code: 404;
+ content: aString , ' not found!';
+ yourself.
+]
+
+{ #category : 'other' }
+HttpResponse >> printAllExceptContentOn: aStream [
+
+ | crlf |
+ crlf := Character cr asString , Character lf asString.
+ aStream
+ nextPutAll: 'HTTP/1.1 ';
+ nextPutAll: code printString; space;
+ nextPutAll: self reasonPhrase;
+ nextPutAll: crlf;
+ yourself.
+ headers keys asSortedCollection do: [:each |
+ aStream
+ nextPutAll: each;
+ nextPutAll: ': ';
+ nextPutAll: (headers at: each);
+ nextPutAll: crlf;
+ yourself.
+ ].
+ aStream nextPutAll: crlf.
+]
+
+{ #category : 'other' }
+HttpResponse >> printOn: aStream [
+
+ | crlf |
+ crlf := Character cr asString , Character lf asString.
+ self printAllExceptContentOn: aStream.
+ aStream
+ nextPutAll: (content ifNil: [''] ifNotNil: [content asUnicodeString]);
+ nextPutAll: crlf;
+ yourself.
+]
+
+{ #category : 'other' }
+HttpResponse >> reasonPhrase [
+
+ ^(Dictionary new
+ at: 200 put: 'OK';
+ at: 204 put: 'No Content';
+ at: 303 put: 'See Other';
+ at: 404 put: 'Not Found';
+ at: 405 put: 'Method Not Allowed';
+ at: 426 put: 'Upgrade Required';
+ at: 500 put: 'Internal Server Error';
+ yourself)
+ at: code
+ ifAbsent: ['Unknown Error'].
+]
+
+{ #category : 'other' }
+HttpResponse >> redirectTo: aString [
+
+ self
+ code: 303;
+ location: aString;
+ yourself.
+]
+
+{ #category : 'other' }
+HttpResponse >> send: aString [
+
+ self
+ code: 200;
+ content: aString;
+ yourself
+]
+
+{ #category : 'other' }
+HttpResponse >> sendContentsBlock: aOneArgumentBlock [
+ "If you want to do your own streaming, then provide a block that takes a socket"
+
+ sendContentsBlock := aOneArgumentBlock.
+]
+
+{ #category : 'other' }
+HttpResponse >> sendResponseOn: aSocket [
+
+ | stream string count t1 t2 |
+ stream := WriteStream on: String new.
+ self printAllExceptContentOn: stream. "Headers, etc."
+ string := stream contents.
+ Log instance log: #'debug' string: 'HttpResponse>>sendResponseOn: - ' , string printString.
+ t1 := System timeNs.
+ count := aSocket write: string.
+ t2 := System timeNs.
+ System sessionCacheStatAt: 7 incrementBy: (t2 - t1) // 1000. "time in socket write (us)"
+ count isNil ifTrue: [self error: aSocket lastErrorString].
+ count < string size ifTrue: [self error: 'Tried to write ' , string size printString , ', but wrote ' , count printString].
+ sendContentsBlock ifNil: [
+ content ifNotNil: [
+ content class isBytes ifFalse: [self error: 'content class is is ' , content class name].
+ aSocket write: content.
+ ].
+ ] ifNotNil: [
+ sendContentsBlock value: aSocket.
+ ].
+]
+
+{ #category : 'other' }
+HttpResponse >> serverError: anException [
+
+ | html description |
+ self code: 500.
+ ((description := anException description) isKindOf: String) ifFalse: [description := description printString].
+ self content: description.
+]
+
+{ #category : 'other' }
+HttpResponse >> setCookie: keyString value: valueString [
+
+ self
+ setCookie: keyString
+ value: valueString
+ path: nil
+ maxAge: 365 * 24 * 60 * 60 "usually one year"
+ secure: false
+ serverOnly: false
+ sameSite: false.
+]
+
+{ #category : 'other' }
+HttpResponse >> setCookie: keyString
+ value: valueString
+ path: pathString
+ maxAge: secondsInteger
+ secure: secureBoolean
+ serverOnly: serverBoolean
+ sameSite: sameSiteBoolean [
+
+ | string |
+ string := keyString , '=' , valueString , '; Path=' , (pathString ifNil: ['/'] ifNotNil: [pathString]).
+ secondsInteger ifNotNil: [string := string , '; Max-Age=' , secondsInteger printString].
+ secureBoolean ifTrue: [string := string , '; Secure'].
+ serverBoolean ifTrue: [string := string , '; HttpOnly'].
+ sameSiteBoolean ifTrue: [string := string , '; SameSite=Strict'].
+ headers
+ at: 'Set-Cookie'
+ put: string
+]
+
+{ #category : 'other' }
+HttpResponse >> setDate [
+
+ headers
+ at: 'Date'
+ put: (HttpResponse webStringForDateTime: DateTime now).
+]
diff --git a/src/WebGS-Core/HttpServer.class.st b/src/WebGS-Core/HttpServer.class.st
new file mode 100644
index 0000000..ff20e78
--- /dev/null
+++ b/src/WebGS-Core/HttpServer.class.st
@@ -0,0 +1,275 @@
+"Sample runHttp."
+Class {
+ #name : 'HttpServer',
+ #superclass : 'AbstractHttpServer',
+ #instVars : [
+ 'request',
+ 'response',
+ 'socket'
+ ],
+ #classInstVars : [
+ 'htdocs'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'constants' }
+HttpServer class >> contentTypeFor: aPath [
+ "Used when sending a file"
+
+ ^self contentTypes
+ at: (aPath subStrings: $.) last asLowercase
+ otherwise: 'text/html; charset=UTF-8'.
+]
+
+{ #category : 'constants' }
+HttpServer class >> contentTypes [
+ "Used when sending a file"
+
+ ^KeyValueDictionary new
+ at: 'css' put: 'text/css';
+ at: 'gif' put: 'image/gif';
+ at: 'html' put: 'text/html; charset=UTF-8';
+ at: 'ico' put: 'image/x-icon';
+ at: 'jpg' put: 'image/jpg';
+ at: 'js' put: 'text/javascript';
+ at: 'json' put: 'text/json';
+ at: 'png' put: 'image/png';
+ yourself.
+]
+
+{ #category : 'other' }
+HttpServer class >> htdocs: aString [
+
+ htdocs := aString.
+]
+
+{ #category : 'other' }
+HttpServer class >> serveClientSocket: aSocket router: aRouter [
+
+ self new serveClientSocket: aSocket router: aRouter
+]
+
+{ #category : 'other' }
+HttpServer class >> shutdown [
+ "Nothing needs to be done!"
+]
+
+{ #category : 'required' }
+HttpServer class >> htdocs [
+
+ ^htdocs ifNil: ['./htdocs']
+]
+
+{ #category : 'Request Handler' }
+HttpServer >> buildResponse [
+
+ Log instance log: #'debug' string: 'HttpServer>>buildResponse for ' , request path printString.
+ router ifNil: [
+ self error: 'No routes defined!'.
+ ].
+ response := router handle: request.
+]
+
+{ #category : 'Request Handler' }
+HttpServer >> handleRequest [
+ "We are in a forked process (thread) and socket has the unread request (new socket from accept)"
+
+ Log instance log: #'debug' string: 'HttpServer>>handleRequest'.
+ request := HttpRequest readFromSocket: socket.
+ request method isEmpty ifTrue: [
+ Log instance log: #'warning' string: 'Got an empty request'.
+ ^self.
+ ].
+ request isWebSocketUpgrade ifTrue: [
+ self wsUpgradeRequest.
+ ].
+ response := HttpResponse new.
+ self buildResponse. "<- work is done here for dynamic content"
+ response ifNil: [ "no dynamic content available, try static content"
+ self handleRequestForFile.
+ ] ifNotNil: [
+ self sendResponse. "dynamic content is returned here"
+ ].
+]
+
+{ #category : 'Request Handler' }
+HttpServer >> handleRequestForFile [
+ "The #buildResponse method didn't create a response.
+ We will check to see if there is a static file available that matches the path."
+
+ | gsFile |
+ Log instance log: #'debug' string: 'HttpServer>>handleRequestForFile'.
+ (gsFile := self openFile) ifNil: [ "does file exist?"
+ Log instance log: #'debug' string: 'HttpServer>>handleRequestForFile - not found!'.
+ response := HttpResponse notFound: request path.
+ self sendResponse.
+ ^self.
+ ].
+ [
+ response := HttpResponse new
+ contentLength: gsFile fileSize;
+ lastModified: gsFile lastModified;
+ contentType: (self class contentTypeFor: gsFile pathName);
+ yourself.
+ request method = 'HEAD' ifFalse: [ "A HEAD request has the file size and type but not the contents."
+ response sendContentsBlock: [:_socket |
+ [gsFile atEnd not] whileTrue: [socket write: (gsFile next: 32000)].
+ ].
+ ].
+ self sendResponse.
+ ] ensure: [
+ gsFile close.
+ ].
+]
+
+{ #category : 'Request Handler' }
+HttpServer >> handleRequestWithErrorHandling [
+ "We are in a forked process (thread) and socket has the unread request (new socket from accept)"
+
+ [
+ self handleRequest.
+ ] on: Error , Admonition do: [:ex |
+ Log instance haltIfRequested.
+ Log instance log: #'error' string:
+ ex printString , Character lf asString ,
+ (GsProcess stackReportToLevel: 50).
+ response := HttpResponse serverError: ex.
+ self sendResponse.
+ ].
+]
+
+{ #category : 'Request Handler' }
+HttpServer >> openFile [
+ "We will check to see if there is a static file available that matches the path."
+
+ | file path |
+ file := request path.
+ (path := self class htdocs) ifNil: [^nil]. "Should we offer static files?"
+ (file includesString: '../') ifTrue: [^nil]. "Is request for a file below provided path?"
+ (file isEmpty or: [file = '/']) ifTrue: [file := '/index.html'].
+ path := path , file.
+ Log instance log: #'debug' string: 'HttpServer>>openFile - ' , path printString.
+ ^GsFile openReadOnServer: path
+]
+
+{ #category : 'Request Handler' }
+HttpServer >> sendResponse [
+
+ [
+ response sendResponseOn: socket.
+ Log instance log: #'debug' string: 'Response sent to socket: ', socket printString.
+ ] on: Error do: [:ex |
+ Log instance haltIfRequested.
+ Log instance log: #'error' string: ex description , ' - socket: ', socket printString, Character lf asString , (GsProcess stackReportToLevel: 40).
+ ].
+]
+
+{ #category : 'Request Handler' }
+HttpServer >> serveClientSocket: aSocket router: aRouter [
+ "Serve the request in a forked process."
+
+ socket := aSocket.
+ router := aRouter.
+ Log instance log: #'debug' string: 'HttpServer>>serveClientSocket: ' , socket printString.
+ [socket isConnected
+ ifTrue: [self handleRequestWithErrorHandling] "<- work is done here"
+ ifFalse: [Log instance log: #'warning' string: 'Socket is not connected: ' , socket printString].
+ ] ensure: [
+ socket close.
+ socket := nil.
+ ].
+]
+
+{ #category : 'WebSockets' }
+HttpServer >> webSocket_gs [
+
+ request isWebSocketUpgrade ifFalse: [self error: 'Expected a WebSocket protocol!'].
+ Log instance log: #'debug' string: 'HttpServer>>webSocket_gs'.
+ [
+ socket readWillNotBlockWithin: -1. "Wait forever (other GsProcess instances can run and abort)"
+ ] whileTrue: [
+ | frame |
+ [
+ frame := WebSocketDataFrame fromSocket: socket.
+ ] on: Error do: [:ex |
+ Log instance log: #'debug' string: 'HttpServer>>webSocket_gs - ' , ex description.
+ Log instance haltIfRequested.
+ WebSocketDataFrame sendDisconnect: 1002 onSocket: socket.
+ socket close.
+ Processor activeProcess terminate. "There isn't really anything to return!"
+ ].
+ frame isDisconnect ifTrue: [
+ Log instance log: #'debug' string: 'HttpServer>>onDataDo: - disconnect - ' , frame data printString.
+ WebSocketDataFrame sendDisconnect: frame data onSocket: socket.
+ self wsDisconnect.
+ socket close.
+ Processor activeProcess terminate. "There isn't really anything to return!"
+ ].
+ frame isPing ifTrue: [
+ Log instance log: #'debug' string: 'HttpServer>>onDataDo: - ping - ' , frame data printString.
+ WebSocketDataFrame sendPongData: frame data onSocket: socket.
+ ] ifFalse: [
+ frame isBinary ifTrue: [
+ self wsBinaryData: frame data.
+ ] ifFalse: [
+ self wsTextData: frame data decodeFromUTF8ToUnicode.
+ ].
+ ].
+ ].
+]
+
+{ #category : 'WebSockets' }
+HttpServer >> wsBinaryData: byteArray [
+
+]
+
+{ #category : 'WebSockets' }
+HttpServer >> wsDisconnect [
+
+]
+
+{ #category : 'WebSockets' }
+HttpServer >> wsSecureResponseFor: aKey [
+ "If the Key is 'dGhlIHNhbXBsZSBub25jZQ==', the response is 's3pPLMBiTxaQ9kYGzzhZRbK+xOo='."
+
+ | bytes key sha1 stream |
+ key := aKey , '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'.
+ sha1 := key asSha1String.
+ stream := ReadStream on: sha1.
+ bytes := ByteArray new.
+ [stream atEnd not] whileTrue: [
+ bytes add: ('16r' , stream next asString , stream next asString) asNumber.
+ ].
+ ^bytes asBase64String
+]
+
+{ #category : 'WebSockets' }
+HttpServer >> wsTextData: aUnicodeString [
+
+]
+
+{ #category : 'WebSockets' }
+HttpServer >> wsUpgradeRequest [
+
+ | count crlf key version |
+ version := request headers at: 'sec-websocket-version' ifAbsent: ['0'].
+ version asNumber < 13 ifTrue: [
+ self error: 'HttpServer requires at least version 13!'.
+ ].
+ crlf := Character cr asString , Character lf asString.
+ key := request headers at: 'sec-websocket-key' ifAbsent: [''].
+ key := self wsSecureResponseFor: key.
+ response := 'HTTP/1.1 101 Switching Protocols' , crlf ,
+ 'Upgrade: websocket' , crlf ,
+ 'Connection: Upgrade' , crlf ,
+ 'Sec-WebSocket-Accept: ' , key , crlf , crlf.
+ count := socket write: response.
+ count == response size ifFalse: [self error: 'Unable to write response!'].
+]
+
+{ #category : 'WebSockets' }
+HttpServer >> wsWithBinaryDo: binaryBlock withTextDo: textBlock [
+
+ self error: 'Please override #wsBinaryData: and #wsTextData:'.
+]
diff --git a/src/WebGS-Core/HttpsListener.class.st b/src/WebGS-Core/HttpsListener.class.st
new file mode 100644
index 0000000..8e09e89
--- /dev/null
+++ b/src/WebGS-Core/HttpsListener.class.st
@@ -0,0 +1,63 @@
+Class {
+ #name : 'HttpsListener',
+ #superclass : 'HttpListener',
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'Web Server' }
+HttpsListener >> initialize [
+
+ super initialize.
+ self configureCertificates.
+]
+
+{ #category : 'Web Server' }
+HttpsListener >> mainLoopBody: aSocket [
+
+ | t1 t2 |
+ t1 := System timeNs.
+ [
+ aSocket secureAccept ifFalse: [
+ System sessionCacheStatAt: 2 incrementBy: 1. "secure accept failure count"
+ Log instance log: #'warning' string: aSocket lastErrorString.
+ ^self
+ ].
+ ] on: Error do: [:ex |
+ System sessionCacheStatAt: 2 incrementBy: 1. "secure accept failure count"
+ Log instance log: #'warning' string: aSocket lastErrorString.
+ ^self
+ ].
+ t2 := System timeNs.
+ System sessionCacheStatAt: 1 incrementBy: (t2 - t1) // 1000. "time in secure accept (us)"
+ super mainLoopBody: aSocket.
+]
+
+{ #category : 'Web Server' }
+HttpsListener >> newSocket [
+
+ ^GsSecureSocket newServer
+]
+
+{ #category : 'Web Server' }
+HttpsListener >> protocol [
+
+ ^'https'
+]
+
+{ #category : 'Web Server' }
+HttpsListener >> configureCertificates [
+
+ | password |
+ Log instance log: #'debug' string: 'HttpsListener>>configureCertificates'.
+ password := GsSecureSocket getPasswordFromFile: '$GEMSTONE/examples/openssl/private/server_1_server_passwd.txt'.
+ GsSecureSocket
+ useServerCertificateFile: '$GEMSTONE/examples/openssl/certs/server_1_servercert.pem'
+ withPrivateKeyFile: '$GEMSTONE/examples/openssl/private/server_1_serverkey.pem'
+ privateKeyPassphrase: password.
+
+ "Don't request a certificate from the client. This is typical."
+ GsSecureSocket disableCertificateVerificationOnServer.
+
+ "Use all ciphers except NULL ciphers and anonymous Diffie-Hellman and sort by strength."
+ GsSecureSocket setServerCipherListFromString: 'ALL:!ADH:@STRENGTH'.
+]
diff --git a/src/WebGS-Core/Log.class.st b/src/WebGS-Core/Log.class.st
new file mode 100644
index 0000000..7387ee2
--- /dev/null
+++ b/src/WebGS-Core/Log.class.st
@@ -0,0 +1,90 @@
+Class {
+ #name : 'Log',
+ #superclass : 'Object',
+ #instVars : [
+ 'haltOnError',
+ 'logFileName',
+ 'logTypes'
+ ],
+ #classInstVars : [
+ 'instance'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'other' }
+Log class >> instance [
+
+ instance ifNil: [
+ instance := self basicNew initialize; yourself.
+ System commit.
+ ].
+ ^instance
+]
+
+{ #category : 'other' }
+Log class >> new [
+
+ self error: 'Use #''instance''!'.
+]
+
+{ #category : 'other' }
+Log >> haltIfRequested [
+
+ haltOnError ifTrue: [self halt].
+]
+
+{ #category : 'other' }
+Log >> haltOnError: aBoolean [
+
+ haltOnError := aBoolean.
+]
+
+{ #category : 'other' }
+Log >> initialize [
+
+ haltOnError := false.
+ logFileName := (System performOnServer: 'pwd') trimSeparators, '/webServer.log'.
+ logTypes := #(#'startup' "#'debug' #'warning'" #'error').
+]
+
+{ #category : 'other' }
+Log >> log: aSymbol string: aString [
+ "Write a string to the log if aSymbol in logTypes.
+Log instance log: #'debug' string: 'something'.
+"
+
+ (logTypes includes: aSymbol) ifTrue: [
+ | string |
+ string := DateAndTime now printStringWithRoundedSeconds ,
+ ' - ', System gemProcessId printString ,
+ ' - ', Processor activeProcess asOop printString ,
+ ' - ' , aSymbol ,
+ ' - ' , aString.
+ System clientIsRemote ifTrue: [
+ (GsFile openAppendOnServer: logFileName) log: string; close.
+ ] ifFalse: [ "stdout for linked topaz"
+ GsFile gciLogServer: string.
+ ]
+ ].
+]
+
+{ #category : 'other' }
+Log >> logFileName: aString [
+
+ logFileName := aString.
+]
+
+{ #category : 'other' }
+Log >> logTypes [
+
+ ^logTypes
+]
+
+{ #category : 'other' }
+Log >> logTypes: anArray [
+"
+ Log instance logTypes: #(#'startup' #'debug' #'warning' #'error').
+"
+ logTypes := anArray.
+]
diff --git a/src/WebGS-Core/Route.class.st b/src/WebGS-Core/Route.class.st
new file mode 100644
index 0000000..80c7724
--- /dev/null
+++ b/src/WebGS-Core/Route.class.st
@@ -0,0 +1,125 @@
+"I describe a route."
+Class {
+ #name : 'Route',
+ #superclass : 'Object',
+ #instVars : [
+ 'method',
+ 'pathPieces',
+ 'block'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'constructors' }
+Route class >> method: methodString path: pathString block: aBlock [
+
+ ^self basicNew
+ method: methodString;
+ path: pathString;
+ block: aBlock;
+ yourself
+]
+
+{ #category : 'constructors' }
+Route class >> new [
+
+ self error: 'Use #method:path:block:'
+]
+
+{ #category : 'handler' }
+Route >> handle: aRequest [
+
+ | args getArgument requestPathStream response |
+ Log instance log: #'debug' string: 'Route>>handle: ' ,
+ aRequest path printString , ' - ' , pathPieces printString.
+ method = aRequest method ifFalse: [^nil].
+ response := HttpResponse new.
+ args := Array with: aRequest with: response.
+ requestPathStream := ReadStream on: aRequest path.
+ getArgument := false.
+ pathPieces do: [:each |
+ Log instance log: #'debug' string: 'A - ' , each printString , ' - ' , getArgument printString.
+ getArgument ifTrue: [
+ | string |
+ string := String new.
+ [
+ requestPathStream atEnd ifTrue: [
+ ^nil.
+ ].
+ string add: requestPathStream next.
+ Log instance log: #'debug' string: 'B - ' , string printString.
+ string endsWith: each.
+ ] whileFalse.
+ args add: (string := string copyFrom: 1 to: string size - each size).
+ Log instance log: #'debug' string: 'C - ' , string printString.
+ getArgument := false.
+ ] ifFalse: [
+ each == $: ifTrue: [
+ getArgument := true.
+ ] ifFalse: [
+ | requestPiece |
+ requestPiece := requestPathStream next: each size.
+ each = requestPiece ifFalse: [
+ ^nil
+ ].
+ ].
+ ].
+ ].
+ getArgument ifTrue: [
+ args add: requestPathStream upToEnd.
+ ].
+ requestPathStream atEnd ifFalse: [
+ ^nil
+ ].
+ args size: block argumentCount.
+ Log instance log: #'debug' string: 'Route>>handle: ' ,
+ aRequest printString , ' - ' , args printString.
+ block valueWithArguments: args.
+ ^response
+]
+
+{ #category : 'setters' }
+Route >> block: aBlock [
+
+ block := aBlock.
+]
+
+{ #category : 'setters' }
+Route >> method: aString [
+
+ method := aString.
+]
+
+{ #category : 'setters' }
+Route >> path: aString [
+
+ | i j |
+ aString first == $/ ifFalse: [
+ self error: 'Path must begin with $/'.
+ ].
+ aString = '/' ifTrue: [
+ pathPieces := #('/').
+ ] ifFalse: [
+ pathPieces := Array new.
+ i := 1.
+ [
+ j := aString indexOf: $: startingAt: i.
+ j > 0.
+ ] whileTrue: [
+ pathPieces add: (aString copyFrom: i to: j - 1).
+ i := j.
+ [
+ | char |
+ j := j + 1.
+ char := aString at: j.
+ (char isLetter or: [char isDigit or: [char == $_]]) and: [j < aString size].
+ ] whileTrue.
+ pathPieces add: $:.
+ i := j.
+ ].
+ i < aString size ifTrue: [
+ pathPieces add: (aString copyFrom: i to: aString size).
+ ].
+ ].
+ Log instance log: #'debug' string: pathPieces printString.
+]
diff --git a/src/WebGS-Core/Router.class.st b/src/WebGS-Core/Router.class.st
new file mode 100644
index 0000000..4065b5c
--- /dev/null
+++ b/src/WebGS-Core/Router.class.st
@@ -0,0 +1,62 @@
+"This is the abstract superclass for a web router.
+
+The required methods are in the 'required' category."
+Class {
+ #name : 'Router',
+ #superclass : 'Object',
+ #instVars : [
+ 'routes'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'constructors' }
+Router class >> new [
+
+ ^self basicNew
+ initialize;
+ yourself
+]
+
+{ #category : 'handler' }
+Router >> handle: aRequest [
+
+ Log instance log: #'debug' string: 'Router>>handle: ' , aRequest printString.
+ routes do: [:each |
+ (each handle: aRequest) ifNotNil: [:response |
+ Log instance log: #'debug' string: response printString.
+ ^response
+ ].
+ ].
+ ^nil
+]
+
+{ #category : 'initialization' }
+Router >> initialize [
+
+ routes := Array new.
+]
+
+{ #category : 'routes' }
+Router >> get: aPath do: aBlock [
+
+ routes add: (Route method: 'GET' path: aPath block: aBlock)
+]
+
+{ #category : 'routes' }
+Router >> head: aPath do: aBlock [
+
+ routes add: (Route method: 'HEAD' path: aPath block: aBlock).
+]
+
+{ #category : 'routes' }
+Router >> post: aPath do: aBlock [
+
+ routes add: (Route method: 'POST' path: aPath block: aBlock)
+]
+
+{ #category : 'routes' }
+Router >> put: aPath do: aBlock [
+
+ routes add: (Route method: 'PUT' path: aPath block: aBlock)
+]
diff --git a/src/WebGS-Core/WebApp.class.st b/src/WebGS-Core/WebApp.class.st
new file mode 100644
index 0000000..293bd1a
--- /dev/null
+++ b/src/WebGS-Core/WebApp.class.st
@@ -0,0 +1,153 @@
+"This is the abstract superclass for a web application.
+
+The required methods are in the 'required' category."
+Class {
+ #name : 'WebApp',
+ #superclass : 'HttpServer',
+ #instVars : [
+ 'html'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'Accessing' }
+WebApp >> _socket [
+
+ ^(SessionTemps current at: #'HttpRequest_socket') at: Processor activeProcess.
+]
+
+{ #category : 'base' }
+WebApp >> buildResponse [
+ "If you override this method, then you simply need to populate (or remove) the response object:
+
+ response
+ content: self myObject asJson;
+ contentType: 'text/json';
+ yourself.
+
+ This implementation assumes that the first piece of the path is a differentiator (e.g., a selector to be performed).
+ For example, 'http://localhost:8888/foo/bar' will build a response for 'foo'."
+
+ | newSelector pieces selector size |
+ html := nil. "HtmlElement html."
+ Log instance log: #'debug' string: 'WebApp>>buildResponse'.
+ pieces := request path subStrings: $/.
+ selector := pieces at: 2.
+ selector isEmpty ifTrue: [selector := self defaultSelector].
+ size := selector size.
+ (3 < size and: [(selector copyFrom: size - 2 to: size) = '.gs' and: [
+ (self class canUnderstand: (newSelector := (selector copyFrom: 1 to: size - 3) , '_gs')) or: [
+ self class canUnderstand: (newSelector := (selector copyFrom: 1 to: size - 3) , '_gs:')
+ ]]])
+ ifTrue: [selector := newSelector]
+ ifFalse: [
+ (self pathExists: selector asString) ifFalse: [
+ response := nil.
+ ^self
+ ].
+ ].
+ "We don't generate the response body, so we don't know the content length (as we would for a file).
+ According to the standard, we SHOULD provide the length, but that is optional
+ (versus SHALL which would be required)."
+ request method = 'HEAD' ifTrue: [
+
+ ] ifFalse: [request method = 'OPTIONS' ifTrue: [
+ response code: 204. "No Content"
+ ] ifFalse: [(request method = 'GET' or: [request method = 'POST']) ifTrue: [
+ self buildResponseFor: selector.
+ response hasContent ifFalse: [
+ response content: html printString.
+ ].
+ ] ifFalse: [
+ self error: 'Unrecognized request method: ' , request method printString.
+ ]]].
+ response maxAge: self maxAge.
+]
+
+{ #category : 'base' }
+WebApp >> buildResponseFor: aString [
+ "aString will contain the first directory in the path. In this implementation,
+ http://localhost:8888/foo/bar will automatically send #foo to self.
+
+ If you have portions of the page that are standard and don't depend on the request,
+ then you can override this method to add things before and after. For example,
+ a top section could come before and a bottom section could come after."
+
+ | size |
+ Log instance log: #'debug' string: 'WebApp>>buildResponseFor: ' , aString printString.
+ size := aString size.
+ ((3 < size and: [(aString copyFrom: size - 2 to: size) = '_gs']) or: [
+ 4 < size and: [(aString copyFrom: size - 3 to: size) = '_gs:']
+ ]) ifFalse: [
+ self perform: aString asSymbol.
+ ] ifTrue: [
+ | dict |
+ (aString last == $:) ifFalse: [
+ dict := self perform: aString asSymbol.
+ ] ifTrue: [
+ request method = 'GET' ifTrue: [
+ dict := request arguments.
+ ] ifFalse: [
+ dict := JsonParser parse: request bodyContents.
+ dict isPetitFailure ifTrue: [self error:dict message].
+ ].
+ dict := self perform: aString asSymbol with: dict.
+ ].
+ (dict isKindOf: AbstractDictionary) ifTrue: [
+ response content: dict asJson.
+ ].
+ ].
+]
+
+{ #category : 'override options' }
+WebApp >> defaultSelector [
+ "if the path is empty, e.g., http://localhost/, then default to this 'directory' or method selector."
+
+ ^'index.html'
+]
+
+{ #category : 'override options' }
+WebApp >> maxAge [
+ "This result can be cached and reused for this many seconds."
+
+ ^0
+]
+
+{ #category : 'selectors' }
+WebApp >> allowedSelectors [
+ "If we are using selectors as the first piece of the path, then we can provide
+ some security by listing the allowed selectors. This prevents malicious clients
+ from executing arbitrary code."
+
+ ^#('index' 'message')
+]
+
+{ #category : 'selectors' }
+WebApp >> pathExists: aString [
+ "You could override this to answer true if you don't
+ want to maintain the #allowedSelectors list."
+
+ ^self allowedSelectors includes: aString
+]
+
+{ #category : 'utilities' }
+WebApp >> encode: aString [
+ "HTML encoding for certain characters."
+
+ | stream x |
+ stream := WriteStream on: String new.
+ aString do: [:each |
+ | index |
+ index := #($" $& $' $< $>) indexOf: each.
+ 0 < index ifTrue: [
+ stream nextPutAll: (#('"' '&' ''' '<' '>') at: index).
+ ] ifFalse: [
+ ((x := each codePoint) < 32 or: [127 < x]) ifTrue: [
+ stream nextPutAll: '&#'; print: x; nextPut: $;.
+ ] ifFalse: [
+ stream nextPut: each.
+ ].
+ ].
+ ].
+ ^stream contents
+]
diff --git a/src/WebGS-Core/WebExternalSession.class.st b/src/WebGS-Core/WebExternalSession.class.st
new file mode 100644
index 0000000..7660675
--- /dev/null
+++ b/src/WebGS-Core/WebExternalSession.class.st
@@ -0,0 +1,169 @@
+"It seems that GsExternalSession does not properly handle hostPassword encryption (see HR9764 and http://kermit.gemtalksystems.com/bug?bug=47308)."
+Class {
+ #name : 'WebExternalSession',
+ #superclass : 'GsExternalSession',
+ #instVars : [
+ 'hostPassword',
+ 'password',
+ 'isAvailable',
+ 'port'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'other' }
+WebExternalSession class >> startServer: aServer withRouter: aRouter [
+
+ ^super newDefault
+ login;
+ startServer: aServer withRouter: aRouter;
+ yourself
+]
+
+{ #category : 'other' }
+WebExternalSession >> _isOnMyStone [
+ "GemStone has a bug in this method and we are always on the current stone!"
+
+ ^true
+]
+
+{ #category : 'other' }
+WebExternalSession >> _signalIfError [
+
+ (GsExternalSession canUnderstand: #'_signalIfError') ifTrue: [ "3.6.0 and later"
+ super _signalIfError.
+ ] ifFalse: [
+ self _signalIfError: self _gciLibrary.
+ ].
+]
+
+{ #category : 'other' }
+WebExternalSession >> beNotAvailable [
+
+ isAvailable := false.
+]
+
+{ #category : 'other' }
+WebExternalSession >> forceLogout [
+
+ super forceLogout.
+ port := 0.
+ isAvailable := false.
+]
+
+{ #category : 'other' }
+WebExternalSession >> hostPassword: aString [
+
+ hostPassword := aString copy
+]
+
+{ #category : 'other' }
+WebExternalSession >> isAvailable [
+
+ ^isAvailable
+]
+
+{ #category : 'other' }
+WebExternalSession >> login [
+
+ | result |
+ stoneSessionId ifNotNil: [
+ ImproperOperation signal: 'Stone session ' , stoneSessionId printString ,
+ ' already associated with this GsExternalSession!'.
+ ].
+ self _gciLibrary
+ GciSetNetEx_: parameters gemStoneName
+ _: parameters hostUsername
+ _: hostPassword
+ _: parameters gemService
+ _: 0. "parameters passwordIsEncryptedAsIntegerBoolean." "1 or 0: GCI_LOGIN_PW_ENCRYPTED"
+ self _signalIfError.
+ result := self _gciLibrary
+ GciLoginEx_: parameters username
+ _: password
+ _: (parameters loginFlags bitAnd: 1 bitInvert)
+ _: 0. "haltOnErrNum"
+ self _signalIfError.
+ 0 == result ifTrue: [
+ self error: 'Login failed for unknown reason!'.
+ ].
+ gciSessionId := self _gciLibrary GciGetSessionId.
+ stoneSessionId := Object _objectForOop: (self _gciLibrary GciPerform_: System asOop _: 'session' _: nil _: 0).
+ self _signalIfError.
+ self _isOnMyStone ifTrue: [
+ stoneSessionSerial := GsSession serialOfSession: stoneSessionId.
+ gemProcessId := (System descriptionOfSession: stoneSessionId) at: 2.
+ ] ifFalse: [
+ stoneSessionSerial := self executeString: 'GsSession currentSession serialNumber'.
+ gemProcessId := self executeString: 'System gemVersionAt: #''processId'''.
+ ].
+ self log: 'GsExternalSession login: ' , self _describe.
+]
+
+{ #category : 'other' }
+WebExternalSession >> password: aString [
+
+ password := aString copy
+]
+
+{ #category : 'other' }
+WebExternalSession >> serveClientSocket: clientSocket [
+
+ | semaphore serverSocket |
+ Log instance log: #'debug' string: 'WebExternalSession>>serveClientSocket: ' , clientSocket printString.
+ semaphore := Semaphore new.
+ serverSocket := DbTransientSocket new: (GsSignalingSocket new
+ connectTo: port on: 'localhost' timeoutMs: 5000;
+ yourself).
+ [
+ [
+ clientSocket isConnected and: [(clientSocket readWillNotBlockWithin: -1) and: [serverSocket isConnected]]
+ ] whileTrue: [
+ | bytes |
+ bytes := clientSocket read: 4096.
+ bytes size == 0 ifTrue: [
+ clientSocket close.
+ ] ifFalse: [
+ serverSocket write: bytes.
+ Log instance log: #'debug' string: 'sent ' , bytes size printString , ' bytes from ' , clientSocket printString , ' to ' , serverSocket printString.
+ ].
+ ].
+ semaphore signal.
+ ] fork.
+ [
+ [
+ serverSocket isConnected and: [(serverSocket readWillNotBlockWithin: -1) and: [clientSocket isConnected]]
+ ] whileTrue: [
+ | bytes |
+ bytes := serverSocket read: 4096.
+ bytes size == 0 ifTrue: [
+ serverSocket close.
+ ] ifFalse: [
+ clientSocket write: bytes.
+ Log instance log: #'debug' string: 'sent ' , bytes size printString , ' bytes from ' , serverSocket printString , ' to ' , clientSocket printString.
+ ].
+ ].
+ semaphore signal.
+ ] fork.
+ semaphore wait.
+ (Delay forMilliseconds: 1) wait.
+ clientSocket close.
+ serverSocket close.
+ isAvailable := true.
+]
+
+{ #category : 'other' }
+WebExternalSession >> startServer: aServer withRouter: aRouter [
+
+ | listener |
+ Log instance log: #'debug' string: 'WebExternalSession>>startWithRouter: ' , aRouter printString.
+ listener := (self executeString: 'HttpListener new') first.
+ port := self
+ send: 'server:' to: listener withArguments: (Array with: aServer);
+ send: 'port:' to: listener withArguments: (Array with: nil);
+ send: 'router:' to: listener withArguments: (Array with: aRouter);
+ send: 'createListener' to: listener.
+ self forkString: '(Object objectForOop: ' , listener printString , ') mainLoop'.
+ isAvailable := true.
+ Log instance log: #'debug' string: 'remote port: ' , port printString.
+]
diff --git a/src/WebGS-Core/WebSocketDataFrame.class.st b/src/WebGS-Core/WebSocketDataFrame.class.st
new file mode 100644
index 0000000..9225c70
--- /dev/null
+++ b/src/WebGS-Core/WebSocketDataFrame.class.st
@@ -0,0 +1,250 @@
+"Frame format (best viewed with a fixed-width font!):
+
+ 0 1 2 3
+ 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
+ +-+-+-+-+-------+-+-------------+-------------------------------+
+ |F|R|R|R| opcode|M| Payload len | Extended payload length |
+ |I|S|S|S| (4) |A| (7) | (16/64) |
+ |N|V|V|V| |S| | (if payload len==126/127) |
+ | |1|2|3| |K| | |
+ +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - +
+ | Extended payload length continued, if payload len == 127 |
+ + - - - - - - - - - - - - - - - +-------------------------------+
+ | |Masking-key, if MASK set to 1 |
+ +-------------------------------+-------------------------------+
+ | Masking-key (continued) | Payload Data |
+ +-------------------------------- - - - - - - - - - - - - - - - +
+ : Payload Data continued ... :
+ + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +
+ | Payload Data continued ... |
+ +---------------------------------------------------------------+"
+Class {
+ #name : 'WebSocketDataFrame',
+ #superclass : 'Object',
+ #instVars : [
+ 'fin',
+ 'rsv1',
+ 'rsv2',
+ 'rsv3',
+ 'opcode',
+ 'data'
+ ],
+ #category : 'WebGS-Core'
+}
+
+{ #category : 'other' }
+WebSocketDataFrame class >> fromSocket: aSocket [
+
+ ^self basicNew
+ initializeFromSocket: aSocket;
+ yourself
+]
+
+{ #category : 'other' }
+WebSocketDataFrame class >> new [
+
+ self error: 'Use other constructors'.
+]
+
+{ #category : 'other' }
+WebSocketDataFrame class >> sendDisconnect: data onSocket: aSocket [
+
+ self basicNew sendDisconnect: data onSocket: aSocket
+]
+
+{ #category : 'other' }
+WebSocketDataFrame class >> sendPongData: data onSocket: aSocket [
+
+ self basicNew sendPongData: data onSocket: aSocket
+]
+
+{ #category : 'other' }
+WebSocketDataFrame class >> sendText: data onSocket: aSocket [
+
+ self basicNew sendText: data onSocket: aSocket
+]
+
+{ #category : 'accessors' }
+WebSocketDataFrame >> data [
+
+ ^data
+]
+
+{ #category : 'other' }
+WebSocketDataFrame >> initializeFromSocket: aSocket [
+ "fin rsv1 rsv2 rsv3 opcode mask data"
+
+ | byte bytes count hasMask mask payloadLen |
+ bytes := ByteArray new: 4.
+ count := aSocket read: 2 into: bytes.
+ count < 2 ifTrue: [ "A GemStone bug (49606) causes readWillNotBlock to return true and the read to return zero bytes"
+ fin := 1.
+ opcode := 8.
+ ^self
+ ].
+ byte := bytes at: 1.
+ fin := (byte bitAnd: 2r10000000) ~= 0.
+ rsv1 := (byte bitAnd: 2r01000000) ~= 0.
+ rsv2 := (byte bitAnd: 2r00100000) ~= 0.
+ rsv3 := (byte bitAnd: 2r00010000) ~= 0.
+ opcode := byte bitAnd: 2r00001111.
+ byte := bytes at: 2.
+ hasMask := (byte bitAnd: 2r10000000) ~= 0.
+ hasMask ifFalse: [self error: 'Invalid response from client!'].
+ payloadLen := byte bitAnd: 2r01111111.
+ payloadLen == 126 ifTrue: [
+ count := aSocket read: 2 into: bytes.
+ count ~= 2 ifTrue: [self error: 'Invalid response from client!'].
+ payloadLen := (bytes at: 1) * 256 + (bytes at: 2).
+ ] ifFalse: [
+ payloadLen == 127 ifTrue: [
+ count := aSocket read: 4 into: bytes.
+ count ~= 4 ifTrue: [self error: 'Invalid response from client!'].
+ payloadLen := (bytes at: 1) * 256 + (bytes at: 2) * 256 + (bytes at: 3) * 256 + (bytes at: 4).
+ ].
+ ].
+ mask := ByteArray new: 4.
+ count := aSocket read: 4 into: mask.
+ count ~= 4 ifTrue: [self error: 'Invalid response from client!'].
+ bytes := ByteArray new: payloadLen.
+ count := payloadLen == 0 ifTrue: [0] ifFalse: [aSocket read: payloadLen into: bytes].
+ count ~= payloadLen ifTrue: [self error: 'Invalid response from client!'].
+ 1 to: count do: [:i |
+ bytes at: i put: ((bytes at: i) bitXor: (mask at: i - 1 \\ 4 + 1)).
+ ].
+ opcode == 0 ifTrue: [ "Continuation"
+ self error: 'Continuation frame not (yet) supported!'.
+ ].
+ opcode == 1 ifTrue: [ "Text"
+ data := bytes decodeFromUTF8.
+ ^self
+ ].
+ opcode == 2 ifTrue: [ "Binary"
+ data := bytes.
+ ^self
+ ].
+ opcode == 8 ifTrue: [ "Close"
+ bytes notEmpty ifTrue: [
+ data := bytes unsigned16At: 1.
+ ].
+ ^self
+ ].
+ opcode == 9 ifTrue: [ "Ping"
+ data := bytes.
+ ^self
+ ].
+ opcode == 16rA ifTrue: [ "Pong"
+ data := bytes.
+ ^self
+ ].
+]
+
+{ #category : 'other' }
+WebSocketDataFrame >> sendBinary: bytes onSocket: aSocket [
+
+ self
+ sendOpcode: 16r2
+ data: bytes
+ onSocket: aSocket
+]
+
+{ #category : 'other' }
+WebSocketDataFrame >> sendDisconnect: anInteger onSocket: aSocket [
+
+ | bytes |
+ anInteger ifNil: [
+ bytes := ByteArray new: 0.
+ ] ifNotNil: [
+ bytes := ByteArray new: 2.
+ bytes unsigned16At: 1 put: anInteger.
+ ].
+ self
+ sendOpcode: 16r8
+ data: bytes
+ onSocket: aSocket
+]
+
+{ #category : 'other' }
+WebSocketDataFrame >> sendOpcode: type data: bytes onSocket: aSocket [
+
+ | count |
+ bytes size < 126 ifTrue: [
+ data := (ByteArray new: 2) , bytes.
+ data
+ at: 1 put: 2r10000000 + type;
+ at: 2 put: bytes size;
+ yourself.
+ ] ifFalse: [
+ bytes size < 16r10000 ifTrue: [
+ data := (ByteArray new: 4) , bytes.
+ data
+ at: 1 put: 2r10000000 + 16r1;
+ at: 2 put: 126;
+ unsigned16At: 3 put: bytes size;
+ yourself.
+ ] ifFalse: [
+ data := (ByteArray new: 8) , bytes.
+ data
+ at: 1 put: 2r10000000 + 16r1;
+ at: 2 put: 127;
+ unsigned32At: 3 put: bytes size;
+ yourself.
+ ].
+ ].
+ count := aSocket write: data.
+ count == data size ifFalse: [self error: 'Unable to write data!'].
+]
+
+{ #category : 'other' }
+WebSocketDataFrame >> sendPongData: bytes onSocket: aSocket [
+
+ self
+ sendOpcode: 16rA
+ data: bytes
+ onSocket: aSocket
+]
+
+{ #category : 'other' }
+WebSocketDataFrame >> sendText: bytes onSocket: aSocket [
+
+ self
+ sendOpcode: 16r1
+ data: bytes
+ onSocket: aSocket
+]
+
+{ #category : 'testing' }
+WebSocketDataFrame >> isBinary [
+
+ ^opcode == 2
+]
+
+{ #category : 'testing' }
+WebSocketDataFrame >> isContinuation [
+
+ ^opcode == 0
+]
+
+{ #category : 'testing' }
+WebSocketDataFrame >> isDisconnect [
+
+ ^opcode == 8
+]
+
+{ #category : 'testing' }
+WebSocketDataFrame >> isFinal [
+
+ ^fin
+]
+
+{ #category : 'testing' }
+WebSocketDataFrame >> isPing [
+
+ ^opcode == 9
+]
+
+{ #category : 'testing' }
+WebSocketDataFrame >> isText [
+
+ ^opcode == 1
+]
diff --git a/src/WebGS-Core/package.st b/src/WebGS-Core/package.st
new file mode 100644
index 0000000..8e5b2a3
--- /dev/null
+++ b/src/WebGS-Core/package.st
@@ -0,0 +1 @@
+Package { #name : 'WebGS-Core' }
diff --git a/src/WebGS-Core/properties.st b/src/WebGS-Core/properties.st
new file mode 100644
index 0000000..61bc452
--- /dev/null
+++ b/src/WebGS-Core/properties.st
@@ -0,0 +1,4 @@
+{
+ #format : 'tonel',
+ #convention : 'RowanHybrid'
+}
diff --git a/src/WebGS-OpenApi/DocumentedRouter.class.st b/src/WebGS-OpenApi/DocumentedRouter.class.st
new file mode 100644
index 0000000..c89d231
--- /dev/null
+++ b/src/WebGS-OpenApi/DocumentedRouter.class.st
@@ -0,0 +1,108 @@
+"A Router that also builds an OpenApiSpec describing the registered routes.
+
+Use the standard Router protocol (get:do:, post:do:, ...) for routes you do not
+want to document, or the documented variants (get:do:operation:, ...) to attach
+an OpenApiOperation to a route. Two meta-routes are pre-registered:
+ GET /openapi.json - the OpenAPI 3 document
+ GET /docs - Swagger UI loaded from a CDN"
+Class {
+ #name : 'DocumentedRouter',
+ #superclass : 'Router',
+ #instVars : [
+ 'spec'
+ ],
+ #category : 'WebGS-OpenApi'
+}
+
+{ #category : 'docs' }
+DocumentedRouter class >> swaggerUiHtml [
+
+ ^'
+
+
+
+API Docs
+
+
+
+
+
+
+
+
+'
+]
+
+{ #category : 'docs' }
+DocumentedRouter >> installDocRoutes [
+ "Register the meta-endpoints that serve the spec and the Swagger UI. Called from initialize."
+
+ super get: '/openapi.json' do: [:request :response |
+ response
+ content: spec asJson;
+ contentType: 'application/json; charset=UTF-8';
+ accessControlAllowOrigin: '*'.
+ ].
+ super get: '/docs' do: [:request :response |
+ response
+ content: self class swaggerUiHtml;
+ contentType: 'text/html; charset=UTF-8'.
+ ].
+]
+
+{ #category : 'docs' }
+DocumentedRouter >> spec [
+ "The OpenApiSpec this router populates. Configure it before registering routes:
+ router spec title: 'Films API'; version: '1.0.0'; description: '...'."
+
+ ^spec
+]
+
+{ #category : 'initialization' }
+DocumentedRouter >> initialize [
+
+ super initialize.
+ spec := OpenApiSpec new.
+ self installDocRoutes.
+]
+
+{ #category : 'routes' }
+DocumentedRouter >> delete: aPath do: aBlock [
+
+ routes add: (Route method: 'DELETE' path: aPath block: aBlock)
+]
+
+{ #category : 'routes' }
+DocumentedRouter >> delete: aPath do: aBlock operation: anOperation [
+
+ self delete: aPath do: aBlock.
+ spec addOperation: anOperation method: 'DELETE' path: aPath.
+]
+
+{ #category : 'routes' }
+DocumentedRouter >> get: aPath do: aBlock operation: anOperation [
+
+ super get: aPath do: aBlock.
+ spec addOperation: anOperation method: 'GET' path: aPath.
+]
+
+{ #category : 'routes' }
+DocumentedRouter >> post: aPath do: aBlock operation: anOperation [
+
+ super post: aPath do: aBlock.
+ spec addOperation: anOperation method: 'POST' path: aPath.
+]
+
+{ #category : 'routes' }
+DocumentedRouter >> put: aPath do: aBlock operation: anOperation [
+
+ super put: aPath do: aBlock.
+ spec addOperation: anOperation method: 'PUT' path: aPath.
+]
diff --git a/src/WebGS-OpenApi/OpenApiOperation.class.st b/src/WebGS-OpenApi/OpenApiOperation.class.st
new file mode 100644
index 0000000..f48c420
--- /dev/null
+++ b/src/WebGS-OpenApi/OpenApiOperation.class.st
@@ -0,0 +1,160 @@
+"Holds the OpenAPI metadata for a single (method, path) endpoint:
+summary, description, tags, parameters, request body, and responses.
+
+Path parameters are auto-derived by OpenApiSpec from the route's path string,
+so you usually only declare query parameters, request bodies, and responses here."
+Class {
+ #name : 'OpenApiOperation',
+ #superclass : 'Object',
+ #instVars : [
+ 'summary',
+ 'description',
+ 'operationId',
+ 'tags',
+ 'parameters',
+ 'requestBody',
+ 'responses',
+ 'responseOrder'
+ ],
+ #category : 'WebGS-OpenApi'
+}
+
+{ #category : 'constructors' }
+OpenApiOperation class >> new [
+
+ ^self basicNew initialize; yourself
+]
+
+{ #category : 'building' }
+OpenApiOperation >> description: aString [
+
+ description := aString.
+]
+
+{ #category : 'building' }
+OpenApiOperation >> operationId: aString [
+
+ operationId := aString.
+]
+
+{ #category : 'building' }
+OpenApiOperation >> queryParam: aName type: aTypeString description: aDescription [
+
+ ^self
+ queryParam: aName
+ type: aTypeString
+ required: false
+ description: aDescription
+]
+
+{ #category : 'building' }
+OpenApiOperation >> queryParam: aName type: aTypeString required: aBoolean description: aDescription [
+
+ parameters add: (Dictionary new
+ at: 'name' put: aName;
+ at: 'in' put: 'query';
+ at: 'required' put: aBoolean;
+ at: 'description' put: aDescription;
+ at: 'schema' put: (OpenApiSchema new type: aTypeString; yourself) asOpenApiDictionary;
+ yourself).
+]
+
+{ #category : 'building' }
+OpenApiOperation >> requestBodyJson: aSchema [
+
+ ^self requestBodySchema: aSchema description: nil
+]
+
+{ #category : 'building' }
+OpenApiOperation >> requestBodySchema: aSchema description: aString [
+
+ | body content |
+ content := Dictionary new
+ at: 'application/json' put: (Dictionary new
+ at: 'schema' put: aSchema asOpenApiDictionary;
+ yourself);
+ yourself.
+ body := Dictionary new
+ at: 'required' put: true;
+ at: 'content' put: content;
+ yourself.
+ aString ifNotNil: [body at: 'description' put: aString].
+ requestBody := body.
+]
+
+{ #category : 'building' }
+OpenApiOperation >> response: aCode description: aString [
+
+ ^self response: aCode description: aString schema: nil
+]
+
+{ #category : 'building' }
+OpenApiOperation >> response: aCode description: aString schema: aSchemaOrNil [
+
+ | entry content |
+ entry := Dictionary new
+ at: 'description' put: aString;
+ yourself.
+ aSchemaOrNil ifNotNil: [
+ content := Dictionary new
+ at: 'application/json' put: (Dictionary new
+ at: 'schema' put: aSchemaOrNil asOpenApiDictionary;
+ yourself);
+ yourself.
+ entry at: 'content' put: content.
+ ].
+ responses at: aCode printString put: entry.
+ responseOrder add: aCode printString.
+]
+
+{ #category : 'building' }
+OpenApiOperation >> summary: aString [
+
+ summary := aString.
+]
+
+{ #category : 'building' }
+OpenApiOperation >> tag: aString [
+
+ tags add: aString.
+]
+
+{ #category : 'initialization' }
+OpenApiOperation >> initialize [
+
+ parameters := Array new.
+ responses := Dictionary new.
+ responseOrder := Array new.
+ tags := Array new.
+]
+
+{ #category : 'serialization' }
+OpenApiOperation >> asOpenApiDictionaryWithPathParameters: pathParamNames [
+
+ | dict allParams orderedResponses |
+ dict := Dictionary new.
+ summary ifNotNil: [dict at: 'summary' put: summary].
+ description ifNotNil: [dict at: 'description' put: description].
+ operationId ifNotNil: [dict at: 'operationId' put: operationId].
+ tags isEmpty ifFalse: [dict at: 'tags' put: tags asArray].
+
+ allParams := Array new.
+ pathParamNames do: [:name |
+ allParams add: (Dictionary new
+ at: 'name' put: name;
+ at: 'in' put: 'path';
+ at: 'required' put: true;
+ at: 'schema' put: (Dictionary new at: 'type' put: 'string'; yourself);
+ yourself).
+ ].
+ parameters do: [:p | allParams add: p].
+ allParams isEmpty ifFalse: [dict at: 'parameters' put: allParams].
+
+ requestBody ifNotNil: [dict at: 'requestBody' put: requestBody].
+
+ orderedResponses := Dictionary new.
+ responseOrder do: [:code | orderedResponses at: code put: (responses at: code)].
+ orderedResponses isEmpty ifFalse: [dict at: 'responses' put: orderedResponses].
+
+ ^dict
+]
diff --git a/src/WebGS-OpenApi/OpenApiSchema.class.st b/src/WebGS-OpenApi/OpenApiSchema.class.st
new file mode 100644
index 0000000..4c812e6
--- /dev/null
+++ b/src/WebGS-OpenApi/OpenApiSchema.class.st
@@ -0,0 +1,177 @@
+"A builder for a JSON Schema fragment used inside an OpenAPI document.
+
+Use class methods (string, integer, number, boolean, object, array:, ref:) to construct,
+then send instance messages to add properties, required-lists, descriptions, etc."
+Class {
+ #name : 'OpenApiSchema',
+ #superclass : 'Object',
+ #instVars : [
+ 'type',
+ 'format',
+ 'description',
+ 'example',
+ 'properties',
+ 'propertyOrder',
+ 'required',
+ 'items',
+ 'ref',
+ 'enum'
+ ],
+ #category : 'WebGS-OpenApi'
+}
+
+{ #category : 'constructors' }
+OpenApiSchema class >> array: itemSchema [
+
+ ^self new
+ type: 'array';
+ items: itemSchema;
+ yourself
+]
+
+{ #category : 'constructors' }
+OpenApiSchema class >> boolean [
+
+ ^self new type: 'boolean'
+]
+
+{ #category : 'constructors' }
+OpenApiSchema class >> integer [
+
+ ^self new type: 'integer'
+]
+
+{ #category : 'constructors' }
+OpenApiSchema class >> new [
+
+ ^self basicNew initialize; yourself
+]
+
+{ #category : 'constructors' }
+OpenApiSchema class >> number [
+
+ ^self new type: 'number'
+]
+
+{ #category : 'constructors' }
+OpenApiSchema class >> object [
+
+ ^self new type: 'object'
+]
+
+{ #category : 'constructors' }
+OpenApiSchema class >> ref: aName [
+ "A reference to a named schema declared in OpenApiSpec components."
+
+ ^self new ref: aName
+]
+
+{ #category : 'constructors' }
+OpenApiSchema class >> string [
+
+ ^self new type: 'string'
+]
+
+{ #category : 'building' }
+OpenApiSchema >> description: aString [
+
+ description := aString.
+]
+
+{ #category : 'building' }
+OpenApiSchema >> enum: aCollection [
+
+ enum := aCollection.
+]
+
+{ #category : 'building' }
+OpenApiSchema >> example: anObject [
+
+ example := anObject.
+]
+
+{ #category : 'building' }
+OpenApiSchema >> format: aString [
+
+ format := aString.
+]
+
+{ #category : 'building' }
+OpenApiSchema >> items: aSchema [
+
+ items := aSchema.
+]
+
+{ #category : 'building' }
+OpenApiSchema >> property: aName schema: aSchema [
+
+ properties ifNil: [properties := Dictionary new].
+ propertyOrder ifNil: [propertyOrder := Array new].
+ (properties includesKey: aName) ifFalse: [propertyOrder add: aName].
+ properties at: aName put: aSchema.
+]
+
+{ #category : 'building' }
+OpenApiSchema >> property: aName type: aTypeString [
+
+ ^self property: aName schema: (OpenApiSchema new type: aTypeString; yourself)
+]
+
+{ #category : 'building' }
+OpenApiSchema >> property: aName type: aTypeString description: aString [
+
+ ^self property: aName schema: (OpenApiSchema new
+ type: aTypeString;
+ description: aString;
+ yourself)
+]
+
+{ #category : 'building' }
+OpenApiSchema >> ref: aName [
+
+ ref := aName.
+]
+
+{ #category : 'building' }
+OpenApiSchema >> required: aCollection [
+
+ required := aCollection.
+]
+
+{ #category : 'building' }
+OpenApiSchema >> type: aString [
+
+ type := aString.
+]
+
+{ #category : 'initialization' }
+OpenApiSchema >> initialize [
+
+]
+
+{ #category : 'serialization' }
+OpenApiSchema >> asOpenApiDictionary [
+
+ | dict props |
+ ref ifNotNil: [
+ ^Dictionary new
+ at: '$ref' put: '#/components/schemas/' , ref;
+ yourself
+ ].
+ dict := Dictionary new.
+ type ifNotNil: [dict at: 'type' put: type].
+ format ifNotNil: [dict at: 'format' put: format].
+ description ifNotNil: [dict at: 'description' put: description].
+ items ifNotNil: [dict at: 'items' put: items asOpenApiDictionary].
+ properties ifNotNil: [
+ props := Dictionary new.
+ propertyOrder do: [:k |
+ props at: k put: (properties at: k) asOpenApiDictionary.
+ ].
+ dict at: 'properties' put: props.
+ ].
+ required ifNotNil: [dict at: 'required' put: required asArray].
+ enum ifNotNil: [dict at: 'enum' put: enum asArray].
+ example ifNotNil: [dict at: 'example' put: example].
+ ^dict
+]
diff --git a/src/WebGS-OpenApi/OpenApiSpec.class.st b/src/WebGS-OpenApi/OpenApiSpec.class.st
new file mode 100644
index 0000000..dcb1380
--- /dev/null
+++ b/src/WebGS-OpenApi/OpenApiSpec.class.st
@@ -0,0 +1,180 @@
+"Top-level OpenAPI 3.0 document. Populated automatically by DocumentedRouter as
+routes are registered; configure title/version/description/servers/schemas
+through the spec accessor on a DocumentedRouter."
+Class {
+ #name : 'OpenApiSpec',
+ #superclass : 'Object',
+ #instVars : [
+ 'title',
+ 'version',
+ 'description',
+ 'servers',
+ 'paths',
+ 'pathOrder',
+ 'schemas',
+ 'schemaOrder'
+ ],
+ #category : 'WebGS-OpenApi'
+}
+
+{ #category : 'constructors' }
+OpenApiSpec class >> new [
+
+ ^self basicNew initialize; yourself
+]
+
+{ #category : 'utilities' }
+OpenApiSpec class >> openApiPathFor: aWebGsPath [
+ "Translate WebGS '/films/:id' into OpenAPI '/films/{id}'."
+
+ | stream pathStream ch paramName |
+ stream := WriteStream on: String new.
+ pathStream := ReadStream on: aWebGsPath.
+ [pathStream atEnd] whileFalse: [
+ ch := pathStream next.
+ ch == $: ifTrue: [
+ paramName := String new.
+ [pathStream atEnd not and: [
+ | c |
+ c := pathStream peek.
+ c isLetter or: [c isDigit or: [c == $_]]
+ ]] whileTrue: [paramName add: pathStream next].
+ stream nextPut: ${; nextPutAll: paramName; nextPut: $}.
+ ] ifFalse: [stream nextPut: ch].
+ ].
+ ^stream contents
+]
+
+{ #category : 'utilities' }
+OpenApiSpec class >> pathParameterNamesIn: aWebGsPath [
+ "Extract the parameter names from a WebGS-style path: '/films/:id/views/:k' -> #('id' 'k')."
+
+ | pathStream names ch paramName |
+ names := Array new.
+ pathStream := ReadStream on: aWebGsPath.
+ [pathStream atEnd] whileFalse: [
+ ch := pathStream next.
+ ch == $: ifTrue: [
+ paramName := String new.
+ [pathStream atEnd not and: [
+ | c |
+ c := pathStream peek.
+ c isLetter or: [c isDigit or: [c == $_]]
+ ]] whileTrue: [paramName add: pathStream next].
+ names add: paramName.
+ ].
+ ].
+ ^names
+]
+
+{ #category : 'building' }
+OpenApiSpec >> addOperation: anOperation method: aMethodString path: aPathString [
+ "Register an operation under (method, path). Multiple methods on the same path are allowed."
+
+ | openApiPath byMethod |
+ openApiPath := self class openApiPathFor: aPathString.
+ byMethod := paths at: openApiPath ifAbsent: [
+ | m |
+ m := Dictionary new.
+ paths at: openApiPath put: m.
+ pathOrder add: openApiPath.
+ m
+ ].
+ byMethod at: aMethodString asLowercase put: (Array with: anOperation with: aPathString).
+]
+
+{ #category : 'building' }
+OpenApiSpec >> description: aString [
+
+ description := aString.
+]
+
+{ #category : 'building' }
+OpenApiSpec >> schema: aName definition: aSchema [
+
+ (schemas includesKey: aName) ifFalse: [schemaOrder add: aName].
+ schemas at: aName put: aSchema.
+]
+
+{ #category : 'building' }
+OpenApiSpec >> server: aUrl description: aDescription [
+
+ | entry |
+ entry := Dictionary new
+ at: 'url' put: aUrl;
+ yourself.
+ aDescription ifNotNil: [entry at: 'description' put: aDescription].
+ servers add: entry.
+]
+
+{ #category : 'building' }
+OpenApiSpec >> title: aString [
+
+ title := aString.
+]
+
+{ #category : 'building' }
+OpenApiSpec >> version: aString [
+
+ version := aString.
+]
+
+{ #category : 'initialization' }
+OpenApiSpec >> initialize [
+
+ title := 'WebGS API'.
+ version := '1.0.0'.
+ servers := Array new.
+ paths := Dictionary new.
+ pathOrder := Array new.
+ schemas := Dictionary new.
+ schemaOrder := Array new.
+]
+
+{ #category : 'serialization' }
+OpenApiSpec >> asJson [
+
+ ^self asOpenApiDictionary asJson
+]
+
+{ #category : 'serialization' }
+OpenApiSpec >> asOpenApiDictionary [
+
+ | root info pathsDict componentsDict schemasDict |
+ root := Dictionary new.
+ root at: 'openapi' put: '3.0.3'.
+
+ info := Dictionary new
+ at: 'title' put: title;
+ at: 'version' put: version;
+ yourself.
+ description ifNotNil: [info at: 'description' put: description].
+ root at: 'info' put: info.
+
+ servers isEmpty ifFalse: [root at: 'servers' put: servers asArray].
+
+ pathsDict := Dictionary new.
+ pathOrder do: [:openApiPath |
+ | byMethod pathItem |
+ byMethod := paths at: openApiPath.
+ pathItem := Dictionary new.
+ byMethod keysAndValuesDo: [:methodKey :pair |
+ | op webGsPath pathParamNames |
+ op := pair at: 1.
+ webGsPath := pair at: 2.
+ pathParamNames := self class pathParameterNamesIn: webGsPath.
+ pathItem at: methodKey put: (op asOpenApiDictionaryWithPathParameters: pathParamNames).
+ ].
+ pathsDict at: openApiPath put: pathItem.
+ ].
+ root at: 'paths' put: pathsDict.
+
+ schemas isEmpty ifFalse: [
+ schemasDict := Dictionary new.
+ schemaOrder do: [:name | schemasDict at: name put: (schemas at: name) asOpenApiDictionary].
+ componentsDict := Dictionary new at: 'schemas' put: schemasDict; yourself.
+ root at: 'components' put: componentsDict.
+ ].
+
+ ^root
+]
diff --git a/src/WebGS-OpenApi/package.st b/src/WebGS-OpenApi/package.st
new file mode 100644
index 0000000..1021b20
--- /dev/null
+++ b/src/WebGS-OpenApi/package.st
@@ -0,0 +1 @@
+Package { #name : 'WebGS-OpenApi' }
diff --git a/src/WebGS-OpenApi/properties.st b/src/WebGS-OpenApi/properties.st
new file mode 100644
index 0000000..61bc452
--- /dev/null
+++ b/src/WebGS-OpenApi/properties.st
@@ -0,0 +1,4 @@
+{
+ #format : 'tonel',
+ #convention : 'RowanHybrid'
+}
diff --git a/src/WebGS-Sample/Sample.class.st b/src/WebGS-Sample/Sample.class.st
new file mode 100644
index 0000000..1b8e2ee
--- /dev/null
+++ b/src/WebGS-Sample/Sample.class.st
@@ -0,0 +1,199 @@
+"No class-specific documentation for Sample, hierarchy is:
+Object
+ WebApp( begin end exception html request response)
+ Sample( main)
+"
+Class {
+ #name : 'Sample',
+ #superclass : 'WebApp',
+ #instVars : [
+ 'clientString'
+ ],
+ #classVars : [
+ 'Counter'
+ ],
+ #category : 'WebGS-Sample'
+}
+
+{ #category : 'other' }
+Sample class >> runDistributedHttp [
+"
+ Sample runDistributedHttp.
+"
+ self runDistributedHttp: 4.
+]
+
+{ #category : 'other' }
+Sample class >> runDistributedHttp: anInteger [
+"
+ Sample runDistributedHttp: 4.
+"
+ self htdocs: (System performOnServer: 'pwd') trimSeparators , '/htdocs'.
+ System commit.
+ HttpListener new
+ listenBacklog: 200;
+ port: 8888;
+ server: (HttpLoadBalancer startServer: self withRouter: nil gemCount: anInteger);
+ run.
+]
+
+{ #category : 'other' }
+Sample class >> runDistributedHttps [
+"
+ Sample runDistributedHttps.
+"
+ self runDistributedHttps: 4.
+]
+
+{ #category : 'other' }
+Sample class >> runDistributedHttps: anInteger [
+"
+ Sample runDistributedHttps: 4.
+"
+ self htdocs: (System performOnServer: 'pwd') trimSeparators , '/htdocs'.
+ System commit.
+ HttpsListener new
+ listenBacklog: 200;
+ port: 8888;
+ server: (HttpLoadBalancer startServer: self withRouter: nil gemCount: anInteger);
+ run.
+]
+
+{ #category : 'other' }
+Sample class >> runHttp [
+"
+ Sample runHttp.
+"
+ HttpListener new
+ listenBacklog: 200;
+ port: 8888;
+ server: self;
+ run.
+]
+
+{ #category : 'other' }
+Sample class >> runHttps [
+"
+ Sample runHttps.
+"
+ HttpsListener new
+ listenBacklog: 100;
+ port: 8888;
+ server: self;
+ run.
+]
+
+{ #category : 'REST API' }
+Sample >> add_gs: args [
+ "localhost:8888/add.gs?x=1&y=2"
+
+ | x y |
+ x := (args at: 'x') asInteger.
+ y := (args at: 'y') asInteger.
+ ^Dictionary new
+ at: 'sum' put: x + y;
+ yourself.
+]
+
+{ #category : 'REST API' }
+Sample >> counter_gs: args [
+ "localhost:8888/counter.gs"
+
+ Counter ifNil: [Counter := 0].
+ Counter := Counter + 1.
+ System commit.
+ ^Dictionary new
+ at: 'counter' put: Counter;
+ yourself.
+]
+
+{ #category : 'REST API' }
+Sample >> cpu_gs: args [
+
+ | ms endTime |
+ ms := (args at: 'ms') asInteger.
+ endTime := System _timeGmtFloat + (ms / 1000).
+ [System _timeGmtFloat < endTime] whileTrue: [].
+ ^Dictionary new
+ at: 'ms' put: ms;
+ yourself
+]
+
+{ #category : 'REST API' }
+Sample >> echo_gs: args [
+
+ "UserGlobals at: #'James' put: args.
+ System commit."
+ ^args
+]
+
+{ #category : 'REST API' }
+Sample >> sleep_gs: args [
+
+ | ms |
+ ms := (args at: 'ms') asInteger.
+ (Delay forMilliseconds: ms) wait.
+ ^Dictionary new
+ at: 'ms' put: ms;
+ yourself
+]
+
+{ #category : 'REST API' }
+Sample >> stone_gs [
+
+ ^System stoneConfigurationReport
+]
+
+{ #category : 'REST API' }
+Sample >> uploadFile_gs [
+
+ | dict headers part pieces size string |
+ dict := Dictionary new.
+ part := request upToNextPartAsUnicode. "should be an empty string"
+ 2 timesRepeat: [
+ headers := request nextPartHeaders. "should be a Dictionary"
+ string := headers at: (Unicode7 withAll: 'content-disposition').
+ pieces := string subStrings: $;.
+ string := ((pieces at: 3) subStrings: $=) at: 2.
+ string := string copyFrom: 2 to: string size - 1.
+ part := request upToNextPartAsUnicode. "should be file contents"
+ size := part size.
+ dict at: string put: size.
+ ].
+ ^dict
+]
+
+{ #category : 'WebSockets' }
+Sample >> webSocket_gs [
+
+ Log instance log: #'debug' string: 'Sample>>webSocket_gs'.
+ "We can send arbitrary data on the socket"
+ [self wsSendToClient] fork.
+ "We can receive arbitrary data on the socket.
+ The following never returns but quietly terminates when the other side closes the connection"
+ super webSocket_gs.
+]
+
+{ #category : 'WebSockets' }
+Sample >> wsBinaryData: aByteArray [
+
+ Log instance log: #'debug' string: 'Sample>>webSocket_gs - ' , aByteArray printString.
+]
+
+{ #category : 'WebSockets' }
+Sample >> wsSendToClient [
+
+ [
+ (Delay forSeconds: 1) wait.
+ socket isConnected.
+ ] whileTrue: [
+ WebSocketDataFrame sendText: clientString printString , ' at ' , Time now printString onSocket: socket.
+ ].
+]
+
+{ #category : 'WebSockets' }
+Sample >> wsTextData: unicode [
+
+ Log instance log: #'debug' string: 'Sample>>webSocket_gs - ' , unicode printString.
+ clientString := unicode asString.
+]
diff --git a/src/WebGS-Sample/package.st b/src/WebGS-Sample/package.st
new file mode 100644
index 0000000..fb69f51
--- /dev/null
+++ b/src/WebGS-Sample/package.st
@@ -0,0 +1 @@
+Package { #name : 'WebGS-Sample' }
diff --git a/src/WebGS-Sample/properties.st b/src/WebGS-Sample/properties.st
new file mode 100644
index 0000000..61bc452
--- /dev/null
+++ b/src/WebGS-Sample/properties.st
@@ -0,0 +1,4 @@
+{
+ #format : 'tonel',
+ #convention : 'RowanHybrid'
+}
diff --git a/src/properties.st b/src/properties.st
new file mode 100644
index 0000000..61bc452
--- /dev/null
+++ b/src/properties.st
@@ -0,0 +1,4 @@
+{
+ #format : 'tonel',
+ #convention : 'RowanHybrid'
+}
diff --git a/testRowan.sh b/testRowan.sh
new file mode 100755
index 0000000..e99fcea
--- /dev/null
+++ b/testRowan.sh
@@ -0,0 +1,285 @@
+#!/bin/bash
+#
+# testRowan.sh — Prove the topaz install path and Rowan are identical.
+#
+# The Rowan/Tonel source (WebGS project under ./src + ./rowan, Films demo
+# project under ./Films) is the source of truth. This harness provisions two
+# throwaway GemStone stones and installs WebGS + the Films demo into each a
+# different way:
+#
+# topaz the hand-written topaz fileouts shipped on main:
+# install.sh -> src/WebGS.gs -> WebGS dict (19 classes)
+# installFilmsApi.sh -> src/Films.gs, src/FilmsApi.gs -> Films dict (2 classes)
+# rowan the same source loaded via Rowan (installRowan.sh --with-films):
+# WebGS project -> WebGS dict (19 classes)
+# Films project -> Films dict (2 classes)
+#
+# It asserts the two are IDENTICAL:
+# * Structure: every class in the WebGS and Films dictionaries has a
+# byte-identical shape + full method set (not just the tested paths), AND
+# each class lands in the same symbol dictionary.
+# * Behaviour: the Dart suite (tests/http.dart) produces identical results.
+# i.e. installing from Rowan and installing from the topaz fileout produce the
+# very same image.
+#
+# Everything is disposable; nothing touches the developer's own stones.
+#
+# Usage: ./testRowan.sh # GEMSTONE=/path LDI_PORT=NNNN ./testRowan.sh
+#
+set -uo pipefail
+
+# ---- configuration -----------------------------------------------------------
+export GEMSTONE="${GEMSTONE:-/Users/srbaker/Documents/GemStone/GemStone64Bit3.7.5-arm64.Darwin}"
+export PATH="$GEMSTONE/bin:$PATH"
+REPO="$(cd "$(dirname "$0")" && pwd)"
+PARENT="$(dirname "$REPO")"
+EXTENT="$GEMSTONE/bin/extent0.rowan3.dbf" # Rowan-V3-enabled base extent
+USER_NAME="$(id -un)"
+LDI_PORT="${LDI_PORT:-53799}"
+HTTP_PORT=8888
+STONE_USER=DataCurator
+STONE_PASS=swordfish
+ROWAN_DICTS="#(#'RowanKernel' #'RowanLoader' #'RowanTools' #'RowanClientServices')"
+DUMP_DICTS="'WebGS' 'Films'" # symbol dictionaries compared across both install paths
+MODES="topaz rowan"
+
+WORK="$(mktemp -d "${TMPDIR:-/tmp}/webgs-rowan.XXXXXX")"
+RESULTS="$WORK/results"; mkdir -p "$RESULTS"
+SERVER_PID=""
+STARTED_NETLDI=""
+
+log() { printf '\n\033[1;36m== %s\033[0m\n' "$*"; }
+info() { printf ' %s\n' "$*"; }
+die() { printf '\n\033[1;31mFAIL: %s\033[0m\n' "$*" >&2; [ -n "${KEEP_WORK:-}" ] && { cp -r "$WORK" "$KEEP_WORK" 2>/dev/null; echo " (logs at $KEEP_WORK)" >&2; }; exit 1; }
+
+topaz_login() { # $1 = stone name
+ printf 'set user %s password %s\nset gemstone !@localhost#netldi:%s!%s\nlogin\n' \
+ "$STONE_USER" "$STONE_PASS" "$LDI_PORT" "$1"
+}
+
+cleanup() {
+ [ -n "$SERVER_PID" ] && kill "$SERVER_PID" 2>/dev/null
+ for m in $MODES; do
+ pkill -f "gem webgs_${m}_$$" 2>/dev/null
+ stopstone "webgs_${m}_$$" "$STONE_USER" "$STONE_PASS" >/dev/null 2>&1
+ done
+ [ -n "$STARTED_NETLDI" ] && stopnetldi "$LDI_PORT" >/dev/null 2>&1
+ rm -rf "$WORK"
+}
+trap cleanup EXIT
+
+export GEMSTONE_GLOBAL_DIR="$WORK"
+export GEMSTONE_NRS_ALL="#netldi:$LDI_PORT#dir:$WORK"
+
+# ---- infrastructure ----------------------------------------------------------
+[ -f "$EXTENT" ] || die "Rowan extent not found: $EXTENT"
+lsof -nP -iTCP:"$LDI_PORT" 2>/dev/null | grep -q LISTEN && die "port $LDI_PORT busy (set LDI_PORT=)"
+mkdir -p "$WORK/locks"
+log "Starting NetLDI on port $LDI_PORT (guest mode)"
+startnetldi -g -a "$USER_NAME" -P "$LDI_PORT" -l "$WORK/netldi.log" "$LDI_PORT" >/dev/null 2>&1 \
+ || die "startnetldi failed (see $WORK/netldi.log)"
+STARTED_NETLDI=1
+
+provision_stone() { # $1 = stone name
+ local stone="$1" d="$WORK/$1"
+ mkdir -p "$d/data" "$d/log"
+ copydbf "$EXTENT" "$d/data/extent0.dbf" >/dev/null 2>&1
+ chmod u+w "$d/data/extent0.dbf"
+ cat > "$d/system.conf" </dev/null 2>&1 \
+ || die "startstone $stone failed (see $d/log/stone.log)"
+ waitstone "$stone" >/dev/null 2>&1 || die "waitstone $stone failed"
+}
+
+start_server() { # $1 = stone name; launches `Sample runHttp` in background
+ local stone="$1" i
+ ( cd "$REPO" && topaz -lq >"$WORK/server-$stone.out" 2>&1 </dev/null
+ for i in $(seq 1 60); do
+ curl -s -o /dev/null "http://localhost:$HTTP_PORT/" 2>/dev/null && return 0
+ sleep 0.5
+ done
+ die "server for $stone never came up on :$HTTP_PORT"
+}
+
+stop_server() { # $1 = stone name
+ [ -n "$SERVER_PID" ] && kill "$SERVER_PID" 2>/dev/null
+ pkill -f "gem $1" 2>/dev/null
+ SERVER_PID=""
+ sleep 1
+}
+
+run_suite() { # $1 = mode label; normalize Dart results to $RESULTS/