some code from examples/Windows/winsock/clientserver in the FreeBASIC distribution.
I'm short on time, so here's the code:
netmsg.bi:
Code: Select all
'
' Protocol definition
'
#ifndef __NETMSG_BI__
#define __NESMSG_BI__ 1
Type proto
Type As string * 5
UName as string * 31
Msg as string * 81
End Type
' This only defined a header, but that's better than nothing.
' This will allow for a more flexible protocol that's more realistic
' yet still compatable in design as the original "block" protocol.
' The main problem with the original proto is the implementation.
'
' The data packet must be sent in a single TCP/IP packet.
' In the near future, I will design a "connectionless" server
' using datagrams over UDP/IP.
'
Type proto_ng
Type As Integer
User As Integer
Msg As Integer
End Type
#define MAKEMSG(a0,a1,a2,a3) asc(a0) + asc(a1) shl 8 + asc(a2) shl 16 + asc(a3) shl 24
const SERVER_MSG_HELLO = MAKEMSG( "H", "E", "L", "O" )
const SERVER_MSG_SUP = MAKEMSG( "S", "U", "P", "!" )
const SERVER_MSG_CHAT = MAKEMSG( "C", "H", "A", "T" )
const SERVER_MSG_BYE = MAKEMSG( "B", "Y", "E", "!" )
const SERVER_MSG_CYA = MAKEMSG( "C", "Y", "A", "!" )
#endif
Code: Select all
'
' Network messaging server.
' Copyright (C) 2007, Segin<segin2005@gmail.com>
'
' Licensed under the GPLv2
'
' Beware, heavy wizardry at work!
'
#include once "netmsg.bi"
#include once "windows.bi"
#include "win/winsock2.bi"
#ifdef __FB_DOS__
#error "Please provide info on Waterloo TCP/IP to maintainer"
#endif
#ifdef __FB_LINUX__
#include once "netinet/in.bi"
#include once "arpa/inet.bi"
#endif
#ifdef __FB_WIN32__
function hStart( byval verhigh as integer = 2, byval verlow as integer = 0 ) as integer
dim wsaData as WSAData
if( WSAStartup( MAKEWORD( verhigh, verlow ), @wsaData ) <> 0 ) then
return FALSE
end if
if( wsaData.wVersion <> MAKEWORD( verhigh, verlow ) ) then
WSACleanup( )
return FALSE
end if
function = TRUE
end function
function hShutdown( ) as integer
function = WSACleanup( )
end function
#define hPrintError(e) print "error calling "; #e; ": "; WSAGetLastError( )
#endif
#ifdef __FB_LINUX__
'
' Linux does NOT need socket library inits, unlike Windows...
'
function hStart() as integer
return TRUE
end function
function hShutdown() as Integer
return hStart()
end function
#define hPrintError(e) print "error calling "; #e; ": "; perror(#e)
#endif
function hResolve( byval hostname as string ) as integer
dim ia as in_addr
dim hostentry as hostent ptr
'' check if it's an ip address
ia.S_addr = inet_addr( hostname )
if ( ia.S_addr = INADDR_NONE ) then
'' if not, assume it's a name, resolve it
hostentry = gethostbyname( hostname )
if ( hostentry = 0 ) then
exit function
end if
function = *cast( integer ptr, *hostentry->h_addr_list )
else
'' just return the address
function = ia.S_addr
end if
end function
'':::::
function hOpen( byval proto as integer = IPPROTO_TCP ) as SOCKET
dim s as SOCKET
s = opensocket( AF_INET, SOCK_STREAM, proto )
if( s = NULL ) then
return NULL
end if
function = s
end function
'':::::
function hConnect( byval s as SOCKET, byval ip as integer, byval port as integer ) as integer
dim sa as sockaddr_in
sa.sin_port = htons( port )
sa.sin_family = AF_INET
sa.sin_addr.S_addr = ip
function = connect( s, cast( PSOCKADDR, @sa ), len( sa ) ) <> SOCKET_ERROR
end function
'':::::
function hBind( byval s as SOCKET, byval port as integer ) as integer
dim sa as sockaddr_in
sa.sin_port = htons( port )
sa.sin_family = AF_INET
sa.sin_addr.S_addr = INADDR_ANY
function = bind( s, cast( PSOCKADDR, @sa ), len( sa ) ) <> SOCKET_ERROR
end function
'':::::
function hListen( byval s as SOCKET, byval timeout as integer = SOMAXCONN ) as integer
function = listen( s, timeout ) <> SOCKET_ERROR
end function
'':::::
function hAccept( byval s as SOCKET, byval sa as sockaddr_in ptr ) as SOCKET
dim salen as integer
salen = len( sockaddr_in )
function = accept( s, cast( PSOCKADDR, sa ), @salen )
end function
'':::::
function hClose( byval s as SOCKET ) as integer
shutdown( s, 2 )
function = closesocket( s )
end function
'':::::
function hSend( byval s as SOCKET, byval buffer as zstring ptr, byval bytes as integer ) as integer
function = send( s, buffer, bytes, 0 )
end function
'':::::
function hReceive( byval s as SOCKET, byval buffer as zstring ptr, byval bytes as integer ) as integer
function = recv( s, buffer, bytes, 0 )
end function
'':::::
function hIp2Addr( byval ip as integer ) as zstring ptr
dim ia as in_addr
ia.S_addr = ip
function = inet_ntoa( ia )
end function
#define CLIENTADDR(c) *hIp2Addr( c.sin_addr.S_addr ) & "(" & c.sin_addr & ")"
Dim shared sock As SOCKET
Dim ret As Integer
Dim Shared user As ZString * 30
Dim shared packet as Proto
Dim msg As ZString * 80
Dim shared sa As sockaddr_in
Dim shared s As SOCKET
Dim char As Byte
Dim shared nick As String
Dim Shared Connected As Integer
Dim Threads(2) as Any Ptr
Dim Shared Running As Integer
Dim Shared mutex As Any Ptr
const SERVER_PORT = 1337
cls
function serverIni( ) as integer
'' start winsock
if( hStart( ) = FALSE ) then
hPrintError( hStart )
return FALSE
end if
'' create a socket for listening
sock = hOpen( )
if( sock = NULL ) then
hPrintError( hOpen )
return FALSE
end if
'' bind it to the server port
if( hBind( sock, SERVER_PORT ) = FALSE ) then
hPrintError( hBind )
return FALSE
end if
function = TRUE
end function
function GetString(Prompt As String = "> ") As String
Dim char As Byte
Dim Path As String
Dim X As Integer
Dim Y As Integer
Dim TY as Integer
Dim TX As Integer
MutexLock(mutex)
X = CsrLin()
Y = Pos()
Locate 1,1
Print Space(80);
Locate 1,1
Print Prompt;
MutexUnlock(mutex)
do while char <> 13
char = Asc(inkey$)
if char > 31 And char < 127 then
If Len(Path) = 79 Then Goto StartScreenUpdate
If Len(Path) > 79 Then Path = Left(Path,79)
Path+=Chr(char)
Goto StartScreenUpdate
end if
if char = 8 Then
Path = Left(Path, Len(Path) - 1)
Goto StartScreenUpdate
End If
StartScreenUpdate:
MutexLock(mutex)
' Screenlock to prevent flicker
' Useless in console modes
ScreenLock
Locate 1,1
Print Space(80);
Locate 1,1
Print Prompt;
Locate 1,1+Len(Prompt)
Print Right(Path,80 - Len(Prompt));
ScreenUnlock
EndScreenUpdate:
TY = Pos()
TX = CsrLin()
Locate X, Y
sleep 50
X = CsrLin
Y = Pos()
Locate TX, TY
MutexUnlock(mutex)
loop
Locate 1,1
Print Space(80);
Locate X, Y
Return Path
End Function
Sub Quit(ret As Integer = 0)
MutexDestroy(mutex)
End ret
End Sub
Sub UpdateStatusBar()
MutexLock(mutex)
Dim X As Integer
Dim Y As Integer
X = CsrLin()
Y = Pos()
Locate 2,1
Color 0,7
Print Space(80)
Locate 2,2
Print "-- Connection from " + *hIp2Addr( sa.sin_addr.S_addr ) + " (" + nick + ") [server] --"
Color 7,0
Locate X, Y
MutexUnlock(mutex)
End Sub
Color 7,0
mutex = MutexCreate
Running = 1
ret = serverIni( )
if ret = FALSE then
print "Error in netmsgd server init"
hShutdown
Quit
end if
if( hListen( sock ) = FALSE ) then
hPrintError( hListen )
hShutdown
Quit FALSE
end if
locate 3,1
UpdateStatusBar()
Nickname:
Print "Please enter a nick."
msg = GetString("nick> ")
nick = Left(msg,30)
if Len(nick) = 0 goto Nickname
UpdateStatusBar()
Print "Using nickname " + nick
print "Waiting for connection on port 1337"
s = hAccept( sock, @sa )
if( s = INVALID_SOCKET ) then
hPrintError( hAccept )
end if
UpdateStatusBar()
print "Connection from " + *hIp2Addr( sa.sin_addr.S_addr ) + "(" & sa.sin_port & ")"
Connected = 1
Sub SendMsg(mType As String, msg As String)
MutexLock(mutex)
If Len(msg) = 0 Then Exit Sub
packet.msg = msg
packet.type = mType
packet.uname = Cast(String, Left(Nick,30))
hSend(s, @packet, Sizeof(packet))
Color 2
if mType = "CHAT" then
Print packet.uname + ": " + packet.msg
End If
color 7
MutexUnlock(mutex)
UpdateStatusBar()
End Sub
Sub RecvThread()
Dim msg As Proto
Dim bytes As Integer
Dim msgType As String
Dim msgUser As String
Dim msgMsg As String
Dim i as Integer
Do
bytes = hReceive( s, @packet, Sizeof(packet) )
msgUser = Str(bytes)
if bytes <> Sizeof(packet) Then
If bytes = -1 Or bytes = 0 Then
'Server has died without telling us.
print "Connection closed by client."
Connected = 0
cls
hShutdown
quit
Goto EndThread
End If
print "hRecieve() returned " & bytes & " bytes."
Goto EndRecv
End If
Select Case packet.type
Case "CHAT"
' This is the only screen operation IN threaded section
' of program execution in which locking mutex = bad stuff
Color 6
Print packet.uNAME + ": " + packet.msg
color 7
UpdateStatusBar()
Case "BYE!"
SendMsg("CYA!","server to client: clear to disconnect.")
Connected = 0
cls
hShutdown
quit
Goto EndThread
Case else
print !"Unknown packet type:\"" + packet.type + !"\"."
Print "Sizeof(packet) = " & Sizeof(packet) & ", bytes = " & bytes
Sleep(1)
End Select
EndRecv:
Loop
EndThread:
Running = 0
End Sub
Threads(2) = ThreadCreate(@RecvThread)
Do While Connected
msg = GetString
if Left(msg, 5) = "/quit" Then
SendMsg("CYA!","server to client: please disconnect now.")
Connected = 0
Goto EndSend
End If
If Len(msg) > 1 Then
SendMsg("CHAT", msg)
End If
EndSend:
Loop
Running = 0
hClose(s)
hClose(sock)
hShutdown()
cls
quit
Code: Select all
'
' Network messaging client.
' Copyright (C) 2007, Segin<segin2005@gmail.com>
'
' Licensed under the GPLv2
'
' Beware, heavy wizardry at work!
'
#include once "netmsg.bi"
#include "win/winsock2.bi"
#ifdef __FB_DOS__
#error "Please provide info on Waterloo TCP/IP to maintainer"
#endif
#ifdef __FB_LINUX__
#include once "netinet/in.bi"
#include once "arpa/inet.bi"
#endif
#ifdef __FB_WIN32__
function hStart( byval verhigh as integer = 2, byval verlow as integer = 0 ) as integer
dim wsaData as WSAData
if( WSAStartup( MAKEWORD( verhigh, verlow ), @wsaData ) <> 0 ) then
return FALSE
end if
if( wsaData.wVersion <> MAKEWORD( verhigh, verlow ) ) then
WSACleanup( )
return FALSE
end if
function = TRUE
end function
function hShutdown( ) as integer
function = WSACleanup( )
end function
#define hPrintError(e) print "error calling "; #e; ": "; WSAGetLastError( )
#endif
#ifdef __FB_LINUX__
'
' Linux does NOT need socket library inits, unlike Windows...
'
function hStart() as integer
return TRUE
end function
function hShutdown() as Integer
return hStart()
end function
#define hPrintError(e) print "error calling "; #e; ": "; perror(#e)
#endif
function hResolve( byval hostname as string ) as integer
dim ia as in_addr
dim hostentry as hostent ptr
'' check if it's an ip address
ia.S_addr = inet_addr( hostname )
if ( ia.S_addr = INADDR_NONE ) then
'' if not, assume it's a name, resolve it
hostentry = gethostbyname( hostname )
if ( hostentry = 0 ) then
exit function
end if
function = *cast( integer ptr, *hostentry->h_addr_list )
else
'' just return the address
function = ia.S_addr
end if
end function
'':::::
function hOpen( byval proto as integer = IPPROTO_TCP ) as SOCKET
dim s as SOCKET
s = opensocket( AF_INET, SOCK_STREAM, proto )
if( s = NULL ) then
return NULL
end if
function = s
end function
'':::::
function hConnect( byval s as SOCKET, byval ip as integer, byval port as integer ) as integer
dim sa as sockaddr_in
sa.sin_port = htons( port )
sa.sin_family = AF_INET
sa.sin_addr.S_addr = ip
function = connect( s, cast( PSOCKADDR, @sa ), len( sa ) ) <> SOCKET_ERROR
end function
'':::::
function hBind( byval s as SOCKET, byval port as integer ) as integer
dim sa as sockaddr_in
sa.sin_port = htons( port )
sa.sin_family = AF_INET
sa.sin_addr.S_addr = INADDR_ANY
function = bind( s, cast( PSOCKADDR, @sa ), len( sa ) ) <> SOCKET_ERROR
end function
'':::::
function hListen( byval s as SOCKET, byval timeout as integer = SOMAXCONN ) as integer
function = listen( s, timeout ) <> SOCKET_ERROR
end function
'':::::
function hAccept( byval s as SOCKET, byval sa as sockaddr_in ptr ) as SOCKET
dim salen as integer
salen = len( sockaddr_in )
function = accept( s, cast( PSOCKADDR, sa ), @salen )
end function
'':::::
function hClose( byval s as SOCKET ) as integer
shutdown( s, 2 )
function = closesocket( s )
end function
'':::::
function hSend( byval s as SOCKET, byval buffer as zstring ptr, byval bytes as integer ) as integer
function = send( s, buffer, bytes, 0 )
end function
'':::::
function hReceive( byval s as SOCKET, byval buffer as zstring ptr, byval bytes as integer ) as integer
function = recv( s, buffer, bytes, 0 )
end function
'':::::
function hIp2Addr( byval ip as integer ) as zstring ptr
dim ia as in_addr
ia.S_addr = ip
function = inet_ntoa( ia )
end function
#define CLIENTADDR(c) *hIp2Addr( c.sin_addr.S_addr ) & "(" & c.sin_addr & ")"
Dim shared sock As SOCKET
Dim ret As Integer
Dim Shared user As ZString * 30
Dim shared packet as Proto
Dim msg As ZString * 80
Dim shared sa As sockaddr_in
Dim shared s As SOCKET
Dim char As Byte
Dim shared nick As String
Dim Shared Connected As Integer
Dim Threads(2) as Any Ptr
Dim Shared Running As Integer
Dim Shared serv As String * 60
Dim Shared mutex As Any Ptr
const SERVER_PORT = 1337
serv = "0.0.0.0"
cls
function clientIni( ) as integer
'' start winsock
if( hStart( ) = FALSE ) then
hPrintError( hStart )
return FALSE
end if
'' create a socket for a connection
sock = hOpen( )
if( sock = NULL ) then
hPrintError( hOpen )
return FALSE
end if
function = TRUE
end function
function GetString(Prompt As String = "> ") As String
Dim char As Byte
Dim Path As String
Dim X As Integer
Dim Y As Integer
Dim TY as Integer
Dim TX as Integer
MutexLock(mutex)
X = CsrLin()
Y = Pos()
Locate 1,1
Print Space(80);
Locate 1,1
Print Prompt;
MutexUnlock(mutex)
do while char <> 13
char = Asc(inkey$)
if char > 31 And char < 127 then
If Len(Path) = 79 Then Goto StartScreenUpdate
If Len(Path) > 79 Then Path = Left(Path,79)
Path+=Chr(char)
Goto StartScreenUpdate
end if
if char = 8 Then
Path = Left(Path, Len(Path) - 1)
Goto StartScreenUpdate
End If
StartScreenUpdate:
MutexLock(mutex)
' Screenlock to prevent flicker
' Useless in console modes
ScreenLock
Locate 1,1
Print Space(80);
Locate 1,1
Print Prompt;
Locate 1,1+Len(Prompt)
Print Right(Path,80 - Len(Prompt));
ScreenUnlock
EndScreenUpdate:
TY = Pos()
TX = CsrLin()
Locate X, Y
sleep 50
X = CsrLin
Y = Pos()
Locate TX, TY
MutexUnlock(mutex)
loop
Locate 1,1
Print Space(80);
Locate X, Y
Return Path
End Function
Sub Quit(ret As Integer = 0)
MutexDestroy(mutex)
End ret
End Sub
Sub UpdateStatusBar()
MutexLock(mutex)
Dim X As Integer
Dim Y As Integer
X = CsrLin()
Y = Pos()
Locate 2,1
Color 0,7
Print Space(80)
Locate 2,2
Print "-- Connected to " + serv + " (" + nick + ") [client] --"
Color 7,0
Locate X, Y
MutexUnlock(mutex)
End Sub
Color 7,0
mutex = MutexCreate
Running = 1
ret = clientIni( )
if ret = FALSE then
print "Error in netmsg client init"
hShutdown
Quit(FALSE)
end if
locate 3,1
UpdateStatusBar()
Nickname:
Print "Please enter a nick."
msg = GetString("nick> ")
nick = Left(msg,30)
if Len(nick) = 0 goto Nickname
UpdateStatusBar()
Print "Using nickname " + nick
Print "Please enter the server address (IP or hostname)"
serv = Left(GetString("server> "),60)
UpdateStatusBar()
print "Connecting to " +serv + " on port 1337"
if( hConnect( sock, hResolve( serv ), 1337 ) = FALSE ) then
hPrintError( hConnect )
quit
end if
print "Connected to " + serv + "(" & 1337 & ")"
Connected = 1
Sub SendMsg(mType As String, msg As String)
MutexLock(mutex)
If Len(msg) = 0 Then Exit Sub
packet.msg = msg
packet.type = "CHAT"
packet.uname = Cast(String, Left(Nick,30))
hSend(sock, @packet, Sizeof(packet))
Color 2
if mType = "CHAT" then
Print packet.uname + ": " + packet.msg
End If
color 7
MutexUnlock(mutex)
UpdateStatusBar()
End Sub
Sub RecvThread()
Dim msg As Proto
Dim bytes As Integer
Dim msgType As String
Dim msgUser As String
Dim msgMsg As String
Dim i as Integer
Do
msgType = "" : msgUser = "" : msgMsg = ""
bytes = hReceive( sock, @packet, Sizeof(packet) )
if bytes <> Sizeof(packet) Then
If bytes = -1 Or bytes = 0 Then
'Server has died without telling us.
print serv +": Connection closed by remote host."
Connected = 0
cls
hShutdown
quit
Goto EndThread
End If
print "hRecieve() returned " & bytes & " bytes."
Goto EndRecv
End If
Select Case packet.type
Case "CHAT"
Color 6
Print packet.uNAME + ": " + packet.msg
Color 7
UpdateStatusBar()
Case "CYA!"
Connected = 0
cls
hShutdown
quit
Goto EndThread
Case else
print !"Unknown packet type:\"" + packet.type + !"\"."
Print "Sizeof(packet) = " & Sizeof(packet) & ", bytes = " & bytes
Sleep(1)
End Select
EndRecv:
Loop
EndThread:
Running = 0
End Sub
Threads(2) = ThreadCreate(@RecvThread)
Do While Connected
msg = GetString
if Left(msg, 5) = "/quit" Then
SendMsg("BYE!","client to server: request to disconnect.")
Sleep(4000)
Goto EndSend
End If
If Len(msg) > 1 Then
SendMsg("CHAT", msg)
End If
EndSend:
Loop
Running = 0
hClose(s)
hClose(sock)
hShutdown()
cls
quit
Code: Select all
This is Netmsg version 1.0
============================
Netmsg is a two-way communications system that runs in a client-server fashion.
One machine run as the server, and another as a client. Netmsg is basically a
simple instant-messaging system.
The server will only handle one client. Any attempts to connect additional
clients will not work (they will connect, but the server has no means of
attaching to them)
This program is currently Win32-specific, but would require VERY minor changes
for Linux support. There is no DOS support, but if I find a copy of the DOS
pthreads library, I might be able to convince the FreeBASIC maintainers to
use it for RTLib's DOS target. DOS support will also require Waterloo TCP.
This program is also very CPU and memory efficent. The total CPU usage
for a 30 minute chat session (in seconds) is around 15 seconds for both
client and server.
It might seem odd that the client and server act a lot alike. The client is
actually a modified version of the server's code.
To compile:
fbc serv.bas
fbc client.bas
RUNNING NETMSG
===========================
Netmsg is designed with a server-client model. Thus, the server machine must
be started before the client can connect. Please note that the client CAN
connect to the server as soon as it is started, but any messages sent by the
client to the server before the chat nickname is entered on the server are
silently dropped. This is belived to be a bug in the server, but I don't feel
like fixing it.
BUG REPORTS
============================
Netmsg has a few graphical glitches at times, and most of the potential ones
are taken care of (prevented) by using mutexes and thread locking. On
occasion, the status bar will end up being shown twice, on the input entry
line. This is not fatal, and will not affect the running of the program.
If something serious happens, please send a sensible and in-depth report to
segin2005@gmail.com. Send an email saying something "netmsg crashed, pls help"
tells me nothing. It's like finding a dead body. Sure, you know he's dead, but
you don't know how he died, or who you need to arrest for his murder, or even
if it was murder at all!
TEXT ENTRY (FOR ADVANCED USERS AND PROGRAMMERS)
============================
Netmsg uses a custom-made input entry loop. The loop is capable of managing
text slightly better than the traditional BASIC input statements, including
the ability to save the cursor position for incoming messages and restore it
after preforming the input check. Input is checked every 50 milliseconds. One
side effect of the save/restore of the cursor position is that the console
caret will always appear in the message area. This can be confusing if you
accidently type a space, and then leave your computer. It it probably possible
to emulate the proper cursor, it would probably break the code. If it ain't
broke, don't fix it.