Vb security

[Fenomeno85]

Ciao a tutti, mi stavo chiedendo una cosa ... siccome per la tesina di fine anno ho una parte di acquisizione dati, mi piacerebbe sapere:
io acquisisco da un pc, i dati che prendo e che elaboro li spedisco al mio pc dove risiede il db ... posso fare un collegamento criptato nell'invio dei dati?? e poi il server (mio pc) decripta automaticamente i dati??

~§~ Sempre E Solo Lei ~§~

[matpez]

Si certo, ma come li mandi i dati...tramite il winsock ?

[cionci]

Ho riaperto...scusate...

Ciao

[Fenomeno85]

Originariamente inviato da cionci
Ho riaperto...scusate...

Ciao

de nada ... grazie cionci

comunque penso che dovrei implementare sotto winsock ma non se so nada.

~§~ Sempre E Solo Lei ~§~

[VICIUS]

Uhm se non ho capito male quello che vuoi fare è piu o meno quello che fa ssh. Inviare dati tramite un canale criptato da un client a un server. So che ssh usa SSL per che dovrebbe essere presente anche su windows, su planet source code se non ricordo male c'era anche un esempio. Se non vuoi scervellarti con librerie strane e affini puoi sempre inventarti un algoritmo anche molto semplice. Se non ricordo male basta anche una semplicissima trasformazione lineare che potrebbe essere un buon collegamento con matematica.

ciao

[Fenomeno85]

dove posso trovare qualche esempio o spiegazione su queste cose?

~§~ Sempre E Solo Lei ~§~

[matpez]

Non penso che tu debba passare dati della N.A.S.A. cmq in ogni modo potresti passarli tramite winsock delle stringhe criptate con una chiava conosciuta da te, poi il programma da te che legge i dati e mette nel database li riconverte ed il gioco è fatto.

Se hai problemi di winsock ti posso postare qlc esempio a riguardo sulla connessione diretta tra server e client

[cionci]

Sì...infatti credo che ti basti criptare con qualcosa tipo l'algoritmo RC2...

[Fenomeno85]

se hai qualche esempio grazie

~§~ Sempre E Solo Lei ~§~

[matpez]

Se ci sono dubbi chiedi!

[matpez]

Questo sono 2 funzioni che ti servono per codificare/decodificare

Private Const CRYPT_NEWKEYSET As Long = &H8
Private Const MS_DEF_PROV As String = "Microsoft Base Cryptographic Provider v1.0"
Private Const PROV_RSA_FULL As Long = 1
Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
Private Const ALG_CLASS_HASH As Long = 32768
Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_TYPE_STREAM As Long = 2048
Private Const ALG_SID_RC4 As Long = 1
Private Const ALG_SID_MD5 As Long = 3
Private Const CALG_MD5 As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
Private Const CALG_RC4 As Long = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
Private Const ENCRYPT_ALGORITHM As Long = CALG_RC4

Private Declare Function CryptAcquireContext Lib "Advapi32.dll" Alias "CryptAcquireContextA" (phProv As Long, ByVal pszContainer As Long, ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "Advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, phHash As Long) As Long
Private Declare Function CryptHashData Lib "Advapi32.dll" (ByVal hHash As Long, ByVal pbData As String, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDeriveKey Lib "Advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hBaseData As Long, ByVal dwFlags As Long, phKey As Long) As Long
Private Declare Function CryptDestroyHash Lib "Advapi32.dll" (ByVal hHash As Long) As Long
Private Declare Function CryptDestroyKey Lib "Advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function CryptEncrypt Lib "Advapi32.dll" (ByVal hKey As Long, ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal pbData As String, pdwDataLen As Long, ByVal dwBufLen As Long) As Long
Private Declare Function CryptDecrypt Lib "Advapi32.dll" (ByVal hKey As Long, ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal pbData As String, pdwDataLen As Long) As Long
Private Declare Function CryptReleaseContext Lib "Advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long


Public Function EncryptAPI(ByVal sTesto As String, ByVal sChiave As String, Optional ByVal bUUEncoding As Boolean = False) As String
    
  'Cripta il testo specificato con le API.
  On Error Resume Next
  
  Dim lHHash          As Long
  Dim lHkey           As Long
  Dim lHExchgKey      As Long
  Dim lHCryptprov     As Long
  Dim lCryptLength    As Long
  Dim lCryptBufLen    As Long
  Dim lngRet          As Long
  Dim sCryptBuffer    As String
  Dim sProvider       As String
    
  
  If sTesto = "" Then Exit Function
  sProvider = MS_DEF_PROV & vbNullChar
  lngRet = CryptAcquireContext(lHCryptprov, 0&, sProvider, PROV_RSA_FULL, 0)
  If lngRet = 0 Then
    lngRet = CryptAcquireContext(lHCryptprov, 0&, sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)
  End If
  If lngRet Then
    If CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash) Then
      If CryptHashData(lHHash, sChiave, Len(sChiave), 0) Then
        If CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, 0, lHkey) Then
          CryptDestroyHash (lHHash)
          lHHash = 0
          lCryptLength = Len(sTesto)
          lCryptBufLen = lCryptLength * 2
          sCryptBuffer = String$(lCryptBufLen, vbNullChar)
          LSet sCryptBuffer = sTesto
          If CryptEncrypt(lHkey, 0, 1, 0, sCryptBuffer, lCryptLength, lCryptBufLen) Then
            sCryptBuffer = Mid$(sCryptBuffer, 1, lCryptLength)
            If bUUEncoding Then
              sCryptBuffer = UUEncode(sCryptBuffer)
            End If
            EncryptAPI = sCryptBuffer
          End If
        End If
      End If
    End If
  End If
  If Err.LastDllError Then Err = Err.LastDllError
  If lHkey Then Call CryptDestroyKey(lHkey)
  If lHExchgKey Then CryptDestroyKey (lHExchgKey)
  If lHHash Then CryptDestroyHash (lHHash)
  If lHCryptprov Then Call CryptReleaseContext(lHCryptprov, 0)
    
End Function

Public Function DecryptAPI(ByVal sTesto As String, ByVal sChiave As String, Optional ByVal bUUDecode As Boolean = False) As String
  
  'Decripta il testo specificato con le API.
  On Error Resume Next
  
  Dim lHExchgKey          As Long
  Dim lHCryptprov         As Long
  Dim lHHash              As Long
  Dim lHkey               As Long
  Dim lCryptBufLen        As Long
  Dim sProvider           As String
  Dim sCryptBuffer        As String
  
  
  If sTesto = "" Then Exit Function
  If bUUDecode Then
    sTesto = UUDecode(sTesto)
  End If
  sProvider = vbNullChar
  sProvider = MS_DEF_PROV & vbNullChar
  If CryptAcquireContext(lHCryptprov, 0&, sProvider, PROV_RSA_FULL, 0) Then
    If CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash) Then
      If CryptHashData(lHHash, sChiave, Len(sChiave), 0) Then
        If CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, 0, lHkey) Then
          CryptDestroyHash (lHHash)
          lHHash = 0
          lCryptBufLen = Len(sTesto) * 2
          sCryptBuffer = String$(lCryptBufLen, vbNullChar)
          LSet sCryptBuffer = sTesto
          If CryptDecrypt(lHkey, 0, 1, 0, sCryptBuffer, lCryptBufLen) Then
            DecryptAPI = Mid$(sCryptBuffer, 1, lCryptBufLen / 2)
          End If
        End If
      End If
    End If
  End If
  If Err.LastDllError Then Err = Err.LastDllError
  If (lHkey) Then Call CryptDestroyKey(lHkey)
  If lHExchgKey Then CryptDestroyKey (lHExchgKey)
  If lHHash Then CryptDestroyHash (lHHash)
  If lHCryptprov Then Call CryptReleaseContext(lHCryptprov, 0)

End Function

Private Function UUEncode(ByVal InputBuffer As String) As String
    
  On Error Resume Next
  
  Dim bytChar()       As Byte
  Dim bytBuffer()     As Byte
  Dim intStrPos       As Integer
  Dim strOutBuffer    As String
  Dim nLen            As Integer
  
  
  nLen = Len(InputBuffer)
  For intStrPos = 1 To nLen Step 3
    bytBuffer = StrConv(Mid$(InputBuffer, intStrPos, 3), vbFromUnicode)
    ReDim Preserve bytChar(IIf(UBound(bytBuffer) = 3, 3, UBound(bytBuffer) + 1))
    If UBound(bytBuffer) < 3 Then ReDim Preserve bytBuffer(UBound(bytBuffer) + 1)
    bytChar(0) = Int(bytBuffer(0) / 4)
    bytChar(0) = IIf(bytChar(0), (bytChar(0) And 63) + 32, 96)
    bytChar(1) = ((bytBuffer(0) * 16) And 48) Or (Int(bytBuffer(1) / 16) And 15)
    bytChar(1) = IIf(bytChar(1), (bytChar(1) And 63) + 32, 96)
    bytChar(2) = ((bytBuffer(1) * 4) And 60) Or (Int(bytBuffer(2) / 64) And 3)
    bytChar(2) = IIf(bytChar(2), (bytChar(2) And 63) + 32, 96)
    bytChar(3) = (bytBuffer(2) And 63)
    bytChar(3) = IIf(bytChar(3), (bytChar(3) And 63) + 32, 96)
    strOutBuffer = strOutBuffer & StrConv(bytChar, vbUnicode)
  Next
  UUEncode = strOutBuffer
  Err.Clear
    
End Function

Private Function UUDecode(ByVal InputBuffer As String) As String
  
  On Error Resume Next
  
  Dim bytChar()     As Byte
  Dim intLen        As Integer
  Dim strOutBuffer  As String
  Dim intFill       As Integer
  
  intLen = 1
  intFill = Len(InputBuffer) Mod 4
  InputBuffer = InputBuffer & String$(intFill, "`")
  Do While intLen <= Len(InputBuffer)
    bytChar = StrConv(Mid$(InputBuffer, intLen, 4), vbFromUnicode)
    ReDim Preserve bytChar(3)
    strOutBuffer = strOutBuffer & Chr$(((((bytChar(0) - 32) And 63) * 4) Or Int(((bytChar(1) - 32) And 63) / 16)) And &HFF)
    strOutBuffer = strOutBuffer & Chr$(((((bytChar(1) - 32) And 63) * 16) Or Int(((bytChar(2) - 32) And 63) / 4)) And &HFF)
    strOutBuffer = strOutBuffer & Chr$(((((bytChar(2) - 32) And 63) * 64) Or ((bytChar(3) - 32) And 63)) And &HFF)
    intLen = intLen + 4
  Loop
  Select Case intFill
    Case 1
      UUDecode = Left$(strOutBuffer, Len(strOutBuffer) - intFill)
    Case 2
      UUDecode = Left$(strOutBuffer, Len(strOutBuffer) - intFill)
    Case 3
      UUDecode = Left$(strOutBuffer, Len(strOutBuffer) - intFill - 1)
    Case Else
      UUDecode = strOutBuffer
  End Select
  Err.Clear
    
End Function

[Fenomeno85]

ottimo ... nel client, dove c'è la possibilità di mettere l'indi ip, come faccio a mettere il nome di un sito?
Spiego, se io mi appoggio al nome del mio sito (che è in remoto sul mio pc) ho l'indirizzo ip.

~§~ Sempre E Solo Lei ~§~

[matpez]

Intendi appoggiarti ad un DNS ?

Perchè se tu vuoi per esempio comvertire un URL in IP ci sono diverse funzioni che lo fanno!

Vuoi fare così tu?

[Fenomeno85]

Originariamente inviato da matpez
Intendi appoggiarti ad un DNS ?

Perchè se tu vuoi per esempio comvertire un URL in IP ci sono diverse funzioni che lo fanno!

Vuoi fare così tu?

si esatto

~§~ Sempre E Solo Lei ~§~

[matpez]

Se manca qlc dimmelo.... :P

Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1

Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Private Type WSADATA
  wVersion                                As Integer
  wHighVersion                            As Integer
  szDescription(0 To MAX_WSADescription)  As Byte
  szSystemStatus(0 To MAX_WSASYSStatus)   As Byte
  wMaxSockets                             As Integer
  wMaxUDPDG                               As Integer
  dwVendorInfo                            As Long
End Type

Private Function SocketsInitialize() As Boolean

  Dim WSAD          As WSADATA
  Dim x             As Integer
  
  
  x = WSAStartup(WS_VERSION_REQD, WSAD)
  
  If x <> 0 Then
    SocketsInitialize = False
    Exit Function
  End If
  
  If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
    SocketsInitialize = False
    Exit Function
  End If
  
  If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
    SocketsInitialize = False
    Exit Function
  End If
  
  SocketsInitialize = True
        
End Function

Private Function SocketsCleanup() As Boolean
  
  Call WSACleanup
    
End Function

Private Function HiByte(ByVal wParam As Integer) As Variant

  HiByte = wParam \ &H100 And &HFF&

End Function

Private Function LoByte(ByVal wParam As Integer) As Variant

  LoByte = wParam And &HFF&

End Function

Public Function GetIPFromHostName(ByVal sHostName As String) As String

  'converte l'host name in IP address.

  Dim ptrHosent       As Long
  Dim ptrAddress      As Long
  Dim ptrIPAddress    As Long
  Dim sAddress        As String
   
   
  If SocketsInitialize() Then
    sAddress = Space$(4)

    ptrHosent = gethostbyname(sHostName & vbNullChar)

    If ptrHosent <> 0 Then

      ptrAddress = ptrHosent + 12
      
      RtlMoveMemory ptrAddress, ByVal ptrAddress, 4
      RtlMoveMemory ptrIPAddress, ByVal ptrAddress, 4
      RtlMoveMemory ByVal sAddress, ByVal ptrIPAddress, 4

      GetIPFromHostName = Asc(sAddress) & "." & Asc(Mid$(sAddress, 2, 1)) & "." & Asc(Mid$(sAddress, 3, 1)) & "." & Asc(Mid$(sAddress, 4, 1))
      
      SocketsCleanup

    End If
  End If
   
End Function

[Fenomeno85]

oggi pome la guardo grazie

~§~ Sempre E Solo Lei ~§~

[Fenomeno85]

incomincio a rompere un pò:
1) ma quanto devo inizializzare MAX_WSADescription e MAX_WSASYSStatus??
2) il nome del sito è il valore di sHostName perchè è la variabile che faccio passare.

~§~ Sempre E Solo Lei ~§~

[matpez]

1) scusa mi sono dimenticato di dartele:

Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128

2) si è il nome del sito senza http://


Cmq se metti tutto in un modulo è meglio, così vedi solo la funzioni public, quelle private nn compaiono

[Fenomeno85]

RtlMoveMemory che fa che mi continua a dire che non è dichiarata??

~§~ Sempre E Solo Lei ~§~

[matpez]

Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

Ti chiedo scusa ma io ho una classe intera sul network e quando tolgo qlc funzione per darla in giro mi dimentico sempre qlc pezzetto!!