* Websockets & examples

packages/fcl-web/Makefile

@@ -2,7 +2,7 @@
 # Don't edit, this file is generated by FPCMake Version 2.0.0
 #
 default: all
-MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim i386-android i386-aros m68k-linux m68k-netbsd m68k-amiga m68k-atari m68k-palmos m68k-macosclassic m68k-embedded m68k-sinclairql powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macosclassic powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-haiku x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded x86_64-iphonesim x86_64-android x86_64-aros x86_64-dragonfly arm-linux arm-netbsd arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android arm-aros arm-freertos arm-ios powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-embedded mipsel-android mips64el-linux jvm-java jvm-android i8086-embedded i8086-msdos i8086-win16 aarch64-linux aarch64-freebsd aarch64-darwin aarch64-win64 aarch64-android aarch64-ios wasm32-embedded wasm32-wasi sparc64-linux riscv32-linux riscv32-embedded riscv64-linux riscv64-embedded xtensa-linux xtensa-embedded xtensa-freertos z80-embedded z80-zxspectrum z80-msxdos z80-amstradcpc
+MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim i386-android i386-aros m68k-linux m68k-netbsd m68k-amiga m68k-atari m68k-palmos m68k-macosclassic m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macosclassic powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-haiku x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded x86_64-iphonesim x86_64-android x86_64-aros x86_64-dragonfly arm-linux arm-netbsd arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android arm-aros arm-ios powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-embedded mipsel-android jvm-java jvm-android i8086-embedded i8086-msdos i8086-win16 aarch64-linux aarch64-darwin aarch64-android aarch64-ios wasm-wasm sparc64-linux
 BSDs = freebsd netbsd openbsd darwin dragonfly
 UNIXs = linux $(BSDs) solaris qnx haiku aix
 LIMIT83fs = go32v2 os2 emx watcom msdos win16 atari
@@ -196,24 +196,6 @@ $(error When compiling for mipsel-embedded, a sub-architecture (e.g. SUBARCH=pic
 endif
 override FPCOPT+=-Cp$(SUBARCH)
 endif
-ifeq ($(FULL_TARGET),xtensa-embedded)
-ifeq ($(SUBARCH),)
-$(error When compiling for xtensa-embedded, a sub-architecture (e.g. SUBARCH=lx106 or SUBARCH=lx6) must be defined)
-endif
-override FPCOPT+=-Cp$(SUBARCH)
-endif
-ifeq ($(FULL_TARGET),xtensa-freertos)
-ifeq ($(SUBARCH),)
-$(error When compiling for xtensa-freertos, a sub-architecture (e.g. SUBARCH=lx106 or SUBARCH=lx6) must be defined)
-endif
-override FPCOPT+=-Cp$(SUBARCH)
-endif
-ifeq ($(FULL_TARGET),arm-freertos)
-ifeq ($(SUBARCH),)
-$(error When compiling for arm-freertos, a sub-architecture (e.g. SUBARCH=armv6m or SUBARCH=armv7em) must be defined)
-endif
-override FPCOPT+=-Cp$(SUBARCH)
-endif
 ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
 TARGETSUFFIX=$(OS_TARGET)
 SOURCESUFFIX=$(OS_SOURCE)
@@ -554,97 +536,12 @@ endif
 else
 CROSSBINDIR=
 endif
-ifeq ($(OS_SOURCE),linux)
-ifndef GCCLIBDIR
-ifeq ($(CPU_TARGET),i386)
-ifneq ($(findstring x86_64,$(shell uname -a)),)
-ifeq ($(BINUTILSPREFIX),)
-GCCLIBDIR:=$(shell dirname `gcc -m32 -print-libgcc-file-name`)
-else
-CROSSGCCOPT=-m32
-endif
-endif
-endif
-ifeq ($(CPU_TARGET),powerpc)
-ifeq ($(BINUTILSPREFIX),)
-GCCLIBDIR:=$(shell dirname `gcc -m32 -print-libgcc-file-name`)
-else
-CROSSGCCOPT=-m32
-endif
-endif
-ifeq ($(CPU_TARGET),powerpc64)
-ifeq ($(BINUTILSPREFIX),)
-GCCLIBDIR:=$(shell dirname `gcc -m64 -print-libgcc-file-name`)
-else
-CROSSGCCOPT=-m64
-endif
-endif
-ifeq ($(CPU_TARGET),sparc)
-ifneq ($(findstring sparc64,$(shell uname -a)),)
-ifeq ($(BINUTILSPREFIX),)
-GCCLIBDIR:=$(shell dirname `gcc -m32 -print-libgcc-file-name`)
-else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips mipsel),)
-CROSSGCCOPT=-mabi=32
-else
-CROSSGCCOPT=-m32
-endif
-endif
-endif
-endif
-endif
-ifdef FPCFPMAKE
-FPCFPMAKE_CPU_TARGET=$(shell $(FPCFPMAKE) -iTP)
-ifeq ($(CPU_TARGET),$(FPCFPMAKE_CPU_TARGET))
-FPCMAKEGCCLIBDIR:=$(GCCLIBDIR)
-else
-ifneq ($(findstring $(FPCFPMAKE_CPU_TARGET),aarch64 powerpc64 riscv64 sparc64 x86_64),)
-FPCMAKE_CROSSGCCOPT=-m64
-else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips64 mips64el),)
-FPCMAKE_CROSSGCCOPT=-mabi=64
-else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips mipsel),)
-FPCMAKE_CROSSGCCOPT=-mabi=32
-else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),riscv64),)
-FPCMAKE_CROSSGCCOPT=-mabi=lp64
-else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),riscv32),)
-FPCMAKE_CROSSGCCOPT=-mabi=ilp32
-else
-FPCMAKE_CROSSGCCOPT=-m32
-endif
-endif
-endif
-endif
-endif
-FPCMAKEGCCLIBDIR:=$(shell dirname `gcc $(FPCMAKE_CROSSGCCOPT) -print-libgcc-file-name`)
-endif
-endif
-ifndef FPCMAKEGCCLIBDIR
-FPCMAKEGCCLIBDIR:=$(shell dirname `gcc -print-libgcc-file-name`)
-endif
-ifndef GCCLIBDIR
-CROSSGCC=$(strip $(wildcard $(addsuffix /$(BINUTILSPREFIX)gcc$(SRCEXEEXT),$(SEARCHPATH))))
-ifneq ($(CROSSGCC),)
-GCCLIBDIR:=$(shell dirname `$(CROSSGCC) $(CROSSGCCOPT) -print-libgcc-file-name`)
-endif
-endif
-endif
-ifdef inUnix
-ifeq ($(OS_SOURCE),netbsd)
-OTHERLIBDIR:=/usr/pkg/lib
-endif
-export GCCLIBDIR FPCMAKEGCCLIBDIR OTHERLIBDIR
-endif
 BATCHEXT=.bat
 LOADEREXT=.as
 EXEEXT=.exe
 PPLEXT=.ppl
 PPUEXT=.ppu
 OEXT=.o
-LTOEXT=.bc
 ASMEXT=.s
 SMARTEXT=.sl
 STATICLIBEXT=.a
@@ -839,11 +736,6 @@ STATICLIBPREFIX=
 STATICLIBEXT=.a
 SHORTSUFFIX=d16
 endif
-ifeq ($(OS_TARGET),msxdos)
-STATICLIBPREFIX=
-STATICLIBEXT=.a
-SHORTSUFFIX=msd
-endif
 ifeq ($(OS_TARGET),embedded)
 ifeq ($(CPU_TARGET),i8086)
 STATICLIBPREFIX=
@@ -851,9 +743,6 @@ STATICLIBEXT=.a
 else
 EXEEXT=.bin
 endif
-ifeq ($(CPU_TARGET),z80)
-OEXT=.rel
-endif
 SHORTSUFFIX=emb
 endif
 ifeq ($(OS_TARGET),win16)
@@ -862,12 +751,6 @@ STATICLIBEXT=.a
 SHAREDLIBEXT=.dll
 SHORTSUFFIX=w16
 endif
-ifeq ($(OS_TARGET),zxspectrum)
-OEXT=.rel
-endif
-ifeq ($(OS_TARGET),wasi)
-EXEEXT=.wasm
-endif
 ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
 FPCMADE=fpcmade.$(SHORTSUFFIX)
 ZIPSUFFIX=$(SHORTSUFFIX)
@@ -1363,14 +1246,6 @@ REQUIRE_PACKAGES_HASH=1
 REQUIRE_PACKAGES_LIBTAR=1
 REQUIRE_PACKAGES_FPMKUNIT=1
 endif
-ifeq ($(FULL_TARGET),m68k-sinclairql)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
 ifeq ($(FULL_TARGET),powerpc-linux)
 REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_PASZLIB=1
@@ -1659,14 +1534,6 @@ REQUIRE_PACKAGES_HASH=1
 REQUIRE_PACKAGES_LIBTAR=1
 REQUIRE_PACKAGES_FPMKUNIT=1
 endif
-ifeq ($(FULL_TARGET),arm-freertos)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
 ifeq ($(FULL_TARGET),arm-ios)
 REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_PASZLIB=1
@@ -1763,14 +1630,6 @@ REQUIRE_PACKAGES_HASH=1
 REQUIRE_PACKAGES_LIBTAR=1
 REQUIRE_PACKAGES_FPMKUNIT=1
 endif
-ifeq ($(FULL_TARGET),mips64el-linux)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
 ifeq ($(FULL_TARGET),jvm-java)
 REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_PASZLIB=1
@@ -1819,14 +1678,6 @@ REQUIRE_PACKAGES_HASH=1
 REQUIRE_PACKAGES_LIBTAR=1
 REQUIRE_PACKAGES_FPMKUNIT=1
 endif
-ifeq ($(FULL_TARGET),aarch64-freebsd)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
 ifeq ($(FULL_TARGET),aarch64-darwin)
 REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_PASZLIB=1
@@ -1835,14 +1686,6 @@ REQUIRE_PACKAGES_HASH=1
 REQUIRE_PACKAGES_LIBTAR=1
 REQUIRE_PACKAGES_FPMKUNIT=1
 endif
-ifeq ($(FULL_TARGET),aarch64-win64)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
 ifeq ($(FULL_TARGET),aarch64-android)
 REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_PASZLIB=1
@@ -1859,15 +1702,7 @@ REQUIRE_PACKAGES_HASH=1
 REQUIRE_PACKAGES_LIBTAR=1
 REQUIRE_PACKAGES_FPMKUNIT=1
 endif
-ifeq ($(FULL_TARGET),wasm32-embedded)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),wasm32-wasi)
+ifeq ($(FULL_TARGET),wasm-wasm)
 REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_PASZLIB=1
 REQUIRE_PACKAGES_FCL-PROCESS=1
@@ -1883,94 +1718,6 @@ REQUIRE_PACKAGES_HASH=1
 REQUIRE_PACKAGES_LIBTAR=1
 REQUIRE_PACKAGES_FPMKUNIT=1
 endif
-ifeq ($(FULL_TARGET),riscv32-linux)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),riscv32-embedded)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),riscv64-linux)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),riscv64-embedded)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),xtensa-linux)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),xtensa-embedded)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),xtensa-freertos)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),z80-embedded)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),z80-zxspectrum)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),z80-msxdos)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
-ifeq ($(FULL_TARGET),z80-amstradcpc)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-PROCESS=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_LIBTAR=1
-REQUIRE_PACKAGES_FPMKUNIT=1
-endif
 ifdef REQUIRE_PACKAGES_RTL
 PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR))))))
 ifneq ($(PACKAGEDIR_RTL),)
@@ -2216,9 +1963,9 @@ endif
 ifndef CROSSBOOTSTRAP
 ifneq ($(BINUTILSPREFIX),)
 override FPCOPT+=-XP$(BINUTILSPREFIX)
-ifneq ($(RLINKPATH),)
-override FPCOPT+=-Xr$(RLINKPATH)
 endif
+ifneq ($(BINUTILSPREFIX),)
+override FPCOPT+=-Xr$(RLINKPATH)
 endif
 endif
 ifndef CROSSCOMPILE
@@ -2302,40 +2049,16 @@ override COMPILER_UNITTARGETDIR=$(COMPILER_TARGETDIR)
 override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX)
 endif
 endif
-ifdef SYSROOTPATH
-override FPCOPT+=-XR$(SYSROOTPATH)
-else
-ifeq ($(OS_TARGET),$(OS_SOURCE))
-ifneq ($(findstring $(OS_TARGET),darwin),)
-ifneq ($(findstring $(CPU_TARGET),aarch64),)
-ifneq ($(wildcard /Library/Developer/CommandLineTools/SDKs/MacOSX.sdk),)
-override FPCOPT+=-XR/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk
-endif
-endif
-endif
-endif
-endif
 ifdef CREATESHARED
 override FPCOPT+=-Cg
 endif
 ifneq ($(findstring $(OS_TARGET),dragonfly freebsd openbsd netbsd linux solaris),)
-ifneq ($(findstring $(CPU_TARGET),x86_64 mips mipsel riscv64),)
+ifneq ($(findstring $(CPU_TARGET),x86_64 mips mipsel),)
 override FPCOPT+=-Cg
 endif
 endif
 ifdef LINKSHARED
 endif
-ifdef GCCLIBDIR
-override FPCOPT+=-Fl$(GCCLIBDIR)
-ifdef FPCMAKEGCCLIBDIR
-override FPCMAKEOPT+=-Fl$(FPCMAKEGCCLIBDIR)
-else
-override FPCMAKEOPT+=-Fl$(GCCLIBDIR)
-endif
-endif
-ifdef OTHERLIBDIR
-override FPCOPT+=$(addprefix -Fl,$(OTHERLIBDIR))
-endif
 ifdef OPT
 override FPCOPT+=$(OPT)
 endif
@@ -2392,15 +2115,13 @@ override INSTALLPPUFILES:=$(filter-out $(INSTALL_BUILDUNIT)$(PPUEXT),$(INSTALLPP
 endif
 ifdef INSTALLPPUFILES
 ifneq ($(IMPORTLIBPREFIX)-$(STATICLIBEXT),$(STATICLIBPREFIX)-$(STATICLIBEXT))
-override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(subst $(PPUEXT),$(LTOEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))) $(addprefix $(IMPORTLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))
+override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))) $(addprefix $(IMPORTLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))
 else
-override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(subst $(PPUEXT),$(LTOEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))
+override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))
 endif
 ifneq ($(UNITTARGETDIRPREFIX),)
-override INSTALLPPUFILENAMES:=$(notdir $(INSTALLPPUFILES))
-override INSTALLPPULINKFILENAMES:=$(notdir $(INSTALLPPULINKFILES))
-override INSTALLPPUFILES=$(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPUFILENAMES))
-override INSTALLPPULINKFILES=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPULINKFILENAMES)))
+override INSTALLPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(notdir $(INSTALLPPUFILES)))
+override INSTALLPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(notdir $(INSTALLPPULINKFILES))))
 endif
 override INSTALL_CREATEPACKAGEFPC=1
 endif
@@ -2555,14 +2276,12 @@ ifdef CLEAN_UNITS
 override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(CLEAN_UNITS))
 endif
 ifdef CLEANPPUFILES
-override CLEANPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(subst $(PPUEXT),$(LTOEXT),$(CLEANPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))) $(addprefix $(IMPORTLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES)))
+override CLEANPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))) $(addprefix $(IMPORTLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES)))
 ifdef DEBUGSYMEXT
 override CLEANPPULINKFILES+=$(subst $(PPUEXT),$(DEBUGSYMEXT),$(CLEANPPUFILES))
 endif
-override CLEANPPUFILENAMES:=$(CLEANPPUFILES)
-override CLEANPPUFILES=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILENAMES))
-override CLEANPPULINKFILENAMES:=$(CLEANPPULINKFILES)
-override CLEANPPULINKFILES=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILENAMES)))
+override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES))
+override CLEANPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES)))
 endif
 fpc_clean: $(CLEANTARGET)
 ifdef CLEANEXEFILES
@@ -2586,9 +2305,8 @@ endif
 ifdef LIB_NAME
 	-$(DEL) $(LIB_NAME) $(LIB_FULLNAME)
 endif
-	-$(DEL) $(FPCMADE) *$(FULL_TARGET).fpm Package.fpc *$(ASMEXT)
-	-$(DEL) $(FPCEXTFILE) $(REDIRFILE) script*.res link*.res *_script.res *_link.res
-	-$(DEL) $(PPAS) *_ppas$(BATCHEXT) ppas$(BATCHEXT) ppaslink$(BATCHEXT)
+	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
+	-$(DEL) *$(ASMEXT) *_ppas$(BATCHEXT) ppas$(BATCHEXT) ppaslink$(BATCHEXT)
 fpc_cleanall: $(CLEANTARGET)
 ifdef CLEANEXEFILES
 	-$(DEL) $(CLEANEXEFILES)
@@ -2609,14 +2327,13 @@ ifdef CLEAN_FILES
 endif
 	-$(DELTREE) units
 	-$(DELTREE) bin
-	-$(DEL) *$(OEXT) *$(LTOEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
 ifneq ($(PPUEXT),.ppu)
 	-$(DEL) *.o *.ppu *.a
 endif
 	-$(DELTREE) *$(SMARTEXT)
-	-$(DEL) fpcmade.* Package.fpc *.fpm
-	-$(DEL) $(FPCEXTFILE) $(REDIRFILE) script*.res link*.res *_script.res *_link.res
-	-$(DEL) $(PPAS) *_ppas$(BATCHEXT) ppas$(BATCHEXT) ppaslink$(BATCHEXT)
+	-$(DEL) fpcmade.* Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
+	-$(DEL) *_ppas$(BATCHEXT) ppas$(BATCHEXT) ppaslink$(BATCHEXT)
 ifdef AOUTEXT
 	-$(DEL) *$(AOUTEXT)
 endif

packages/fcl-web/examples/websocket/README.md

@@ -0,0 +1,41 @@
+# Websocket examples
+
+This directory contains the examples for the websockets functionality of
+FCL-Web
+
+## server
+
+Small standalone chat server. It accepts JSON messages and uses from/to/msg fields in
+the json objects to dispatch messages. If no to: is present, a message is
+distributed to all connected clients.
+
+## client
+A small command-line chat client to connect to the server.
+It will ask for a name, and then starts a loop in which you can enter
+one-line messages that will be sent to the server.
+
+## Upgrade
+A demonstration of the HTTP server "upgrade" mechanism; 
+This chat server not only acts as the server example, but also serves files on the same port.
+
+A sample client can also be found in the pas2js sources, which is a sample
+client program that works in the browser. (see the demo/websocket folder)
+
+## Running the examples
+All programs print help when invoked with the -h command-line parameter.
+
+To test the examples, run the server in a terminal window:
+
+```sh
+wsserver -p 8080
+```
+
+(will start listening on  port 8080)
+
+In another terminal, run
+
+```sh
+wsclient -u ws://localhost:8080/
+```
+
+You can run this program multiple times in different terminal windows.

packages/fcl-web/examples/websocket/client/wsclient.lpi

@@ -0,0 +1,55 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="Websocket Client Application"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <Units>
+      <Unit>
+        <Filename Value="wsclient.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="wsclient"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

packages/fcl-web/examples/websocket/client/wsclient.lpr

@@ -0,0 +1,338 @@
+program wsclient;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  cthreads,
+  {$ENDIF}
+  Classes, jsonparser, fpJSON,SysUtils, StrUtils, CustApp, uriparser, httpprotocol, fphttpclient;
+
+type
+
+  { TWebsocketClientApplication }
+
+  TWebsocketClientApplication = class(TCustomApplication)
+  private
+    FUri : TUri;
+    FLastRecipient : string;
+    FAlias : String;
+    FClient: TWebsocketClient;
+    FPump : TWSMessagePump;
+    FMsgCount : Integer;
+    FUsePump : Boolean;
+    procedure DoControl(Sender: TObject; aType: TFrameType; const aData: TBytes);
+    procedure DoDisconnect(Sender: TObject);
+    procedure DoIncomingMessage(Sender: TObject; const aMessage: TWSMessage);
+    function SendMessage(const aTo, aLine: string): Boolean;
+    procedure ShowHelp;
+  Protected
+    function AskAlias: String;
+    function CheckMessages: boolean;
+    function ConnectToServer: Boolean;
+    function GetCommandOrMessage: Boolean;
+    function ParseOptions: String;
+    function QueryUser(Prompt: String; aDefault: String): String;
+    procedure DoRun; override;
+  public
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Usage(const aError: string); virtual;
+  end;
+
+{ TWebsocketClientApplication }
+
+function TWebsocketClientApplication.ParseOptions : String;
+
+begin
+  if not HasOption('u','url') then
+    Exit('Need URL option');
+  FUri:=ParseURI(GetOptionValue('u','url'));
+  if IndexText(FURI.Protocol,['ws','wss'])<0 then
+    Exit('Invalid protocol in uri: need one of ws,wss');
+  if (FURI.Port=0) then
+    FURI.Port:=8080;
+  FAlias:=GetOptionValue('a','alias');
+  FUsePump:=HasOption('p','pump');
+end;
+
+Function TWebsocketClientApplication.QueryUser(Prompt : String; aDefault : String) : String;
+
+begin
+  if aDefault<>'' then
+    Prompt:=Prompt+' ['+aDefault+']';
+  Write(Prompt+'> ');
+  ReadLn(Result);
+  if Result='' then
+    Result:=aDefault;
+end;
+
+Function TWebsocketClientApplication.AskAlias : String;
+
+begin
+  Repeat
+    Result:=QueryUser('Please give your alias for the chat','');
+  Until (Result<>'');
+end;
+
+procedure TWebsocketClientApplication.DoRun;
+var
+  ErrorMsg: String;
+
+begin
+  // quick check parameters
+  ErrorMsg:=CheckOptions('hu:a:p', ['help','url','alias','pump']);
+  if (ErrorMsg='') and not HasOption('h', 'help') then
+    ErrorMsg:=ParseOptions;
+  if (ErrorMsg<>'') or HasOption('h', 'help') then
+    begin
+    Usage(ErrorMsg);
+    Terminate;
+    Exit;
+    end;
+  if FAlias='' then
+    FAlias:=AskAlias;
+  if ConnectToServer then
+    Writeln('Enter message or command (/stop /help), empty message will just check for incoming messages');
+  SendMessage(FAlias,'Hello, this is a friendly greeting message from the client');
+  CheckMessages;
+  While not Terminated do
+    begin
+    GetCommandOrMessage;
+    CheckMessages;
+    end;
+  Terminate;
+end;
+
+constructor TWebsocketClientApplication.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  StopOnException:=True;
+  FClient:=TWebsocketClient.Create(Self);
+  FClient.OnDisconnect:=@DoDisconnect;
+  FClient.OnMessageReceived:=@DoIncomingMessage;
+  FClient.OnControl:=@DoControl;
+end;
+
+destructor TWebsocketClientApplication.Destroy;
+begin
+  FreeAndNil(FClient);
+  inherited Destroy;
+end;
+
+procedure TWebsocketClientApplication.Usage(const aError : string);
+begin
+  { add your help code here }
+  writeln('Usage: ', ExeName, ' [options]');
+  Writeln('where options is one or more of:');
+  Writeln('-h  --help             this help text');
+  Writeln('-u --url=URL           the URL to connect to. Mandatory');
+  Writeln('-a --alias=nick        your nick name in the chat');
+  Writeln('-p --pump              use message pump');
+  ExitCode:=Ord(aError<>'');
+end;
+
+Function TWebsocketClientApplication.ConnectToServer : Boolean;
+
+Var
+  Res : string;
+
+begin
+  FClient.HostName:=FURI.Host;
+  FClient.Port:=FURI.Port;
+  Res:=FURI.Path;
+  if (FURI.Document<>'') then
+    Res:=IncludeHTTPPathDelimiter(Res)+FURI.Document;
+  FClient.Resource:=Res;
+  if FUsePump then
+    begin
+    FPump:=TWSThreadMessagePump.Create(Self);
+    FPump.Interval:=50;
+    FClient.MessagePump:=FPump;
+    FPump.Execute;
+    end;
+  try
+    FClient.Connect;
+    Result:=True;
+  except
+    on E : Exception do
+      begin
+      ShowException(E);
+      terminate;
+      end;
+  end;
+end;
+
+Procedure TWebsocketClientApplication.ShowHelp;
+
+begin
+  Writeln('Enter a command or a message text. Commands start with / and can be one of:');
+  Writeln('/help  - this text');
+  Writeln('/quit  - stop the program.');
+  Writeln('/stop  - stop the program.');
+  Writeln('/ping [ping text] - send a ping.');
+  Writeln('/pong [pong text] - send a pong.');
+end;
+
+Function TWebsocketClientApplication.GetCommandOrMessage : Boolean;
+
+Var
+  aCmd,aLine,aTo : String;
+
+begin
+  aLine:=QueryUser(FAlias,'');
+  Result:=aLine<>'';
+  if not Result then
+    exit;
+  if Copy(aLine,1,1)='/' then
+    begin
+    aCmd:=ExtractWord(1,aLine,[' ']);
+    System.Delete(aLine,1,length(aCmd)+1);
+    aCmd:=Copy(aCmd,2,Length(aCmd)-1);
+    case lowercase(aCmd) of
+      'quit',
+      'stop' :
+        begin
+        Result:=False;
+        Terminate;
+        end;
+      'help':
+        begin
+        Result:=False;
+        ShowHelp;
+        end;
+      'ping':
+        begin
+        FClient.Ping(aLine);
+        end;
+      'pong':
+        begin
+        FClient.Pong(aLine);
+        end;
+    end
+    end
+  else if (aLine<>'') then
+    begin
+    aTo:=QueryUser('Recipient',FLastRecipient);
+    if (aTo<>'*') and (aTo<>'') then
+      FLastRecipient:=aTo;
+    if aTo='*' then
+      aTo:='';
+    SendMessage(aTo,aLine)
+    end;
+end;
+
+Function TWebsocketClientApplication.SendMessage(const aTo,aLine : string) : Boolean;
+
+Var
+  aJSON : TJSONObject;
+  Msg : String;
+
+begin
+  Result:=False;
+  aJSON:=TJSONObject.Create(['from',FAlias,'msg',aLine,'to',aTo]);
+  try
+    Msg:=aJSON.asJSON;
+    try
+      FClient.SendMessage(msg);
+      Result:=True;
+    except
+      on E : Exception do
+        ShowException(E);
+    end;
+  finally
+    aJSON.Free;
+  end;
+end;
+
+procedure TWebsocketClientApplication.DoControl(Sender: TObject; aType: TFrameType; const aData: TBytes);
+
+var
+  aReason : String;
+  aCode : Integer;
+
+begin
+  inc(fMsgCount);
+  Case aType of
+  ftClose:
+    begin
+    aCode:=TWSConnection(Sender).GetCloseData(aData,aReason);
+    Writeln('Close code ',aCode,' received with readon: ',aReason);
+    end;
+  ftPing:
+    begin
+    Writeln('Ping received');
+    end;
+  ftPong:
+    begin
+    Writeln('Pong received');
+    end;
+  else
+    Writeln('Unknown control code: ',aType);
+  end;
+end;
+
+procedure TWebsocketClientApplication.DoDisconnect(Sender: TObject);
+begin
+  Writeln('Connection closed, terminating');
+  Terminate;
+end;
+
+procedure TWebsocketClientApplication.DoIncomingMessage(Sender: TObject; const aMessage: TWSMessage);
+Var
+  S,From,Recip : String;
+  D : TJSONData;
+  Msg : TJSONObject absolute D;
+
+begin
+  inc(fMsgCount);
+  if not aMessage.IsText then
+    begin
+    Writeln('Incoming message is not text');
+    exit;
+    end;
+  S:=aMessage.AsString;
+  try
+    D:=GetJSON(S);
+    try
+      if Not (D is TJSONOBject) then
+        Raise EJSON.Create('Not an object: '+S);
+      From:=Msg.Get('from','');
+      Recip:=Msg.Get('to','');
+      Write('From <',From,'>');
+      if SameText(Recip,FAlias) then
+        Writeln(' to you:')
+      else
+        Writeln(' to all:');
+      Writeln(Msg.Get('msg',''));
+    finally
+      FreeAndNil(D)
+    end;
+  except
+    Writeln('Incoming message is not valid JSON: ',S);
+  end;
+end;
+
+Function TWebsocketClientApplication.CheckMessages: boolean;
+
+begin
+  FMsgCount:=0;
+  if FUsePump then
+    CheckSynchronize()
+  else
+    while FClient.CheckIncoming=irOK do
+      ;
+
+  Result:=(FMsgCount>0);
+end;
+
+
+var
+  Application: TWebsocketClientApplication;
+begin
+  Application:=TWebsocketClientApplication.Create(nil);
+  Application.Title:='Websocket Client Application';
+  Application.Run;
+  Application.Free;
+end.
+

packages/fcl-web/examples/websocket/server/wsserver.lpi

@@ -0,0 +1,61 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="wsserver"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <Units>
+      <Unit>
+        <Filename Value="wsserver.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="../wschat.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="wsserver"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value=".."/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

packages/fcl-web/examples/websocket/server/wsserver.lpr

@@ -0,0 +1,87 @@
+program wsserver;
+
+uses
+  {$ifdef unix} cthreads, cwstring, {$endif}
+  custapp, sysutils, jsonparser, fpjson, syncobjs, classes,
+  fpwebsocket, fpwebsocketclient, fpwebsocketserver, fpcustwsserver, wschat;
+
+Type
+
+  { TWSApp }
+
+  TWSApp = class(TCustomApplication)
+  private
+    FSrv : TWebSocketServer;
+    FChat : TWebsocketChat;
+    procedure DoChatLog(Sender: TObject; const Msg: String);
+  Public
+    constructor create(aOwner : TComponent); override;
+    destructor destroy; override;
+    procedure DoRun; override;
+  end;
+
+{ TWSApp }
+
+procedure TWSApp.DoChatLog(Sender: TObject; const Msg: String);
+begin
+  Writeln(Msg);
+end;
+
+constructor TWSApp.create(aOwner: TComponent);
+begin
+  inherited create(aOwner);
+  FSrv:=TWebSocketServer.Create(Self);
+  FChat:=TWebsocketChat.Create(Self);
+  FChat.WebsocketServer:=FSrv;
+  FChat.OnLog:=@DoChatLog;
+  // Must do this here, because the events are protected
+  FSrv.OnMessageReceived:[email protected];
+  FSrv.OnControlReceived:[email protected];
+  FSrv.OnDisconnect:[email protected];
+end;
+
+destructor TWSApp.destroy;
+begin
+  FreeAndNil(FChat);
+  FreeAndNil(FSrv);
+  inherited destroy;
+end;
+
+
+procedure TWSApp.DoRun;
+
+
+begin
+  CheckOptions('p:t:ahw:i:m:',['port:','threadmode','accept-threaded','wait:','idle:','mask:']);
+  case GetOptionValue('t','threadmode') of
+    'pool'   : FSrv.ThreadMode:=wtmThreadPool;
+    'thread' : FSrv.ThreadMode:=wtmThread;
+    'none'   : FSrv.ThreadMode:=wtmNone;
+  else
+    FSrv.ThreadMode:=wtmThread;
+  end;
+  // Will not return till stopped.
+  FSrv.ThreadedAccept:=HasOption('a','accept-threaded');
+  if HasOption('w','wait') then
+    FSrv.MessageWaitTime:=StrToIntDef(GetOptionValue('w','wait'),DefaultWaitTime);
+  if HasOption('i','idle') then
+    FSrv.AcceptIdleTimeout:=StrToIntDef(GetOptionValue('i','idle'),DefaultAcceptTimeout);
+  FSrv.Active:=True;
+  FSrv.OutgoingFrameMask:=StrToIntDef(GetOptionValue('m','mask'),0);
+  if Not FSrv.ThreadedAccept then
+    Terminate
+  else
+    While Not Terminated do
+      Sleep(10)
+end;
+
+begin
+  With TWSApp.Create(Nil) do
+    try
+      Initialize;
+      Run;
+    finally
+      Free;
+    end;
+end.
+

packages/fcl-web/examples/websocket/upgrade/httpupgrader.lpi

@@ -0,0 +1,60 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="HTTP upgrade Application"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <Units>
+      <Unit>
+        <Filename Value="httpupgrader.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="../wschat.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="httpupgrader"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value=".."/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

packages/fcl-web/examples/websocket/upgrade/httpupgrader.lpr

@@ -0,0 +1,132 @@
+program httpupgrader;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  cthreads,
+  {$ENDIF}
+  Classes, SysUtils, CustApp, jsonparser,fpmimetypes, fphttpserver, fpwebfile, httproute, wschat, wsupgrader, fpwebsocket, fpcustwsserver;
+
+type
+
+  { THTTPUpgradeApplication }
+
+  THTTPUpgradeApplication = class(TCustomApplication)
+  private
+    procedure DoChatLog(Sender: TObject; const Msg: String);
+    procedure DoRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest; var AResponse: TFPHTTPConnectionResponse);
+  protected
+    FServer : TFPHttpServer;
+    FUpgrader : TWebsocketUpgrader;
+    FChat: TWebsocketChat;
+    procedure DoRun; override;
+
+  public
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Usage(Msg : string); virtual;
+  end;
+
+{ THTTPUpgradeApplication }
+
+procedure THTTPUpgradeApplication.DoChatLog(Sender: TObject; const Msg: String);
+begin
+  Writeln(Msg);
+end;
+
+procedure THTTPUpgradeApplication.DoRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest;
+  var AResponse: TFPHTTPConnectionResponse);
+begin
+  HTTPRouter.RouteRequest(aRequest,aResponse);
+end;
+
+procedure THTTPUpgradeApplication.DoRun;
+var
+  ErrorMsg: String;
+begin
+  // quick check parameters
+  ErrorMsg:=CheckOptions('hH:d:p:r:st:', ['help','host:','directory:','port:','resource:','ssl','thread:']);
+  if (ErrorMsg<>'') or HasOption('h', 'help') then
+    begin
+    Usage(ErrorMsg);
+    Terminate;
+    Exit;
+    end;
+  TSimpleFileModule.BaseDir:=GetOptionValue('d','directory');
+  TSimpleFileModule.IndexPageName:='index.html';
+  TSimpleFileModule.RegisterDefaultRoute;
+  MimeTypes.LoadKnownTypes;
+  FServer.UseSSL:=Hasoption('s','ssl');
+  FServer.Port:=StrToIntDef(GetOptionValue('p','port'),3030);
+  FUpgrader.Host:=GetOptionValue('H','host');
+  FUpgrader.Resource:=GetOptionValue('r','resource');
+  Case LowerCase(getOptionValue('t','thread')) of
+    'none' :
+       begin
+       FServer.ThreadMode:=tmNone;
+       FUpgrader.ThreadMode:=wtmNone;
+       end;
+    'pool' :
+       begin
+       FServer.ThreadMode:=tmThreadPool;
+       FUpgrader.ThreadMode:=wtmThreadPool;
+       end;
+  else
+    FServer.ThreadMode:=tmThread;
+    FUpgrader.ThreadMode:=wtmThread;
+  end;
+  FUpgrader.Active:=True;
+  FServer.Active:=True;
+  Terminate;
+end;
+
+constructor THTTPUpgradeApplication.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  StopOnException:=True;
+  FServer:=TFPHttpServer.Create(Self);
+  FServer.OnRequest:=@DoRequest;
+  FUpgrader:=TWebsocketUpgrader.Create(Self);
+  FUpgrader.WebServer:=FServer;
+  FUpgrader.name:='UWebSocket';
+  FChat:=TWebsocketChat.Create(Self);
+  FChat.WebsocketServer:=FUpgrader;
+  FChat.OnLog:=@DoChatLog;
+  // Must do this here, because the events are protected
+  FUpgrader.OnMessageReceived:[email protected];
+  FUpgrader.OnControlReceived:[email protected];
+  FUpgrader.OnDisconnect:[email protected];
+end;
+
+destructor THTTPUpgradeApplication.Destroy;
+begin
+  FreeAndNil(FUpgrader);
+  FreeAndNil(FServer);
+  inherited Destroy;
+end;
+
+procedure THTTPUpgradeApplication.Usage(Msg: string);
+begin
+  if Msg<>'' then
+    Writeln('Error: ',Msg);
+  Writeln('Usage: ', ExeName, ' [options]');
+  Writeln('Where [options] is one or more of:');
+  Writeln('-d --directory=DIRECTORY  Directory to serve files from');
+  Writeln('-h --help                 This message');
+  Writeln('-H --host=HOST            The hostname to use for accepting websockets.');
+  Writeln('-p --port=PORT            Port nr to listen on');
+  Writeln('-r --resource=PATH        Resource to use for accepting websockets');
+  Writeln('-s --ssl                  Use SSL');
+  Writeln('-t --thread=MODEL         Threading model to use (one of: none,thread,pool)');
+end;
+
+var
+  Application: THTTPUpgradeApplication;
+begin
+  Application:=THTTPUpgradeApplication.Create(nil);
+  Application.Title:='HTTP Server & Websocket chat Application';
+  Application.Run;
+  Application.Free;
+end.
+

packages/fcl-web/examples/websocket/wschat.pp

@@ -0,0 +1,226 @@
+{
+    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2021 - by the Free Pascal development team
+
+    Simple websocket chat server implementation
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit wschat;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpcustwsserver, fpwebsocket, syncobjs, fpjson;
+
+Type
+
+  { TWebsocketChat }
+  TChatLogEvent = procedure (Sender : TObject; Const Msg : String) of object;
+
+  TWebsocketChat = Class(TComponent)
+  Private
+    FLock : TCriticalSection;
+    FMap : TStringList;
+    FOnLog: TChatLogEvent;
+    FSrv: TCustomWSServer;
+    procedure SetServer(AValue: TCustomWSServer);
+  Protected
+    Procedure DoLog(Const Msg : String); overload;
+    Procedure DoLog(Const Fmt : String; Args : Array of const); overload;
+    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    function GetConnectionFromUser(aFrom: String): TWSConnection; virtual;
+    procedure MapConnection(aFrom: String; aConn: TWSConnection); virtual;
+  Public
+    Constructor Create(aOwner : TComponent); override;
+    Destructor Destroy; override;
+    procedure DoControlReceived(Sender: TObject; aType: TFrameType; const aData: TBytes); virtual;
+    procedure DoDisconnect(Sender: TObject); virtual;
+    procedure DoMessageReceived(Sender: TObject; const aMessage: TWSMessage); virtual;
+    Property WebsocketServer : TCustomWSServer Read FSrv Write SetServer;
+    Property OnLog : TChatLogEvent Read FOnLog Write FOnLog;
+  end;
+
+implementation
+
+Constructor TWebsocketChat.Create(aOwner : TComponent);
+
+begin
+  Inherited;
+  FMap:=TStringList.Create;
+  FLock:=TCriticalSection.Create;
+end;
+
+destructor TWebsocketChat.Destroy;
+begin
+  FreeAndNil(FLock);
+  FreeAndNil(FMap);
+  inherited Destroy;
+end;
+
+procedure TWebsocketChat.DoMessageReceived(Sender: TObject; const aMessage: TWSMessage);
+
+Var
+  S,From,Recip : String;
+  D : TJSONData;
+  Msg : TJSONObject absolute D;
+  SenderConn,RecipConn : TWSConnection;
+
+begin
+  SenderConn:=Sender as TWSConnection;
+  RecipConn:=Nil;
+  S:=aMessage.AsString;
+  DoLog('Received message: '+S);
+  try
+    D:=GetJSON(S);
+    try
+      if Not (D is TJSONOBject) then
+        Raise EJSON.Create('Not an object: '+S);
+      From:=Msg.Get('from','');
+      if From<>'' then
+        MapConnection(From,SenderConn);
+      Recip:=Msg.Get('to','');
+    finally
+      FreeAndNil(D)
+    end;
+  except
+    DoLog('Message is not JSON, echoing as JSON');
+    S:='{ "msg": "You sent: '+StringReplace(S,'"','\"',[rfReplaceAll])+'" }';
+    RecipConn:=SenderConn;
+  end;
+  if (Recip<>'') then
+    begin
+    RecipConn:=GetConnectionFromUser(Recip);
+    if RecipConn=Nil then
+      exit;
+    end;
+  if Assigned(RecipConn) then
+    RecipConn.Send(S)
+  else
+    FSRv.BroadcastMessage(S);
+end;
+
+procedure TWebsocketChat.DoControlReceived(Sender: TObject; aType: TFrameType; const aData: TBytes);
+
+Var
+  aReason : String;
+  aCode : Integer;
+
+begin
+  Case aType of
+  ftClose:
+    begin
+    aCode:=TWSConnection(Sender).GetCloseData(aData,aReason);
+    DoLog('Close code %d received with reason: %s',[aCode,aReason]);
+    end;
+  ftPing:
+    begin
+    DoLog('Ping received');
+    end;
+  ftPong:
+    begin
+    DoLog('Pong received');
+    end;
+  else
+    DoLog('Unknown control code: %d',[Ord(aType)]);
+  end;
+end;
+
+procedure TWebsocketChat.DoDisconnect(Sender: TObject);
+
+Var
+  Conn : TWSConnection;
+  Found : Boolean;
+  I : Integer;
+  aID,N,V : String;
+
+
+begin
+  Conn:=(Sender as TWSConnection);
+  aID:=Conn.ConnectionID;
+  DoLog('Connection '+aID+' disappeared');
+  FLock.Enter;
+  try
+    Found:=False;
+    I:=FMap.Count-1;
+    While (I>=0) and not Found do
+      begin
+      FMap.GetNameValue(I,N,V);
+      Found:=SameText(V,aID);
+      if Found then
+        FMap.Delete(I);
+      Dec(I);
+      end;
+  finally
+    Flock.Leave;
+  end;
+end;
+
+Function TWebsocketChat.GetConnectionFromUser(aFrom : String): TWSConnection;
+
+Var
+  aID : String;
+
+begin
+  FLock.Enter;
+  try
+    aID:=FMap.Values[aFrom];
+  finally
+    FLock.Leave;
+  end;
+  Result:=FSrv.Connections.FindConnectionById(aID);
+end;
+
+procedure TWebsocketChat.MapConnection(aFrom : String; aConn : TWSConnection);
+
+begin
+  // We could also store the connection object directly in the objects array,
+  // but this way we demonstrate the ConnectionID and FindConnectionByID
+  Flock.Enter;
+  try
+    FMap.Values[aFrom]:=aConn.ConnectionID;
+  finally
+    FLock.Leave;
+  end;
+end;
+
+procedure TWebsocketChat.SetServer(AValue: TCustomWSServer);
+begin
+  if FSrv=AValue then Exit;
+  if Assigned(FSRV) then
+    FSRV.RemoveFreeNotification(Self);
+  FSrv:=AValue;
+  if Assigned(FSRV) then
+    FSRV.FreeNotification(Self);
+end;
+
+procedure TWebsocketChat.DoLog(const Msg: String);
+begin
+  If Assigned(FonLog) then
+    FOnLog(Self,Msg);
+end;
+
+procedure TWebsocketChat.DoLog(const Fmt: String; Args: array of const);
+begin
+  DoLog(Format(Fmt,Args));
+end;
+
+procedure TWebsocketChat.Notification(AComponent: TComponent; Operation: TOperation);
+begin
+  inherited Notification(AComponent, Operation);
+  if (Operation=opRemove) and (aComponent=FSrv) then
+    FSrv:=Nil;
+end;
+
+
+end.
+

packages/fcl-web/fpmake.pp

@@ -53,6 +53,7 @@ begin
     P.SourcePath.Add('src/jsonrpc');
     P.SourcePath.Add('src/hpack');
     P.SourcePath.Add('src/restbridge');
+    P.SourcePath.Add('src/websocket');
     T:=P.Targets.addUnit('fpmimetypes.pp');
 
     T:=P.Targets.AddUnit('httpdefs.pp');
@@ -427,6 +428,30 @@ begin
       AddUnit('sqldbrestbridge');
       AddUnit('sqldbrestconst');
       end;
+    T:=P.Targets.AddUnit('fpwebsocket.pp');
+    T.Resourcestrings:=True;
+    T:=P.Targets.AddUnit('fpcustwsserver.pp');
+    With T.Dependencies do  
+      begin
+      AddUnit('fpwebsocket');
+      end;
+    T:=P.Targets.AddUnit('fpwebsocketserver.pp');
+    With T.Dependencies do  
+      begin
+      AddUnit('fpwebsocket');
+      AddUnit('fpcustwsserver');
+      end;
+    T:=P.Targets.AddUnit('fpwebsocketclient.pp');
+    With T.Dependencies do  
+      begin
+      AddUnit('fpwebsocket');
+      end;
+    T:=P.Targets.AddUnit('wsupgrader.pp');
+    With T.Dependencies do  
+      begin
+      AddUnit('fpwebsocket');
+      AddUnit('fpcustwsserver');
+      end;
     end;
 end;
     

packages/fcl-web/src/websocket/fpcustwsserver.pp

@@ -0,0 +1,840 @@
+{
+    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2021 - by the Free Pascal development team
+
+    Abstract websocket server implementation
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit fpcustwsserver;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, ssockets, fpthreadpool, fpwebsocket;
+
+Const
+  DefaultAcceptTimeout = 50;
+  DefaultWaitTime = 0;
+
+
+Type
+  TCustomWSServer = Class;
+  EWebsocketServer = Class(EWebsocket);
+
+  TWSSendToFilter = Procedure (AConnection: TWSServerConnection; var aAllow : Boolean) of object;
+  TWSAllowConnectionEvent = procedure(Sender: TObject; AConnection: TWSServerConnection; Var aAllow : Boolean) of object;
+  TWSConnectEvent = procedure(Sender: TObject; AConnection: TWSServerConnection) of object;
+  TWSGetSocketHandlerEvent = Procedure (Sender : TObject; Const UseSSL : Boolean; Out AHandler : TSocketHandler) of object;
+  TWSSocketHandlerCreatedEvent = Procedure (Sender : TObject; AHandler : TSocketHandler) of object;
+  TConnectionIterator = Procedure (aConnection : TWSServerConnection; var aContinue : boolean) of object;
+  TWSErrorEvent = Procedure(Sender : TObject; aConnection : TWSServerConnection; aError : Exception) of object;
+
+  { TWSConnectionList }
+
+  TWSConnectionList = Class(TThreadList)
+    Function ForEach(aIterator : TConnectionIterator) : Boolean;
+    Function FindConnectionById(aID : String) : TWSConnection;
+  end;
+
+
+  TWSThreadMode = (wtmNone,wtmThread,wtmThreadPool);
+
+  { TWSServerConnectionHandler }
+
+  TWSServerConnectionHandler = Class(TObject)
+  Private
+    FServer : TCustomWSServer;
+    FWaitTime: Integer;
+    function GetList: TWSConnectionList;
+  Protected
+    Type
+      TErrorHandler = Procedure (aConnection : TWSServerConnection; E : Exception) of object;
+    // Default handler for iterator which checks & reads 1 incoming message
+    procedure DoCheckConnectionRequests(aConnection: TWSServerConnection; var aContinue: boolean); virtual;
+    // Will pass on to the server
+    Procedure RemoveConnection(aConnection : TWSServerConnection); virtual;
+    // Will pass on exception and connection to the server
+    Procedure HandleError(aConnection : TWSServerConnection; E : Exception);
+  Public
+    Constructor Create(aServer : TCustomWSServer); virtual;
+    Destructor Destroy; override;
+    // loop over all connections, calling aIterator
+    Procedure Foreach(aIterator : TConnectionIterator);
+    // Close all connections
+    Procedure CloseConnections; virtual;
+    // Check for requests, and handle them.
+    Procedure CheckIncomingMessages; virtual;
+    // New connection
+    Procedure HandleConnection(aConnection : TWSServerConnection; DoHandshake : Boolean); virtual; abstract;
+    // Our server
+    Property Server : TCustomWSServer Read FServer;
+    // Shortcut to server list of connections
+    Property List : TWSConnectionList Read GetList;
+    // Time (in milliseconds) to wait for incoming connection requests
+    Property WaitTime : Integer Read FWaitTime Write FWaitTime;
+  end;
+
+
+  { TWSSimpleConnectionHandler }
+
+  TWSSimpleConnectionHandler = Class(TWSServerConnectionHandler)
+  private
+  Public
+    Procedure HandleConnection(aConnection : TWSServerConnection; DoHandshake : Boolean); override;
+  end;
+
+
+  { TWSThreadedConnectionHandler }
+
+  TWSThreadedConnectionHandler = Class(TWSServerConnectionHandler)
+  private
+    procedure ConnectionDone(Sender: TObject);
+  public
+    Type
+        { TWSConnectionThread }
+      TWSConnectionThread = Class(TThread)
+      private
+        FConnection: TWSServerConnection;
+        FOnDone : TNotifyEvent;
+        FDoHandshake : Boolean;
+      Public
+        Constructor CreateConnection(AConnection : TWSServerConnection; aOnConnectionDone : TNotifyEvent; DoHandShake : Boolean); virtual;
+        Procedure Execute; override;
+        Property Connection : TWSServerConnection Read FConnection;
+      end;
+  Public
+    procedure CheckIncomingMessages; override;
+    Procedure HandleConnection(aConnection : TWSServerConnection; DoHandshake : Boolean); override;
+  end;
+
+  { TWSPooledConnectionHandler }
+
+  TWSPooledConnectionHandler = Class(TWSServerConnectionHandler)
+  Private
+    FPool : TFPCustomSimpleThreadPool;
+    FBusy : TThreadList;
+  Protected
+    Type
+       { THandleRequestTask }
+       THandleRequestTask = Class(TThreadPoolTask)
+       private
+         FConnection: TWSServerConnection;
+         FDoHandshake : Boolean;
+       Protected
+         procedure DoExecute; override;
+       Public
+         Constructor Create(aConnection : TWSServerConnection; aOnConnectionDone : TNotifyEvent; aOnError : TErrorHandler; aDoHandshake : Boolean);
+         Property Connection : TWSServerConnection Read FConnection;
+       end;
+    function IsBusy(aConnection: TWSServerConnection): Boolean;
+    procedure ConnectionDone(Sender: TObject); virtual;
+    procedure ScheduleRequest(aConnection: TWSServerConnection; DoHandShake : Boolean);virtual;
+    procedure CheckRequest(aConnection: TWSServerConnection; var aContinue : Boolean);virtual;
+  Public
+    Procedure CloseConnections; override;
+    procedure CheckIncomingMessages; override;
+    Constructor Create(aServer : TCustomWSServer); override;
+    Procedure HandleConnection(aConnection : TWSServerConnection; DoHandshake : Boolean); override;
+    function CreatePool : TFPCustomSimpleThreadPool;
+    Property Pool : TFPCustomSimpleThreadPool Read FPool;
+  end;
+
+  { TCustomWSServer }
+
+  TCustomWSServer = class(TComponent)
+  private
+    FConnections: TWSConnectionList;
+    FMessageWaitTime: Cardinal;
+    FOnConnect: TWSConnectEvent;
+    FOnError: TWSErrorEvent;
+    FOnMessageReceived: TWSMessageEvent;
+    FOnControl : TWSControlEvent;
+    FOnDisconnect: TNotifyEvent;
+    FOptions: TWSOptions;
+    FOutgoingFrameMask: Integer;
+    FWebSocketVersion: Integer;
+    FOnAllow: TWSAllowConnectionEvent;
+    FResource: string;
+    FConnectionHandler : TWSServerConnectionHandler;
+    FThreadMode: TWSThreadmode;
+    FOnConnectionHandshake: TWSConnectionHandshakeEvent;
+    function GetActiveConnectionCount: Integer;
+    procedure SetOptions(const Value: TWSOptions);
+    procedure SetResource(AValue: string);
+  protected
+    // Virtual so it can be overriden;
+    procedure SetThreadMode(AValue: TWSThreadMode); virtual;
+    // Called when a connection is disconnected
+    Procedure DoDisconnect(Sender : TObject);  virtual;
+    // Free connection handler
+    Procedure FreeConnectionHandler; virtual;
+    // Create connection handler if it is not set yet
+    procedure StartConnectionHandler; virtual;
+    // Handle error
+    procedure HandleError(aConnection : TWSServerConnection; E : Exception); virtual;
+    // Disconnect connection when asked, remove from list, free connection
+    procedure RemoveConnection(AConnection: TWSServerConnection; aDoDisconnect: Boolean); virtual;
+    // Close connection socket
+    Procedure CloseConnectionSocket(aConnection :TWSServerConnection; var aContinue : boolean); virtual;
+    Procedure CheckInactive;
+    // Must be implemented by descendents
+    procedure SetActive(const Value: Boolean); virtual;
+    function GetActive: Boolean; virtual;
+    Function CreateConnectionHandler : TWSServerConnectionHandler; virtual;
+    // Allow-all TWSSendToFilter
+    procedure DoAllowAll(aConnection: TWSServerConnection; var aAllow: Boolean);
+    // Create connection list
+    function CreateConnections: TWSConnectionList; virtual;
+    // Create TWSServerConnection based on incoming socket stream
+    function CreateWebsocketConnection(aStream : TSocketStream; aOptions: TWSOptions): TWSServerConnection; virtual;
+    // Allow the connection ?
+    function AllowConnection(AConnection: TWSServerConnection) : Boolean; virtual;
+    // Event handlers for messages : Call OnMessageReceived
+    procedure DoMessageReceived(Sender: TObject; const aMessage : TWSMessage); virtual;
+    // Event handlers for control frames : Call OnControlReceived
+    Procedure DoControlReceived(Sender: TObject; aType : TFrameType; const aData: TBytes);virtual;
+    // Wait for connections to close
+    function WaitForConnections(aMaxAttempts : Integer = 10) : Boolean; virtual;
+    // Active or not ?
+    Property Active : Boolean Read GetActive Write SetActive;
+    // Read only access to connection handler
+    property ConnectionHandler : TWSServerConnectionHandler Read FConnectionHandler;
+  public
+    constructor Create(AOwner: TComponent); overload; override;
+    destructor Destroy; override;
+    // Broadcast text data to all connections
+    procedure BroadcastFrame(aFrame : TWSFrame); virtual;
+    // Broadcast text data to all connections
+    procedure BroadcastMessage(AMessage: string); virtual;
+    // Broadcast binary data to all connections
+    procedure BroadcastData(AData: TBytes); virtual;
+    // Send frame to connections, calling aSelector to see whether frame must be sent to a particular connection
+    procedure SendFrameTo(aFrame : TWSFrame; aSelector : TWSSendToFilter); virtual;
+    // Send message to connections, calling aSelector to see whether data must be sent to a particular connection
+    procedure SendMessageTo(AMessage: string; aSelector : TWSSendToFilter); virtual;
+    // Send binary data to connections, calling aSelector to see whether data must be sent to a particular connection
+    procedure SendDataTo(AData: TBytes; aSelector : TWSSendToFilter); virtual;
+    // Do something for all connections. Stop when iterator indicates to stop
+    Procedure Foreach(aIterator : TConnectionIterator);
+    // Connection list
+    property Connections: TWSConnectionList read FConnections;
+    // Count of connections
+    property ConnectionCount : Integer Read GetActiveConnectionCount;
+  protected
+    // Websocket version to use
+    Property WebSocketVersion : Integer Read FWebSocketVersion Write FWebSocketVersion Default DefaultWebSocketVersion;
+    // Wait time when checking for new messages
+    Property MessageWaitTime : Cardinal Read FMessageWaitTime Write FMessageWaitTime;
+    // Options regarding WebSocket Protocol
+    Property Options : TWSOptions Read FOptions Write SetOptions;
+    // Resource: when set, the request must match this.
+    Property Resource : string Read FResource Write SetResource;
+    // Thread mode
+    Property ThreadMode : TWSThreadMode Read FThreadMode write SetThreadMode;
+    // Called when a new connection is made.
+    property OnConnect: TWSConnectEvent read FOnConnect write FOnConnect;
+    // Called when handshake was received, use this to disallow connection
+    Property OnAllow : TWSAllowConnectionEvent Read FOnAllow Write FOnAllow;
+    // Called when a text message is received.
+    property OnMessageReceived: TWSMessageEvent read FOnMessageReceived write FOnMessageReceived;
+    // Called when a connection is disconnected. Sender is TWSServerConnection
+    property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
+    // Called when a control message is received.
+    property OnControlReceived: TWSControlEvent read FOnControl write FOnControl;
+    // Called when a websocket handshake is performed; use this to tune the response headers.
+    Property OnConnectionHandshake : TWSConnectionHandshakeEvent Read FOnConnectionHandshake Write FOnConnectionHandshake;
+    // Called when unhandled exceptions occur
+    Property OnError : TWSErrorEvent Read FOnError Write FOnError;
+    // Mask to use when sending frames. Set to nonzero value to send masked frames.
+    Property OutgoingFrameMask : Integer Read FOutgoingFrameMask Write FOutgoingFrameMask;
+  end;
+
+implementation
+
+{ TWSConnectionList }
+
+function TWSConnectionList.ForEach(aIterator: TConnectionIterator): Boolean;
+Var
+  L : TList;
+  I : Integer;
+
+begin
+  Result:=True;
+  L:=LockList;
+  try
+    I:=0;
+    While Result and (I<L.Count) do
+      begin
+      aIterator(TWSServerConnection(L[i]),Result);
+      Inc(I);
+      end;
+  finally
+    UnlockList;
+  end;
+end;
+
+function TWSConnectionList.FindConnectionById(aID: String): TWSConnection;
+Var
+  L : TList;
+  I : Integer;
+
+begin
+  Result:=Nil;
+  L:=LockList;
+  try
+    I:=0;
+    While (Result=Nil) and (I<L.Count) do
+      begin
+      Result:=TWSServerConnection(L[I]);
+      if Result.ConnectionID<>aID then
+        Result:=Nil;
+      Inc(I);
+      end;
+  finally
+    UnlockList;
+  end;
+end;
+
+{ TCustomWSServer }
+
+procedure TCustomWSServer.DoMessageReceived(Sender: TObject; const aMessage: TWSMessage);
+begin
+  if Assigned(OnMessageReceived) and (TWSConnection(Sender).HandshakeCompleted) then
+    OnMessageReceived(Sender, AMessage);
+end;
+
+procedure TCustomWSServer.DoControlReceived(Sender: TObject; aType: TFrameType; const aData: TBytes);
+begin
+  if Assigned(OnControlReceived) and (TWSConnection(Sender).HandshakeCompleted) then
+    OnControlReceived(Sender, AType,aData);
+end;
+
+function TCustomWSServer.AllowConnection(AConnection: TWSServerConnection) : Boolean;
+
+begin
+  Result:=True;
+  if Assigned(FonAllow) then
+    OnAllow(Self,aConnection,Result);
+end;
+
+function TCustomWSServer.WaitForConnections(aMaxAttempts: Integer): Boolean;
+
+Var
+  aLastCount,ACount : Integer;
+
+begin
+  ACount:=0;
+  aLastCount:=ConnectionCount;
+  While (ConnectionCount>0) and (aCount<aMaxAttempts) do
+    begin
+    Sleep(100);
+    if (ConnectionCount=aLastCount) then
+      Inc(ACount)
+    else
+      aLastCount:=ConnectionCount;
+    end;
+  Result:=aLastCount=0;
+end;
+
+procedure TCustomWSServer.BroadcastData(AData: TBytes);
+
+begin
+  SendDataTo(aData,@DoAllowAll);
+end;
+
+Procedure TCustomWSServer.DoAllowAll(aConnection :TWSServerConnection; var aAllow : Boolean);
+
+begin
+  aAllow:=Assigned(AConnection);
+end;
+
+function TCustomWSServer.CreateConnections: TWSConnectionList;
+begin
+  Result:=TWSConnectionList.Create;
+end;
+
+procedure TCustomWSServer.BroadcastMessage(AMessage: string);
+
+begin
+  SendMessageTo(aMessage,@DoAllowAll);
+end;
+
+constructor TCustomWSServer.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FWebSocketVersion:=DefaultWebSocketVersion;
+  FConnections:=CreateConnections;
+end;
+
+destructor TCustomWSServer.Destroy;
+begin
+  FreeAndNil(FConnections);
+  inherited;
+end;
+
+procedure TCustomWSServer.BroadcastFrame(aFrame: TWSFrame);
+begin
+  SendFrameTo(aFrame,@DoAllowAll);
+end;
+
+function TCustomWSServer.CreateWebsocketConnection(aStream: TSocketStream; aOptions: TWSOptions): TWSServerConnection;
+
+Var
+  aTransport: TWSServerTransport;
+
+begin
+  aTransport:=TWSServerTransport.Create(aStream);
+  Result:=TWSServerConnection.Create(Self,aTransport,aOptions);
+  Result.OutgoingFrameMask:=Self.OutgoingFrameMask;
+end;
+
+procedure TCustomWSServer.SendDataTo(AData: TBytes; aSelector: TWSSendToFilter);
+
+  Function DoAllow(Conn : TWSServerConnection) : Boolean;
+  begin
+    Result:=Conn.HandshakeCompleted;
+    if Result then
+      aSelector(Conn,Result);
+  end;
+
+var
+  Connection: TWSServerConnection;
+  L : TList;
+  I : integer;
+
+begin
+  L:=Connections.LockList;
+  try
+    For I:=0 to L.Count-1 do
+      begin
+      Connection:=TWSServerConnection(L[i]);
+      if DoAllow(Connection) then
+        Connection.Send(ftBinary,aData);
+      end;
+  finally
+    Connections.UnlockList;
+  end;
+end;
+
+procedure TCustomWSServer.Foreach(aIterator: TConnectionIterator);
+Var
+  L : TList;
+  aContinue : Boolean;
+  I : Integer;
+
+begin
+  aContinue:=True;
+  L:=Connections.LockList;
+  try
+    For I:=L.Count-1 downto 0 do
+      if aContinue then
+        aIterator(TWSServerConnection(L[i]),aContinue);
+  finally
+    Connections.UnlockList;
+  end;
+end;
+
+procedure TCustomWSServer.SendFrameTo(aFrame: TWSFrame; aSelector: TWSSendToFilter);
+
+  Function DoAllow(Conn : TWSServerConnection) : Boolean;
+
+  begin
+    Result:=Conn.HandshakeCompleted;
+    if Result then
+      aSelector(Conn,Result);
+  end;
+
+var
+  Connection: TWSServerConnection;
+  L : TList;
+  I : integer;
+
+begin
+  // Create the message only once.
+  L:=Connections.Locklist;
+  try
+    For I:=0 to L.Count-1 do
+      begin
+      Connection:=TWSServerConnection(L[i]);
+      if DoAllow(Connection) then
+        Connection.Send(aFrame);
+      end;
+  finally
+    Connections.UnlockList;
+  end;
+end;
+
+procedure TCustomWSServer.SendMessageTo(AMessage: string; aSelector: TWSSendToFilter);
+
+  Function DoAllow(Conn : TWSServerConnection) : Boolean;
+  begin
+    Result:=Conn.HandshakeCompleted;
+    if Result then
+      aSelector(Conn,Result);
+  end;
+
+var
+  Connection: TWSServerConnection;
+  L : TList;
+  I : integer;
+
+begin
+  // Create the message only once.
+  L:=Connections.Locklist;
+  try
+    For I:=0 to L.Count-1 do
+      begin
+      Connection:=TWSServerConnection(L[i]);
+      if DoAllow(Connection) then
+        Connection.Send(aMessage);
+      end;
+  finally
+    Connections.UnlockList;
+  end;
+end;
+
+function TCustomWSServer.GetActive: Boolean;
+begin
+  Result:=False;
+end;
+
+function TCustomWSServer.CreateConnectionHandler: TWSServerConnectionHandler;
+begin
+  Case ThreadMode of
+    wtmNone : Result:=TWSSimpleConnectionHandler.Create(Self);
+    wtmThread : Result:=TWSThreadedConnectionHandler.Create(Self);
+    wtmThreadPool : Result:=TWSPooledConnectionHandler.Create(Self);
+  end;
+end;
+
+procedure TCustomWSServer.SetActive(const Value: Boolean);
+begin
+  // Do nothing
+end;
+
+procedure TCustomWSServer.SetOptions(const Value: TWSOptions);
+begin
+  if (FOptions = Value) then exit;
+  CheckInactive;
+  FOptions := Value;
+end;
+
+procedure TCustomWSServer.SetResource(AValue: string);
+begin
+  if FResource=AValue then Exit;
+  CheckInactive;
+  FResource:=AValue;
+end;
+
+procedure TCustomWSServer.SetThreadMode(AValue: TWSThreadMode);
+
+begin
+  if FThreadMode=AValue then Exit;
+  CheckInactive;
+  FThreadMode:=AValue;
+  FreeAndNil(FConnectionHandler);
+end;
+
+procedure TCustomWSServer.DoDisconnect(Sender: TObject);
+begin
+  if Assigned(OnDisconnect) then
+    OnDisconnect(Sender);
+end;
+
+procedure TCustomWSServer.FreeConnectionHandler;
+begin
+  FreeAndNil(FConnectionHandler);
+end;
+
+procedure TCustomWSServer.StartConnectionHandler;
+
+begin
+  if (ConnectionHandler=nil) then
+    FConnectionHandler:=CreateConnectionHandler;
+  FConnectionHandler.WaitTime:=MessageWaitTime;
+end;
+
+procedure TCustomWSServer.HandleError(aConnection: TWSServerConnection; E: Exception);
+begin
+  if Assigned(FOnError) then
+    FOnError(Self,aConnection,E);
+end;
+
+function TCustomWSServer.GetActiveConnectionCount: Integer;
+
+Var
+  L : TList;
+begin
+  L:=Connections.LockList;
+  try
+    Result:=L.Count;
+  finally
+    Connections.UnlockList;
+  end;
+end;
+
+procedure TCustomWSServer.CloseConnectionSocket(aConnection: TWSServerConnection; var aContinue: boolean);
+begin
+  aConnection.ServerTransport.CloseSocket;
+  aContinue:=True;
+end;
+
+procedure TCustomWSServer.RemoveConnection(AConnection: TWSServerConnection;aDoDisconnect: Boolean);
+begin
+  if aDoDisconnect then
+    try
+      aConnection.Disconnect;
+    except
+      on E : Exception do
+       HandleError(aConnection,E);
+    end;
+  DoDisconnect(aConnection);
+  Connections.Remove(aConnection);
+  aConnection.Free;
+end;
+
+procedure TCustomWSServer.CheckInactive;
+begin
+  if Active then
+    Raise EWebsocketServer.Create(SErrServerActive);
+end;
+
+
+{ TWSThreadedConnectionHandler }
+
+procedure TWSThreadedConnectionHandler.CheckIncomingMessages;
+begin
+  // Do nothing
+end;
+
+procedure TWSThreadedConnectionHandler.ConnectionDone(Sender: TObject);
+begin
+  RemoveConnection(Sender as TWSServerConnection);
+end;
+
+procedure TWSThreadedConnectionHandler.HandleConnection(aConnection: TWSServerConnection; DoHandshake: Boolean);
+begin
+  TWSConnectionThread.CreateConnection(aConnection,@ConnectionDone,DoHandShake);
+end;
+
+{ TWSServerConnectionHandler }
+
+function TWSServerConnectionHandler.GetList: TWSConnectionList;
+begin
+  Result:=FServer.Connections;
+end;
+
+procedure TWSServerConnectionHandler.DoCheckConnectionRequests(aConnection: TWSServerConnection; var aContinue: boolean);
+begin
+  aConnection.CheckIncoming(WaitTime,True);
+  aContinue:=True;
+end;
+
+procedure TWSServerConnectionHandler.RemoveConnection(aConnection: TWSServerConnection);
+begin
+  FServer.RemoveConnection(aConnection,True);
+end;
+
+procedure TWSServerConnectionHandler.HandleError(aConnection : TWSServerConnection; E: Exception);
+begin
+  if Assigned(FServer) then
+    FServer.HandleError(aConnection,E);
+end;
+
+constructor TWSServerConnectionHandler.Create(aServer: TCustomWSServer);
+begin
+  FServer:=aServer;
+  FWaitTime:=DefaultWaitTime;
+end;
+
+destructor TWSServerConnectionHandler.Destroy;
+begin
+  FServer:=Nil;
+  inherited Destroy;
+end;
+
+procedure TWSServerConnectionHandler.Foreach(aIterator: TConnectionIterator);
+begin
+  FServer.Foreach(aIterator);
+end;
+
+procedure TWSServerConnectionHandler.CloseConnections;
+begin
+  Foreach(@FServer.CloseConnectionSocket);
+end;
+
+procedure TWSServerConnectionHandler.CheckIncomingMessages;
+begin
+  Foreach(@DoCheckConnectionRequests);
+end;
+
+
+{ TWSSimpleConnectionHandler }
+
+procedure TWSSimpleConnectionHandler.HandleConnection(aConnection: TWSServerConnection; DoHandshake : Boolean);
+begin
+  if DoHandShake then
+     aConnection.PerformHandShake;
+  aConnection.CheckIncoming(WaitTime);
+end;
+
+{ TWSThreadedConnectionHandler.TWSConnectionThread }
+
+constructor TWSThreadedConnectionHandler.TWSConnectionThread.CreateConnection(AConnection: TWSServerConnection; aOnConnectionDone : TNotifyEvent; DoHandShake : Boolean);
+begin
+  FOnDone:=aOnConnectionDone;
+  FConnection:=AConnection;
+  FDoHandshake:=DoHandshake;
+  FreeOnTerminate:=True;
+  Inherited Create(False);
+end;
+
+procedure TWSThreadedConnectionHandler.TWSConnectionThread.Execute;
+
+begin
+  try
+    // Always handle first request
+    if FDoHandshake then
+      begin
+      Connection.PerformHandshake;
+      if not Connection.HandshakeResponseSent then
+        Terminate;
+      end;
+    While not Terminated do
+      if Connection.CheckIncoming(10)=irClose then
+        Terminate;
+  except
+    Raise;
+   //  on E : Exception do
+      // Server.HandleUnexpectedError(E);
+  end;
+  If Assigned(FOnDone) then
+    FOnDone(Connection);
+end;
+
+{ TWSPooledConnectionHandler.THandleRequestTask }
+
+constructor TWSPooledConnectionHandler.THandleRequestTask.Create(aConnection: TWSServerConnection; aOnConnectionDone: TNotifyEvent; aOnError: TErrorHandler; aDoHandshake : Boolean);
+
+begin
+  Inherited Create;
+  // So it is removed from the busy list.
+  DoneOnException:=True;
+  OnDone:=aOnConnectionDone;
+  FConnection:=aConnection;
+  FDoHandshake:=aDoHandshake;
+end;
+
+procedure TWSPooledConnectionHandler.THandleRequestTask.DoExecute;
+begin
+  if FDoHandshake then
+    Connection.PerformHandshake;
+  Connection.ReadMessage;
+end;
+
+{ TWSPooledConnectionHandler }
+
+procedure TWSPooledConnectionHandler.CheckIncomingMessages;
+
+begin
+  // First schedule what is already there..
+  FPool.CheckQueuedTasks;
+  // Now maybe add new ones
+  Foreach(@CheckRequest);
+end;
+
+constructor TWSPooledConnectionHandler.Create(aServer: TCustomWSServer);
+begin
+  inherited Create(aServer);
+  FPool:=CreatePool;
+  FBusy:=TThreadList.Create;
+end;
+
+Function TWSPooledConnectionHandler.IsBusy(aConnection : TWSServerConnection) : Boolean;
+
+Var
+  L : TList;
+
+begin
+  L:=FBusy.LockList;
+  try
+    Result:=L.IndexOf(aConnection)<>-1;
+  finally
+    FBusy.UnlockList;
+  end;
+end;
+
+procedure TWSPooledConnectionHandler.ScheduleRequest(aConnection: TWSServerConnection; DoHandShake : Boolean);
+
+begin
+  // So we don't schedule it again while it is waiting to be handled.
+  if not IsBusy(aConnection) then
+    begin
+    FBusy.Add(aConnection);
+    FPool.AddTask(THandleRequestTask.Create(aConnection,@ConnectionDone,@HandleError,DoHandshake));
+    end;
+end;
+
+procedure TWSPooledConnectionHandler.CheckRequest(aConnection: TWSServerConnection; var aContinue: Boolean);
+begin
+  if Server.Active then
+    Case aConnection.CheckIncoming(WaitTime,False) of
+      irWaiting : ScheduleRequest(aConnection,False);
+      irClose :  RemoveConnection(aConnection);
+    else
+      // nothing
+    end;
+//  if Server.Active and aConnection.AllowNewRequest and aConnection.RequestPending then
+//
+end;
+
+procedure TWSPooledConnectionHandler.CloseConnections;
+begin
+  FPool.CancelQueuedTasks;
+  inherited CloseConnections;
+end;
+
+procedure TWSPooledConnectionHandler.ConnectionDone(Sender: TObject);
+
+var
+  aTask : THandleRequestTask absolute Sender;
+  aConn : TWSServerConnection;
+
+begin
+  aConn:=aTask.Connection;
+  FBusy.Remove(aConn);
+  if aConn.CheckIncoming(10)=irClose then
+    RemoveConnection(aConn);
+end;
+
+procedure TWSPooledConnectionHandler.HandleConnection(aConnection: TWSServerConnection; DoHandshake : Boolean);
+begin
+  ScheduleRequest(aConnection,DoHandshake);
+end;
+
+function TWSPooledConnectionHandler.CreatePool: TFPCustomSimpleThreadPool;
+
+Var
+  P : TFPSimpleThreadPool;
+
+begin
+  P:=TFPSimpleThreadPool.Create;
+  P.AddTimeout:=30;
+  Result:=P;
+end;
+
+
+
+end.
+

packages/fcl-web/src/websocket/fpwebsocket.pp

@@ -0,0 +1,1561 @@
+{
+    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2021 - by the Free Pascal development team
+
+    Abstract websocket protocol implementation - objects only
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit fpwebsocket;
+
+{$mode objfpc}
+{$h+}
+{$modeswitch advancedrecords}
+{$modeswitch typehelpers}
+
+interface
+
+uses
+  Classes, SysUtils, sockets, ssockets;
+
+Const
+  SSecWebSocketGUID = '258EAFA5-E914-47DA-95CA-C5AB0DC85B11';
+
+  SSecWebsocketProtocol = 'Sec-WebSocket-Protocol';
+  SSecWebsocketVersion = 'Sec-WebSocket-Version';
+  SSecWebsocketExtensions = 'Sec-WebSocket-Extensions';
+  SSecWebsocketKey = 'Sec-WebSocket-Key';
+  SSecWebsocketAccept = 'Sec-WebSocket-Accept';
+
+  MinFrameSize = 4;
+
+  DefaultWebSocketVersion = 13;
+
+  // Opcodes
+  FlagContinuation = $0;
+  FlagText         = $1;
+  FlagBinary       = $2;
+  FlagClose        = $8;
+  FlagPing         = $9;
+  FlagPong         = $A;
+
+  // For SVR etc.
+  FlagTwoBytes   = 126;
+  FlagEightBytes = 127;
+  FlagFinalFrame : Byte = $80;
+  FlagMasked     : Byte = $80;
+  FlagLengthMask : Byte = $7F;
+
+  FlagRES1 = $40;
+  FlagRES2 = $20;
+  FlagRES3 = $10;
+
+
+type
+  EWebSocket = Class(Exception);
+  EWSHandShake = class(EWebSocket);
+
+  TFrameType = (ftContinuation,ftText,ftBinary,ftClose,ftPing,ftPong);
+
+  TFrameTypes = Set of TFrameType;
+
+  TFrameSequence = (fsFirst,fsContinuation,fsLast);
+  TFrameSequences = Set of TFrameSequence;
+
+  TIncomingResult = (irNone,    // No data waiting
+                     irWaiting, // Data waiting
+                     irOK,      // Data was waiting and handled
+                     irClose    // Data was waiting, handled, and we must disconnect (CloseState=csClosed)
+                     );
+
+  { TFrameTypeHelper }
+
+  TFrameTypeHelper = Type helper for TFrametype
+  private
+    function GetAsFlag: Byte;
+    procedure SetAsFlag(AValue: Byte);
+  Public
+    Property asFlag : Byte Read GetAsFlag Write SetAsFlag;
+  end;
+
+
+  { TWSHeaders }
+
+  TWSHeaders = class
+  private
+    FRawHeaders: TStrings;
+    FResource: String;
+  Protected
+    Function GetS(aIdx : Integer) : String;
+    procedure SetS(AIndex: Integer; const AValue: string);
+    Function GetH(const aName : string) : String;
+    procedure SetH(const aName, aValue: string);
+  Public
+    Const
+      WSHeaderNames : Array[0..8] of string
+                    = ('Host','Origin','Connection','Upgrade',SSecWebSocketProtocol,
+                       SSecWebSocketVersion,SSecWebSocketExtensions,SSecWebSocketKey,
+                       SSecWebSocketAccept);
+  public
+    constructor Create(const aResource : String; const AHeaderList: TStrings); virtual;
+    Destructor Destroy; override;
+    Property RawHeaders : TStrings Read FRawHeaders;
+    property Resource : String Read FResource Write FResource;
+    property Host: string Index 0 read GetS Write SetS;
+    property Origin: string Index 1 read GetS Write SetS;
+    property Connection: string Index 2 read GetS Write SetS;
+    property Upgrade: string Index 3 read GetS Write SetS;
+    property Protocol: string Index 4 read GetS Write SetS;
+    property Version: string Index 5 read GetS Write SetS;
+    property Extensions : String Index 6 read GetS Write SetS;
+    property Key: string Index 7 read GetS Write SetS;
+  end;
+
+  { TWSHandShakeRequest }
+
+  TWSHandShakeRequest = Class(TWSHeaders)
+  private
+    FPort: Word;
+  Public
+    Constructor Create(const aResource : string; const aExtraHeaders : TStrings); override;
+    class function GenerateKey: String; static;
+    Procedure ToStrings(aHeaders : TStrings);
+    Property Port : Word Read FPort Write FPort;
+  End;
+
+
+  { TWSHandShakeResponse }
+
+  TWSHandShakeResponse = Class (TWSHeaders)
+  private
+    FHTTPVersion: String;
+    FStatusCode: Integer;
+    FStatusText: String;
+  Public
+    Constructor Create(const aResource : string; const aExtraHeaders : TStrings); override;
+    Procedure ToStrings(aHandShake : TWSHandshakeRequest; aResponse : TStrings; AddStatusLine : Boolean);
+    Property HTTPVersion : String Read FHTTPVersion Write FHTTPVersion;
+    Property StatusCode : Integer Read FStatusCode Write FStatusCode;
+    Property StatusText : String Read FStatusText Write FSTatusText;
+    property Accept : String Index 8 read GetS Write SetS;
+  End;
+
+{$INTERFACES CORBA}
+
+  { TWSTransport }
+
+  { IWSTransport }
+
+  IWSTransport = Interface
+    // Check if transport can read data
+    Function CanRead(aTimeOut: Integer) : Boolean;
+    // Read length of buffer bytes. Raise exception if no data read
+    Procedure ReadBuffer (aBytes : TBytes);
+    // Read at most aCount bytes into buffer. Return number of bytes actually read, set length of buffer to actually read
+    function ReadBytes (var aBytes : TBytes; aCount : Integer) : Integer;
+    // Write at most aCount bytes.
+    function WriteBytes (aBytes : TBytes; aCount : Integer) : Integer;
+    // Write complete buffer. Raise exception if not all bytes were written.
+    Procedure WriteBuffer (aBytes : TBytes);
+    function ReadLn : String;
+    function PeerIP: string;
+  end;
+
+  { TWSSocketHelper }
+
+  TWSSocketHelper = Class (TObject,IWSTransport)
+  Private
+    FSocket : TSocketStream;
+  Public
+    Constructor Create (aSocket : TSocketStream);
+    Function CanRead(aTimeOut: Integer) : Boolean;
+    function PeerIP: string; virtual;
+    function ReadLn : String; virtual;
+    function ReadBytes (var aBytes : TBytes; aCount : Integer) : Integer; virtual;
+    Procedure ReadBuffer (aBytes : TBytes); virtual;
+    function WriteBytes (aBytes : TBytes; aCount : Integer) : Integer; virtual;
+    Procedure WriteBuffer (aBytes : TBytes);
+    Property Socket : TSocketStream Read FSocket;
+  end;
+
+  TWSTransport = class(TObject, IWSTransport)
+  Private
+    FHelper : TWSSocketHelper;
+    FStream : TSocketStream;
+    function GetSocket: TSocketStream;
+  Public
+    Constructor Create(aStream : TSocketStream);
+    Destructor Destroy; override;
+    Procedure CloseSocket;
+    Property Helper : TWSSocketHelper Read FHelper Implements IWSTransport;
+    Property Socket : TSocketStream Read GetSocket;
+  end;
+
+
+  { TWSFramePayload }
+
+  TWSFramePayload = record
+    DataLength: QWord;
+    // Data is unmasked
+    Data: TBytes;
+    MaskKey: Integer;
+    Masked: Boolean;
+    Procedure ReadData(var Content : TBytes; aTransport : IWSTransport);
+    Procedure Read(buffer: TBytes; aTransport : IWSTransport);
+    class procedure DoMask(var aData: TBytes; Key: Integer); static;
+    class procedure CopyMasked(SrcData: TBytes; var DestData: TBytes; Key: Integer; aOffset: Integer); static;
+    class function CopyMasked(SrcData: TBytes; Key: Integer) : TBytes; static;
+  end;
+
+  { TWSFrame }
+  TWSFrame = Class
+  private
+    FFrameType: TFrameType;
+    FFinalFrame: Boolean;
+    FRSV: Byte;
+    FPayload : TWSFramePayload;
+  protected
+    function Read(aTransport: IWSTransport): boolean;
+    function GetAsBytes : TBytes; virtual;
+  Public
+    // Read a message from transport. Returns Nil if the connection was closed when reading.
+    class function CreateFromStream(aTransport : IWSTransport): TWSFrame;
+  public
+    constructor Create(aType: TFrameType; aIsFinal: Boolean; APayload: TBytes; aMask : Integer = 0); overload; virtual;
+    constructor Create(Const aMessage : UTF8String; aMask : Integer = 0); overload; virtual;
+    constructor Create(aType: TFrameType; aIsFinal: Boolean = True; aMask: Integer = 0); overload; virtual;
+    property Reserved : Byte read FRSV write FRSV;
+    property FinalFrame: Boolean read FFinalFrame write FFinalFrame;
+    property Payload : TWSFramePayload Read FPayload Write FPayLoad;
+    property FrameType: TFrameType read FFrameType;
+    Property AsBytes : TBytes Read GetAsBytes;
+  end;
+  TWSFrameClass = Class of TWSFrame;
+
+  { TWSMessage }
+
+  TWSMessage = record
+  private
+    function GetAsString: UTF8String;
+    function GetAsUnicodeString: UnicodeString;
+  Public
+    PayLoad : TBytes;
+    Sequences : TFrameSequences;
+    IsText : Boolean;
+    Property AsString : UTF8String Read GetAsString;
+    Property AsUTF8String : UTF8String Read GetAsString;
+    Property AsUnicodeString : UnicodeString Read GetAsUnicodeString;
+  end;
+
+
+  TWSMessageEvent = procedure(Sender: TObject; const aMessage : TWSMessage) of object;
+  TWSControlEvent = procedure(Sender: TObject; aType : TFrameType; const aData: TBytes) of object;
+
+  TCloseState = (csNone,csSent,csReceived,csClosed);
+  TCloseStates = Set of TCloseState;
+
+  TWSOption = (woPongExplicit,      // Send Pong explicitly, not implicitly.
+               woCloseExplicit,     // SeDo Close explicitly, not implicitly.
+               woIndividualFrames,  // Send frames one by one, do not concatenate.
+               woSkipUpgradeCheck,  // Skip handshake "Upgrade:" HTTP header cheack.
+               woSkipVersionCheck   // Skip handshake "Sec-WebSocket-Version' HTTP header check.
+              );
+  TWSOptions = set of TWSOption;
+
+
+  { TWSConnection }
+
+  TWSConnection = class
+  Private
+    class var _ConnectionCount : {$IFDEF CPU64}QWord{$ELSE}Cardinal{$ENDIF};
+  private
+    FAutoDisconnect: Boolean;
+    FConnectionID: String;
+    FFreeUserData: Boolean;
+    FOnDisconnect: TNotifyEvent;
+    FOutgoingFrameMask: Integer;
+    FOwner: TComponent;
+    FUserData: TObject;
+    FWebSocketVersion: Integer;
+    FInitialOpcode : TFrameType;
+    FMessageContent : TBytes;
+    FHandshakeRequest: TWSHandShakeRequest;
+    FOnMessageReceived: TWSMessageEvent;
+    FOnControl: TWSControlEvent;
+    FCloseState : TCloseState;
+    FOptions: TWSOptions;
+    Function GetPeerIP : String;
+  protected
+    procedure AllocateConnectionID; virtual;
+    Procedure SetCloseState(aValue : TCloseState); virtual;
+    Procedure DoDisconnect; virtual; abstract;
+    // Read message from connection. Return False if connection was closed.
+    function DoReadMessage: Boolean;
+    procedure DispatchEvent(aInitialType : TFrameType; aFrame: TWSFrame);
+    Procedure SetHandShakeRequest(aRequest : TWSHandShakeRequest);
+    Function HandleIncoming(aFrame: TWSFrame) : Boolean; virtual;
+    function GetHandshakeCompleted: Boolean; virtual; abstract;
+    Function GetTransport : IWSTransport; virtual; abstract;
+    property Owner : TComponent Read FOwner;
+  Public
+    Type
+      TConnectionIDAllocator = Procedure(out aID : String) of object;
+    class var IDAllocator : TConnectionIDAllocator;
+  Public
+    Constructor Create(aOwner : TComponent; aOptions : TWSOptions); virtual;
+    destructor Destroy; override;
+    // Extract close data
+    Class Function GetCloseData(aBytes : TBytes; Out aReason : String) : Word;
+    // Send close with message data
+    procedure Close(aData : TBytes = Nil); overload;
+    procedure Close(aMessage : UTF8String);overload;
+    // Check incoming message
+    function CheckIncoming(aTimeout: Integer; DoRead : Boolean = True): TIncomingResult;
+    // read & process incoming message. Return nil if connection was close.
+    function ReadMessage: Boolean;
+    // Disconnect
+    Procedure Disconnect;
+    // Descendents can override this to provide custom frames
+    Function FrameClass : TWSFrameClass; virtual;
+    // Send raw frame. No checking is done !
+    procedure Send(aFrame : TWSFrame); virtual;
+    // Send message
+    procedure Send(const AMessage: UTF8string);
+    // Send binary data
+    procedure Send(const ABytes: TBytes);
+    // Send control frame. ftPing,ftPong,ftClose
+    procedure Send(aFrameType: TFrameType; aData : TBytes = Nil);
+    // Disconnect when status is set to csClosed;
+    Property AutoDisconnect : Boolean Read FAutoDisconnect Write FAutoDisconnect;
+    // Close frame handling
+    Property CloseState : TCloseState Read FCloseState;
+    // Connection ID, allocated during create
+    Property ConnectionID : String Read FConnectionID;
+    // If set to true, the owner data is freed when the connection is freed.
+    Property FreeUserData : Boolean Read FFreeUserData Write FFreeUserData;
+    // Request headers during handshake
+    property HandshakeRequest: TWSHandShakeRequest read FHandshakeRequest;
+    // Has handshake been completed ?
+    property HandshakeCompleted: Boolean read GetHandshakeCompleted;
+    // Options passed by server
+    Property Options : TWSOptions Read FOptions;
+    // Mask to use when sending frames. Set to nonzero value to send masked frames.
+    Property OutgoingFrameMask : Integer Read FOutgoingFrameMask Write FOutgoingFrameMask;
+    // Peer IP address
+    property PeerIP: string read GetPeerIP;
+    // Transport in use by this connection
+    property Transport: IWSTransport read GetTransport;
+    // User data to associate with this connection.
+    Property UserData : TObject Read FUserData Write FUserData;
+    // Socket version to check for
+    Property WebSocketVersion : Integer Read FWebSocketVersion Write FWebSocketVersion;
+    // Called when text/binary data was received
+    property OnMessageReceived: TWSMessageEvent read FOnMessageReceived write FOnMessageReceived;
+    // Called when Ping, Pong, Close control messages come in.
+    property OnControl: TWSControlEvent read FOnControl write FOnControl;
+    // Called when disconnect is called.
+    property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
+  end;
+
+  { TWSClientTransport }
+
+  TWSClientTransport = Class(TWSTransport)
+  end;
+
+  { TWSClientConnection }
+
+  TWSClientConnection = Class(TWSConnection)
+  private
+    FTransport : TWSClientTransport;
+    FHandshakeResponse: TWSHandShakeResponse;
+  Protected
+    function GetTransport : IWSTransport ; override;
+  public
+    Constructor Create(aOwner: TComponent; aTransport : TWSClientTransport; aOptions : TWSOptions); reintroduce; overload;
+    Destructor Destroy; override;
+    //
+    function GetHandshakeCompleted: Boolean; override;
+    // Owned by connection
+    Property ClientTransport : TWSClientTransport Read FTransport;
+    //
+    Property HandShakeResponse : TWSHandShakeResponse Read FHandshakeResponse Write FHandshakeResponse;
+  End;
+
+  { TWSServerTransport }
+
+  TWSServerTransport = class(TWSTransport)
+  end;
+
+  { TWSServerConnection }
+  TWSConnectionHandshakeEvent =  procedure (aRequest : TWSHandShakeRequest; aResponse : TWSHandShakeResponse) of object;
+
+  TWSServerConnection = Class(TWSConnection)
+  Private
+    FExtraHeaders: TStrings;
+    FHandshakeResponseSent: Boolean;
+    FOnHandShake: TWSConnectionHandshakeEvent;
+    FTransport : TWSServerTransport;
+  Protected
+    Procedure DoDisconnect; override;
+    function GetTransport: IWSTransport; override;
+    procedure DoPrepareHandshakeResponse(aRequest : TWSHandShakeRequest; aResponse : TWSHandShakeResponse); virtual;
+    function GetHandshakeCompleted: Boolean; override;
+  public
+    // Transport is owned by connection
+    constructor Create(aOwner : TComponent; aTransport : TWSServerTransport; aOptions : TWSOptions); overload;
+    // disconnect
+    destructor Destroy; override;
+    // Do full circle.
+    Procedure PerformHandshake; virtual;
+    // Given a request, send response
+    function DoHandshake(const aRequest : TWSHandShakeRequest): Boolean;
+    // Has handshake been exchanged?
+    property HandshakeResponseSent: Boolean read FHandshakeResponseSent;
+    // Extra handshake headers
+    Property ExtraHeaders : TStrings Read FExtraHeaders;
+    // Owned by connection
+    property ServerTransport : TWSServerTransport Read FTransport;
+    // Called when exchanging handshake
+    Property OnHandshake : TWSConnectionHandshakeEvent Read FOnHandShake write FOnHandshake;
+  end;
+
+Type
+
+  { TBytesHelper }
+
+  TBytesHelper = Type helper for TBytes
+    // No swapping of bytes
+    Function ToInt32(aOffset : Integer = 0) : LongInt;
+    Function ToWord(aOffset : Integer = 0) : Word;
+    Function ToQWord(aOffset : Integer = 0) : QWord;
+    Procedure FromInt32(const aData : Longint; aOffset : Integer = 0);
+    Procedure FromWord(const aData : Word; aOffset : Integer = 0);
+    Procedure FromQWord(const aData : QWord; aOffset : Integer = 0);
+    procedure Reverse(var Dest: TBytes; Offset: Integer; Size: Integer);
+    Function Reverse(Offset: Integer; Size: Integer) : TBytes;
+    Procedure Append(aData : TBytes);
+  end;
+
+
+Resourcestring
+  SErrNotSimpleOperation = 'Frame type %d is not a simple operation.';
+  SErrCloseAlreadySent = 'Close message already sent, cannot send more data.';
+  SErrHandshakeInComplete = 'Operation cannot be performed while the handshake is not completed';
+  SErrConnectionActive = 'Operation cannot be performed while the websocket connection is active';
+  SErrConnectionInActive = 'Operation cannot be performed while the websocket connection is not active';
+  SErrServerActive = 'Operation cannot be performed while the websocket connection is active';
+  SErrInvalidSizeFlag = 'Invalid size flag: %d';
+  SErrInvalidFrameType = 'Invalid frame type flag: %d';
+
+function DecodeBytesBase64(const s: string; Strict: boolean = false) : TBytes;
+function EncodeBytesBase64(const aBytes : TBytes) : String;
+
+
+implementation
+
+uses strutils, sha1,base64;
+
+{ TFrameTypeHelper }
+
+function TFrameTypeHelper.GetAsFlag: Byte;
+
+Const
+  Flags : Array[TFrameType] of byte = (FlagContinuation,FlagText,FlagBinary,FlagClose,FlagPing,FlagPong);
+
+begin
+  Result:=Flags[Self];
+end;
+
+procedure TFrameTypeHelper.SetAsFlag(AValue: Byte);
+begin
+  case aValue of
+    FlagContinuation : Self:=ftContinuation;
+    FlagText :         Self:=ftText;
+    FlagBinary :       Self:=ftBinary;
+    FlagClose :        Self:=ftClose;
+    FlagPing :         Self:=ftPing;
+    FlagPong :         Self:=ftPong;
+  else
+    Raise EConvertError.CreateFmt(SErrInvalidFrameType,[aValue]);
+  end;
+end;
+
+
+{ TWSServerTransport }
+
+
+{ TWSHandShakeResponse }
+
+constructor TWSHandShakeResponse.Create(const aResource: string; const aExtraHeaders: TStrings);
+begin
+  inherited Create(aResource, aExtraHeaders);
+  HTTPVersion:='1.1';
+  StatusCode:=101;
+  StatusText:='Switching Protocols';
+end;
+
+procedure TWSHandShakeResponse.ToStrings(aHandShake: TWSHandshakeRequest; aResponse: TStrings; AddStatusLine: Boolean);
+
+  Function CalcKey : String;
+
+  Var
+    B : TBytes;
+    hash : TSHA1Digest;
+    K : string;
+  begin
+    // respond key
+    b:=[];
+    k:= Trim(aHandshake.Key) + SSecWebSocketGUID;
+    hash:=sha1.SHA1String(k);
+    SetLength(B,SizeOf(hash));
+    Move(Hash,B[0],Length(B));
+    Result:=EncodeBytesBase64(B);
+  end;
+
+begin
+  // Fill needed headers
+  Upgrade:='websocket';
+  Connection:='Upgrade';
+  // Chrome doesn't like it if you send an empty protocol header.
+  if (Protocol='') and (aHandshake.Protocol<>'') then
+    Protocol:=aHandshake.Protocol;
+  if Version='' then
+    Version:=IntToStr(DefaultWebSocketVersion);
+  if Accept='' then
+    Accept:=CalcKey;
+  if AddStatusLine then
+    aResponse.Add('HTTP/%s %d %s',[HTTPVersion,StatusCode,StatusText]);
+  aResponse.AddStrings(RawHeaders);
+end;
+
+{ TWSTransport }
+
+function TWSTransport.GetSocket: TSocketStream;
+begin
+  Result:=FHelper.Socket
+end;
+
+constructor TWSTransport.Create(aStream : TSocketStream);
+begin
+  FStream:=aStream;
+  FHelper:=TWSSocketHelper.Create(FStream);
+end;
+
+destructor TWSTransport.Destroy;
+begin
+  FreeAndNil(FHelper);
+  FreeAndNil(FStream);
+  inherited Destroy;
+end;
+
+procedure TWSTransport.CloseSocket;
+begin
+  sockets.CloseSocket(FStream.Handle);
+end;
+
+{ TWSTransport }
+
+constructor TWSSocketHelper.Create(aSocket: TSocketStream);
+begin
+  FSocket:=aSocket;
+{$if defined(FreeBSD) or defined(Linux)}
+  FSocket.ReadFlags:=MSG_NOSIGNAL;
+  FSocket.WriteFlags:=MSG_NOSIGNAL;
+{$endif}
+end;
+
+function TWSSocketHelper.CanRead(aTimeOut: Integer): Boolean;
+begin
+  Result:=FSocket.CanRead(aTimeout);
+end;
+
+function TWSSocketHelper.PeerIP: string;
+
+  Function SocketAddrToString(ASocketAddr: TSockAddr): String;
+  begin
+    if ASocketAddr.sa_family = AF_INET then
+      Result := NetAddrToStr(ASocketAddr.sin_addr)
+    else // no ipv6 support yet
+      Result := '';
+  end;
+
+begin
+  Result:= SocketAddrToString(FSocket.RemoteAddress);
+end;
+
+function TWSSocketHelper.ReadLn: String;
+
+Var
+  C : Byte;
+  aSize : integer;
+
+begin
+  // Preset
+  Result:='';
+  SetLength(Result,255);
+  aSize:=0;
+  C:=0;
+  While (FSocket.Read(C,1)=1) and (C<>10) do
+    begin
+    Inc(aSize);
+    if aSize>Length(Result) then
+      SetLength(Result,Length(Result)+255);
+    Result[aSize]:=AnsiChar(C);
+    end;
+  if (aSize>0) and (Result[aSize]=#13) then
+    Dec(aSize);
+  SetLength(Result,aSize);
+end;
+
+function TWSSocketHelper.ReadBytes(var aBytes: TBytes; aCount: Integer): Integer;
+begin
+  SetLength(aBytes,aCount);
+  Result:=FSocket.ReadData(aBytes,aCount);
+  SetLength(aBytes,Result);
+end;
+
+procedure TWSSocketHelper.ReadBuffer(aBytes: TBytes);
+begin
+  FSocket.ReadBuffer(aBytes,Length(ABytes));
+end;
+
+function TWSSocketHelper.WriteBytes(aBytes: TBytes; aCount: Integer): Integer;
+begin
+  Result:=FSocket.WriteData(aBytes,aCount);
+end;
+
+procedure TWSSocketHelper.WriteBuffer(aBytes: TBytes);
+begin
+  FSocket.WriteBuffer(aBytes,0,Length(aBytes));
+end;
+
+{ TWSMessage }
+
+function TWSMessage.GetAsString: UTF8String;
+
+begin
+  Result:=TEncoding.UTF8.GetAnsiString(Payload);
+end;
+
+function TWSMessage.GetAsUnicodeString: UnicodeString;
+begin
+  Result:=UTF8Decode(asUTF8String);
+end;
+
+{ TBytesHelper }
+
+Function TBytesHelper.Reverse(Offset: Integer; Size: Integer) : TBytes;
+
+begin
+  Result:=[];
+  Reverse(Result,Offset,Size);
+end;
+
+procedure TBytesHelper.Append(aData: TBytes);
+
+Var
+  sLen,dLen : SizeInt;
+
+begin
+  sLen:=Length(Self);
+  dLen:=Length(aData);
+  if dLen>0 then
+    begin
+    SetLength(Self,dLen+sLen);
+    Move(aData[0],Self[sLen],dLen);
+    end;
+end;
+
+procedure TBytesHelper.Reverse(var Dest: TBytes; Offset: Integer; Size: Integer);
+var
+  I: Integer;
+begin
+  SetLength(dest, Size);
+  for I := 0 to Size - 1 do
+    Dest[Size-1-I]:=Self[Offset+I];
+end;
+
+function TBytesHelper.ToInt32(aOffset: Integer = 0): LongInt;
+begin
+  Result:=0;
+  Move(Self[aOffSet],Result,SizeOf(LongInt));
+end;
+
+function TBytesHelper.ToWord(aOffset: Integer): Word;
+begin
+  Result:=0;
+  Move(Self[aOffSet],Result,SizeOf(Word));
+end;
+
+function TBytesHelper.ToQWord(aOffset: Integer): QWord;
+begin
+  Result:=0;
+  Move(Self[aOffSet],Result,SizeOf(QWord));
+end;
+
+
+procedure TBytesHelper.FromInt32(const aData: Longint; aOffset: Integer);
+
+begin
+  Move(aData, Self[aOffSet],SizeOf(Longint));
+end;
+
+procedure TBytesHelper.FromWord(const aData: Word; aOffset: Integer = 0);
+begin
+  Move(aData, Self[aOffSet],SizeOf(Word));
+end;
+
+procedure TBytesHelper.FromQWord(const aData: QWord; aOffset: Integer);
+begin
+  Move(aData, Self[aOffSet],SizeOf(QWord));
+end;
+
+Function HToNx(Host: QWord) : QWord;
+
+begin
+{$ifdef FPC_BIG_ENDIAN}
+  htonx:=host;
+{$else}
+  htonx:=SwapEndian(host);
+{$endif}
+end;
+
+Function NToHx(Net: QWord) : QWord;
+
+begin
+{$ifdef FPC_BIG_ENDIAN}
+  ntohx:=Net;
+{$else}
+  ntohx:=SwapEndian(Net);
+{$endif}
+end;
+
+function EncodeBytesBase64(const aBytes : TBytes) : String;
+
+var
+  OutStream : TStringStream;
+  Encoder   : TBase64EncodingStream;
+
+begin
+  if Length(aBytes)=0 then
+    Exit('');
+  Encoder:=Nil;
+  OutStream:=TStringStream.Create('');
+  try
+    Encoder:=TBase64EncodingStream.create(OutStream);
+    Encoder.WriteBuffer(aBytes,0,Length(aBytes));
+    Encoder.Flush;
+    Result:=OutStream.DataString;
+  finally
+    Encoder.Free;
+    OutStream.free;
+  end;
+end;
+
+
+function DecodeBytesBase64(const s: string; Strict: boolean = false) : TBytes;
+
+Const
+  StrictModes : Array[Boolean] of TBase64DecodingMode = (bdmMime,bdmStrict);
+
+var
+  missing : Integer;
+  SD : String;
+  Instream,
+  Outstream : TBytesStream;
+  Decoder   : TBase64DecodingStream;
+
+begin
+  Result:=[];
+  if Length(s)=0 then
+    Exit;
+  SD:=S;
+  Missing:=Length(Sd) mod 4;
+  if Missing>0 then
+    SD:=SD+StringOfChar('=',Missing);
+  Outstream:=Nil;
+  Decoder:=Nil;
+  Instream:=TStringStream.Create(SD);
+  try
+    Outstream:=TBytesStream.Create(Nil);
+    Decoder:=TBase64DecodingStream.Create(Instream,StrictModes[Strict]);
+    Outstream.CopyFrom(Decoder,Decoder.Size);
+    Result:=Outstream.Bytes;
+  finally
+    Decoder.Free;
+    Outstream.Free;
+    Instream.Free;
+  end;
+end;
+
+
+
+{ TWSFramePayload }
+
+
+procedure TWSFramePayload.ReadData(var Content: TBytes; aTransport: IWSTransport);
+
+Const
+  MaxBufSize = 32*1024;
+
+Var
+  Buf : TBytes;
+  aPos,toRead : QWord;
+  aCount : Longint;
+
+begin
+  Buf:=[];
+  ToRead:=DataLength;
+  aPos:=0;
+  Repeat
+    aCount:=ToRead;
+    if aCount>MaxBufSize then
+      aCount:=MaxBufSize;
+    SetLength(Buf,aCount);
+    aTransport.ReadBytes(Buf,aCount);
+    Move(Buf[0],Content[aPos],aCount);
+    Inc(aPos,aCount);
+    ToRead:=DataLength-aPos;
+  Until (ToRead<=0);
+end;
+
+procedure TWSFramePayload.Read(buffer: TBytes; aTransport: IWSTransport);
+
+Var
+  LenFlag : Byte;
+  paylen16 : Word;
+  content: TBytes;
+
+begin
+  content:=[];
+  Masked := ((buffer[1] and FlagMasked) <> 0);
+  LenFlag := buffer[1] and FlagLengthMask;
+
+  Case LenFlag of
+   FlagTwoBytes:
+    begin
+    aTransport.ReadBytes(Buffer,2);
+    Paylen16:=Buffer.ToWord(0);
+    DataLength := ntohs(PayLen16);
+    end;
+  FlagEightBytes:
+    begin
+    aTransport.ReadBytes(Buffer,8);
+    DataLength:=Buffer.ToQWord(0);
+    DataLength := ntohx(DataLength); // MVC : Needs fixing
+    end
+  else
+    DataLength:=lenFlag;
+  end;
+
+  if Masked then
+  begin
+    aTransport.ReadBytes(Buffer,4);
+    MaskKey:=buffer.ToInt32(0);
+  end;
+  SetLength(content, DataLength);
+  if (DataLength>0) then
+    begin
+    ReadData(Content,aTransport);
+    if Masked then
+      DoMask(Content, MaskKey);
+    Data := content;
+    end;
+end;
+
+
+{ TWSFrame }
+
+constructor TWSFrame.Create(aType: TFrameType; aIsFinal: Boolean; APayload: TBytes; aMask: Integer=0);
+
+begin
+  Create(aType,aIsFinal,aMask);
+  FPayload.Data := APayload;
+  if Assigned(aPayload) then
+    FPayload.DataLength := Cardinal(Length(aPayload));
+end;
+
+constructor TWSFrame.Create(aType: TFrameType; aIsFinal : Boolean = True; aMask: Integer=0);
+
+begin
+  FPayload:=Default(TWSFramePayload);
+  FPayload.MaskKey:=aMask;
+  FPayload.Masked:=aMask<>0;
+  FFrameType := aType;
+  FFinalFrame := AIsFinal;
+end;
+
+
+constructor TWSFrame.Create(const aMessage: UTF8String; aMask: Integer=0);
+
+Var
+  Data : TBytes;
+
+begin
+  Data:=TEncoding.UTF8.GetAnsiBytes(AMessage);
+  Create(ftText,True,Data,aMask);
+end;
+
+class function TWSFrame.CreateFromStream(aTransport : IWSTransport): TWSFrame;
+
+begin
+  Result:=TWSFrame.Create;
+  try
+    if not Result.Read(aTransport) then
+      FreeAndNil(Result);
+  except
+    FreeAndNil(Result);
+    Raise;
+  end;
+end;
+
+
+function TWSFrame.Read(aTransport: IWSTransport): boolean;
+
+Var
+  Buffer : Tbytes;
+  B1 : Byte;
+
+begin
+  Result:=False;
+  Buffer:=Default(TBytes);
+  SetLength(Buffer,2);
+  if aTransport.ReadBytes(Buffer,2)=0 then
+    Exit;
+  if Length(Buffer)<2 then
+    Raise EWebSocket.Create('Could not read frame header');
+  B1:=buffer[0];
+  FFinalFrame:=(B1 and FlagFinalFrame) = FlagFinalFrame;
+  FRSV:=B1 and ($F0) and (not FlagFinalFrame);
+  FFrameType.AsFlag:=(B1 and $F);
+  FPayload.Read(Buffer,aTransport);
+  Result:=True;
+end;
+
+
+function TWSFrame.GetAsBytes: TBytes;
+
+var
+  LenByte,firstByte: Byte;
+  buffer, LengthBytes: TBytes;
+  aOffSet, I : Integer;
+  pLen16 : Word;
+  pLen64 : QWord;
+
+begin
+  Result:=Nil;
+  firstByte := FrameType.AsFlag;
+  if FinalFrame then
+    firstByte := firstByte or FlagFinalFrame;
+  if FPayload.DataLength < FlagTwoBytes then
+  begin
+    aOffSet:=2;
+    LenByte := Byte(FPayload.DataLength);
+    LengthBytes:=[];
+  end
+  else if Payload.DataLength < (1 shl 16) then
+  begin
+    aOffset:=4;
+    LenByte := FlagTwoBytes;
+    plen16:=Payload.DataLength;
+    SetLength(LengthBytes, SizeOf(Word));
+    LengthBytes.FromWord(HToNs(pLen16));
+  end
+  else
+  begin
+    aOffset:=10;
+    LenByte:=FlagEightBytes;
+    plen64:=Payload.DataLength;
+    SetLength(LengthBytes, Sizeof(UInt64));
+    LengthBytes.FromQWord(HToNx(Plen64));
+  end;
+
+  Buffer:=[];
+  if FPayload.Masked then
+    begin
+    lenByte:=Lenbyte or FlagMasked;
+    aoffSet:=aOffSet+4;
+    end;
+  SetLength(buffer,aOffset+Int64(FPayload.DataLength));
+  buffer[0] := firstByte;
+  buffer[1] := LenByte;
+  for I := 0 to Length(LengthBytes)-1 do
+    buffer[2 + I] := LengthBytes[I];
+  if Payload.Masked then
+    begin
+    Buffer.FromInt32(Payload.MaskKey,aOffSet-4);
+    TWSFramePayload.CopyMasked(Payload.Data,Buffer,Payload.MaskKey,aOffset);
+    end
+  else
+    for I:=0 to Payload.DataLength-1 do
+      buffer[aOffset + I]:=Payload.Data[I];
+
+  Result := Buffer;
+end;
+
+class Procedure TWSFramePayload.DoMask(var aData: TBytes; Key: Integer);
+
+
+begin
+  CopyMasked(aData,aData,Key,0)
+end;
+
+class procedure TWSFramePayload.CopyMasked(SrcData : TBytes; Var DestData: TBytes; Key: Integer; aOffset: Integer);
+
+var
+  currentMaskIndex: Longint;
+  byteKeys: TBytes;
+  I: Longint;
+
+begin
+  CurrentMaskIndex := 0;
+  byteKeys:=[];
+  SetLength(byteKeys, SizeOf(Key));
+  ByteKeys.FromInt32(Key);
+  for I := 0 to Length(SrcData) - 1 do
+    begin
+    DestData[I+aOffset] := SrcData[I] XOR byteKeys[currentMaskIndex];
+    currentMaskIndex := (currentMaskIndex + 1) mod 4;
+    end;
+end;
+
+class function TWSFramePayload.CopyMasked(SrcData: TBytes; Key: Integer): TBytes;
+begin
+  Result:=[];
+  SetLength(Result,Length(SrcData));
+  CopyMasked(SrcData,Result,Key,0)
+end;
+
+{ TWSRequest }
+
+function TWSHeaders.GetS(aIdx: Integer): String;
+begin
+  Result:=GetH(WSHeaderNames[aIdx]);
+end;
+
+procedure TWSHeaders.SetS(AIndex: Integer; const AValue: string);
+begin
+  SetH(WSHeaderNames[aIndex],aValue);
+end;
+
+function TWSHeaders.GetH(const aName: string): String;
+begin
+  Result:=Trim(FRawHeaders.Values[aName]);
+end;
+
+Procedure TWSHeaders.SetH(const aName,aValue: string);
+begin
+  FRawHeaders.Values[aName]:=' '+aValue;
+end;
+
+constructor TWSHeaders.Create(Const aResource : String; const AHeaderList: TStrings);
+
+var
+  I : Integer;
+  N,V : String;
+
+begin
+  FResource:=aResource;
+  FRawHeaders:=TStringList.Create;
+  FRawHeaders.NameValueSeparator:=':';
+  if Assigned(aHeaderList) then
+    for I:=0 to aHeaderList.Count-1 do
+      begin
+      aHeaderList.GetNameValue(I,N,V);
+      if (N<>'') and (V<>'') then
+        FRawHeaders.Add(N+': '+Trim(V));
+      end;
+end;
+
+destructor TWSHeaders.Destroy;
+begin
+  FreeAndNil(FRawHeaders);
+  inherited;
+end;
+
+{ TWSConnection }
+
+procedure TWSConnection.Send(aFrameType : TFrameType; aData : TBytes = Nil);
+
+Var
+  aFrame : TWSFrame;
+
+begin
+  if not (aFrameType in [ftClose,ftPing,ftPong]) then
+    Raise EWebSocket.CreateFmt(SErrNotSimpleOperation,[Ord(aFrameType)]);
+  aFrame:=FrameClass.Create(aFrameType,True,aData);
+  try
+    Send(aFrame);
+  finally
+    aFrame.Free;
+  end;
+end;
+
+procedure TWSConnection.SetHandShakeRequest(aRequest: TWSHandshakeRequest);
+begin
+  FreeAndNil(FHandshakeRequest);
+  FHandShakeRequest:=aRequest;
+end;
+
+constructor TWSConnection.Create(aOwner : TComponent; aOptions: TWSOptions);
+begin
+  FOwner:=aOwner;
+  Foptions:=aOptions;
+  FWebSocketVersion:=WebSocketVersion;
+  AllocateConnectionID;
+end;
+
+destructor TWSConnection.Destroy;
+begin
+  FreeAndNil(FHandshakeRequest);
+  If FreeUserData then
+    FreeAndNil(FUserData);
+  inherited;
+end;
+
+class function TWSConnection.GetCloseData(aBytes: TBytes; out aReason: String): Word;
+begin
+  Result:=0;
+  aReason:='';
+  if Length(aBytes)>1 then
+    Result:=NToHs(aBytes.ToWord(0));
+  if Length(aBytes)>2 then
+    aReason:=TEncoding.UTF8.GetAnsiString(aBytes,2,Length(aBytes)-2);
+end;
+
+function TWSConnection.GetPeerIP: String;
+
+Var
+  S : IWSTransport;
+
+begin
+  S:=Transport;
+  if Assigned(S) then
+    Result:=S.PeerIP
+  else
+    Result:=''
+end;
+
+procedure TWSConnection.AllocateConnectionID;
+begin
+  if Assigned(IDAllocator) then
+    IDAllocator(FConnectionID);
+  if FConnectionID='' then
+{$IFDEF CPU64}
+    FConnectionID:=IntToStr(InterlockedIncrement64(_ConnectionCount));
+{$ELSE}
+    FConnectionID:=IntToStr(InterlockedIncrement(_ConnectionCount));
+{$ENDIF}
+end;
+
+procedure TWSConnection.SetCloseState(aValue: TCloseState);
+begin
+  FCloseState:=aValue;
+  if (FCloseState=csClosed) and autoDisconnect then
+    Disconnect;
+end;
+
+function TWSConnection.ReadMessage: Boolean;
+begin
+  Result:=DoReadMessage;
+end;
+
+procedure TWSConnection.DispatchEvent(aInitialType : TFrameType; aFrame : TWSFrame);
+
+Var
+  msg: TWSMessage;
+
+begin
+  Case aInitialType of
+  ftPing,
+  ftPong,
+  ftClose :
+     begin
+     If Assigned(FOnControl) then
+       FOnControl(Self,aInitialType,FMessageContent);
+     FMessageContent:=[];
+     end;
+  ftBinary,
+  ftText :
+    begin
+    if Assigned(FOnMessageReceived) then
+      begin
+      Msg:=Default(TWSMessage);
+      Msg.IsText:=(aInitialType=ftText);
+      if aFrame.FrameType=ftBinary then
+        Msg.Sequences:=[fsFirst]
+      else
+        Msg.Sequences:=[fsContinuation];
+      if aFrame.FinalFrame then
+        Msg.Sequences:=Msg.Sequences+[fsLast];
+      Msg.PayLoad:=FMessageContent;
+      FOnMessageReceived(Self, Msg);
+      end;
+    FMessageContent:=[];
+    end;
+  ftContinuation: ; // Cannot happen normally
+  end;
+end;
+
+Function TWSConnection.HandleIncoming(aFrame : TWSFrame) : Boolean;
+
+   Procedure UpdateCloseState;
+
+   begin
+     if (FCloseState=csNone) then
+       FCloseState:=csReceived
+     else if (FCloseState=csSent) then
+       FCloseState:=csClosed;
+   end;
+
+begin
+  Result:=True;
+  // here we handle payload.
+  if aFrame.FrameType<>ftContinuation then
+    FInitialOpcode:=aFrame.FrameType;
+  if aFrame.FrameType in [ftPong,ftBinary,ftText,ftPing] then
+    FMessageContent:=aFrame.Payload.Data;
+  // Special handling
+  Case aFrame.FrameType of
+   ftContinuation:
+     FMessageContent.Append(aFrame.Payload.Data);
+   ftPing:
+     begin
+     if not (woPongExplicit in Options) then
+       Send(ftPong,aFrame.Payload.Data);
+     end;
+   ftClose:
+     begin
+     // If our side sent the initial close, this is the reply, and we must disconnect (Result=false).
+     Result:=FCloseState=csNone;
+     if Result then
+       begin
+       FMessageContent:=aFrame.Payload.Data;
+       if not (woCloseExplicit in Options) then
+         begin
+         Send(ftClose); // Will update state
+         Result:=False; // We can disconnect.
+         end
+       else
+         UpdateCloseState
+       end
+     else
+       UpdateCloseState;
+     end;
+  else
+    ; // avoid Compiler warning
+  End;
+  if (aFrame.FinalFrame) or (woIndividualFrames in Options) then
+    DispatchEvent(FInitialOpcode,aFrame);
+end;
+
+function TWSConnection.FrameClass: TWSFrameClass;
+
+begin
+  Result:=TWSFrame;
+end;
+
+procedure TWSConnection.Send(const AMessage: UTF8String);
+
+var
+  aFrame: TWSFrame;
+
+begin
+  aFrame:=FrameClass.Create(aMessage);
+  try
+    Send(aFrame);
+  finally
+    aFrame.Free;
+  end;
+end;
+
+procedure TWSConnection.Send(const ABytes: TBytes);
+var
+  aFrame: TWSFrame;
+begin
+  aFrame:=FrameClass.Create(ftBinary,True,ABytes);
+  try
+    Send(aFrame);
+  finally
+    aFrame.Free;
+  end;
+end;
+
+procedure TWSConnection.Close(aMessage: UTF8String);
+begin
+  Close(TEncoding.UTF8.GetAnsiBytes(aMessage));
+end;
+
+procedure TWSConnection.Disconnect;
+begin
+  DoDisconnect;
+  if Assigned(FOnDisconnect) then
+    FOnDisconnect(Self);
+end;
+
+procedure TWSConnection.Close(aData: TBytes);
+begin
+  Send(ftClose,aData);
+end;
+
+procedure TWSConnection.Send(aFrame: TWSFrame);
+
+Var
+  Data : TBytes;
+
+begin
+  if FCloseState=csClosed then
+    Raise EWebSocket.Create(SErrCloseAlreadySent);
+  Data:=aFrame.AsBytes;
+  Transport.WriteBytes(Data,Length(Data));
+  if (aFrame.FrameType=ftClose) then
+    begin
+    if FCloseState=csNone then
+      FCloseState:=csSent
+    else if FCloseState=csReceived then
+      FCloseState:=csClosed;
+    end;
+end;
+
+Function TWSConnection.DoReadMessage : Boolean ;
+
+Var
+  F : TWSFrame;
+
+begin
+  Result:=False;
+  If not Transport.CanRead(0) then
+    Exit;
+  f:=FrameClass.CreateFromStream(Transport);
+  try
+    if Assigned(F) then
+      Result:=HandleIncoming(F)
+  finally
+    F.Free;
+  end;
+end;
+
+function TWSConnection.CheckIncoming(aTimeout: Integer; DoRead: Boolean = True): TIncomingResult;
+
+begin
+  if not Transport.CanRead(aTimeOut) then
+    Result:=irNone
+  else if Not DoRead then
+    Result:=irWaiting
+  else if ReadMessage then
+    Result:=irOK
+  else
+    Result:=irClose
+end;
+
+constructor TWSClientConnection.Create(aOwner: TComponent; aTransport: TWSClientTransport; aOptions : TWSOptions);
+begin
+  Inherited Create(aOwner,aOptions);
+  FTransport:=aTransport;
+end;
+
+destructor TWSClientConnection.Destroy;
+begin
+  FreeAndNil(FTransport);
+  inherited;
+end;
+
+function TWSClientConnection.GetHandshakeCompleted: Boolean;
+begin
+  Result:=Assigned(FHandshakeResponse);
+end;
+
+
+function TWSClientConnection.GetTransport: IWSTransport;
+
+begin
+  Result:=FTransport;
+end;
+
+{ TWSHandShakeRequest }
+
+Class Function TWSHandShakeRequest.GenerateKey : String;
+
+Var
+  I : Integer;
+  B : TBytes;
+
+begin
+  B:=[];
+  SetLength(B,16);
+  For I:=0 to 15 do
+    B[i]:=Random(256);
+  Result:=EncodeBytesBase64(B);
+end;
+
+
+constructor TWSHandShakeRequest.Create(const aResource: string; const aExtraHeaders: TStrings);
+begin
+  Inherited Create(aResource,aExtraHeaders);
+  Version:=IntToStr(DefaultWebSocketVersion);
+end;
+
+procedure TWSHandShakeRequest.ToStrings(aHeaders: TStrings);
+
+  procedure Add(const AName, aValue, aDefault: String);
+
+  Var
+    V : String;
+  begin
+    V:=aValue;
+    if V='' then
+      V:=aDefault;
+    if V<>'' then
+      aHeaders.Add(aName+': '+V)
+  end;
+
+
+Var
+  N,V : String;
+  I  : Integer;
+
+begin
+  aHeaders.Clear;
+  if Resource='' then
+    Resource:='/';
+  aHeaders.Add('GET ' + Resource + ' HTTP/1.1');
+  V:=Host;
+  if (V<>'') and (Port<>443) and (Port<>80) then
+    V:=V+':'+IntToStr(Port);
+  Add('Host',V,'');
+  Add('Upgrade',Upgrade,'websocket');
+  Add('Connection',Connection,'Upgrade');
+  Add('Origin',Origin,Host);
+  if Key='' then
+    Key:=GenerateKey;
+  Add('Sec-WebSocket-Key',Key,'');
+  Add('Sec-WebSocket-Protocol',Protocol,'');
+  Add('Sec-WebSocket-Version',Version,'');
+  For I:=0 to RawHeaders.Count-1 do
+    begin
+    RawHeaders.GetNameValue(I,N,V);
+    if (N<>'') and (V<>'') then
+      if (aHeaders.Values[N]='') then
+        Add(N,V,'')
+    end;
+end;
+
+{ TWSServerConnection }
+
+constructor TWSServerConnection.Create(aOwner : TComponent; aTransport : TWSServerTransport; aOptions : TWSOptions);
+begin
+  Inherited Create(aOwner,aOptions);
+  FHandshakeResponseSent := False;
+  FTransport:=aTransport;
+  FExtraHeaders:=TStringList.Create;
+  FExtraHeaders.NameValueSeparator:=':';
+end;
+
+destructor TWSServerConnection.Destroy;
+begin
+  DisConnect;
+  inherited;
+end;
+
+procedure TWSServerConnection.PerformHandshake;
+
+Var
+  Headers : TStrings;
+  aResource,Status,aLine : String;
+  HSR : TWSHandShakeRequest;
+
+begin
+  Status:=Transport.ReadLn;
+  aResource:=ExtractWord(2,Status,[' ']);
+  HSR:=Nil;
+  Headers:=TStringList.Create;
+  try
+    Headers.NameValueSeparator:=':';
+    aLine:=Transport.ReadLn;
+    While aLine<>'' do
+      begin
+      Headers.Add(aLine);
+      aLine:=Transport.ReadLn;
+      end;
+    HSR:=TWSHandShakeRequest.Create(aResource,Headers);
+    FHandshakeResponseSent:=DoHandshake(HSR);
+  finally
+    HSR.Free;
+    Headers.Free;
+  end;
+end;
+
+
+function TWSServerConnection.GetHandshakeCompleted: Boolean;
+begin
+  Result:=HandshakeResponseSent;
+end;
+
+procedure TWSServerConnection.DoDisconnect;
+begin
+  if Assigned(FTransport) then
+    FTransport.CloseSocket;
+  FreeAndNil(FTransPort);
+end;
+
+function TWSServerConnection.GetTransport: IWSTransport;
+begin
+  Result:=FTransport;
+end;
+
+procedure TWSServerConnection.DoPrepareHandshakeResponse(aRequest: TWSHandShakeRequest; aResponse: TWSHandShakeResponse);
+begin
+  If Assigned(OnHandshake) then
+    OnHandShake(aRequest,aResponse);
+end;
+
+
+function TWSServerConnection.DoHandshake(const aRequest : TWSHandShakeRequest) : Boolean;
+
+var
+  aLine,Reply : string;
+  aResp : TWSHandShakeResponse;
+  H : TStrings;
+  B : TBytes;
+
+
+begin
+  Result:=False;
+  H:=Nil;
+  aResp:=TWSHandShakeResponse.Create('',FExtraHeaders);
+  try
+    DoPrepareHandshakeResponse(aRequest,aResp);
+    try
+      H:=TStringList.Create;
+      aResp.ToStrings(aRequest,H,True);
+      Reply:='';
+      For aLine in H do
+        Reply:=Reply+aLine+#13#10;
+      Reply:=Reply+#13#10;
+      B:=TEncoding.UTF8.GetAnsiBytes(Reply);
+      Transport.WriteBytes(B,Length(B));
+      Result:=True;
+      FHandshakeResponseSent:=True;
+    except
+      on E: Exception do
+      begin
+        // Close the connection if the handshake failed
+        Disconnect;
+      end;
+    end;
+  finally
+    H.Free;
+    aResp.Free;
+  end;
+end;
+
+
+end.

packages/fcl-web/src/websocket/fpwebsocketclient.pp

@@ -0,0 +1,703 @@
+{
+    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2021 - by the Free Pascal development team
+
+    Websocket client implementation.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+{$mode ObjFPC}{$H+}
+unit fpwebsocketclient;
+
+interface
+
+uses
+  sysutils, classes, fpwebsocket, ssockets;
+
+Type
+  EWebSocketClient = Class(EWebSocket);
+
+  TWSClientHandShakeEvent = Procedure(Sender : TObject; aHeaders : TStrings) of Object;
+  TWSClientHandShakeResponseEvent = Procedure(Sender : TObject; aResponse : TWSHandShakeResponse; Var aAllow : Boolean) of Object;
+  TWSErrorEvent = Procedure (Sender : TObject; E : Exception) of object;
+
+  { TWSMessagePump }
+
+  TWSMessagePump = Class (TComponent)
+  private
+    FInterval:Integer;
+    FList: TThreadList;
+    FReads: TSocketStreamArray;
+    FExceptions : TSocketStreamArray;
+    FOnError: TWSErrorEvent;
+    procedure SetInterval(AValue: Integer);
+  Protected
+    function WaitForData: Boolean;
+    Function CheckConnections : Boolean; virtual;
+    Procedure ReadConnections;
+    Property List : TThreadList Read FList;
+  Public
+    Constructor Create(aOwner : TComponent); override;
+    Destructor Destroy; override;
+    Procedure AddClient(aConnection : TWSClientConnection);
+    Procedure RemoveClient(aConnection : TWSClientConnection);
+    Procedure Execute; virtual; abstract;
+    Procedure Terminate; virtual; abstract;
+    Property Interval : Integer Read FInterval Write SetInterval;
+    Property OnError : TWSErrorEvent Read FOnError Write FOnError;
+  End;
+
+  // Default message driver, works with thread that checks sockets for available data
+
+  TWSThreadMessagePump = Class(TWSMessagePump)
+  Private
+    FThread : TThread;
+    Procedure ThreadTerminated(Sender : TObject);
+  Protected
+    Type
+      TMessageDriverThread = Class(TThread)
+      Public
+        FPump : TWSThreadMessagePump;
+        Constructor Create(aPump : TWSThreadMessagePump; aTerminate : TNotifyEvent);
+        Procedure Execute;override;
+      End;
+  Public
+    Procedure Execute; override;
+    Procedure Terminate; override;
+  End;
+
+  TCustomWebsocketClient = class;
+
+  { TWebSocketClientConnection }
+
+  TWebSocketClientConnection = class(TWSClientConnection)
+  protected
+    Procedure DoDisconnect; override;
+    function GetClient: TCustomWebsocketClient; virtual;
+  Public
+    Property WebsocketClient : TCustomWebsocketClient Read GetClient;
+  end;
+
+  { TCustomWSClientConnection }
+
+  { TCustomWebsocketClient }
+
+  TCustomWebsocketClient = Class(TComponent)
+  private
+    FOutGoingFrameMask: Integer;
+    FPort: Integer;
+    FActive: Boolean;
+    FLoadActive : Boolean;
+    FHostName: String;
+    FUseSSL: Boolean;
+    FResource: string;
+    FConnectTimeout: Integer;
+    FOptions: TWSOptions;
+    FSocket : TInetSocket;
+    FTransport : TWSClientTransport;
+    FCheckTimeOut: Integer;
+    FAutoCheckMessages: Boolean;
+    FHandShake : TWSHandShakeRequest;
+    FMessagePump: TWSMessagePump; // Do not free
+    FHandshakeResponse: TWSHandShakeResponse;
+    FOnSendHandShake: TWSClientHandshakeEvent;
+    FOnHandshakeResponse: TWSClientHandshakeResponseEvent;
+    FConnection: TWebSocketClientConnection;
+    FOnMessageReceived: TWSMessageEvent;
+    FOnControl: TWSControlEvent;
+    FOnDisconnect: TNotifyEvent;
+    FOnConnect: TNotifyEvent;
+    procedure SetActive(const Value: Boolean);
+    procedure SetHostName(const Value: String);
+    procedure SetMessagePump(AValue: TWSMessagePump);
+    procedure SetPort(const Value: Integer);
+    procedure SetUseSSL(const Value: Boolean);
+    procedure SetConnectTimeout(const Value: Integer);
+    procedure SetResource(const Value: string);
+    procedure SetCheckTimeOut(const Value: Integer);
+    procedure SetOptions(const Value: TWSOptions);
+    procedure SetAutoCheckMessages(const Value: Boolean);
+    procedure SendHeaders(aHeaders: TStrings);
+    procedure ConnectionDisconnected(Sender: TObject);
+  Protected
+    Procedure CheckInactive;
+    Procedure Loaded; override;
+    function CreateClientConnection(aTransport : TWSClientTRansport): TWebSocketClientConnection; virtual;
+    procedure MessageReceived(Sender: TObject; const aMessage : TWSMessage);
+    Procedure ControlReceived(Sender: TObject; aType : TFrameType; const aData: TBytes);virtual;
+    function CheckHandShakeResponse(aHeaders: TStrings): Boolean; virtual;
+    function CreateHandShakeRequest: TWSHandShakeRequest; virtual;
+    function CreateHandshakeResponse(aHeaders: TStrings): TWSHandShakeResponse; virtual;
+    procedure SendHandShakeRequest; virtual;
+    function ReadHandShakeResponse: Boolean; virtual;
+    Function DoHandShake : Boolean;
+    Property Transport : TWSClientTRansport Read FTransport;
+  Public
+    Property Connection: TWebSocketClientConnection Read FConnection;
+  Public
+    Destructor Destroy; override;
+    // Check for incoming messages
+    Function CheckIncoming : TIncomingResult;
+    // Connect and perform handshake
+    Procedure Connect;
+    // Disconnect from server.
+    Procedure Disconnect(SendClose : boolean = true);
+    // Send a ping message
+    Procedure Ping(aMessage: UTF8String);
+    // Send a pong message
+    Procedure Pong(aMessage: UTF8String);
+    // Send raw data (ftBinary)
+    Procedure SendData(aBytes : TBytes);
+    // Send a string message
+    Procedure SendMessage(Const aMessage : String);
+  Public
+    // Connect/Disconnect
+    Property Active : Boolean Read FActive Write SetActive;
+    // Check for message timeout
+    Property CheckTimeOut : Integer Read FCheckTimeOut Write SetCheckTimeOut;
+    // Timeout for connect
+    Property ConnectTimeout : Integer Read FConnectTimeout Write SetConnectTimeout;
+    // Host to connect to
+    Property HostName : String Read FHostName Write SetHostName;
+    // Message driver
+    Property MessagePump : TWSMessagePump Read FMessagePump Write SetMessagePump;
+    // Options
+    Property Options : TWSOptions Read FOptions Write SetOptions;
+    // Mask to use for outgoing frames
+    Property OutGoingFrameMask : Integer Read FOutGoingFrameMask Write FOutGoingFrameMask;
+    // Port to connect to
+    Property Port : Integer Read FPort Write SetPort;
+    // Path/Document in HTTP URL for GET request
+    Property Resource : string Read FResource Write SetResource;
+    // User SSL when connecting
+    Property UseSSL : Boolean Read FUseSSL Write SetUseSSL;
+    // Events
+    // Called when handshake is about to be sent
+    Property OnSendHandShake : TWSClientHandshakeEvent Read FOnSendHandShake Write FOnSendHandshake;
+    // Called when handshake response is received
+    Property OnHandshakeResponse : TWSClientHandshakeResponseEvent Read FOnHandshakeResponse Write FOnHandshakeResponse;
+    // Called when a text message is received.
+    property OnMessageReceived: TWSMessageEvent read FOnMessageReceived write FOnMessageReceived;
+    // Called when a connection is disconnected. Sed
+    property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
+    // Called when a connection is established
+    property OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
+    // Called when a control message is received.
+    property OnControl: TWSControlEvent read FOnControl write FOnControl;
+  End;
+
+  TWebsocketClient = Class(TCustomWebsocketClient)
+  Published
+    Property HostName;
+    Property Port;
+    Property CheckTimeOut;
+    Property ConnectTimeout;
+    Property MessagePump;
+    Property Options;
+    Property Resource;
+    Property UseSSL;
+    Property OnSendHandShake;
+    Property OnHandshakeResponse;
+    property OnMessageReceived;
+    property OnDisconnect;
+    property OnConnect;
+    property OnControl;
+    Property OutGoingFrameMask;
+  End;
+
+implementation
+
+uses sha1;
+
+{ TWebSocketClientConnection }
+
+procedure TWebSocketClientConnection.DoDisconnect;
+begin
+  If Assigned(WebSocketClient) then
+    WebSocketClient.ConnectionDisconnected(Self);
+end;
+
+function TWebSocketClientConnection.GetClient: TCustomWebsocketClient;
+
+begin
+  Result:=Owner as TCustomWebsocketClient;
+end;
+
+
+{ TCustomWebsocketClient }
+
+procedure TCustomWebsocketClient.CheckInactive;
+begin
+  If Active then
+    Raise EWebSocketClient.Create(SErrConnectionActive);
+end;
+
+Function TCustomWebsocketClient.CheckIncoming : TIncomingResult;
+
+begin
+  If Not Active then
+    Raise EWebSocketClient.Create(SErrConnectionInActive);
+  if Not Connection.HandshakeCompleted then
+    Raise EWebSocketClient.Create(SErrHandshakeInComplete);
+  Result:=Connection.CheckIncoming(CheckTimeout);
+  if (Result=irClose) then
+    begin
+    Disconnect(False);
+    end;
+end;
+
+procedure TCustomWebsocketClient.ControlReceived(Sender: TObject; aType : TFrameType; const aData: TBytes);
+begin
+  If Assigned(FOnControl) then
+    FOnControl(Sender, aType, aData);
+end;
+
+function TCustomWebsocketClient.CreateClientConnection(aTransport: TWSClientTRansport): TWebsocketClientConnection;
+
+begin
+  Result:=TWebsocketClientConnection.Create(Self,aTransport,FOptions);
+end;
+
+procedure TCustomWebsocketClient.ConnectionDisconnected(Sender : TObject);
+
+begin
+  Factive:=False;
+  If Assigned(MessagePump) then
+    MessagePump.RemoveClient(FConnection);
+  If Assigned(OnDisconnect) then
+    OnDisconnect(FConnection);
+end;
+
+procedure TCustomWebsocketClient.Connect;
+begin
+  If Active then
+    Exit;
+  FreeAndNil(FSocket);
+  FreeAndNil(FTransport);
+  FSocket:=TInetSocket.Create(HostName,Port,ConnectTimeout);
+  FTransport:=TWSClientTransport.Create(FSocket);
+  FConnection:=CreateClientConnection(FTransport);
+  FConnection.OnMessageReceived:=@MessageReceived;
+  FConnection.OnControl:=@ControlReceived;
+  FCOnnection.OutgoingFrameMask:=Self.OutGoingFrameMask;
+  FActive:=True;
+  if not DoHandShake then
+    Disconnect(False)
+  else
+    begin
+    If Assigned(MessagePump) then
+      MessagePump.AddClient(FConnection);
+    if Assigned(OnConnect) then
+      OnConnect(Self);
+    end;
+end;
+
+
+destructor TCustomWebsocketClient.Destroy;
+begin
+  DisConnect(False);
+  FreeAndNil(FHandShake);
+  FreeAndNil(FHandshakeResponse);
+  Inherited;
+end;
+
+
+Function TCustomWebsocketClient.CreateHandShakeRequest : TWSHandShakeRequest;
+
+begin
+  Result:=TWSHandShakeRequest.Create('',Nil);
+end;
+
+procedure TCustomWebsocketClient.SendData(aBytes: TBytes);
+
+begin
+  Connection.Send(aBytes);
+end;
+
+procedure TCustomWebsocketClient.SendHeaders(aHeaders : TStrings);
+
+Var
+  S : String;
+  B : TBytes;
+
+begin
+  for S in AHeaders do
+    begin
+    B:=TEncoding.UTF8.GetAnsiBytes(S+#13#10);
+    Connection.Transport.WriteBytes(B,Length(B));
+    end;
+  B:=TEncoding.UTF8.GetAnsiBytes(#13#10);
+  Connection.Transport.WriteBytes(B,Length(B));
+end;
+
+procedure TCustomWebsocketClient.SendHandShakeRequest;
+
+Var
+  aRequest : TWSHandShakeRequest;
+  aHeaders : TStrings;
+begin
+  aHeaders:=Nil;
+  FreeAndNil(FHandShake);
+  aRequest:=CreateHandShakeRequest;
+  try
+    aRequest.Host:=HostName;
+    aRequest.Port:=Port;
+    aRequest.Resource:=Resource;
+    aHeaders:=TStringList.Create;
+    aHeaders.NameValueSeparator:=':';
+    aRequest.ToStrings(aHeaders);
+    if Assigned(FOnSendHandshake) then
+      FOnSendHandshake(self,aHeaders);
+    // Do not use FClient.WriteHeader, it messes up the strings !
+    SendHeaders(aHeaders);
+    FHandShake:=aRequest;
+  finally
+    aHeaders.Free;
+    if FhandShake<>aRequest then
+      aRequest.Free;
+  end;
+end;
+
+procedure TCustomWebsocketClient.SendMessage(const aMessage: String);
+begin
+  Connection.Send(aMessage);
+end;
+
+Function TCustomWebsocketClient.CreateHandshakeResponse(aHeaders : TStrings) : TWSHandShakeResponse;
+
+begin
+  Result:=TWSHandShakeResponse.Create('',aHeaders);
+end;
+
+Function TCustomWebsocketClient.CheckHandShakeResponse(aHeaders : TStrings) : Boolean;
+
+Var
+  K : String;
+  hash : TSHA1Digest;
+  B : TBytes;
+
+begin
+  B:=[];
+  FreeAndNil(FHandshakeResponse);
+  FHandshakeResponse:=CreateHandshakeResponse(aHeaders);
+  k := Trim(FHandshake.Key) + SSecWebSocketGUID;
+  hash:=sha1.SHA1String(k);
+  SetLength(B,SizeOf(hash));
+  Move(Hash,B[0],Length(B));
+  k:=EncodeBytesBase64(B);
+  Result:=SameText(K,FHandshakeResponse.Accept)
+          and SameText(FHandshakeResponse.Upgrade,'websocket')
+          and SameText(FHandshakeResponse.Version,FHandShake.Version);
+end;
+
+Function TCustomWebsocketClient.ReadHandShakeResponse : Boolean;
+
+Var
+  S : String;
+  aHeaders : TStrings;
+
+begin
+  Result:=False;
+  aHeaders:=TStringList.Create;
+  Try
+    aHeaders.NameValueSeparator:=':';
+    Repeat
+      S:=Connection.Transport.ReadLn;
+      aHeaders.Add(S);
+    Until (S='');
+    Result:=CheckHandShakeResponse(aHeaders);
+    if Result and Assigned(FOnHandshakeResponse) then
+       FOnHandshakeResponse(Self,FHandShakeResponse,Result);
+    if Result then
+      FConnection.HandshakeResponse:=FHandShakeResponse
+  Finally
+    aHeaders.Free;
+  End;
+end;
+
+Function TCustomWebsocketClient.DoHandShake : Boolean;
+
+begin
+  SendHandShakeRequest;
+  Result:=ReadHandShakeResponse;
+end;
+
+procedure TCustomWebsocketClient.Loaded;
+begin
+  inherited;
+  if FLoadActive then
+    Connect;
+end;
+
+procedure TCustomWebsocketClient.MessageReceived(Sender: TObject; const aMessage : TWSMessage) ;
+begin
+  if Assigned(OnMessageReceived) and (TWSClientConnection(Sender).HandshakeCompleted) then
+    OnMessageReceived(Self, AMessage);
+end;
+
+procedure TCustomWebsocketClient.Ping(aMessage: UTF8String);
+begin
+  FConnection.Send(ftPing,TEncoding.UTF8.GetAnsiBytes(aMessage));
+end;
+
+procedure TCustomWebsocketClient.Pong(aMessage: UTF8String);
+begin
+  FConnection.Send(ftPong,TEncoding.UTF8.GetAnsiBytes(aMessage));
+end;
+
+procedure TCustomWebsocketClient.Disconnect(SendClose : boolean = true);
+
+begin
+  if Not Active then
+    Exit;
+  if SendClose then
+    Connection.Close('');
+  if Assigned(MessagePump) then
+    MessagePump.RemoveClient(Connection);
+  FreeAndNil(FConnection);
+  FActive:=False;
+end;
+
+procedure TCustomWebsocketClient.SetActive(const Value: Boolean);
+begin
+  FLoadActive := Value;
+  if (csDesigning in ComponentState) then
+    exit;
+  if Value then
+    Connect
+  else
+    Disconnect;
+end;
+
+procedure TCustomWebsocketClient.SetAutoCheckMessages(const Value: Boolean);
+begin
+  CheckInactive;
+  FAutoCheckMessages := Value;
+end;
+
+procedure TCustomWebsocketClient.SetCheckTimeOut(const Value: Integer);
+begin
+  CheckInactive;
+  FCheckTimeOut := Value;
+end;
+
+procedure TCustomWebsocketClient.SetConnectTimeout(const Value: Integer);
+begin
+  CheckInactive;
+  FConnectTimeout := Value;
+end;
+
+procedure TCustomWebsocketClient.SetHostName(const Value: String);
+begin
+  CheckInactive;
+  FHostName := Value;
+end;
+
+procedure TCustomWebsocketClient.SetMessagePump(AValue: TWSMessagePump);
+begin
+  if FMessagePump=AValue then Exit;
+  If Assigned(FMessagePump) then
+    FMessagePump.RemoveFreeNotification(Self);
+  FMessagePump:=AValue;
+  If Assigned(FMessagePump) then
+    FMessagePump.FreeNotification(Self);
+end;
+
+procedure TCustomWebsocketClient.SetOptions(const Value: TWSOptions);
+begin
+  CheckInactive;
+  FOptions := Value;
+end;
+
+procedure TCustomWebsocketClient.SetPort(const Value: Integer);
+begin
+  CheckInactive;
+  FPort := Value;
+end;
+
+procedure TCustomWebsocketClient.SetResource(const Value: string);
+begin
+  CheckInactive;
+  FResource := Value;
+end;
+
+procedure TCustomWebsocketClient.SetUseSSL(const Value: Boolean);
+begin
+  CheckInactive;
+  FUseSSL := Value;
+end;
+
+
+{ TTMSClientWebSocketConnection }
+
+
+
+{ TWSMessagePump }
+
+procedure TWSMessagePump.AddClient(aConnection: TWSClientConnection);
+begin
+  List.Add(aConnection);
+end;
+
+procedure TWSMessagePump.RemoveClient(aConnection: TWSClientConnection);
+begin
+  FList.Remove(aConnection);
+end;
+
+procedure TWSMessagePump.SetInterval(AValue: Integer);
+begin
+  if FInterval=AValue then Exit;
+  FInterval:=AValue;
+end;
+
+Function TWSMessagePump.WaitForData : Boolean;
+
+Var
+  dummy1,dummy2 : TSocketStreamArray;
+
+begin
+  Dummy1:=Nil;
+  Dummy2:=Nil;
+  Result:=False;
+  // FReadSet was populated by checkconnections
+  SetLength(FExceptions,0);
+  if Length(FReads)=0 then
+    begin
+    TThread.Sleep(FInterval);
+    end
+  else
+    begin
+    try
+      // We take the first ont in the list.
+      Result := FReadS[0].Select(FReads,dummy1,dummy2,FInterval);
+    except
+      Result := False;
+    end;
+    end;
+end;
+
+function TWSMessagePump.CheckConnections: Boolean;
+
+Var
+  aList : TList;
+  aClient: TWSClientConnection;
+  aTrans : TWSClientTransport;
+  I,aLen : Integer;
+
+begin
+  Result:=False;
+  aList := List.LockList;
+  try
+    aLen:=0;
+    SetLength(FReads,aList.Count);
+    for I := 0 to aList.Count - 1 do
+      begin
+      aClient := TWSClientConnection(aList.Items[I]);
+      if assigned(aClient) then
+        aTrans:=aClient.ClientTransport
+      else
+        aTrans:=Nil;
+      if (aTrans<>nil) then
+        begin
+        // There is already data
+        FReads[aLen]:=aTrans.Socket;
+        Inc(aLen);
+        end;
+      end;
+  finally
+    List.UnlockList;
+  end;
+  if Not Result then
+    Result:=WaitForData;
+end;
+
+constructor TWSMessagePump.Create(aOwner : TComponent);
+begin
+  FList:=TThreadList.Create;
+  FReads:=[];
+  FExceptions:=[];
+  Finterval:=50;
+end;
+
+destructor TWSMessagePump.Destroy;
+begin
+  FreeAndNil(FList);
+  inherited;
+end;
+
+procedure TWSMessagePump.ReadConnections;
+
+Var
+  aList : TList;
+  aClient: TWSClientConnection;
+  I : Integer;
+
+begin
+  try
+    aList := List.LockList;
+    try
+      FReads:=[];
+      for I := 0 to aList.Count - 1 do
+        begin
+        aClient:= TWSClientConnection(aList.Items[I]);
+        if assigned(aClient.Transport) then
+           aClient.CheckIncoming(1);
+        end;
+    finally
+      List.UnlockList;
+    end;
+  except
+    on E: Exception do
+      if Assigned(OnError) then
+        OnError(Self,E);
+  end;
+end;
+
+
+{ TWSThreadMessagePump }
+
+procedure TWSThreadMessagePump.Execute;
+begin
+  FThread:=TMessageDriverThread.Create(Self,@ThreadTerminated);
+end;
+
+procedure TWSThreadMessagePump.ThreadTerminated(Sender: TObject);
+begin
+  FThread:=Nil;
+end;
+
+procedure TWSThreadMessagePump.Terminate;
+begin
+  FThread.Terminate;
+  if Assigned(FThread) then
+    FThread.WaitFor;
+end;
+
+{ TWSThreadMessagePump.TMessageDriverThread }
+
+constructor TWSThreadMessagePump.TMessageDriverThread.Create(aPump: TWSThreadMessagePump; aTerminate : TNotifyEvent);
+
+begin
+  FPump:=aPump;
+  OnTerminate:=aTerminate;
+  Inherited Create(False);
+end;
+
+procedure TWSThreadMessagePump.TMessageDriverThread.Execute;
+
+begin
+  While Not Terminated do
+    if FPump.CheckConnections then
+      FPump.ReadConnections
+    else
+      TThread.Sleep(FPump.Interval);
+end;
+
+end.

packages/fcl-web/src/websocket/fpwebsocketserver.pp

@@ -0,0 +1,384 @@
+{
+    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2021 - by the Free Pascal development team
+
+    Standalone websocket server implementation
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+{$mode objfpc}
+{$h+}
+unit fpwebsocketserver;
+
+interface
+
+uses
+  Classes, SysUtils, ssockets, sslbase, fpwebsocket, fpcustwsserver, fpThreadPool;
+
+type
+  TWebSocketServer = Class;
+
+  { TWebSocketServer }
+  TAcceptIdleEvent = Procedure (sender : TObject; var aCheckMessages : Boolean) of object;
+
+  TWebSocketServer = Class(TCustomWSServer)
+  private
+    FAcceptIdleTimeout: Cardinal;
+    FActive: Boolean;
+    FAfterSocketHandlerCreated: TWSSocketHandlerCreatedEvent;
+    FCertificateData: TCertificateData;
+    FMessageWaitTime: Cardinal;
+    FOnAcceptIdle: TAcceptIdleEvent;
+    FOnGetSocketHandler: TWSGetSocketHandlerEvent;
+    FPort: Word;
+    FQueueSize: Word;
+    FServer: TInetServer;
+    FThreadedAccept: Boolean;
+    FUseSSL: Boolean;
+    procedure SetAcceptIdleTimeout(AValue: Cardinal);
+    procedure SetCertificateData(AValue: TCertificateData);
+    procedure SetPort(AValue: Word);
+    procedure SetQueueSize(AValue: Word);
+    procedure SetUseSSL(AValue: Boolean);
+    function GetSocketHandler(const UseSSL: Boolean): TSocketHandler;
+  Protected
+    procedure SetThreadMode(AValue: TWSThreadMode); override;
+    Function GetActive : Boolean; override;
+    Procedure SetActive(const aValue : Boolean); override;
+    // Socket server startup, socket handler
+    Procedure FreeServerSocket; virtual;
+    Procedure StartAccepting; virtual;
+    procedure SetupSocket; virtual;
+    procedure StartServerSocket; virtual;
+    procedure CreateServerSocket; virtual;
+    function CreateSSLSocketHandler: TSocketHandler; virtual;
+    // Socket server callbacks
+    procedure DoConnect(Sender: TObject; Data: TSocketStream); virtual;
+    procedure DoCreateClientHandler(Sender: TObject; out AHandler: TSocketHandler); virtual;
+    procedure DoAllowConnect(Sender: TObject; ASocket: Longint; var Allow: Boolean); virtual;
+    procedure DoAcceptError(Sender: TObject; ASocket: Longint; E: Exception; var ErrorAction: TAcceptErrorAction); virtual;
+    procedure DoAcceptIdle(Sender: TObject); virtual;
+    Property Server : TInetServer Read FServer;
+  public
+    constructor Create(AOwner: TComponent); overload; override;
+    destructor Destroy; override;
+    // if ThreadedAccept = False, this call will not return till server is stopped.
+    Procedure StartServer;
+    // Stop server
+    Procedure StopServer;
+    // Check for incoming messages
+    Procedure CheckIncomingMessages;
+  Published
+    Property Active : Boolean read FActive write SetActive;
+    Property MessageWaitTime;
+    Property Options;
+    Property Port: Word Read FPort Write SetPort default 8080;
+    Property Resource;
+    Property WebSocketVersion;
+    property OnConnect;
+    Property OnAllow;
+    Property OutgoingFrameMask;
+    property OnMessageReceived;
+    property OnDisconnect;
+    property OnControlReceived;
+    Property ThreadMode;
+    // use SSL ?
+    Property UseSSL : Boolean Read FUseSSL Write SetUseSSL;
+    // Properties to use when doing SSL handshake
+    Property CertificateData  : TCertificateData Read FCertificateData Write SetCertificateData;
+    // Called to create socket handler. If not set, or Nil is returned, a standard socket handler is created.
+    Property OnGetSocketHandler : TWSGetSocketHandlerEvent Read FOnGetSocketHandler Write FOnGetSocketHandler;
+    // Called after create socket handler was created, with the created socket handler.
+    Property AfterSocketHandlerCreate : TWSSocketHandlerCreatedEvent Read FAfterSocketHandlerCreated Write FAfterSocketHandlerCreated;
+    // If >0, when no new connection appeared after timeout, OnAcceptIdle is called.
+    Property AcceptIdleTimeout : Cardinal Read FAcceptIdleTimeout Write SetAcceptIdleTimeout;
+    // Max connections on queue (for Listen call)
+    Property QueueSize : Word Read FQueueSize Write SetQueueSize Default 5;
+    // Run Accept in thread ?  If true, calling StartServer or setting Active to true will return at once.
+    Property ThreadedAccept : Boolean Read FThreadedAccept Write FThreadedAccept;
+    // Run when accept is idle. AcceptIdleTimeout. Note that this is run in the accept thread.
+    Property OnAcceptIdle : TAcceptIdleEvent Read FOnAcceptIdle Write FOnAcceptIdle;
+  end;
+
+implementation
+
+uses
+  sslsockets, sockets;
+
+Type
+  { TAcceptThread }
+  TAcceptThread = Class(TThread)
+  Private
+    FServer : TWebSocketServer;
+  Public
+    Constructor Create(aServer : TWebSocketServer);
+    Procedure Execute; override;
+  end;
+
+
+{ TAcceptThread }
+
+constructor TAcceptThread.Create(aServer: TWebSocketServer);
+begin
+  FreeOnTerminate:=True;
+  FServer:=aServer;
+  Inherited Create(False);
+end;
+
+procedure TAcceptThread.Execute;
+
+begin
+  FServer.StartAccepting;
+end;
+
+
+{ TWebSocketServer }
+
+procedure TWebSocketServer.SetUseSSL(AValue: Boolean);
+begin
+  if FUseSSL=AValue then Exit;
+  CheckInactive;
+  FUseSSL:=AValue;
+end;
+
+
+procedure TWebSocketServer.SetPort(AValue: Word);
+begin
+  if FPort=AValue then Exit;
+  CheckInactive;
+  FPort:=AValue;
+end;
+
+procedure TWebSocketServer.SetQueueSize(AValue: Word);
+begin
+  if FQueueSize=AValue then Exit;
+  FQueueSize:=AValue;
+end;
+
+
+function TWebSocketServer.CreateSSLSocketHandler : TSocketHandler;
+
+Var
+  S : TSSLSocketHandler;
+  CK : TCertAndKey;
+
+begin
+  S:=TSSLSocketHandler.GetDefaultHandler;
+  try
+    // We must create the certificate once in our global copy of CertificateData !
+    if CertificateData.NeedCertificateData then
+      begin
+      S.CertGenerator.HostName:=CertificateData.Hostname;
+      CK:=S.CertGenerator.CreateCertificateAndKey;
+      CertificateData.Certificate.Value:=CK.Certificate;
+      CertificateData.PrivateKey.Value:=CK.PrivateKey;
+      end;
+    S.CertificateData:=Self.CertificateData;
+    Result:=S;
+  except
+    S.free;
+    Raise;
+  end;
+end;
+
+
+function TWebSocketServer.GetSocketHandler(const UseSSL: Boolean): TSocketHandler;
+
+begin
+  Result:=Nil;
+  if Assigned(FonGetSocketHandler) then
+    FOnGetSocketHandler(Self,UseSSL,Result);
+  if (Result=Nil) then
+    If UseSSL then
+      Result:=CreateSSLSocketHandler
+    else
+      Result:=TSocketHandler.Create;
+  if Assigned(FAfterSocketHandlerCreated) then
+    FAfterSocketHandlerCreated(Self,Result);
+end;
+
+procedure TWebSocketServer.DoCreateClientHandler(Sender: TObject; out AHandler: TSocketHandler);
+begin
+  AHandler:=GetSocketHandler(UseSSL);
+end;
+
+
+procedure TWebSocketServer.DoConnect(Sender: TObject; Data: TSocketStream);
+
+Var
+  Con : TWSServerConnection;
+
+begin
+  Con:=CreateWebsocketConnection(Data,Options);
+  Con.OnControl:=@DoControlReceived;
+  Con.OnMessageReceived:=@DoMessageReceived;
+  Con.OnDisconnect:=@DoDisconnect;
+  Con.OnHandshake:=OnConnectionHandshake;
+  if Not AllowConnection(Con) then
+    Con.Free
+  else
+    begin
+    Connections.Add(Con);
+    ConnectionHandler.HandleConnection(Con,True);
+    end;
+end;
+
+procedure TWebSocketServer.DoAcceptError(Sender: TObject; ASocket: Longint; E: Exception; var ErrorAction: TAcceptErrorAction);
+begin
+  HandleError(Nil,E);
+  ErrorAction:=aeaStop;
+end;
+
+procedure TWebSocketServer.DoAcceptIdle(Sender: TObject);
+
+Var
+  doCheckMessages : Boolean;
+
+begin
+  doCheckMessages:=True;
+  if Assigned(OnAcceptIdle) then
+    OnAcceptIdle(Self,doCheckMessages);
+  if doCheckMessages then
+    ConnectionHandler.CheckIncomingMessages;
+end;
+
+procedure TWebSocketServer.DoAllowConnect(Sender: TObject; ASocket: Longint; var Allow: Boolean);
+begin
+  Allow:=True;
+end;
+
+procedure TWebSocketServer.SetAcceptIdleTimeout(AValue: Cardinal);
+begin
+  if FAcceptIdleTimeout=AValue then Exit;
+  CheckInactive;
+  FAcceptIdleTimeout:=AValue;
+end;
+
+procedure TWebSocketServer.SetCertificateData(AValue: TCertificateData);
+begin
+  if FCertificateData=AValue then Exit;
+  CheckInactive;
+  FCertificateData.Assign(AValue);
+end;
+
+function TWebSocketServer.GetActive: Boolean;
+begin
+  Result:=Assigned(FServer);
+end;
+
+procedure TWebSocketServer.SetActive(const aValue: Boolean);
+begin
+  if AValue=GetActive then exit;
+  if AValue then
+    StartServer
+  else
+    StopServer;
+end;
+
+procedure TWebSocketServer.SetThreadMode(AValue: TWSThreadMode);
+begin
+  inherited SetThreadMode(AValue);
+  If (ThreadMode<>wtmThread) and (AcceptIdleTimeout=0) then
+    AcceptIdleTimeout:=DefaultAcceptTimeout;
+end;
+
+
+
+
+procedure TWebSocketServer.FreeServerSocket;
+begin
+  FreeAndNil(FServer);
+  FreeConnectionHandler;
+end;
+
+procedure TWebSocketServer.CreateServerSocket;
+
+begin
+  FServer:=TInetServer.Create(FPort);
+  FServer.OnCreateClientSocketHandler:=@DoCreateClientHandler;
+  FServer.MaxConnections:=-1;
+  FServer.OnConnectQuery:=@DoAllowConnect;
+  FServer.OnConnect:=@DoConnect;
+  FServer.OnAcceptError:=@DoAcceptError;
+  FServer.OnIdle:=@DoAcceptIdle;
+  FServer.AcceptIdleTimeOut:=AcceptIdleTimeout;
+end;
+
+procedure TWebSocketServer.SetupSocket;
+
+begin
+  FServer.QueueSize:=Self.QueueSize;
+  FServer.ReuseAddress:=true;
+end;
+
+
+procedure TWebSocketServer.StartServerSocket;
+begin
+  FServer.Bind;
+  FServer.Listen;
+  if ThreadedAccept then
+    TAcceptThread.Create(Self)
+  else
+    begin
+    StartAccepting;
+    StopServer;
+    end;
+end;
+
+procedure TWebSocketServer.StartAccepting;
+
+begin
+  FActive:=True;
+  FServer.StartAccepting;
+end;
+
+procedure TWebSocketServer.StartServer;
+
+begin
+  StartConnectionHandler;
+  CreateServerSocket;
+  SetupSocket;
+  StartServerSocket;
+end;
+
+procedure TWebSocketServer.StopServer;
+begin
+  FActive:=False;
+  FServer.StopAccepting(True);
+  ConnectionHandler.CloseConnections;
+  WaitForConnections(10);
+  FreeServerSocket;
+end;
+
+procedure TWebSocketServer.CheckIncomingMessages;
+begin
+  if Assigned(ConnectionHandler) then
+    ConnectionHandler.CheckIncomingMessages;
+end;
+
+constructor TWebSocketServer.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FPort:=8080;
+  FQueueSize:=5;
+  FMessageWaitTime:=DefaultWaitTime;
+end;
+
+
+destructor TWebSocketServer.Destroy;
+begin
+  Active:=False;
+  FreeServerSocket;
+  inherited Destroy;
+end;
+
+
+
+end.

packages/fcl-web/src/websocket/wsupgrader.pp

@@ -0,0 +1,247 @@
+unit wsupgrader;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, httpprotocol, httpdefs, fphttpserver, fpwebsocket, fpcustwsserver;
+
+Type
+
+  { TCustomWebsocketUpgrader }
+  TAllowUpgradeEvent = Procedure(Sender : TObject; aRequest : TRequest; var aAllow : Boolean) of object;
+
+  TCustomWebsocketUpgrader = Class(TCustomWSServer)
+  private
+    FActive: Boolean;
+    FOnAllowUpgrade: TAllowUpgradeEvent;
+    FStrictProtocolCheck: Boolean;
+    FUpgradeName: String;
+    FWebServer: TFPCustomHttpServer;
+    FHost: String;
+    function GetHandshakeRequest(aRequest: TFPHTTPConnectionRequest): TWSHandShakeRequest;
+    function GetUpgradeName: String;
+    procedure SetHost(AValue: String);
+    procedure SetUpgradeName(AValue: String);
+    procedure SetWebServer(AValue: TFPCustomHttpServer);
+  Protected
+    // Override from custom server
+    procedure SetActive(const aValue: Boolean); override;
+    function GetActive: Boolean; override;
+    Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    // Start upgrader: register, create connection handler
+    procedure StartUpgrader;
+    // End upgrader: unregister, free connection handler
+    procedure StopUpgrader;
+    // Check callback for upgrader mechanism
+    procedure DoCheck(aRequest: TFPHTTPConnectionRequest; var aHandlesUpgrade: Boolean); virtual;
+    // Upgrade callback for upgrader mechanism
+    procedure DoUpgrade(aConnection: TFPHTTPConnection; aRequest: TFPHTTPConnectionRequest); virtual;
+    // Webserver that we must register with
+    Property WebServer : TFPCustomHttpServer Read FWebServer Write SetWebServer;
+    // If set, only this resource will be acceped for upgrade.
+    Property Host : String Read FHost Write SetHost;
+    // Name to use when registering upgrade mechanism. Defaults to Name.
+    Property UpgradeName : String Read GetUpgradeName Write SetUpgradeName;
+    // Check also Host and Sec-Websocket-Version
+    Property StrictProtocolCheck : Boolean Read FStrictProtocolCheck Write FStrictProtocolCheck;
+    // Called when upgrade request is processed. allow is initialized with check for websocket upgrade.
+    Property OnAllowUpgrade : TAllowUpgradeEvent Read FOnAllowUpgrade Write FOnAllowUpgrade;
+  Public
+    Destructor Destroy; override;
+  end;
+
+  TWebsocketUpgrader = class(TCustomWebsocketUpgrader)
+  Published
+    Property Active; // Registers, unregisters
+    Property WebServer;
+    Property Host;
+    Property Resource;
+    Property StrictProtocolCheck;
+    Property ThreadMode;
+    Property WebSocketVersion;
+    Property MessageWaitTime;
+    Property Options;
+    Property OnAllow;
+    property OnMessageReceived;
+    property OnDisconnect;
+    property OnControlReceived;
+    Property OnError;
+    Property OutgoingFrameMask;
+    Property OnAllowUpgrade;
+  end;
+
+
+implementation
+
+Resourcestring
+  SErrWebserverNotAssigned = 'Webserver not assigned';
+  SErrNoUpgradeName = 'Upgradename not set. Set UpgradeName or Name';
+
+{ TCustomWebsocketUpgrader }
+
+Function TCustomWebsocketUpgrader.GetActive : Boolean;
+
+begin
+  Result:=FActive;
+end;
+
+procedure TCustomWebsocketUpgrader.SetActive(const AValue: Boolean);
+begin
+  if FActive=AValue then Exit;
+  If not Assigned(Webserver) then
+    Raise EWebsocket.Create(SErrWebserverNotAssigned);
+  If (UpgradeName='') then
+    Raise EWebsocket.Create(SErrNoUpgradeName);
+  if aValue then
+    StartUpgrader
+  else
+    StopUpgrader;
+  FActive:=AValue;
+end;
+
+Procedure TCustomWebsocketUpgrader.StartUpgrader;
+
+begin
+  StartConnectionHandler;
+  Webserver.RegisterUpdateHandler(UpgradeName,@DoCheck,@DoUpgrade)
+end;
+
+Procedure TCustomWebsocketUpgrader.StopUpgrader;
+
+begin
+  Webserver.UnRegisterUpdateHandler(UpgradeName);
+  ConnectionHandler.CloseConnections;
+  WaitForConnections(10);
+  FreeConnectionHandler;
+end;
+
+procedure TCustomWebsocketUpgrader.SetHost(AValue: String);
+begin
+  if Host=AValue then Exit;
+  CheckInactive;
+  Host:=AValue;
+end;
+
+
+function TCustomWebsocketUpgrader.GetUpgradeName: String;
+begin
+  Result:=FUpgradeName;
+  if Result='' then
+    Result:=Name;
+end;
+
+procedure TCustomWebsocketUpgrader.DoCheck(aRequest: TFPHTTPConnectionRequest; var aHandlesUpgrade: Boolean);
+
+Var
+  aKey,aVersion : String;
+
+begin
+  aKey:=aRequest.GetFieldByName(SSecWebsocketKey);
+  aVersion:=aRequest.GetFieldByName(SSecWebsocketVersion);
+  // Connection: Upgrade is already checked before we get here
+  aHandlesUpgrade:=SameText(aRequest.Method,'GET')
+                   and SameText(aRequest.GetHeader(hhUpgrade),'WebSocket')
+                   and (aKey<>'');
+  if Host<>'' then
+    aHandlesUpgrade:=aHandlesUpgrade and SameText(aRequest.GetHeader(hhHost),Host);
+  if Resource<>'' then
+    aHandlesUpgrade:=aHandlesUpgrade and aRequest.PathInfo.StartsWith(Resource,True);
+  if StrictProtocolCheck and aHandlesUpgrade then
+    aHandlesUpgrade:=((Host<>'') or (aRequest.GetHeader(hhHost)<>''))    // Check also Host present
+                     and (aVersion<>'');  // and Sec-Websocket-Version
+  if Assigned(OnAllowUpgrade) then
+    OnAllowUpgrade(Self,aRequest,aHandlesUpgrade);
+end;
+
+Function TCustomWebsocketUpgrader.GetHandshakeRequest(aRequest: TFPHTTPConnectionRequest) : TWSHandShakeRequest;
+
+Var
+  aHeaders : TStrings;
+  H : THeader;
+  N,V : String;
+  I : Integer;
+
+begin
+  Result:=Nil;
+  aHeaders:=TStringList.Create;
+  try
+    aHeaders.NameValueSeparator:=':';
+    for H:=Succ(Low(THeader)) to High(Theader) do
+      begin
+      V:=aRequest.GetHeader(H);
+      if V<>'' then
+        aHeaders.Add(HTTPHeaderNames[H]+': '+V);
+      end;
+    For I:=0 to aRequest.CustomHeaders.Count-1 do
+      begin
+      aRequest.CustomHeaders.GetNameValue(I,N,V);
+      V:=Trim(V);
+      if (N<>'') and (V<>'') then
+        aHeaders.Add(N+': '+V);
+      end;
+    Result:=TWSHandShakeRequest.Create(aRequest.PathInfo,aHeaders);
+  Finally
+    aHeaders.Free;
+  end;
+end;
+
+procedure TCustomWebsocketUpgrader.DoUpgrade(aConnection: TFPHTTPConnection; aRequest: TFPHTTPConnectionRequest);
+
+Var
+  aHandShake : TWSHandShakeRequest;
+  aConn : TWSServerConnection;
+
+begin
+  aHandShake:=GetHandshakeRequest(aRequest);
+  try
+    aConn:=CreateWebsocketConnection(aConnection.Socket,Options);
+    aConn.OnControl:=@DoControlReceived;
+    aConn.OnMessageReceived:=@DoMessageReceived;
+    aConn.OnDisconnect:=@DoDisconnect;
+    aConn.OnHandshake:=OnConnectionHandshake;
+    aConn.DoHandshake(aHandshake);
+    Connections.Add(aConn);
+    ConnectionHandler.HandleConnection(aConn,False);
+  finally
+    aHandshake.Free;
+  end;
+end;
+
+destructor TCustomWebsocketUpgrader.Destroy;
+begin
+  FActive:=False;
+  inherited Destroy;
+end;
+
+
+procedure TCustomWebsocketUpgrader.SetUpgradeName(AValue: String);
+begin
+  if aValue=GetUpgradeName then
+    exit;
+  CheckInactive;
+  FUpgradeName:=aValue;
+end;
+
+procedure TCustomWebsocketUpgrader.SetWebServer(AValue: TFPCustomHttpServer);
+begin
+  if FWebServer=AValue then Exit;
+  CheckInactive;
+  if Assigned(FWebServer) then
+    FWebServer.RemoveFreeNotification(Self);
+  FWebServer:=AValue;
+  if Assigned(FWebServer) then
+    FWebServer.FreeNotification(Self);
+end;
+
+procedure TCustomWebsocketUpgrader.Notification(AComponent: TComponent; Operation: TOperation);
+begin
+  inherited Notification(AComponent, Operation);
+  if (Operation=opRemove) and (aComponent=FWebServer) then
+    FWebServer:=Nil;
+end;
+
+
+end.
+