%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