%REM
Library CriptoGSS ver 1.0
Created 21.01.2019 by Andrew Mirkin/Justice
Description: Для Клиента 8 и выше!
!!!Важно: используем Серийный номер подписи, а не слепок!!!
SignString - генерит подпись из строки
sSignedData=SignString(doc.Content(0),sSerialNumber)
SignXML - подписывает ХМЛ документ см. приказ ГСС ПМР №147 от 18.10.2018
формируем ХМЛ и затем sSignedXML=SignXML(XMLstring,sSerialNumber)
VerifySignature - проверяет подпись да/нет
GetSignerInfo - возвращает информаццию о подписях в виде массива, но сначала надо делать VerifySignature
mas=GetSignerInfo(signaturesxml)
Forall v In mas
Print v
End Forall
*** доп функции ***
Unique - генерит уникальное имя файла
GetNotesTempDirectory - возвращает путь к времменым файлам
%END REM
Option Public
Option Declare
Const CAPICOM_CURRENT_USER_STORE = 2
Const CAPICOM_CERTIFICATE_INCLUDE_WHOLE_CHAIN = 1
Const CAPICOM_CERT_INFO_SUBJECT_SIMPLE_NAME=0
Const CADESCOM_DISPLAY_DATA_CONTENT=1
Const CADESCOM_BASE64_TO_BINARY=1
Const CADESCOM_CADES_BES=1
Declare Function w32_OSGetSystemTempDirectory Lib "nnotes" Alias "OSGetSystemTempDirectory" ( ByVal S As String) As Integer
%REM
Function Get_Value
Description: Comments for Function
%END REM
Function Get_Value (allText As String, paramName As String) As String
Get_Value=StrRight(allText,paramName+"=")
Get_Value=StrLeft(Get_Value,",")
End Function
%REM
Function GetNotesTempDirectory
Description: Comments for Function
%END REM
Function GetNotesTempDirectory() As String
Dim d As String * 256
Dim s%
s% = w32_OSGetSystemTempDirectory(d)
GetNotesTempDirectory = Left$(d, s%) +"\"
End Function
%REM
Function SignXML
Description: передаем ХМЛ и Серийный номер подписи
%END REM
Function SignXML (XML As String, sSerialNumber As String) As String
dim sSignedData As String
XML=StrRight(XML,"<container>") 'вынимаем соержимое контейнера
XML=StrLeft(XML,"</container>") 'вынимаем соержимое контейнера
sSignedData=SignString(XML ,sSerialNumber) ' генерим подпись
' формируем подписанных хмл
SignXML={<htmlx xmlns="http://_.w3.org/1999/xhtml" xml:lang="ru" lang="ru"><body2 id="electronic-document" style="display: none;"><container>}
SignXML=SignXML+XML
SignXML=SignXML+{</container><servinfo><signaturesxml>}
SignXML=SignXML+sSignedData
SignXML=SignXML+{</signaturesxml></servinfo></body2></htmlx>}
End Function
%REM
Function SignString
Description: Comments for Function
%END REM
Function SignString(Content As String,SerialNumber As String) As String
Dim oSigner, oSignedData', oSettings
On Error GoTo failed
Set oSigner = CreateObject("CAdESCOM.CPSigner")
Set oSigner.Certificate = GetSignerCertificate(SerialNumber)
oSigner.Options = CAPICOM_CERTIFICATE_INCLUDE_WHOLE_CHAIN
Set oSignedData = CreateObject("CAdESCOM.CadesSignedData")
oSignedData.DisplayData=CADESCOM_DISPLAY_DATA_CONTENT
oSignedData.ContentEncoding = CADESCOM_BASE64_TO_BINARY
oSignedData.Content = StringToUTF8B64(Content) 'В UTF-8 и Base64
SignString = oSignedData.SignCades(oSigner,CADESCOM_CADES_BES,True)
Exit Function
failed:
Print "Не удалось создать подпись из-за ошибки: "+Error$
Exit Function
End Function
%REM
Function VerifySignature
Description: Comments for Function
%END REM
Function VerifySignature(dataToVerify As String, sSignedMessage As String) As Boolean
Dim oSignedData
On Error GoTo failed
Set oSignedData = CreateObject("CAdESCOM.CadesSignedData")
oSignedData.DisplayData=CADESCOM_DISPLAY_DATA_CONTENT
oSignedData.ContentEncoding = CADESCOM_BASE64_TO_BINARY
oSignedData.Content = StringToUTF8B64(dataToVerify) 'В UTF-8 и Base64
Call StringTo(sSignedMessage)'Непонятно что тут происходит но без этого не пашет
VerifySignature = oSignedData.VerifyCades(sSignedMessage,CADESCOM_CADES_BES,True)
Exit Function
failed:
Print "Не удалось проверить подпись из-за ошибки: "+Error$
Exit Function
End Function
Function GetSignerCertificate(SerialNumber) As Variant
Set GetSignerCertificate = Nothing
Dim oStore
On Error GoTo failed
Set oStore = CreateObject("CAdESCOM.Store")
oStore.Open(CAPICOM_CURRENT_USER_STORE)
ForAll oCert In oStore.Certificates
If oCert.SerialNumber = SerialNumber Then
Set GetSignerCertificate = oCert
Exit ForAll
End If
End ForAll
If GetSignerCertificate Is Nothing then Print "Выбранный сертификат не найден"
Exit Function
failed:
Print "Возникла ошибка при попытке обращения к хранилишу сертификатов: "+Error$
Exit Function
End Function
%REM
Function StringTo
Description: Comments for Function
%END REM
Function StringTo (ByVal st As String) As String
End Function
%REM
Function GetSignerInfo
Description: Comments for Function
%END REM
Function GetSignerInfo (Sign As String) As Variant
Dim oSignedData, ns As Integer, mas() As String, k As Integer
Set oSignedData = CreateObject("CAdESCOM.CadesSignedData")
oSignedData.DisplayData=CADESCOM_DISPLAY_DATA_CONTENT
oSignedData.ContentEncoding = CADESCOM_BASE64_TO_BINARY
Call StringTo(Sign)'Непонятно что тут происходит но без этого не пашет
On Error Resume Next
Call oSignedData.VerifyCades(Sign,CADESCOM_CADES_BES,False)
ReDim Preserve mas(0)
ForAll v In oSignedData.Signers
ReDim Preserve mas(UBound(mas)+1)
mas(k) = v.Certificate.GetInfo(CAPICOM_CERT_INFO_SUBJECT_SIMPLE_NAME)+". "+Get_Value(v.Certificate.SubjectName,"O")
End ForAll
GetSignerInfo=mas
End Function
Function Unique As String
Dim unik
unik = Evaluate("@Unique")
Unique = StrToken(unik(0), "-", -1) ' drop the username part of the ID which is always the same for this user
End Function
%REM
Function StringToUTF8B64
Description: Comments for Function
%END REM
Function StringToUTF8B64 (st As String) As String
Dim session As New NotesSession, inStream As NotesStream
Dim datapatch As String ,oname As String
datapatch$ = GetNotesTempDirectory' 'Путь для временных файлов
oname$=Unique' временный файл
Set inStream = session.CreateStream() ' XML-ка
Call inStream.Open(datapatch$ & oname$, "utf-8")
Call inStream.Truncate
Call inStream.WriteText(st)
StringToUTF8B64 = inStream.ReadEncoded(ENC_BASE64, 76)
Call inStream.Close
Kill datapatch$ & oname$ ' стереть файл
StringToUTF8B64 = Replace(StringToUTF8B64 ,Chr(10),"")
StringToUTF8B64 = Replace(StringToUTF8B64 ,Chr(9),"")
StringToUTF8B64 = Replace(StringToUTF8B64 ,Chr(13),"")
End Function