windproc.bas

运行多用户

  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 = Transfer_Parameters ' 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 = Transfer_Parameters Then '1
      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 = Service_Commands ' 2
        Set users(ID_User).Jenny = CreateObject("Burro.Balk")
        users(ID_User).Jenny.SetUserData users(ID_User)
        users(ID_User).Jenny.SetUserPermissions UserIDs.No(users(ID_User).list_index), users(ID_User).list_index
        users(ID_User).Jenny.SetCallBack MainApp
      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 = Service_Commands ' 2
          Set users(ID_User).Jenny = CreateObject("Burro.Balk")
          users(ID_User).Jenny.SetUserData users(ID_User)
          users(ID_User).Jenny.SetUserPermissions UserIDs.No(users(ID_User).list_index), users(ID_User).list_index
          users(ID_User).Jenny.SetCallBack MainApp
        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 "QUIT": 'QUIT
    retf = logoff(ID_User)
  Case Else
'MainApp.SvrLogToScreen "Ftp Command Fired"
    users(ID_User).Jenny.New_Cmd Kwrd, argument()
  End Select

End Function

Public Function FTP_Cmd2() As Integer
 
  Dim ArgN As Long
  Dim PathName As String, Drv As String
  
  Dim i As Long
  
  Dim Ok As Integer
  Dim DummyS As String
  
  'variables used during the data exchange
  Dim ExecSlot As Integer
  Dim NewSockAddr As SockAddr
  
  Dim Full_Name As String
  Dim data_representation As String * 1
  Dim open_file As Integer
  Dim retr_stor As Integer  '0=RETR; 1=STOR
  Dim Buffer As String  'contains data to send
  Dim File_Len As Long  '--- Binary mode only
  Dim blocks As Long  'number of 1024 bytes blocks in file
  Dim spare_bytes As Long
  Dim next_block As Long  'next block to send
  Dim next_byte As Long  'points to position in file of the next block to send
  Dim try_again As Integer  'if try_again=true the old line is sent =Ascii mode only
  Dim Dummy As String
  
  Dim DirFnd As Boolean
  Dim error_on_data_cnt As Boolean
  Dim close_data_cnt As Boolean
  
  On Error Resume Next 'routine for error interception
  
  Select Case UCase$(FTP_Command)
  Case "CWD", "XCWD" 'CWD <pathname>
    If users(FTP_Index).State = 2 Then
      
      PathName = ChkPath(FTP_Index, FTP_Args(0))
      Drv = Left(PathName, 2)
      
      '#######################################tr####################
      'controls access rights
      DirFnd = False
      For i = 1 To UserIDs.No(users(FTP_Index).list_index).Pcnt
        If UserIDs.No(users(FTP_Index).list_index).Priv(i).Path = PathName Then
        'To do drive letter permissions use this line
        'If Left(UserIDs.No(users(FTP_Index).list_index).Priv(i).Path, 2) = Drv Then
          DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(i).Accs
          DirFnd = True
          Exit For
        End If
      Next

      If InStr(DummyS, "L") And DirFnd Then
      
      '######################################end tr#####################
         ChDrive Drv
         ChDir PathName
         If Err.Number = 0 Then
           users(FTP_Index).cur_dir = CurDir
           'existing directory
           retf = send_reply("250 CWD command executed.", FTP_Index)
         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$, FTP_Index)
         Else
      '     frmFTP.StatusBar.Panels(1) = "Error " & CStr(Err) & " occurred."
           retf = logoff(FTP_Index)
           'End
         End If
      '#######################################tr####################
      Else
        retf = send_reply("550 CWD command not executed: User does not have permissions", FTP_Index)
      End If
      '#######################################end tr####################
    Else
      'user not logged in
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
  
  Case "CDUP", "XCUP": 'CDUP
    If users(FTP_Index).State = 2 Then
      ChDir users(FTP_Index).cur_dir
      ChDir ".."
      users(FTP_Index).cur_dir = CurDir
      retf = send_reply("200 CDUP command executed.", FTP_Index)
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
  Case "PORT" 'PORT <host-port>
    If users(FTP_Index).State = Service_Commands Then    ' 2
      '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.", FTP_Index)
      Else
        NewSockAddr.sin_family = PF_INET
        'remote IP address
        IPLong.Byte4 = Val(FTP_Args(0))
        IPLong.Byte3 = Val(FTP_Args(1))
        IPLong.Byte2 = Val(FTP_Args(2))
        IPLong.Byte1 = Val(FTP_Args(3))
        CopyMemory i, IPLong, 4
        NewSockAddr.sin_addr = i

        'remote port
        ArgN = Val(FTP_Args(4))
        NewSockAddr.sin_port = htons(ArgN)
        retf = connect(ExecSlot, NewSockAddr, 16)
        If retf < 0 Then
          retf = send_reply("425 Can't build data connection.", FTP_Index)
        Else
          retf = send_reply("200 PORT command executed.", FTP_Index)
          'stores the IP-address and port number in user record
          users(FTP_Index).data_slot = ExecSlot
          users(FTP_Index).IP_Address = FTP_Args(0) & "." & FTP_Args(1) & "." & _
                                        FTP_Args(2) & "." & FTP_Args(3)
          users(FTP_Index).Port = Val(FTP_Args(4))
          'ServerLog ("IP=" & users(FTP_Index).IP_Address & ":" & FTP_Args(4))
          Thread.SendMessage "IP=" & users(FTP_Index).IP_Address & ":" & FTP_Args(4)
'          '<state> field establishes that now is
'          'possible to exec commands requiring a data connection
          users(FTP_Index).State = 3
          Debug.Print "data "; ExecSlot
          Debug.Print "ctrl "; users(FTP_Index).control_slot
        End If
      End If
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
'
  
  Case "TYPE" 'TYPE <type-code>
    If users(FTP_Index).State = 2 Then
      'stores the access parameters in user record
      retf = send_reply("200 TYPE command executed.", FTP_Index)
      users(FTP_Index).data_representation = FTP_Args(0)
      users(FTP_Index).data_format_ctrls = FTP_Args(1)
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
  
  Case "STRU" 'STRU <structure-code>
    If users(FTP_Index).State = 2 Then
      'stores access parameters in the user record
      retf = send_reply("200 STRU command executed.", FTP_Index)
      users(FTP_Index).data_structure = FTP_Args(0)
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
    
  Case "MODE" 'MODE <mode-code>
    If users(FTP_Index).State = 2 Then
      'stores access parameters in the user record
      retf = send_reply("200 MODE command executed.", FTP_Index)
      users(FTP_Index).data_tx_mode = FTP_Args(0)
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
  
  Case "RETR" 'RETR <pathname>
    On Error GoTo FileError
    If users(FTP_Index).State = 3 Then
      Dim Counter As Integer
      Full_Name = ChkPath(FTP_Index, FTP_Args(0))
        'file exist?
      i = FileLen(Full_Name)
      If Err.Number = 0 Then 'Yes
          'controls access rights
        'DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(1).Accs
        'If InStr(DummyS, "R") Then
        DirFnd = False
        PathName = LCase$(Left(Full_Name, InStrRev(Full_Name, "\")))
        For i = 1 To UserIDs.No(users(FTP_Index).list_index).Pcnt
          If LCase$(UserIDs.No(users(FTP_Index).list_index).Priv(i).Path) = PathName Then
          'To do drive letter permissions use this line
          'If Left(UserIDs.No(users(FTP_Index).list_index).Priv(i).Path, 2) = Drv Then
            DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(i).Accs
            DirFnd = True
            Exit For
          End If
        Next
  
        If InStr(DummyS, "R") And DirFnd Then
          retf = open_data_connect(FTP_Index)
          
          If Not open_file Then
            Open Full_Name For Binary Access Read Lock Write As #FTP_Index
            open_file = True
          End If
          Do
            If users(FTP_Index).data_representation = "A" Then
              If try_again Then
              Else      're-send old line
                Line Input #FTP_Index, Buffer
              End If
              retf = send_data(Buffer & vbCrLf, FTP_Index)
              If retf < 0 Then 'SOCKET_ERROR
                retf = WSAGetLastError()
                If retf = WSAEWOULDBLOCK Then
                  try_again = True
                Else        'error on sending
                  error_on_data_cnt = True
                  close_data_cnt = True
                End If
              Else
                try_again = False
              End If
              If EOF(FTP_Index) Then close_data_cnt = True
            Else  'binary transfer
              'sends file on data connection; data are sent in blocks of 1024 bytes
              If next_block = 0 Then
                File_Len = LOF(FTP_Index)
                blocks = Int(File_Len / 1024)    '# of blocks
                spare_bytes = File_Len Mod 1024  '# of remaining bytes
                Buffer = String$(1024, " ")
              End If
              If next_block < blocks Then 'sends blocks
                Get #FTP_Index, next_byte + 1, Buffer
                retf = send_data(Buffer, FTP_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
                  next_block = next_block + 1
                  next_byte = next_byte + 1024
                End If
              Else    'sends remaining bytes
                Buffer = String$(spare_bytes, " ")
                Get #FTP_Index, , Buffer
                retf = send_data(Buffer, FTP_Index)
                close_data_cnt = True
              End If
            End If
          Loop Until close_data_cnt
          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 #FTP_Index    'close file
            If error_on_data_cnt Then    'replies to user
              retf = send_reply("550 RETR command not executed.", FTP_Index)
            Else
              retf = send_reply("226 RETR command completed.", FTP_Index)
            End If
            retf = close_data_connect(FTP_Index)    'close data connection
          End If
        Else
            'the user can't retrieves files
          retf = send_reply("550 You can't take this file action.", FTP_Index)
          retf = close_data_connect(FTP_Index)
        End If
      ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then