rServer2 for PBFORMS

Mike Doty
Member
Join Date: Feb 2005
Posts: 8163
15 Sep 2009, 10:21 PM
Original code with include files at http://www.greatwebdivide.com/files/rserver2.zip
Code:
 
#PBFORMS CREATED V1.51
'Original code with include files at http://www.greatwebdivide.com/files/rserver2.zip
'
'  rserver.bas
'
'  multi-threaded, multi-homed, tcp-based, remote binary data server
'
'  By Don Dickinson modified by Mike Doty  9/15/09 for use with PBFORMS
'  Hereby Public Domain
'  Use implies that you hold the author, Don Dickinson, harmless from any
'  responsibility for effects or side-effects of using this code. It is
'  provided in good faith by the auther - you are using it at your own
'  risk.
#COMPILE EXE
#DIM ALL
'------------------------------------------------------------------------------
'   ** Includes **
'------------------------------------------------------------------------------
#PBFORMS BEGIN INCLUDES
#IF NOT %DEF(%WINAPI)
    #INCLUDE "WIN32API.INC"
#ENDIF
#PBFORMS END INCLUDES
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'   ** Constants **
'------------------------------------------------------------------------------
#PBFORMS BEGIN CONSTANTS
%LOG_DETAILED =   0 '*
%labIP        = 801
%labPort      = 802
%labDate      = 803
%labHits      = 804
%labActive    = 805
%labAction    = 806
%btnStop      = 807
%timer1       = 808
%IDD_DIALOG1  = 101
#PBFORMS END CONSTANTS
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  Included files
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#INCLUDE "win32api.inc"          'windows api, constants, structures
#INCLUDE "wsconst.inc"           'winsock structures and constants
#INCLUDE "pb_file.bas"           'various file and directory routines
#INCLUDE "pb_ini.bas"            '.ini file handling
#INCLUDE "rserver.inc"           'rserver specific constants and structures
REM %DEFAULT_PORT                'might make these variables
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  Globals
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GLOBAL gDlgMain AS LONG          'handle for main dialog window
GLOBAL gLog  AS LONG             'handle to log file
GLOBAL gShutdown AS LONG         'flag telling system to abort and close conns
GLOBAL gSock() AS LONG           'array of client connection sockets
GLOBAL gMainSock() AS LONG       'array of listening sockets
GLOBAL gThread() AS LONG         'array of running threads
GLOBAL gThreadRunning() AS LONG  'array that indicates if a thread has finished
GLOBAL gActive AS LONG           'number of active connections
GLOBAL gHits AS LONG             'total hits
GLOBAL gPort AS LONG             'connection port
GLOBAL gIPAddr() AS LONG         'array of ip addresses being listed to
GLOBAL gIPCount AS LONG          'count of ip addresses being listed to
GLOBAL gCS AS CRITICAL_SECTION   'critical section structure
GLOBAL gIniFile AS STRING        'ini file name and path
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  tcpSafeReceive
'  Specify a length of data to wait for and this function
'  retrieves data until all data has filled the buffer or
'  an error occurs.
'  Returns: %True on success, %False on error
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION tcpSafeReceive(BYVAL hSocket AS LONG, BYVAL iBufferLen AS LONG, _
                        recBuff AS STRING) AS LONG
   DIM iLeft AS LONG
   DIM sBuffer AS STRING
   recBuff = ""
   iLeft = iBufferLen
 
   DO
      sBuffer = SPACE$(iLeft)
      TCP RECV hSocket, iLeft, sBuffer
      IF ERR THEN
         FUNCTION = %False
         EXIT FUNCTION
      END IF
      recBuff = recBuff + LEFT$(sBuffer,iLeft)
 
      IF LEN(recBuff) >= iBufferLen THEN
         EXIT DO
      ELSEIF LEN(RecBuff) = 0 THEN
         EXIT DO
      ELSEIF LEN(sBuffer) = 0 THEN
        EXIT DO
      END IF
      iLeft = iBufferLen - LEN(recBuff)
      SLEEP 5
   LOOP
   FUNCTION = %True
END FUNCTION
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  FormatIP
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION FormatIP(RawAddr AS LONG) AS STRING
   DIM sAddr AS STRING
   sAddr = MKL$(RawAddr)
   FUNCTION = FORMAT$(ASC(MID$(sAddr, 1, 1))) + "." + _
              FORMAT$(ASC(MID$(sAddr, 2, 1))) + "." + _
              FORMAT$(ASC(MID$(sAddr, 3, 1))) + "." + _
              FORMAT$(ASC(MID$(sAddr, 4, 1)))
END FUNCTION
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  LogEvent
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUB LogEvent(BYVAL buffer AS STRING)
   IF gLog THEN
      PRINT #gLog, DATE$ + " " + TIME$ + " " + Buffer
   END IF
END SUB
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  EnterCritical
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUB EnterCritical
   EnterCriticalSection gCS
END SUB
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  LeaveCritical
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUB LeaveCritical
   LeaveCriticalSection gCS
END SUB
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  DisplayEvent
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUB DisplayEvent(BYVAL buffer AS STRING)
   gHits = gHits + 1
   IF gHits > 2000000000 THEN
      gHits = 1
   END IF
   CONTROL SET TEXT gDlgMain, %labAction, TIME$ + "  " + Buffer
   CONTROL SET TEXT gDlgMain, %labActive, FORMAT$(gActive)
   CONTROL SET TEXT gDlgMain, %labHits, FORMAT$(gHits)
END SUB
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  ThreadCleanup
'  If a thread has finished executing, but the thread handle
'  has not been closed, I close it here. This is called by a
'  timer that goes off every %TIMER_INTERVAL milliseconds
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUB ThreadCleanup()
   DIM i AS LONG
   DIM foo AS LONG
   FOR i = 1 TO %MAX_CONNECTIONS
      IF gThread(i) THEN
         IF gThreadRunning(i) = %False THEN
            THREAD CLOSE gThread(i) TO foo
            gThread(i) = 0
         END IF
      END IF
   NEXT i
END SUB
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  InitListen
'  Starts all ip ports listening
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUB InitListen()
   'called by InitDialog
   DIM i AS LONG
   FOR i = 1 TO %MAX_IP_WAIT   'how many interfaces in rserver.inc
      IF gIPAddr(i) <> 0 THEN
         gMainSock(i) = FREEFILE
         TCP OPEN SERVER ADDR gIPAddr(i) PORT gPort AS gMainSock(i) TIMEOUT %TCP_TIMEOUT
         IF ERR THEN
            MSGBOX "Unable to listen to " + FormatIP$(gIPAddr(i)) + _
                   " Err=" + FORMAT$(ERR)
         ELSE
            TCP NOTIFY gMainSock(i), ACCEPT TO gDlgMain AS %TCP_CONNECT
         END IF
      END IF
   NEXT i
 
END SUB
 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  rsCommand
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION rsCommand (BYVAL iCurrentSocket AS LONG, rIn AS XFER_BUFFER_TYPE, _
                   sInBuffer AS STRING) AS LONG
   DIM i AS LONG
   DIM iMoreLeft AS LONG
   DIM iLen AS LONG
   DIM sFile AS STRING
   DIM sReturn AS STRING
   DIM sBuffer AS STRING
   DIM rOut AS XFER_BUFFER_TYPE
   iMoreLeft = %True
   SELECT CASE rIn.iCommand
      '-------- OPEN FILE FOR SHARED ACCESS
      CASE %RSERVER_OPEN_FILE
         '- The length of the file name is the first
         '  two bytes (integer) after the structure.
         '  The file name follows it's length
         '
         sFile = TRIM$(MID$(sInBuffer, 3, CVI(MID$(sInBuffer, 1, 2))))
         LogEvent "OPEN " + sFile
         DisplayEvent "Open File " + sFile
         '- Open the file. If there's an error, the error
         '  is stored in the iResult member. Otherwise,
         '  the file handle is given to the iFile member.
         '
         EnterCritical
         ON ERROR RESUME NEXT
         rOut.iFile = FREEFILE
         OPEN sFile FOR BINARY SHARED AS #rOut.iFile
         IF ERR THEN
            rOut.iFile = 0
         END IF
         rOut.iResult = ERR
         rOut.iDataLen = 0
         LeaveCritical
         '- Send back the results structure
         sReturn = SPACE$(LEN(rOut))
         LSET sReturn = rOut
         TCP SEND iCurrentSocket, sReturn
      '-------- CLOSE FILE
      CASE %RSERVER_CLOSE_FILE
         LogEvent "CLOSE FILE " + FORMAT$(rIn.iFile)
         DisplayEvent "CLOSE " + FORMAT$(rIn.iFile)
         CLOSE #rIn.iFile
         rOut.iResult = 0
         rOut.iDataLen = 0
         rOut.iFile = 0
         sReturn = SPACE$(LEN(rOut))
         LSET sReturn = rOut
         TCP SEND iCurrentSocket, sReturn
      '-------- GET DATA FROM FILE
      CASE %RSERVER_GET
         DisplayEvent "GET " + FORMAT$(rIn.iFile)
         '- How much data do they want?
         iLen = CVL(LEFT$(sInBuffer, 4))
         '- Retrieve the data from the file
         ON ERROR RESUME NEXT
         sBuffer = SPACE$(iLen)
         GET #rIn.iFile,, sBuffer
         IF ERR THEN
            sBuffer = ""
            rOut.iDataLen = 0
         ELSE
            rOut.iDataLen = LEN(sBuffer)
         END IF
         rOut.iResult = ERR
         rOut.iFile = rIn.iFile
         '- Send back the response with the data
         sReturn = SPACE$(LEN(rOut))
         LSET sReturn = rOut
         sReturn = sReturn + sBuffer
         TCP SEND iCurrentSocket, sReturn
 
      '-------- WRITE DATA TO FILE
      CASE %RSERVER_PUT
         DisplayEvent "PUT " + FORMAT$(rIn.iFile)
         ON ERROR RESUME NEXT
         'Write everything to disk in 1-shot 'Mike Doty
         PUT #rIn.iFile,, sInBuffer
         FLUSH #rIn.iFile           'Mike Doty
         rOut.iResult = ERR
         rOut.iFile = rIn.iFile
         rOut.iDataLen = 0
         sReturn = SPACE$(LEN(rOut))
         LSET sReturn = rOut
         TCP SEND iCurrentSocket, sReturn
      '-------- SEEK A POSITION IN THE FILE
      CASE %RSERVER_SEEK
         DisplayEvent "SEEK " + FORMAT$(rIn.iFile)
         ON ERROR RESUME NEXT
         SEEK #rIn.iFile, CVL(LEFT$(sInBuffer, 4))
         rOut.iFile = rIn.iFile
         rOut.iResult = ERR
         rOut.iDataLen = 0
         sReturn = SPACE$(LEN(rOut))
         LSET sReturn = rOut
         TCP SEND iCurrentSocket, sReturn
      '-------- GET LENGTH OF THE FILE
      CASE %RSERVER_LOF
         DisplayEvent "LOF " + FORMAT$(rIn.iFile)
         ON ERROR RESUME NEXT
         i = LOF(rIn.iFile)
         IF ERR THEN
            rOut.iDataLen = 0
            sBuffer = ""
         ELSE
            rOut.iDataLen = 4
            sBuffer = MKL$(i)
         END IF
         rOut.iFile = rIn.iFile
         rOut.iResult = ERR
         sReturn = SPACE$(LEN(rOut))
         LSET sReturn = rOut
         sReturn = sReturn + sBuffer
         TCP SEND iCurrentSocket, sReturn
      '----------- No more to come
      CASE %RSERVER_QUIT
         iMoreLeft = %False
      '----------- UNKNOWN instruction
      CASE ELSE
         LogEvent "UNKNOWN INSTRUCTION:" + STR$(rIn.iCommand)
         DisplayEvent "Unknown Instruction:" + STR$(rIn.iCommand)
         rOut.iResult = 0
         rOut.iFile = 0
         rOut.iDataLen = 0
         sReturn = SPACE$(LEN(rOut))
         LSET sReturn = rOut
         TCP SEND iCurrentSocket, sReturn
   END SELECT
   FUNCTION = iMoreLeft
END FUNCTION
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  tcpHandleConnection
'  This function is called to create a new thread.  It sits in a loop
'  responding to requests until the socket is closed (this generates an
'  error an the loop bails out. When it finishes, it closes the socket.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
THREAD FUNCTION tcpHandleConnection( BYVAL iWhich AS LONG ) AS LONG
   DIM i AS LONG
   DIM iCurrentSocket AS LONG
   DIM iLen AS LONG
   DIM sFile AS STRING
   DIM sResult AS STRING
   DIM sBuffer AS STRING
   DIM sInBuffer AS STRING
   DIM rOut AS XFER_BUFFER_TYPE
   DIM rIn AS XFER_BUFFER_TYPE
   gThreadRunning(iWhich) = %True
   iCurrentSocket = gSock(iWhich)
   DO
      '- If this fails, then there was a tcp error
      IF tcpSafeReceive(iCurrentSocket, LEN(rIn), sBuffer) = %False THEN
         EXIT DO
      '- Monitor the global shutdown flag
      ELSEIF gShutdown THEN
         EXIT DO
      '- Process the data
      ELSE
         LSET rIn = sBuffer
         '- Get the variable portion of the buffer
         IF rIn.iDataLen > 0 THEN
            tcpSafeReceive iCurrentSocket, rIn.iDatalen, sInBuffer
         END IF
         '- This returns %False if the client sent a disconnect
         IF rsCommand(iCurrentSocket, rIn, sInBuffer) = %False THEN
            EXIT DO
         END IF
      END IF
      SLEEP 5
   LOOP
   TCP CLOSE gSock(iWhich)
   gSock(iWhich) = %INVALID_SOCKET
   gThreadRunning(iWhich) = %False
   gActive = gActive - 1
   DisplayEvent "Disconnect: " + FORMAT$(iWhich)
   FUNCTION = %True
END FUNCTION
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  StopButton
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CALLBACK FUNCTION btnStop_Click()
   DIALOG END gDlgMain, 0
   FUNCTION = 1
END FUNCTION
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  Initialize
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION Initialize() AS LONG
   DIM i AS LONG
   '- The configuration file is called rserver.ini
   '  and must be in the same directory as rserver.exe
   '
   gIniFile = TRIM$(ExtractPath(GetExeName()))
   IF RIGHT$(gIniFile, 1) <> "\" THEN
      gIniFile = gIniFile + "\"
   END IF
   gIniFile = gIniFile + "rserver.ini"
   '- This is a multi-threaded application.
   '  I use a critical section to resolve thread conflicts
   '
   InitializeCriticalSection gCS
   '- This program can be set to be multi-homed - that is,
   '  listen on more than one IP address. The IP addresses
   '  are specified in the rserver.ini file required to be
   '  in the same directory as rserver.exe. If it is not
   '  there, then the default IP address for this computer
   '  is assumed. This is based on what is returned
   '  by Host ADDR "" To
   '
   gIPCount = 0
   REDIM gIPAddr(%MAX_IP_WAIT) AS LONG
   FOR i = 1 TO %MAX_IP_WAIT
      gIPAddr(i) = INT(VAL(GetIni(gIniFile, "server", "IPAddr" + FORMAT$(i), "0")))
      IF gIPAddr(i) <> 0 THEN
         INCR gIPCount
      END IF
   NEXT i
   REDIM gMainSock(%MAX_IP_WAIT) AS LONG
   '- Set the default if none were found in the .ini
   IF gIPCount < 1 THEN
      gIPCount = 1
      HOST ADDR "" TO gIPAddr(1)
   END IF
   '- The port is an .ini setting. There is a constant
   '  for the default.
   '
   gPort = INT(VAL(GetIni(gIniFile, "server", "port", FORMAT$(%DEFAULT_PORT))))
   '- These are our connection place holders. Fill up the list with
   '  invalid connections.
   '
   REDIM gSock(1 TO %MAX_CONNECTIONS) AS LONG
   FOR i = 1 TO %MAX_CONNECTIONS
      gSock(i) = %INVALID_SOCKET
   NEXT i
   '- There will be on thread ID per connection
   REDIM gThread(1 TO %MAX_CONNECTIONS) AS LONG
   REDIM gThreadRunning(1 TO %MAX_CONNECTIONS) AS LONG
   gShutdown = %False
   '- Open the log file
   ON ERROR RESUME NEXT
   gLog = FREEFILE
   OPEN "rserver.log" FOR APPEND AS #gLog
   IF ERR THEN
      MSGBOX "Unable to create log file. Error =" + STR$(ERR)
      gLog = 0
   ELSE
      PRINT #gLog, ""
      PRINT #gLog, "**********************************************"
      PRINT #gLog, "START UP " + DATE$ + "  " +TIME$
      PRINT #gLog, "----------------------------------------------"
   END IF
   FUNCTION = %True
END FUNCTION
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  ShutDown
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUB ShutDown()
   DIM i AS LONG
   DIM foo AS LONG
   '- All threads monitor this flag and
   '  will bail as soon as possible after
   '  seeing this.
   '
   gShutdown = %True
   SLEEP 100
   '- Make sure to clean up any open sockets
   '  By closing a socket, the blocking tcp calls
   '  will stop blocking and error out. This
   '  allows the threads to finish executing.
   '
   FOR i = 1 TO %MAX_CONNECTIONS
      IF gSock(i) <> %INVALID_SOCKET THEN
         TCP CLOSE gSock(i)
         gSock(i) = %INVALID_SOCKET
      END IF
   NEXT i
   '- Free any running threads
   FOR i = 1 TO %MAX_CONNECTIONS
      IF gThread(i) <> 0 THEN
         THREAD CLOSE gThread(i) TO foo
         '- Wait for the thread to finish running
         '  When a thread finishes running, it sets its
         '  gThreadRunning() variable to be zero
         '
         DO UNTIL gThreadRunning(i) = %False
            SLEEP 10
         LOOP
      END IF
   NEXT i
 
   '- Close any open files
   IF gLog THEN
      CLOSE #gLog
      gLog = 0
   END IF
   CLOSE
   DeleteCriticalSection gCS
END SUB
'------------------------------------------------------------------------------
'   ** Declarations **
'------------------------------------------------------------------------------
DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
#PBFORMS DECLARATIONS
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'   ** Main Application Entry Point **
'------------------------------------------------------------------------------
FUNCTION PBMAIN()
   Initialize
   ShowDIALOG1 %HWND_DESKTOP
   ShutDown
END FUNCTION
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  gDlgMain_WinProc
'  This is the event loop for the application
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
REM CALLBACK FUNCTION gDlgMain_WinProc
CALLBACK FUNCTION ShowDIALOG1Proc()
   DIM i AS LONG
   DIM iFound AS LONG
   DIM iCurrentSocket AS LONG
   DIM iCount AS LONG
   DIM iEmpty AS LONG
   DIM iMain AS LONG
   SELECT CASE CBMSG
      CASE %WM_INITDIALOG
         InitListen
         '- Create a timer to handle thread cleanup
         SetTimer gDlgMain, %timer1, %CLEANUP_TIMER_INTERVAL, BYVAL %NULL
      CASE %WM_TIMER
         IF CBWPARAM = %timer1 THEN
            ThreadCleanup
         END IF
      CASE %TCP_CONNECT
         '- wparam contains the handle of the socket (FileAttr(hSock, 2) from accept event)
         SELECT CASE LOWRD(CBLPARAM)
            '- Someone is attempting to connect to the server
            CASE %FD_ACCEPT
 
               EnterCritical
               iFound = 0
               '- Find an empty connection
               iEmpty = 0
               FOR i = 1 TO %MAX_CONNECTIONS
                  IF gSock(i) = %INVALID_SOCKET THEN
                     iEmpty = i
                     EXIT FOR
                  END IF
               NEXT i
               '- Figure out which socket this is coming in on.
               iMain = 0
               FOR i = 1 TO %MAX_IP_WAIT
                  IF FILEATTR(gMainSock(i), 2) = CBWPARAM THEN
                     iMain = i
                  END IF
               NEXT i
               '- Now we know which socket the connect request is coming
               '  in on and which one we should assign it to,
               '  so accept the connection and specify the notify events
               '
               IF (iMain > 0) AND (iEmpty > 0) THEN
                  '- Accept the connection
                  gSock(iEmpty) = FREEFILE
                  TCP ACCEPT gMainSock(iMain) AS gSock(iEmpty)
                  'Tcp Notify gSock(iEmpty), To gDlgMain As %TCP_CONNECT
                  DisplayEvent "FD_ACCEPT: " + STR$(gSock(iEmpty)) + " " + STR$(gMainSock(iMain))
                  LogEvent "CONNECT"
                  gActive = gActive + 1
                  THREAD CREATE tcpHandleConnection(iEmpty) TO gThread(iEmpty)
               END IF
               LeaveCritical
         END SELECT
         FUNCTION = 1
 
      CASE %WM_NCACTIVATE
            STATIC hWndSaveFocus AS DWORD
            IF ISFALSE CBWPARAM THEN
                ' Save control focus
                hWndSaveFocus = GetFocus()
            ELSEIF hWndSaveFocus THEN
                ' Restore control focus
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            END IF
       CASE %WM_COMMAND
            ' Process control notifications
            SELECT CASE AS LONG CBCTL
                 CASE %btnstop
                   KillTimer gDlgMain, %Timer1  'added this
                   DIALOG END CBHNDL
                   FUNCTION = 1
             END SELECT
      CASE %WM_SYSCOMMAND
         IF CBWPARAM = %SC_CLOSE THEN
            KillTimer gDlgMain, %timer1
         END IF
      CASE %WM_DESTROY
         IF gLog THEN
            PRINT #gLog, "----------------------------------------------"
            PRINT #gLog, "SHUT DOWN " + DATE$ + "  " + TIME$
            PRINT #gLog, "  Active Clients:" + STR$(gActive)
            PRINT #gLog, "      Total Hits:" + STR$(gHits)
            PRINT #gLog, "**********************************************"
         END IF
   END SELECT
END FUNCTION
'------------------------------------------------------------------------------
'   ** Dialogs **
'------------------------------------------------------------------------------
FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
    LOCAL lRslt AS LONG
#PBFORMS BEGIN DIALOG %IDD_DIALOG1->->
    LOCAL hDlg  AS DWORD
    DIALOG NEW hParent, "", 1063, 7, 200, 200, %WS_MINIMIZEBOX OR %WS_CAPTION _
        OR %WS_SYSMENU OR %WS_VISIBLE OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
        %DS_SETFONT, %WS_EX_LEFT OR %WS_EX_LTRREADING OR _
        %WS_EX_RIGHTSCROLLBAR OR %WS_EX_CONTROLPARENT, TO hDlg
    CONTROL ADD LABEL,  hDlg, -1, "Server IP(s)", 17, 10, 40, 8, %SS_RIGHT OR _
        %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING
    CONTROL ADD LABEL,  hDlg, -1, "Port", 17, 25, 40, 8, %SS_RIGHT OR _
        %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING
    CONTROL ADD LABEL,  hDlg, -1, "Started", 17, 40, 40, 8, %SS_RIGHT OR _
        %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING
    CONTROL ADD LABEL,  hDlg, -1, "Total Hits", 17, 55, 40, 8, %SS_RIGHT OR _
        %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING
    CONTROL ADD LABEL,  hDlg, -1, "Active Clients", 17, 70, 40, 8, %SS_RIGHT _
        OR %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING
    CONTROL ADD LABEL,  hDlg, -1, "Last Action", 17, 85, 40, 8, %SS_RIGHT OR _
        %WS_CHILD OR %WS_VISIBLE, %WS_EX_LEFT OR %WS_EX_LTRREADING
    CONTROL ADD LABEL,  hDlg, %labIP, "", 65, 10, 180, 8
    CONTROL ADD LABEL,  hDlg, %labPort, "", 65, 25, 80, 8
    CONTROL ADD LABEL,  hDlg, %labDate, "", 65, 40, 80, 8
    CONTROL ADD LABEL,  hDlg, %labHits, "0", 65, 55, 80, 8
    CONTROL ADD LABEL,  hDlg, %labActive, "0", 65, 70, 80, 8
    CONTROL ADD LABEL,  hDlg, %labAction, "", 65, 85, 135, 8
    CONTROL ADD BUTTON, hDlg, %btnStop, "&Stop", 150, 177, 40, 15
#PBFORMS END DIALOG
  gDlgMain = hDlg  'Main handle in rserver2
  DIM i AS LONG
  DIM ipa AS STRING
   '- Get a list of the IP addresses for display purposes
   FOR i = 1 TO gIPCount
      IF ipa = "" THEN
         ipa = FormatIP(gIPAddr(i))
      ELSE
         ipa = ipa + "; " + FormatIP(gIPAddr(i))
      END IF
  NEXT i
  DIALOG SET TEXT hDlg, "rServer2 for PBFORMS on Port" + STR$(%DEFAULT_PORT)
  CONTROL SET TEXT  gDlgMain, %LabIP, ipa
  CONTROL SET TEXT  gDlgMain, %labPort, FORMAT$(gPort)
  CONTROL SET TEXT  gDlgMain, %labDate, DATE$ + "   " + TIME$
  REM DIALOG SHOW MODAL hDlg, CALL gDlgMain_WinProc
  DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt
#PBFORMS BEGIN CLEANUP %IDD_DIALOG1
#PBFORMS END CLEANUP
    FUNCTION = lRslt
END FUNCTION
Last edited by Mike Doty; 15 Sep 2009, 10:26 PM.
How long is an idea? Write it down.
Tags: rserver, tcp server
Previous template Next
Announcement

rServer2 for PBFORMS

rServer2 for PBFORMS
