Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

GOST encryption

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • GOST encryption

    Hi all,

    I have ported the GOST data encryption implementation from a VB app to PB.
    Have fun!

    check this site for more info on GOST: http://www.jetico.com/index.htm#/gost.htm

    Code:
    
    '
    'Ported to PB/Win 26.09.2002 by bi@inside.net
    'From a VB source by Ásgeir Bjarni Ingvarsson
    '
    'Gosudarstvennyi Standard Soyuza SSR 28147-89
    '              (GOST 28147-89)
    '
    
    #Compile Exe
    #Include "win32api.inc"
    
    Declare Function DeHex(Inpt As String) As String
    Declare Function GenKeyGOST() As String
    Declare Function DeHex(Inpt As String) As String
    Declare Function DeHex(Inpt As String) As String
    Declare Function BigXOR(ByVal value1 As String, ByVal value2 As String) As String
    Declare Function BigMod32Add(ByVal value1 As String, ByVal value2 As String) As String
    Declare Function BigAdd(ByVal value1 As String, ByVal value2 As String) As String
    Declare Function BigShiftLeft(value1 As String, shifts As Integer) As String
    Declare Function F(R As String, k As String) As String
    Declare Function EncryptGOST(ByVal Inpt As String, ByVal key As String) As String
    Declare Function DecryptGOST(ByVal Inpt As String, ByVal key As String) As String
    Declare Function Encrypt(ByVal Inpt As String, ByVal key As String) As String
    Declare Function PadInpt(Inpt As String) As String
    
    Global S1 As Dword Ptr
    Global S2 As Dword Ptr
    Global S3 As Dword Ptr
    Global S4 As Dword Ptr
    Global S5 As Dword Ptr
    Global S6 As Dword Ptr
    Global S7 As Dword Ptr
    Global S8 As Dword Ptr
    
    Sub InitGOST()
    
      GoTo defs
    
      AS1:
      !DD &H6, &H5, &H1, &H7, &HE, &H0, &H4, &HA, &HB, &H9, &H3, &HD, &H8, &HC, &H2, &HF
      AS2:
      !DD &HE, &HD, &H9, &H0, &H8, &HA, &HC, &H4, &H7, &HF, &H6, &HB, &H3, &H1, &H5, &H2
      AS3:
      !DD &H6, &H5, &H1, &H7, &H2, &H4, &HA, &H0, &HB, &HD, &HE, &H3, &H8, &HC, &HF, &H9
      AS4:
      !DD &H8, &H7, &H3, &H9, &H6, &H4, &HE, &H5, &H2, &HD, &H0, &HC, &H1, &HB, &HA, &HF
      AS5:
      !DD &HA, &H9, &H6, &HB, &H5, &H1, &H8, &H4, &H0, &HD, &H7, &H2, &HE, &H3, &HF, &HC
      AS6:
      !DD &H5, &H3, &H0, &H6, &HB, &HD, &H4, &HE, &HA, &H7, &H1, &HC, &H2, &H8, &HF, &H9
      AS7:
      !DD &H2, &H1, &HC, &H3, &HB, &HD, &HF, &H7, &HA, &H6, &H9, &HE, &H0, &H8, &H4, &H5
      AS8:
      !DD &H6, &H5, &H1, &H7, &H8, &H9, &H4, &H2, &HF, &H3, &HD, &HC, &HA, &HE, &HB, &H0
    
    defs:
    
      S1 = CodePtr(AS1)
      S2 = CodePtr(AS2)
      S3 = CodePtr(AS3)
      S4 = CodePtr(AS4)
      S5 = CodePtr(AS5)
      S6 = CodePtr(AS6)
      S7 = CodePtr(AS7)
      S8 = CodePtr(AS8)
    
    End Sub
    
    Function GenKeyGOST() As String
      Dim i As Integer
      Dim dat As String
      Dim key As String
    
      Randomize
      For i = 1 To 32
          dat = Hex$(Rnd(1,255))
          If Len(dat) = 1 Then dat = "0" & dat
          key = key & dat
      Next i
      Function = key
    End Function
    
    Function EnHex(X As String) As String
      Dim i As Integer
      Dim v As String
      Dim inpt As String
    
      For i = 1 To Len(X)
          v = Hex$(Asc(Mid$(X, i, 1)))
          If Len(v) = 1 Then v = "0" & v
          Inpt = Inpt & v
      Next i
      EnHex = Inpt
    End Function
    
    Function DeHex(Inpt As String) As String
      Dim i As Integer
      Dim X As String
    
      For i = 1 To Len(Inpt) Step 2
          X = X & Chr$(Val("&H" & Mid$(Inpt, i, 2)))
      Next i
      DeHex = X
      End Function
    
    Function PadInpt(Inpt As String) As String
      check1:
      If Not (Len(Inpt) / 16) = (Len(Inpt) \ 16) Then
          Inpt = Inpt & "0"
          GoTo check1
      End If
      PadInpt = Inpt
    End Function
    
    Function BigXOR(ByVal value1 As String, ByVal value2 As String) As String
      Dim valueans As String
      Dim loopit As Integer, tempnum As Integer
    
          tempnum = Len(value1) - Len(value2)
          If tempnum < 0 Then
              valueans = Left$(value2, Abs(tempnum))
              value2 = Mid$(value2, Abs(tempnum) + 1)
          ElseIf tempnum > 0 Then
              valueans = Left$(value1, Abs(tempnum))
              value1 = Mid$(value1, tempnum + 1)
          End If
    
          For loopit = 1 To Len(value1)
              valueans = valueans + Hex$(Val("&H" + Mid$(value1, loopit, 1)) Xor Val("&H" + Mid$(value2, loopit, 1)))
          Next loopit
    
          BigXOR = Right$(valueans, 8)
    End Function
    
    Function BigMod32Add(ByVal value1 As String, ByVal value2 As String) As String
        BigMod32Add = Right$(BigAdd(value1, value2), 8)
    End Function
    
    Function BigAdd(ByVal value1 As String, ByVal value2 As String) As String
      Dim valueans As String
      Dim loopit As Integer, tempnum As Integer
    
          tempnum = Len(value1) - Len(value2)
          If tempnum < 0 Then
              value1 = Space$(Abs(tempnum)) + value1
          ElseIf tempnum > 0 Then
                value2 = Space$(Abs(tempnum)) + value2
          End If
    
          tempnum = 0
          For loopit = Len(value1) To 1 Step -1
              tempnum = tempnum + Val("&H" + Mid$(value1, loopit, 1)) + Val("&H" + Mid$(value2, loopit, 1))
              valueans = Hex$(tempnum Mod 16) + valueans
              tempnum = Int(tempnum / 16)
          Next loopit
    
          If tempnum <> 0 Then
              valueans = Hex$(tempnum) + valueans
          End If
    
        BigAdd = Right$(valueans, 8)
    End Function
    
    Function BigShiftLeft(value1 As String, shifts As Integer) As String
      Dim tempstr As String
      Dim loopit As Integer, loopinner As Integer
      Dim tempnum As Integer
      Dim i As Integer, j As Integer
    
          shifts = shifts Mod 32
    
          If shifts = 0 Then
              BigShiftLeft = value1
              Exit Function
          End If
    
          value1 = Right$(value1, 8)
          tempstr = String$(8 - Len(value1), "0") + value1
          value1 = ""
    
        ' Convert to binary
          For loopit = 1 To 8
              tempnum = Val("&H" + Mid$(tempstr, loopit, 1))
              For loopinner = 3 To 0 Step -1
                  If tempnum And 2 ^ loopinner Then
                      value1 = value1 + "1"
                  Else
                      value1 = value1 + "0"
                  End If
              Next loopinner
          Next loopit
    
          For i = 1 To shifts
              For j = 1 To 32
                  Mid$(value1, j, 1) = Mid$(value1, j + 1, 1)
                  If Not Mid$(value1, 1, 1) = "0" Then Mid$(value1, 1, 1) = "0"
              Next j
          Next i
          tempstr = value1
    
        ' And convert back to hex
          value1 = ""
          For loopit = 0 To 7
              tempnum = 0
              For loopinner = 0 To 3
                  If Val(Mid$(tempstr, 4 * loopit + loopinner + 1, 1)) Then
                      tempnum = tempnum + 2 ^ (3 - loopinner)
                  End If
              Next loopinner
              value1 = value1 + Hex$(tempnum)
          Next loopit
    
          BigShiftLeft = Right$(value1, 8)
    End Function
    
    Function F(R As String, k As String) As String
      Dim X As String
      Dim A As Long, B As Long, C As Long, D As Long, E As Long, l As Long, G As Long, h As Long
    
      X = BigMod32Add(R, k)
      A = Val("&H" & Mid$(X, 1, 1))
      B = Val("&H" & Mid$(X, 2, 1))
      C = Val("&H" & Mid$(X, 3, 1))
      D = Val("&H" & Mid$(X, 4, 1))
      E = Val("&H" & Mid$(X, 5, 1))
      l = Val("&H" & Mid$(X, 6, 1))
      G = Val("&H" & Mid$(X, 7, 1))
      h = Val("&H" & Mid$(X, 8, 1))
    
      A = @S1[A]
      B = @S2[B]
      C = @S3[C]
      D = @S4[D]
      E = @S5[E]
      l = @S6[l]
      G = @S7[G]
      h = @S8[h]
      X = Str$(A) & Str$(B) & Str$(C) & Str$(D) & Str$(E) & Str$(l) & Str$(G) & Str$(h)
      X = BigShiftLeft(X, 11)
      F = X
    End Function
    
    Function Encrypt(ByVal Inpt As String, ByVal key As String) As String
      Dim k(1 To 8) As String
      Dim l As String
      Dim R As String
      Dim j As Integer, i As Integer
    
      k(1) = Mid$(key, 1, 8)
      k(2) = Mid$(key, 8, 8)
      k(3) = Mid$(key, 16, 8)
      k(4) = Mid$(key, 24, 8)
      k(5) = Mid$(key, 32, 8)
      k(6) = Mid$(key, 40, 8)
      k(7) = Mid$(key, 48, 8)
      k(8) = Mid$(key, 56, 8)
      For j = 1 To Len(Inpt) Step 16
          l = Mid$(Inpt, j, 8)
          R = Mid$(Inpt, j + 8, 8)
    
          For i = 1 To 3
              R = BigXOR(R, F(l, k(1)))
              l = BigXOR(l, F(R, k(2)))
              R = BigXOR(R, F(l, k(3)))
              l = BigXOR(l, F(R, k(4)))
              R = BigXOR(R, F(l, k(5)))
              l = BigXOR(l, F(R, k(6)))
              R = BigXOR(R, F(l, k(7)))
              l = BigXOR(l, F(R, k(8)))
          Next i
          R = BigXOR(R, F(l, k(8)))
          l = BigXOR(l, F(R, k(7)))
          R = BigXOR(R, F(l, k(6)))
          l = BigXOR(l, F(R, k(5)))
          R = BigXOR(R, F(l, k(4)))
          l = BigXOR(l, F(R, k(3)))
          R = BigXOR(R, F(l, k(2)))
          l = BigXOR(l, F(R, k(1)))
    
          Mid$(Inpt, j, 8) = R
          Mid$(Inpt, j + 8, 8) = l
      Next j
      Encrypt = Inpt
    
    End Function
    
    Function EncryptGOST(ByVal Inpt As String, ByVal key As String) As String
      Dim InptHex As String
      InptHex = PadInpt(EnHex(Inpt))
      EncryptGOST = Encrypt(InptHex, key)
    End Function
    
    Function DecryptGOST(ByVal Inpt As String, ByVal key As String) As String
      Dim k(1 To 8) As String
      Dim l As String
      Dim R As String
      Dim j As Integer, i As Integer
    
      k(1) = Mid$(key, 1, 8)
      k(2) = Mid$(key, 8, 8)
      k(3) = Mid$(key, 16, 8)
      k(4) = Mid$(key, 24, 8)
      k(5) = Mid$(key, 32, 8)
      k(6) = Mid$(key, 40, 8)
      k(7) = Mid$(key, 48, 8)
      k(8) = Mid$(key, 56, 8)
      For j = 1 To Len(Inpt) Step 16
          l = Mid$(Inpt, j, 8)
          R = Mid$(Inpt, j + 8, 8)
    
          R = BigXOR(R, F(l, k(1)))
          l = BigXOR(l, F(R, k(2)))
          R = BigXOR(R, F(l, k(3)))
          l = BigXOR(l, F(R, k(4)))
          R = BigXOR(R, F(l, k(5)))
          l = BigXOR(l, F(R, k(6)))
          R = BigXOR(R, F(l, k(7)))
          l = BigXOR(l, F(R, k(8)))
          For i = 1 To 3
              R = BigXOR(R, F(l, k(8)))
              l = BigXOR(l, F(R, k(7)))
              R = BigXOR(R, F(l, k(6)))
              l = BigXOR(l, F(R, k(5)))
              R = BigXOR(R, F(l, k(4)))
              l = BigXOR(l, F(R, k(3)))
              R = BigXOR(R, F(l, k(2)))
              l = BigXOR(l, F(R, k(1)))
          Next i
    
          Mid$(Inpt, j, 8) = R
          Mid$(Inpt, j + 8, 8) = l
      Next j
      DecryptGOST = Inpt
    End Function
    
    Function PbMain
      Dim key As String
      Dim x As String
      Dim L As String
      Dim inpt As String
      Dim inpt2 As String
      Dim outmsg As String
    
      InitGOST
    
      inpt = "This string to be encrypted."
    
      key = GenKeyGOST
    
      x = PadInpt(EnHex(inpt))
      L = Encrypt(x, key)
      outmsg = "This string: " + inpt + $CrLf + "with this key: " + key + $CrLf + "results in this crypt string: " + L
      inpt2 = DecryptGOST(L, key)
      x = DeHex(inpt2)
    
      outmsg = outmsg + $CrLf + "decrypts to: " + x
    
      MsgBox outmsg, %MB_OK, "GOST for PB"
    
    End Function
    ...and formatting corrected. Thanks Eddie!

    ------------------
    Balthasar Indermuehle, M.Sc.



    [This message has been edited by Balthasar Indermuehle (edited September 27, 2002).]

  • #2
    Hi Balthasar,

    A small tip: use the 'code' formatting statement (surrounded by []) to make your source code easier to read on the forums.
    Read all about it here:
    http://www.powerbasic.com/support/forums/ubbcode.html


    Kind regards

    ------------------
    Eddy
    mailto:raimundo4u@yahoo.comraimundo4u@yahoo.com</A>
    Eddy

    Comment

    Working...
    X