<%
''........................................
'' RSA插件
'' author Flc 2021-02-02
'' Version v1.0
''........................................


    Public Publickey, Privatekey
    Private SB, Rsa
    Private s_B, s_R, s_U

    Private Sub Class_Initialize()
        Set SB = App.Str.StringBuilder()
        Set Rsa = Server.CreateObject("System.Security.Cryptography.RSACryptoServiceProvider")
        s_B = 0
        s_R = 0
        s_U = 0
    End Sub

    Private Sub Class_Terminate()
        Rsa.Clear()
        Set Rsa = Nothing
        Set SB = Nothing
    End Sub

    ''前置簡寫，base64不進(jìn)行編碼轉(zhuǎn)換
    Public Function B()
        s_B = 1 : Set B = Me
    End Function

    ''前置簡寫，xml轉(zhuǎn)pem 私匙pkcs8轉(zhuǎn)換
    Public Function R()
        s_R = 1 : Set R = Me
    End Function

    ''前置簡寫，xml轉(zhuǎn)pem 公匙轉(zhuǎn)換
    Public Function U()
        s_U = 1 : Set U = Me
    End Function

    ''Rsa密匙初始化
    Public Sub Rsakey()
        With Rsa
            Publickey = .ToXmlString(False)    'xml格式
            Privatekey = .ToXmlString(True)    'xml格式
            'App.Fso.CreateFile RsaFile & "Rsa-Publickey.xml", Publickey
            'App.Fso.CreateFile RsaFile & "Rsa-Privatekey.xml", Privatekey
        End With
    End Sub

    ''密匙pem格式轉(zhuǎn)xml格式
    ''Ascii 密匙
    Public Function Xml(ByVal Ascii)
        Dim Header, Footer, Kind
        If Ascii = "" Then Xml = "" : Exit Function
        If Instr(Ascii, "BEGIN") > 0 And Instr(Ascii, "END") > 0 Then
            If Instr(Ascii, "PUBLIC") Then
                Header = "-----BEGIN PUBLIC KEY-----"
                Footer = "-----END PUBLIC KEY-----"
            ElseIf Instr(Ascii, "RSA PRIVATE") Then
                Header = "-----BEGIN RSA PRIVATE KEY-----"
                Footer = "-----END RSA PRIVATE KEY-----"
            Else
                Header = "-----BEGIN PRIVATE KEY-----"
                Footer = "-----END PRIVATE KEY-----"
            End If
            Dim P0, P1
            P0 = Instr( 1, Ascii, Header, vbTextCompare) + Len(Header)
            P1 = Instr(P0, Ascii, Footer, vbTextCompare)
            Ascii = Mid(Ascii, P0, (P1 - P0))
        End If
        Kind = App.IIF(Len(Ascii) > 800, 1, 0)
        Xml = Encryption(App.Crypt.H.Base64Decode(Ascii), Kind)
    End Function

    ''密匙xml格式轉(zhuǎn)pem格式
    ''Ascii 密匙
    Public Function Pem(ByVal Str)
        Dim I, Filter, Data : Data = Empty : I = 0
        If s_U = 0 Then
            ''pkcs1 私匙
            Filter = "RSA PRIVATE"
            Str = Node(Str, 1)
            Str = B.KeyLength("020100" & Str, "30")
            ''pkcs8 私匙
            If s_R = 1 Then
                Filter = "PRIVATE"
                Str = B.KeyLength(Str, "04")
                Str = B.KeyLength("020100300d06092a864886f70d0101010500" & Str, "30")
                s_R = 0
            End if
        Else
            ''公匙
            Filter = "PUBLIC"
            Str = Node(Str, 0)
            Str = B.KeyLength(Str, "0030")
            Str = B.KeyLength(Str, "03")
            Str = B.KeyLength("300d06092a864886f70d0101010500" & Str, "30")
            s_U = 0
        End If
        Data = App.Crypt.H.Base64Encode(Str)
        SB.Append "-----BEGIN " & Filter & " KEY-----" & VbCrlf
        While I < Len(Data) / 64
            SB.Append Mid(Data, I * 64 + 1, 64) & vbCrlf
            I = I + 1
        Wend
        SB.Append "-----END " & Filter & " KEY-----"
        Pem = SB.ToString
        SB.Clear
    End Function

    ''RSA XML節(jié)點(diǎn)轉(zhuǎn)換
    Private Function Node(ByVal Str, ByVal Ascii)
        Dim N, E, P, D, DP, DQ, InverseQ, Q, Xml
        App.Xml.Load Str
        If Ascii = 1 Then
            N = KeyLength(App.Xml("Modulus").Text, "02")
            E = KeyLength(App.Xml("Exponent").Text, "02")
            P = KeyLength(App.Xml("P").Text, "02")
            Q = KeyLength(App.Xml("Q").Text, "02")
            DP = KeyLength(App.Xml("DP").Text, "02")
            DQ = KeyLength(App.Xml("DQ").Text, "02")
            InverseQ = KeyLength(App.Xml("InverseQ").Text, "02")
            D = KeyLength(App.Xml("D").Text, "02")
            Node = Join(Array(N, E, D, P, Q, DP, DQ, InverseQ), "")
        Else
            N = KeyLength(App.Xml("Modulus").Text, "02")
            E = KeyLength(App.Xml("Exponent").Text, "02")
            Node = N & E
        End If
        App.Xml.Close
    End Function

    ''拼接數(shù)據(jù)長度計(jì)算
    Public Function KeyLength(ByVal Str, ByVal Ascii)
        If s_B = 0 Then Str = App.Crypt.H.Base64Decode(Str)
        If CLng("&H" & Mid(Str, 1, 2)) >= 128 Then Str = "00" & Str
        Dim Obj : Obj = Hex(Cint(Len(Str) / 2))
        If Len(Obj) > 2 Then
            KeyLength = Join(Array(Ascii, App.IIF(Len(Obj) = "3", "820", "82"), Obj, Str), "")
        Else
            If CLng("&H" & Obj) < 128 Then
                KeyLength = Join(Array(Ascii, App.IIF(Len(Obj) = "1", "0", ""), Obj, Str), "")
            Else
                KeyLength = Join(Array(Ascii, App.IIF(Len(Obj) = "1", "810", "81"), Obj, Str), "")
            End if
        End If
        s_B = 0
    End Function

    ''pem轉(zhuǎn)xml節(jié)點(diǎn)分析
    ''目前只支持[1024bit],[2048bit]位數(shù)pem密匙轉(zhuǎn)換
    Private Function Encryption(ByVal Str, ByVal Format)
        Dim Text, Obj, Entry
        Dim N, E, D, P, Q, DP, DQ, Inverseq
        If Left(Migration(Str, 2), 2) = "30" Then
            If CLng("&H" & Leng(Str)) = Len(Str) / 2 Then
                If Format = 1 Then
                    If Left(Migration(Str, 2), 2) = "02" Then Text = Migration(Str, 4)
                End If
                Select Case Left(Migration(Str, 2), 2)
                    Case "30"
                        Text = CLng("&H" & Left(Migration(Str, 2), 2))
                        Obj = Left(Migration(Str, 2), 2)
                        ''OBJECT_IDENTIFIER版本號(hào)，未輸出
                        If Obj = "06" Then
                            Text = Left(Migration(Str, 2), 2)
                            Text = Migration(Str, CLng("&H" & Text) * 2)
                        End If
                        ''UNLL
                        If Left(Migration(Str, 2), 2) = "05" And Left(Migration(Str, 2), 2) = "00" Then
                            Obj = Left(Migration(Str, 2), 2) : Text = Leng(Str)
                            ''2048密匙下多出一位
                            If Left(Str, 2) = "00" Then Text = Migration(Str, 2)
                        End If
                        If Left(Migration(Str, 2), 2) = "30" Then
                            Text = Leng(Str)
                            If Format = 1 Then
                                If Left(Migration(Str, 2), 2) = "02" Then Text = Leng(Str)
                                If Text <> "00" Then
                                    ''Encryption = "{""code"": 1001, ""msg"": ""密匙錯(cuò)誤,請(qǐng)檢查!"", ""data"": """"}"
                                    App.Console "密匙 ["& App.IIf(Format = 1, "Privatekey", "Publickey") &"] 格式錯(cuò)誤"
                                    App.Error.FunctionName = "Rsa.Encryption"
                                    App.Error.Detail = App.IIf(Format = 1, "Privatekey", "Publickey")
                                    App.Error.Raise "error-crypt-rsa"
                                    'Exit Function
                                End If
                            End If
                            If Left(Migration(Str, 2), 2) = "02" Then N = Identifier(Str)
                        End If
                    Case "02"
                        N = Identifier(Str)
                        If  N = "" Then Text = Migration(Str, 2) : N = Identifier(Str)
                    Case Else
                        App.Console "密匙 ["& App.IIf(Format = 1, "Privatekey", "Publickey") &"] 格式錯(cuò)誤"
                        App.Error.FunctionName = "Rsa.Encryption"
                        App.Error.Detail = App.IIf(Format = 1, "Privatekey", "Publickey")
                        App.Error.Raise "error-crypt-rsa"
                End Select
                If Left(Migration(Str, 2), 2) = "02" Then E = Identifier(Str)
                If Format = 1 Then
                    If Left(Migration(Str, 2), 2) = "02" Then D = Identifier(Str)
                    If Left(Migration(Str, 2), 2) = "02" Then P = Identifier(Str)
                    If Left(Migration(Str, 2), 2) = "02" Then Q = Identifier(Str)
                    If Left(Migration(Str, 2), 2) = "02" Then DP = Identifier(Str)
                    If Left(Migration(Str, 2), 2) = "02" Then DQ = Identifier(Str)
                    If Left(Migration(Str, 2), 2) = "02" Then Inverseq = Identifier(Str)
                    Encryption = Join(Array("<RSAKeyValue><Modulus>", N, "</Modulus><Exponent>", E, "</Exponent><P>", P, "</P><Q>", Q, "</Q><DP>", DP, "</DP><DQ>", DQ, "</DQ><InverseQ>", Inverseq, "</InverseQ><D>", D, "</D></RSAKeyValue>"), "")
                Else
                    Encryption = Join(Array("<RSAKeyValue><Modulus>", N, "</Modulus><Exponent>", E, "</Exponent></RSAKeyValue>"), "")
                End If
            End If
        Else
            App.Console "密匙 ["& App.IIf(Format = 1, "Privatekey", "Publickey") &"] 格式錯(cuò)誤"
            App.Error.FunctionName = "Rsa.Encryption"
            App.Error.Detail = App.IIf(Format = 1, "Privatekey", "Publickey")
            App.Error.Raise "error-crypt-rsa"
        End If
    End Function

    ''節(jié)點(diǎn)數(shù)據(jù)提取
    Private Function Identifier(ByRef Str)
        Dim Text
        If Left(Str, 2) = "81" Or Left(Str, 2) = "82" Then
            Text = Leng(Str)
        Else
            Text = Left(Migration(Str, 2), 2)
        End If
        Text = CLng("&H" & Text) * 2
        Text = Left(Migration(Str, Text), Text)
        If Left(Text, 2) = "00" Then Text = Right(Text, Len(Text) - 2)
        Identifier = App.Crypt.B.Base64Encode(App.Crypt.D.Base(Text))
    End Function

    ''節(jié)點(diǎn)長度
    Private Function Leng(ByRef Str)
        Dim I, Lo, Text : I = 1
        Text = Left(Migration(Str, 2), 2)
        Lo = CLng("&H" & Text)
        If Lo >= 128 Then I = I - 1 + (Lo - 128)
        Leng = Left(Migration(Str, I * 2), I * 2)
    End Function

    ''數(shù)據(jù)偏移
    Private Function Migration(ByRef Str, ByVal Length)
        Migration = Str
        Str = Right(Str, Len(Str) - Length)
    End Function

    ''rsa簽名 私匙簽名
    ''4.5以上版本需改.SignHash_2, 以下為SignHash
    ''Hash 加密內(nèi)容
    ''Length sha1 or sha256
    Public Function Sign(ByVal Hash, ByVal Length)
        With Rsa
            .FromXmlString(Privatekey)
            Hash = App.Crypt.Middleware(Hash, "System.Security.Cryptography." & UCase(Length) & "Managed", "")
            Sign = App.Crypt.B.Base64Encode(.SignHash_2(App.Crypt.D.Base(Hash), Length))
        End With
    End Function

    ''rsa驗(yàn)證 公匙驗(yàn)證
    ''4.5以上版本需改.VerifyHash_2, 以下為.VerifyHash
    ''Hash 加密內(nèi)容
    ''Signature 簽名內(nèi)容
    ''Length sha1 or sha256
    Public Function Verify(ByVal Hash, ByVal Signature, ByVal Length)
        With Rsa
            .FromXmlString(Publickey)
            Hash = App.Crypt.Middleware(Hash, "System.Security.Cryptography." & UCase(Length) & "Managed", "")
            Verify = .VerifyHash_2(App.Crypt.D.Base(Hash), Length, App.Crypt.B.Base64Decode(Signature))
        End With
    End Function

    ''Rsa加密 公匙加密
    ''需要.net framework4.5版本庫的支持，系統(tǒng)最低要求win7，win2008
    ''4.5以上版本需改.Encrypt_2
    ''Str 加密內(nèi)容
    Public Function Encrypt(ByVal Str)
        Dim I, MAX_ENCRYPT_BLOCK : I = 0
        With Rsa
            .FromXmlString(Publickey)
            MAX_ENCRYPT_BLOCK = (.KeySize / 8 - 11) * 2
            'Str = App.Crypt.Base(App.Str.ToByte(Server.UrlEncode(Str)))
            Str = App.Crypt.Base(App.Str.ToByte(Str))
            While I < Len(Str) / MAX_ENCRYPT_BLOCK
                ''如果為 true OAEP 填充, 為 false PKCS#1 v1.5 填充。
                SB.Append App.Crypt.Base(.Encrypt_2(App.Crypt.D.Base(Mid(Str, I * MAX_ENCRYPT_BLOCK + 1, MAX_ENCRYPT_BLOCK)), False))
                I = I + 1
            Wend
            Encrypt = App.Crypt.B.Base64Encode(App.Crypt.D.Base(SB.ToString))
            'RsaEncrypt = SB.ToString
            SB.Clear
        End With
    End Function

    ''Rsa解密 私匙解密
    ''需要.net framework4.5版本庫的支持，系統(tǒng)最低要求win7，win2008
    ''4.5以上版本需改.Decrypt_2
    ''Str 解密內(nèi)容
    Public Function Decrypt(ByVal Str)
        Dim I, MAX_ENCRYPT_BLOCK : I = 0
        With Rsa
            .FromXmlString(Privatekey)
            MAX_ENCRYPT_BLOCK = .KeySize / 8 * 2
            Str = App.Crypt.H.Base64Decode(Str)
            While I < Len(Str) / MAX_ENCRYPT_BLOCK
                SB.Append App.Str.ToString(.Decrypt_2(App.Crypt.D.Base(Mid(Str, I * MAX_ENCRYPT_BLOCK + 1, MAX_ENCRYPT_BLOCK)), False))
                I = I + 1
            Wend
            'Decrypt = App.UrlDecode(SB.ToString)
            Decrypt = SB.ToString
            SB.Clear
        End With
    End Function

%>