Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ftpser1a/ftp_srv2.bas

BASIC Source File | 1999-10-04 | 19.6 KB | 560 lines

Attribute VB_Name = "FTP_Srv2"
Option Explicit

Sub ServerLog(ByVal Str As String)
  FtpServ.LogWnd.AddItem Str
  FtpServ.LogWnd.Selected(FtpServ.LogWnd.ListCount - 1) = True
End Sub

'EXEC A FTP COMMAND:
'<id_user> is a number in the range 1 to MAX_N_USERS
'identifing the user who sends the command;
'<cmd> is the command.

Function exec_FTP_cmd(Id_User As Integer, cmd As String) As Integer
Dim Kwrd As String 'keyword
Dim Argument(5) As String 'arguments
Dim ArgN As Long
Dim FTP_Err As Integer 'error
Dim PathName As String, Drv As String

Dim Full_Name As String 'pathname & file name
Dim File_Len As Long 'file lenght in bytes
Dim i As Long

Dim Ok As Integer
Dim Buffer As String
Dim DummyS As String


'variables used during the data exchange
Dim ExecSlot As Integer
Dim NewSockAddr As SockAddr, LclSockAddr As SockAddr

On Error Resume Next 'routine for error interception

FTP_Err = sintax_ctrl(cmd, Kwrd, Argument())
'log commands
ServerLog "<" & Format$(Id_User, "000") & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm - ") & cmd
If FTP_Err <> 0 Then
  retf = send_reply(sintax_error_list(FTP_Err), Id_User)
  Exit Function
End If

Select Case UCase$(Kwrd)
  Case "USER":  'USER <username>
  Ok = False
  Debug.Print N_RECOGNIZED_USERS;
  For i = 1 To N_RECOGNIZED_USERS
    'Debug.Print UserIDs.No(i).Name
    'controls if the user is in the list of known users
    If Argument(0) = UserIDs.No(i).Name Then
      'the user must enter a password but anonymous users can be accepted
      If UserIDs.No(i).Name = "anonymous" Then
        retf = send_reply("331 User anonymous accepted, please type your e-mail address as password.", Id_User)
      Else
        retf = send_reply("331 User name Ok, type in your password.", Id_User)
      End If
      users(Id_User).list_index = i
      users(Id_User).cur_dir = UserIDs.No(i).Home
      users(Id_User).state = 1
      Ok = True
      Exit For
    End If
  Next
  If Not Ok Then  'unknown user
    retf = send_reply("530 Not logged in, user " & Argument(0) & " is unknown.", Id_User)
    retf = logoff(Id_User)
  End If

  Case "PASS": 'PASS <password>
  If users(Id_User).state = 1 Then
    If LCase(UserIDs.No(users(Id_User).list_index).Name) = "anonymous" Then
      'anonymous user
      retf = send_reply("230 User anonymous logged in, proceed.", Id_User)
      users(Id_User).state = 2
    Else
      If Argument(0) = UserIDs.No(users(Id_User).list_index).Pass Then
        'correct password, the user can proceed
        retf = send_reply("230 User logged in, proceed.", Id_User)
        users(Id_User).state = 2
      Else
        'wrong password, the user is disconnected
        retf = send_reply("530 Not logged in, wrong password.", Id_User)
        retf = logoff(Id_User)
      End If
    End If
  Else
    'the user must enter his name
    retf = send_reply("503 I need your username.", Id_User)
  End If

  Case "CWD", "XCWD": 'CWD <pathname>
  If users(Id_User).state = 2 Then
    PathName = ChkPath(Id_User, Argument(0))
    Drv = Left(PathName, 2)
    ChDrive Drv
    ChDir PathName
    If Err.Number = 0 Then
      users(Id_User).cur_dir = CurDir
      'existing directory
      retf = send_reply("250 CWD command executed.", Id_User)
    ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
      'no existing directory
      retf = send_reply("550 CWD command not executed: " & Error$, Id_User)
    Else
      'FtpServ.StatusBar.panels(1) = "Error " & CStr(Err) & " occurred."
      retf = logoff(Id_User)
      'End
    End If
  Else
    'user not logged in
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "CDUP", "XCUP": 'CDUP
  If users(Id_User).state = 2 Then
    ChDir users(Id_User).cur_dir
    ChDir ".."
    users(Id_User).cur_dir = CurDir
    retf = send_reply("200 CDUP command executed.", Id_User)
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "QUIT": 'QUIT
  retf = logoff(Id_User)

  Case "PORT": 'PORT <host-port>
  If users(Id_User).state = 2 Then
    'opens a data connection
    ExecSlot = Socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
    If ExecSlot < 0 Then
      'error
      retf = send_reply("425 Can't build data connection.", Id_User)
    Else
      NewSockAddr.sin_family = PF_INET
      'remote IP address
      IPLong.Byte4 = Val(Argument(0))
      IPLong.Byte3 = Val(Argument(1))
      IPLong.Byte2 = Val(Argument(2))
      IPLong.Byte1 = Val(Argument(3))
      CopyMemory i, IPLong, 4
      NewSockAddr.sin_addr = i

      'remote port
      ArgN = Val(Argument(4))
      NewSockAddr.sin_port = htons(ArgN)
      retf = connect(ExecSlot, NewSockAddr, 16)
      If retf < 0 Then
        retf = send_reply("425 Can't build data connection.", Id_User)
      Else
        retf = send_reply("200 PORT command executed.", Id_User)
        'stores the IP-address and port number in user record
        users(Id_User).data_slot = ExecSlot
        users(Id_User).IP_address = Argument(0) & "." & Argument(1) & "." & Argument(2) & "." & Argument(3)
        users(Id_User).Port = Val(Argument(4))
        ServerLog ("IP=" & users(Id_User).IP_address & ":" & Argument(4))
        '<state> field establishes that now is
        'possible to exec commands requiring a data connection
        users(Id_User).state = 3
      End If
    End If
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "TYPE": 'TYPE <type-code>
  If users(Id_User).state = 2 Then
    'stores the access parameters in user record
    retf = send_reply("200 TYPE command executed.", Id_User)
    users(Id_User).data_representation = Argument(0)
    users(Id_User).data_format_ctrls = Argument(1)
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "STRU": 'STRU <structure-code>
  If users(Id_User).state = 2 Then
    'stores access parameters in the user record
    retf = send_reply("200 STRU command executed.", Id_User)
    users(Id_User).data_structure = Argument(0)
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "MODE": 'MODE <mode-code>
  If users(Id_User).state = 2 Then
    'stores access parameters in the user record
    retf = send_reply("200 MODE command executed.", Id_User)
    users(Id_User).data_tx_mode = Argument(0)
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "RETR": 'RETR <pathname>
  If users(Id_User).state = 3 Then
    Full_Name = ChkPath(Id_User, Argument(0))
    'file exist?
    i = FileLen(Full_Name)
    If Err.Number = 0 Then 'Yes
      'controls access rights
      DummyS = UserIDs.No(users(Id_User).list_index).Priv(1).Accs
      If InStr(DummyS, "R") Then
        retf = open_data_connect(Id_User)
        'initializes record which contains file parameters
        files_info(Id_User).Full_Name = Full_Name
        files_info(Id_User).data_representation = users(Id_User).data_representation
        files_info(Id_User).open_file = False
        files_info(Id_User).retr_stor = 0
        'enables timer to send data on connection
        FtpServ.Timer1(Id_User).Enabled = True
      Else
        'the user can't retrieves files
        retf = send_reply("550 You can't take this file action.", Id_User)
        retf = close_data_connect(Id_User)
      End If
    ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
      'no existing file
      retf = send_reply("550 RETR command not executed: " & Error$, Id_User)
      retf = close_data_connect(Id_User)
    Else
      FtpServ.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
      retf = close_data_connect(Id_User)
      retf = logoff(Id_User)
      'End
    End If
  ElseIf users(Id_User).state = 2 Then
    retf = send_reply("425 Can't open data connection.", Id_User)
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "STOR": 'STOR <pathname>
  If users(Id_User).state = 3 Then
    Full_Name = ChkPath(Id_User, Argument(0))
    'controls access rights
    DummyS = UserIDs.No(users(Id_User).list_index).Priv(1).Accs
    If InStr(DummyS, "W") Then
      retf = open_data_connect(Id_User)
      'initializes record which contains file parameters
      files_info(Id_User).Full_Name = Full_Name
      files_info(Id_User).data_representation = users(Id_User).data_representation
      files_info(Id_User).open_file = False
      files_info(Id_User).retr_stor = 1
      'enables timer to receive data on connection
      FtpServ.Timer1(Id_User).Enabled = True
    Else
      'the user can't stores files
      retf = send_reply("550 You can't take this file action.", Id_User)
      retf = close_data_connect(Id_User)
    End If
  ElseIf users(Id_User).state = 2 Then
    retf = send_reply("425 Can't open data connection.", Id_User)
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "RNFR":  'RNFR <pathname>
  If users(Id_User).state = 2 Then
    Full_Name = ChkPath(Id_User, Argument(0))
    'file exists?
    i = FileLen(Full_Name)
    If Err.Number = 0 Then 'Yes
      'controls access rights
      DummyS = UserIDs.No(users(Id_User).list_index).Priv(1).Accs
      If InStr(DummyS, "M") Then
        'The user can updates files.
        'The name of file to rename is temporarily stored in the user record.
        users(Id_User).temp_data = Full_Name
        'next command must be a RNTO
        users(Id_User).state = 6
        retf = send_reply("350 ReName command expect further information.", Id_User)
      Else
        'the user can't writes on files
        retf = send_reply("550 You can't take this file action.", Id_User)
      End If
    ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
      'no existing file
      retf = send_reply("550 RNFR command not executed: " & Error$, Id_User)
    Else
      FtpServ.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
      retf = logoff(Id_User)
      'End
    End If
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "RNTO":  'RNTO <pathname>
  If users(Id_User).state = 6 Then
    Full_Name = ChkPath(Id_User, Argument(0))
    Name users(Id_User).temp_data As Full_Name
    If Err.Number = 0 Then
      users(Id_User).state = 2
      'file exists
      retf = send_reply("350 ReName command executed.", Id_User)
    ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
      'no existing file
      retf = send_reply("550 RNTO command not executed: " & Error$, Id_User)
    Else
      FtpServ.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
      retf = logoff(Id_User)
      'End
    End If
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "DELE":  'DELE <pathname>
  If users(Id_User).state = 2 Then
    Full_Name = ChkPath(Id_User, Argument(0))
    'controls access rights
    DummyS = UserIDs.No(users(Id_User).list_index).Priv(1).Accs
    If InStr(DummyS, "K") Then
      'the user can updates files
      Kill Full_Name
      If Err.Number = 0 Then
        'file exists
        retf = send_reply("250 DELE command executed.", Id_User)
      ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
        'file no exists
        retf = send_reply("550 DELE command not executed: " & Error$, Id_User)
      Else
        FtpServ.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
        retf = logoff(Id_User)
        'End
      End If
    Else
      'the user can't delete files
      retf = send_reply("550 You can't take this file action.", Id_User)
    End If
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "RMD", "XRMD": 'RMD <pathname>
  If users(Id_User).state = 2 Then
    PathName = ChkPath(Id_User, Argument(0))
    'controls access rights
    DummyS = UserIDs.No(users(Id_User).list_index).Priv(1).Accs
    If InStr(DummyS, "D") Then
      'the user can updates files
      Kill PathName & "\*.*"
      If Err.Number = 53 Or Err.Number = 708 Then Err.Number = 0 'empty directory
      RmDir PathName
      If Err.Number = 0 Then
        'directory exists
        retf = send_reply("250 RMD command executed.", Id_User)
      ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
        'directory no exists
        retf = send_reply("550 RMD command not executed: " & Error$, Id_User)
      Else
        FtpServ.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
        retf = logoff(Id_User)
        'End
      End If
    Else
      'the user can't delete files
      retf = send_reply("550 You can't take this file action.", Id_User)
    End If
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "MKD", "XMKD": 'MKD <pathname>
  If users(Id_User).state = 2 Then
    PathName = ChkPath(Id_User, Argument(0))
    'controls access rights
    DummyS = UserIDs.No(users(Id_User).list_index).Priv(1).Accs
    If InStr(DummyS, "M") Then
      'the user can updates files
      MkDir PathName
      If Err.Number = 0 Then
        'the directory is been created
        retf = send_reply("257 " & Argument(0) & " created.", Id_User)
      ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
        'the directory isn't been created
        retf = send_reply("550 MKD command not executed: " & Error$, Id_User)
      Else
        FtpServ.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
        retf = logoff(Id_User)
        'End
      End If
    Else
      'the user can't write on files
      retf = send_reply("550 You can't take this file action.", Id_User)
    End If
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "PWD", "XPWD": 'PWD
  If users(Id_User).state = 2 Then
    PathName = users(Id_User).cur_dir
    PathName = Right$(PathName, Len(PathName) - 2)
    retf = send_reply("257 """ & PathName & """ is the current directory.", Id_User)
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If

  Case "LIST", "NLST"   'LIST <pathname>Or InStr(Argument(0), "-L")
    LIST_NLST Id_User, Kwrd, Argument(0)

  Case "SYST":  'SYST
  DummyS = "215 IBM PC TCP/IP"
  retf = send_reply(DummyS, Id_User)

  Case "STAT":  'STAT <pathname>
    retf = send_reply("200 Not Implemented..", Id_User)

  Case "HELP":  'HELP <string>
  DummyS = "214-This is the list of recognized FTP commands:"
  retf = send_reply(DummyS, Id_User)
    DummyS = "214-   USER  PASS  CWD   XCWD  CDUP  XCUP  QUIT  PORT" & vbCrLf _
           & "214-   PASV  TYPE  STRU  MODE  RETR  STOR  RNFR  RNTO" & vbCrLf _
           & "214-   DELE  RMD   XRMD  MKD   XMKD  PWD   XPWD" & vbCrLf _
           & "214    LIST  NLST  SYST  STAT  HELP  NOOP"
  retf = send_reply(DummyS, Id_User)

  Case "NOOP": 'NOOP
  retf = send_reply("200 NOOP command executed.", Id_User)

End Select

End Function

Private Function ChkPath(ByVal Id_User As Integer, ByVal Arg As String) As String
    If Left$(Arg, 1) = "\" Then
      ChkPath = DEFAULT_DRIVE & Arg                   'absolute path
    Else
      If Right$(users(Id_User).cur_dir, 1) = "\" Then 'relative path
        ChkPath = users(Id_User).cur_dir & Arg        'radix
      Else
        ChkPath = users(Id_User).cur_dir & "\" & Arg
      End If
    End If
End Function

Private Sub SendBuffer(Id_User As Integer, ByRef Buffer As String)
Dim ii As Long
  Debug.Print Buffer
  'sends data in buffer on data connection;
  'data are sending in blocks of 1024 bytes
  ii = 1
  Do While Mid$(Buffer, ii, 1024) <> ""
    retf = send_data(Mid$(Buffer, ii, 1024), Id_User)
    If retf < 0 Then
      retf = WSAGetLastError()
      If retf = WSAEWOULDBLOCK Then
        'try again
      Else
        'error on send
        Exit Do
      End If
    Else
      ii = ii + 1024
    End If
    DoEvents
  Loop
  Buffer = ""
End Sub


Private Sub LIST_NLST(ByVal Id_User As Integer, ByVal Typ As String, ByVal Arg As String)
Dim File_Name As String, name_ As String, exte_ As String
Dim DummyS As String
Dim SepN As Integer
Dim Full_Name As String 'pathname & file name
Dim PathName As String, Buffer As String

  If users(Id_User).state = 3 Then
    If InStr(Arg, "-a -L") Then Arg = Left(Arg, (InStr(Arg, "-a -L") - 1))
    If Arg = "" Then
      'if LIST/NLST command has no argument the working directory is the current directory
      PathName = users(Id_User).cur_dir
    Else
      PathName = ChkPath(Id_User, Arg)
    End If
    If (GetAttr(PathName) And 16) <> 0 Then
      '--- the pathname indicates a directory
      'if radix then elides final backslash
      If Right$(PathName, 1) = "\" Then
        PathName = Left$(PathName, Len(PathName) - 1)
      End If
      File_Name = Dir$(PathName & "\*.*", 16)
      'rebuilds the full file name
      '(pathname & file name)
      Full_Name = PathName & "\" & File_Name
    Else
      'the pathname indicates a file
      Full_Name = PathName
      File_Name = Dir$(Full_Name)
    End If
    If Err.Number = 0 Then
      'opens data connection
      retf = open_data_connect(Id_User)
      Do
        If File_Name = "." Or File_Name = ".." Then
          'parent directories
          DummyS = Format$(File_Name, "@@@@@@@@@@@@!") & " <DIR>"
        ElseIf GetAttr(Full_Name) = 16 Then
          'subdirectory
          SepN = InStr(File_Name, ".")
          If SepN <> 0 Then
            'name
            name_ = Left$(File_Name, SepN - 1)
            'extension
            exte_ = Mid$(File_Name, SepN + 1)
          Else
            name_ = File_Name
            exte_ = "   "
          End If
          DummyS = "drwxr-xr-x   1 user    group  "
          If Typ = "LIST" Then
            DummyS = DummyS & Format$(FileLen(Full_Name), " @@@@@@@@@") _
             & " " & Format$(FileDateTime(Full_Name), " mmm dd hh:nn ") & File_Name
          End If
        Else
          'file
          SepN = InStr(File_Name, ".")
          If SepN <> 0 Then
            'name
            name_ = Left$(File_Name, SepN - 1)
            'extension
            exte_ = Mid$(File_Name, SepN + 1)
          Else
            name_ = File_Name
            exte_ = "   "
          End If
          DummyS = "-rwxr--r--   1 user    group  "
          If Typ = "LIST" Then
            DummyS = DummyS & Format$(FileLen(Full_Name), " @@@@@@@@@") _
             & " " & Format$(FileDateTime(Full_Name), " mmm dd hh:nn ") & File_Name
          End If
        End If
        Buffer = Buffer & DummyS & vbCrLf
        File_Name = Dir$
        If File_Name = "" Then Exit Do
        Full_Name = PathName & "\" & File_Name
      Loop While True
      SendBuffer Id_User, Buffer
      'close data connection
      retf = send_reply("226 " & Typ & " command completed.", Id_User)
      retf = close_data_connect(Id_User)
    ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
      retf = send_reply("450 " & Typ & " command not executed: " & Error$, Id_User)
      retf = close_data_connect(Id_User)
    Else
      FtpServ.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
      retf = close_data_connect(Id_User)
      retf = logoff(Id_User)
      'End
    End If
  ElseIf users(Id_User).state = 2 Then
    retf = send_reply("425 Can't open data connection.", Id_User)
  Else
    retf = send_reply("530 User not logged in.", Id_User)
  End If
End Sub