home *** CD-ROM | disk | FTP | other *** search
VERSION 2.00 Begin Form Form1 BackColor = &H00C0C0C0& Caption = "FTP SERVER" ClientHeight = 4650 ClientLeft = 1470 ClientTop = 2820 ClientWidth = 7335 Height = 5055 Icon = FTP_SRV.FRX:0000 Left = 1410 LinkTopic = "Form1" ScaleHeight = 4650 ScaleWidth = 7335 Top = 2475 Width = 7455 Begin TextBox Text1 Enabled = 0 'False Height = 612 Left = 120 MultiLine = -1 'True TabIndex = 4 Text = "If you want any explanation or wish my collaboration for any project, contact me through e-mail at UNISYSTEM@DNS.OMNIA.IT (refer to Anastasi Lorenzo)." Top = 3960 Width = 7092 End Begin PictureBox EndCmd BackColor = &H000000FF& Height = 1000 Left = 0 ScaleHeight = 975 ScaleWidth = 975 TabIndex = 0 Top = 0 Width = 1000 End Begin Timer Timer1 Enabled = 0 'False Index = 4 Interval = 50 Left = 2040 Top = 4680 End Begin Timer Timer1 Enabled = 0 'False Index = 3 Interval = 50 Left = 1560 Top = 4680 End Begin Timer Timer1 Enabled = 0 'False Index = 2 Interval = 50 Left = 1080 Top = 4680 End Begin Timer Timer1 Enabled = 0 'False Index = 1 Interval = 50 Left = 600 Top = 4680 End Begin Timer Timer1 Enabled = 0 'False Index = 0 Interval = 50 Left = 120 Top = 4680 End Begin PictureBox StatusBar BackColor = &H000000FF& Height = 1000 Left = 0 ScaleHeight = 975 ScaleWidth = 975 TabIndex = 2 Top = 0 Width = 1000 End Begin PictureBox Frame3D1 BackColor = &H000000FF& Height = 1000 Left = 0 ScaleHeight = 975 ScaleWidth = 975 TabIndex = 3 Top = 0 Width = 1000 Begin ListBox LogWnd BackColor = &H00000000& ForeColor = &H0000FF00& Height = 2328 Left = 240 TabIndex = 1 Top = 360 Width = 6612 End End Begin PictureBox VBServer1 BackColor = &H000000FF& Height = 1000 Left = 0 ScaleHeight = 975 ScaleWidth = 975 TabIndex = 5 Top = 0 Width = 1000 End Sub EndCmd_Click () Dim i As Integer 'close all connection For i = 1 To MAX_N_USERS If users(i).control_slot <> INVALID_SOCKET Then 'close control slot retf = CloseTheSocket(users(i).control_slot) End If If users(i).data_slot <> INVALID_SOCKET Then 'close data slot retf = CloseTheSocket(users(i).data_slot) End If Next 'end FTP server retf = WSACleanup() End End Sub Sub Form_Load () Dim i As Integer Dim hdr As String, item As String '--- Initialization 'an FTP command is terminated by Carriage_Return + 'Line_Feed crlf = Chr$(13) + Chr$(10) 'possible sintax errors in FTP commands sintax_error_list(0) = "200 Command Ok." sintax_error_list(1) = "202 Command not implemented, superfluous at this site." sintax_error_list(2) = "500 Sintax error, command unrecognized." sintax_error_list(3) = "501 Sintax error in parameters or arguments." sintax_error_list(4) = "502 Command not implemented." sintax_error_list(6) = "504 Command not implemented for that parameter." 'initializes the list which contains the names, 'passwords, access rights and default directory 'recognized by the server Open WORK_DIR + "\ftp_srv.ini" For Input As NF_INI Line Input #NF_INI, hdr 'usernames If hdr = "[usernames]" Then For i = 1 To N_RECOGNIZED_USERS Line Input #NF_INI, item usernames_list(i) = item Next Else StatusBar.Caption = "Error in INI file!" End End If Line Input #NF_INI, hdr 'passwords If hdr = "[passwords]" Then For i = 1 To N_RECOGNIZED_USERS Line Input #NF_INI, item passwords_list(i) = item Next Else StatusBar.Caption = "Error in INI file!" End End If Line Input #NF_INI, hdr 'access rights If hdr = "[access_rights]" Then For i = 1 To N_RECOGNIZED_USERS Line Input #NF_INI, item access_rights_list(i) = item Next Else StatusBar.Caption = "Error in INI file!" End End If Line Input #NF_INI, hdr 'default directories If hdr = "[default_dirs]" Then For i = 1 To N_RECOGNIZED_USERS Line Input #NF_INI, item default_dir_list(i) = item Next Else StatusBar.Caption = "Error in INI file!" End End If Close #NF_INI 'initializes the records which contain the 'informations on the connected users For i = 1 To MAX_N_USERS users(i).list_index = 0 users(i).control_slot = INVALID_SLOT users(i).data_slot = INVALID_SLOT users(i).IP_address = "" users(i).Port = 0 users(i).data_representation = "A" users(i).data_format_ctrls = "N" users(i).data_structure = "F" users(i).data_tx_mode = "S" users(i).cur_dir = "" users(i).state = 0 users(i).full = False Next 'begins SERVER mode on port 21 VBServer1.Port = 21 VBServer1.SelectAction = FD_ACCEPT Or FD_CLOSE Or FD_READ Or FD_WRITE VBServer1.OpenFlag = True ServerSlot = VBServer1.SocketNumber End Sub Sub Form_Unload (Cancel As Integer) retf = WSACleanup() End Sub Sub Timer1_Timer (index As Integer) Dim close_data_cnt As Integer Dim error_on_data_cnt As Integer Select Case files_info(index).retr_stor Case 0: '--- R E T R Command If files_info(index).data_representation = "A" Then If Not files_info(index).open_file Then 'open file Open files_info(index).full_name For Input Lock Write As #index files_info(index).open_file = True End If 'sends the file on data connection; 'data are sent a line at a time If files_info(index).try_again Then 're-send old line Else Line Input #index, files_info(index).buffer End If retf = send_data(files_info(index).buffer + crlf, index) If retf < 0 Then 'SOCKET_ERROR retf = WSAGetLastError() If retf = WSAEWOULDBLOCK Then files_info(index).try_again = True Else 'error on sending error_on_data_cnt = True close_data_cnt = True End If Else files_info(index).try_again = False End If If EOF(index) Then close_data_cnt = True Else 'binary transfer If Not files_info(index).open_file Then 'open file Open files_info(index).full_name For Binary Lock Write As #index files_info(index).open_file = True End If 'sends file on data connection; 'data are sent in blocks of 1024 bytes If files_info(index).next_block = 0 Then files_info(index).file_len = LOF(index) '# of blocks files_info(index).blocks = Int(files_info(index).file_len / 1024) '# of remaining bytes files_info(index).spare_bytes = files_info(index).file_len Mod 1024 files_info(index).buffer = String$(1024, " ") End If If files_info(index).next_block < files_info(index).blocks Then 'sends blocks Get #index, files_info(index).next_byte + 1, files_info(index).buffer retf = send_data(files_info(index).buffer, index) If retf < 0 Then retf = WSAGetLastError() If retf = WSAEWOULDBLOCK Then 'try again Else error_on_data_cnt = True close_data_cnt = True End If Else 'next block files_info(index).next_block = files_info(index).next_block + 1 files_info(index).next_byte = files_info(index).next_byte + 1024 End If Else 'sends remaining bytes files_info(index).buffer = String$(files_info(index).spare_bytes, " ") Get #index, , files_info(index).buffer retf = send_data(files_info(index).buffer, index) close_data_cnt = True End If End If If close_data_cnt Then 're-initialize files_info record files_info(index).open_file = False files_info(index).next_block = 0 'blocks count files_info(index).next_byte = 0 'pointer to next block files_info(index).try_again = False 'close file Close #index 'replies to user If error_on_data_cnt Then retf = send_reply("550 RETR command not executed.", index) Else retf = send_reply("226 RETR command completed.", index) End If 'close data connection retf = close_data_connect(index) 'disables timer timer1(index).Enabled = False End If Case 1: '--- S T O R Command If files_info(index).data_representation = "A" Then If Not files_info(index).open_file Then 'open file Open files_info(index).full_name For Output Lock Read Write As #index files_info(index).open_file = True End If 'receives file on data connection; 'data are received a line at a time retf = receive_data(files_info(index).buffer, index) If retf < 0 Then 'SOCKET_ERROR retf = WSAGetLastError() If retf = WSAEWOULDBLOCK Then 'try_again Else 'error on receiving error_on_data_cnt = True close_data_cnt = True End If ElseIf retf = 0 Then 'connection closed by peer close_data_cnt = True Else 'retf > 0 'write on file dummy$ = Left$(files_info(index).buffer, retf) Print #index, dummy$ End If Else 'binary transfer If Not files_info(index).open_file Then 'open file Open files_info(index).full_name For Binary Lock Read Write As #index files_info(index).open_file = True End If 'receives file on data connection; retf = receive_data(files_info(index).buffer, index) If retf < 0 Then retf = WSAGetLastError() If retf = WSAEWOULDBLOCK Then 'try again Else error_on_data_cnt = True close_data_cnt = True End If ElseIf retf = 0 Then 'connection closed by peer close_data_cnt = True Else dummy$ = Left$(files_info(index).buffer, retf) Put #index, , dummy$ End If End If If close_data_cnt Then 're-initialize files_info record files_info(index).open_file = False files_info(index).next_block = 0 'blocks count files_info(index).next_byte = 0 'pointer to next block files_info(index).try_again = False 'close file Close #index 'replies to user If error_on_data_cnt Then retf = send_reply("550 STOR command not executed.", index) Else retf = send_reply("226 STOR command completed.", index) End If 'closes data connection retf = close_data_connect(index) 'disables timer timer1(index).Enabled = False End If End Select End Sub Sub VBServer1_Message (MsgVal As Integer, wparam As Integer, lparam As Long) Dim NewSlot As Integer Dim SendBuffer As String Dim lenBuffer As Integer 'send-buffer lenght Dim RecvBuffer As String Dim BytesRead As Integer 'receive-buffer lenght Dim i As Integer Dim fixstr As String * 1024 'event on server slot If wparam = ServerSlot Then retf = GetSelectEventSocket(lparam) '--- FD_ACCEPT If retf = FD_ACCEPT Then 'try to accept new TCP connection NewSlot = acceptSocket(ServerSlot) If NewSlot = INVALID_SOCKET Then msg$ = "Error during an attempt at connection." StatusBar.Caption = msg$ Else 'NewSlot OK 'new service request If num_users >= MAX_N_USERS Then 'the number of users exceeds the 'maximum allowed SendBuffer = "421 Service not available at this time, closing control connection." + crlf lenBuffer = Len(SendBuffer) retf = SendSocket(NewSlot, SendBuffer, lenBuffer, 0) 'close connection retf = CloseTheSocket(NewSlot) Else SendBuffer = "220-Welcome in this demo site!" + crlf SendBuffer = SendBuffer + "220-The software implementing this FTP is entirely realized in VB 3.0" + crlf SendBuffer = SendBuffer + "220-You must consider the packet as a demo version only!" + crlf SendBuffer = SendBuffer + "220 Have a good time ... (L.Anastasi)" + crlf lenBuffer = Len(SendBuffer) 'send welcome message retf = SendSocket(NewSlot, SendBuffer, lenBuffer, 0) 'increases the number of connected users num_users = num_users + 1 'registers the slot number in the first 'free user record For i = 1 To MAX_N_USERS If Not users(i).full Then users(i).control_slot = NewSlot users(i).full = True Exit For End If Next End If 'If num_users End If 'If NewSlot End If 'If retf Exit Sub End If 'If wparam 'event on control slots For i = 1 To MAX_N_USERS If wparam = users(i).control_slot Then retf = GetSelectEventSocket(lparam) '--- FD_READ If retf = FD_READ Then 'store read bytes in RecvBuffer BytesRead = RecvSocket(wparam, fixstr, 1024, 0) RecvBuffer = Left$(fixstr, BytesRead) 'if received string is a command then 'executes it If InStr(RecvBuffer, crlf) > 0 Then retf = exec_FTP_cmd(i, RecvBuffer) End If '--- FD_CLOSE ElseIf retf = FD_CLOSE Then 'connection closed by client retf = CloseTheSocket(wparam) 'frees the user record users(i).control_slot = INVALID_SOCKET users(i).full = False End If Exit Sub End If Next 'event on data slots For i = 1 To MAX_N_USERS If wparam = users(i).data_slot Then retf = GetSelectEventSocket(lparam) '--- FD_WRITE If retf = FD_WRITE Then 'enables sending '--- FD_CLOSE ElseIf retf = FD_CLOSE Then 'connection closed by client retf = CloseTheSocket(wparam) 'reinitilizes data slot users(i).data_slot = INVALID_SOCKET users(i).state = 2 End If Exit Sub End If Next End Sub 
(.txt)