' Server_API.BAS by John White (danilo_yoingco@yahoo.co.uk)
'
' Server_API.BAS uses WSA_ Asynchronous (Multi-Tasking) calls to
' allow the server to monitor Client connections.
'
' mem_Default      -  400 bytes for the WSADATA structure.
' mem_Default+400  -  1024 bytes for the hostEnt data.
' mem_Default+1424 -  16 bytes for (Server) Sockaddr_in structure.
' mem_Default+1440 -  16 bytes for (Client) Sockaddr_in structure.
'                     I have allocated space for 20 Clients (16*20).
' mem_Default+1760 -
' mem_Default+1900 -  256 bytes for the Read/Receive Buffer.
' mem_Default+2156 -  256 bytes for the Write/Send Buffer.

$OPTIMIZE ON
$APPTYPE GUI
$TYPECHECK ON
$ESCAPECHARS ON

' Registry.
Const HKEY_LOCAL_MACHINE=&H80000002
Const KEY_ALL_ACCESS=&HF003F
Const ERROR_SUCCESS=0

' Memory.
Const GMEM_FIXED=0
Const GMEM_MOVEABLE=2
Const GMEM_ZEROINIT=64
Const GMEM_INVALID_HANDLE=&H8000

' Window.
Const WM_COMMAND=&H111
Const WM_CLOSE=16
Const WM_USER=1024

' Socket.
Const AF_INET=2
Const SOCK_STREAM=1
Const VERSION_1_1=257
Const VERSION_2_2=514
Const MAXGETHOSTSTRUCT=1024
Const SM_GETHOST=WM_USER+1
Const SM_ASYNC=WM_USER+2
Const FD_READ=1
Const FD_WRITE=2
Const FD_OOB=4
Const FD_ACCEPT=8
Const FD_CONNECT=16
Const FD_CLOSE=32
Const INADDR_ANY=&H00000000
Const IPPROTO_IP=0
Const IPPROTO_TCP=6
Const SOCKET_ERROR=-1
Const INVALID_SOCKET=-1

Declare Function accept Lib "wsock32.dll" Alias "accept" (hsocket As Long, sockaddr As Long, saSize As Long) As Long
Declare Function BindAddr Lib "wsock32.dll" Alias "bind" (hsocket As Long, sockaddr As Long, saSize As Long) As Long
Declare Function connect Lib "wsock32.dll" Alias "connect" (hsocket As Long, sockaddr As Long, saSize As Long) As Long
Declare Function closesocket Lib "wsock32.dll" Alias "closesocket" (hsocket As Long) As Long
Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal dest As LONG, ByVal source As LONG, ByVal numBytes As LONG)
Declare Function GetLastError Lib "kernel32.dll" Alias "GetLastError" () As Long
Declare Function GlobalAlloc Lib "kernel32.dll" Alias "GlobalAlloc" (flags As Long, numBytes As Long) As Long
Declare Function GlobalFree Lib "kernel32.dll" Alias "GlobalFree" (hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32.dll" Alias "GlobalLock" (hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32.dll" Alias "GlobalUnlock" (hMem As Long) As Long
Declare Function htonl Lib "wsock32.dll" Alias "htonl" (hbo As Long) As Long
Declare Function htons Lib "wsock32.dll" Alias "htons" (hbo As Word) As Word
Declare Function inet_addr Lib "wsock32.dll" Alias "inet_addr" (dottedAdr As String) As Long
Declare Function listen Lib "wsock32.dll" Alias "listen" (hsocket As Long, backlog As Long) As Long
Declare Function recv Lib "wsock32.dll" Alias "recv" (hsocket As Long, buffer As Long, buflen As Long, flags As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" Alias "RegCloseKey" (rootKey As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (rootKey As Long, subKey As String, options As Long, access As Long, status As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (rootKey As Long, valueName As String, reserved As Long, valueType As Long, buffer As Long, bufsize As Long) As Long
Declare Function send Lib "wsock32.dll" Alias "send" (hsocket As Long, buffer As Long, buflen As Long, flags As Long) As Long
Declare Function socket Lib "wsock32.dll" Alias "socket" (af As Long, stype As Long, protocol As Long) As Long
Declare Function WSAAsyncGetHostByName Lib "wsock32.dll" Alias "WSAAsyncGetHostByName" (hwnd As Long, wMsg As Long, hostName As String, hostEnt As Long, heSize As Long) As Long
Declare Function WSAAsyncSelect Lib "wsock32.dll" Alias "WSAAsyncSelect" (hSocket As Long, hwnd As Long, wMsg As Long, bitmask As Long) As Long
Declare Function WSACleanup Lib "wsock32.dll" Alias "WSACleanup" () As Long
Declare Function WSAGetLastError Lib "wsock32.dll" Alias "WSAGetLastError" () As Long
Declare Function WSAStartup Lib "wsock32.dll" Alias "WSAStartup" (version As Word, wsaData As Long) As Long
Declare Sub window_Proc (Handle As Long, uMsg As Long, wParam As Long, lParam As Long)

' Socket Variables.
DIM key_handle AS LONG, host_handle AS LONG, timer0 AS QTIMER
DIM timer0_status AS BYTE, counter AS BYTE, clientSocket(0 TO 19) AS LONG
DIM hostName$ AS STRING, serverSocket AS LONG, susts AS BYTE
DIM asyncMsg AS LONG, readBuffer$ AS STRING, writeBuffer$ AS STRING
DIM bytesRead AS LONG, tc0 AS BYTE

' Memory Variables.
DIM mem_Lock AS LONG, mem_Memory AS LONG, mem_Default AS LONG
DIM mem_Offset AS LONG, FLong AS LONG, FWord AS WORD, FByte AS BYTE
DIM FFour AS LONG

' Generic Variables.
DIM rtn AS LONG, rtnval AS LONG, stg$ AS STRING, slen AS LONG
DIM count AS LONG, window AS QForm

window.WndProc=window_Proc
timer0.Enabled=0 : timer0.Interval=1000 : timer0_status=0
hostName$=STRING$(16,0)
readBuffer$=STRING$(256,0)
writeBuffer$=STRING$(256,0)
susts=0
counter=0
tc0=0

SUB UnLock_DefaultMemory
IF mem_Lock<>0 THEN
rtn=GlobalUnlock(mem_Lock)
IF ((rtn=0) AND (GetLastError()=0)) THEN
'MEM UNLOCKED
ELSE
'MEM NOT UNLOCK
END IF
END IF
END SUB

SUB Free_DefaultMemory
IF mem_Memory<>0 THEN
rtn=GlobalFree(mem_Memory)
IF rtn=0 THEN
'MEM FREED
ELSE
'MEM NOT FREED
END IF
END IF
END SUB

SUB Alloc_DefaultMemory(bufsize AS LONG)
mem_Lock=0
mem_Memory=0
mem_Default=0
mem_Memory=GlobalAlloc(GMEM_MOVEABLE OR GMEM_ZEROINIT, bufsize)
IF mem_Memory<>0 THEN
mem_Lock=GlobalLock(mem_Memory)
IF mem_Lock<>0 THEN
mem_Default=mem_Lock

END IF
END IF
END SUB

SUB timer0_Code
timer0.Interval=1000
IF tc0=0 THEN
tc0=1
' mem_Default+1440+.... will hold a SOCKADDR_IN structure (16 bytes)
' for each accepted (connected) Client.
rtnval=16
clientSocket(counter)=accept(serverSocket,mem_Default+1440+(counter*16),VarPtr(rtnval))
IF clientSocket(counter)<>INVALID_SOCKET THEN
stg$="Welcome Client "+str$(counter)
rtn=send(clientSocket(counter),VarPtr(stg$),LEN(stg$),0)
IF rtn<>SOCKET_ERROR THEN
INC counter
ShowMessage("Client Connected To Server")
END IF
' closesocket(clientSocket(counter))
END IF
tc0=0
END IF
END SUB

SUB timer0_Off
IF timer0_status=1 THEN
timer0.Enabled=0
timer0_status=0
END IF
END SUB

SUB timer0_On
IF timer0_status=0 THEN
timer0.Enabled=1
timer0_status=1
END IF
END SUB

SUB do_ReadData
stg$=VarPtr$(mem_Default+1990)
ShowMessage("Client Wrote: "+stg$)
END SUB

SUB do_AsyncMsg(wParam As Long,lParam As Long)
asyncMsg=(lParam AND &H0000FFFF) ' WSAGETSELECTEVENT(lParam) MACRO.

SELECT CASE asyncMsg

CASE FD_CONNECT
ShowMessage("Client Connected")

CASE FD_WRITE
stg$="Hello Client"
rtn=send(serverSocket,VarPtr(stg$),LEN(stg$),0)

CASE FD_READ
IF clientSocket(0)<>0 THEN
bytesRead=recv(clientSocket(0),mem_Default+1990,256,0)
IF bytesRead=0 THEN
' Connection has Closed.
ELSEIF bytesRead=SOCKET_ERROR THEN
' error.
ELSE
do_ReadData
END IF
END IF

CASE FD_CLOSE
ShowMessage("Client Closed")

CASE ELSE

END SELECT
END SUB

SUB setup_server(wParam As Long,lParam As Long)
IF wParam=host_handle THEN
rtn=(lParam AND &HFFFF0000) ' WSAGETASYNCERROR(lParam) MACRO.
IF rtn=0 THEN
' Here I have used the TCP protocol. If you do not want to use a
' particular protocol just use the IPPROTO_IP (default) protocol.
serverSocket=socket(AF_INET,SOCK_STREAM,IPPROTO_TCP)
IF serverSocket<>INVALID_SOCKET THEN
rtn=WSAAsyncSelect(serverSocket,window.Handle,SM_ASYNC,FD_CONNECT OR FD_READ OR FD_WRITE OR FD_CLOSE)
IF rtn=0 THEN
' This is the SOCKADDR_IN structure (16 bytes) for the Server.
FWord=AF_INET
CopyMemory mem_Default+1424, VarPtr(FWord), 2 ' sin_family
FWord=htons(5000)
CopyMemory mem_Default+1426, VarPtr(FWord), 2 ' sin_port
FLong=htonl(INADDR_ANY)
CopyMemory mem_Default+1428, VarPtr(FLong), 4 ' sin_addr
' 1032 to 1039 - 8 (zero) bytes for sin_zero.

' I had to rename BIND to BindAddr, as RapidQ is using Bind.
rtn=BindAddr(serverSocket,mem_Default+1424,16)
IF rtn=0 THEN
rtn=listen(serverSocket,6)
IF rtn=0 THEN

END IF
END IF
END IF
END IF
END IF
END IF
END SUB

SUB window_Proc(Handle As Integer,uMsg As DWord,wParam As Long,lParam As Long)

SELECT CASE uMsg

CASE WM_CLOSE
IF susts=1 THEN
' DO NOT call WSACleanup() etc from here - Allow this program to go
' to the end of the code to do its cleanup.

' Cleanup any remaining messages/Reads.
bytesRead=recv(serverSocket,mem_Default+1900,256,0)
WHILE ((bytesRead<>0) AND (bytesRead<>SOCKET_ERROR))
bytesRead=recv(serverSocket,mem_Default+1900,256,0)
WEND
closesocket(serverSocket)
END IF

CASE SM_GETHOST
setup_server(wParam,lParam)
timer0_On

CASE SM_ASYNC
do_AsyncMsg(wParam,lParam)

CASE ELSE

END SELECT

END SUB

' ------------------------------ Startup calls -------------------------

' Allocate a default buffer for Socket calls.
Alloc_DefaultMemory(3000)

timer0.OnTimer=timer0_Code

' WSAStartup() MUST be called before doing any other Socket calls.
rtn=WSAStartup(VERSION_1_1,mem_Default)
IF rtn=0 THEN
' Check if version 2.2 of the socket library is available. The version
' numbers are just a WORD, with MSB = 2 (bit 1 - value 512) and LSB = 2
' (bit 1 - value 2). So the WORD has a value of 514 to represent 2.2
CopyMemory VarPtr(FWord), mem_Default, 2
IF FWord=VERSION_1_1 THEN
' This registry key opens the hostname key, which is just the Computer`s
' name that the server is residing on.
rtn=RegOpenKeyEx(HKEY_LOCAL_MACHINE,"System\\CurrentControlSet\\Services\\VxD\\MSTCP",0,KEY_ALL_ACCESS,VarPtr(key_Handle))
IF rtn=ERROR_SUCCESS THEN
rtnval=LEN(hostName$)
rtn=RegQueryValueEx(key_handle,"hostName",0,VarPtr(rtnval),VarPtr(hostName$),VarPtr(rtnval))
IF rtn=ERROR_SUCCESS THEN
' This gets the hostEnt structure, which gives details about the host.
host_handle=WSAAsyncGetHostByName(window.Handle,SM_GETHOST,hostName$,mem_Default+400,MAXGETHOSTSTRUCT)
IF host_handle<>0 THEN
susts=1 ' Success! StartUp STatuS is assigned value 1.
END IF
END IF
rtn=RegCloseKey(key_handle)
IF rtn=ERROR_SUCCESS THEN

ELSE
' Error
END IF
END IF

IF susts=1 THEN window.ShowModal

END IF
rtn=WSACleanup
IF rtn=SOCKET_ERROR THEN
' Error
END IF
END IF

UnLock_DefaultMemory
Free_DefaultMemory