CryptoPro::PKI::TSP::Client::CStamp Stamp(Request.Send(false));

int Verify(PCCERT_CONTEXT pCert = NULL, char *AllowedCriticalExtensions = NULL) const;

#DEFINE FORMAT_MESSAGE_FROM_SYSTEM            0x00001000
#DEFINE TIMESTAMP_DONT_HASH_DATA            0x00000001
#DEFINE TIMESTAMP_VERIFY_CONTEXT_SIGNATURE    0x00000020
#DEFINE TIMESTAMP_NO_AUTH_RETRIEVAL            0x00020000
#DEFINE CERT_STORE_CERTIFICATE_CONTEXT        0x00000001
#DEFINE X509_ASN_ENCODING                    0x00000001
#DEFINE PKCS_7_ASN_ENCODING                 0x00010000

CLEAR
=SetDeclarationAPI()
*------------ Servidores TSA de prueba
lcUrl = "http://time.certum.pl" && OK
*lcUrl = "http://dse200.ncipher.com/TSS/HttpTspServer" && FAIL, NOT FOUND
*lcUrl = "http://tsa.tecxoft.com" && FAIL, SE HA ENCONTRADO UN VALOR DE ETIQUETA INCORRECTO
*lcUrl = "http://zeitstempel.dfn.de" && OK, rapido pro no da TSA
*lcUrl = "https://ca.signfiles.com/tsa/get.aspx"  && FAIL, NO SE PUEDE COMPROBAR EL CERTIFICADO CA
*lcUrl = "https://tsp.iaik.tugraz.at/tsp/TspRequest" && OK - DEMO no da TSA
*lcUrl = "http://tsa.starfieldtech.com"  && OK, rapido pro no da TSA
*lcUrl = "http://timestamp.comodoca.com/rfc3161" && OK
*lcUrl = "http://services.globaltrustfinder.com/adss/tsa" && FAIL, NOT FOUND
*lcUrl = "https://timestamp.geotrust.com/tsa" && FAIL, NOT FOUND
*lcUrl = "http://sha256timestamp.ws.symantec.com/sha256/timestamp"    && OK
*lcUrl = "http://timestamp.globalsign.com/scripts/timstamp.dll" && OK
*lcUrl = "http://timestamp.comodoca.com" && OK
*lcUrl = "https://freetsa.org/tsr" && OK, TSA defectuoso

lcHashToStamp = "00bpE3vtYVJamTeSmgvZ48biWmO1dju9lf4WK50B7zo="
lcAlgorithm = "2.16.840.1.101.3.4.2.1"
SET STEP ON
=GetCryptRetrieveTimeStamp(lcUrl, lcHashToStamp, lcAlgorithm)

PROCEDURE GetCryptRetrieveTimeStamp()
    LPARAMETERS tcUrl AS String, tcHashToStamp AS String, tcAlgorithm AS String
    wszUrl = STRCONV(tcUrl+ CHR(0), 5)
    dwRetrievalFlags = TIMESTAMP_VERIFY_CONTEXT_SIGNATURE
    dwTimeout = 0
    pszHashId = lcAlgorithm + CHR(0)
    pPara = SetStructure_CRYPT_TIMESTAMP_PARA()
    pbData = tcHashToStamp
    cbData = LEN(pbData)
    ppTsContext = 0
    ppTsSigner = 0
    phStore= 0
    nResp = CryptRetrieveTimeStamp(wszUrl, dwRetrievalFlags, dwTimeout, pszHashId, pPara, pbData, cbData, @ppTsContext, @ppTsSigner, @phStore)
    IF nResp=0
        GetMensajeError()
    ENDIF
    *----- Estructura PCRYPT_TIMESTAMP_CONTEXT
    bTsContext = SYS(2600, ppTsContext, 12)
    ncbEmcoded  = CTOBIN(SUBSTR(bTsContext, 1, 4), "4RS")
    ppbEncoded  = CTOBIN(SUBSTR(bTsContext, 5, 4), "4RS")
    ppTimeStamp = CTOBIN(SUBSTR(bTsContext, 9, 4), "4RS")
    *----- Valor para el Nodo EncapsultatedTimeStamp
    cTSB64=SetTimeStampToken(ncbEmcoded, ppbEncoded)
    ? cTSB64
    *----- Estructura CRYPT_TIMESTAMP_INFO 
    =GetDedoce_TimeStampInfo(ppTimeStamp)
    *----- Certificado del firmante TSA (Time Stamp Authority)
    CryptUIDlgViewContext(CERT_STORE_CERTIFICATE_CONTEXT, ppTsSigner, 0, NULL, 0,  0)
ENDPROC

PROCEDURE GetDedoce_TimeStampInfo()
    LPARAMETERS ppTimeStamp AS Long
    cTimeStampInfo = SYS(2600, ppTimeStamp, 76)
    *------- dwVersion
    ndwVersion    = CTOBIN(SUBSTR(cTimeStampInfo, 1, 4), "4RS")
    *------- pszTSAPolicyId
    ppszTSAPolicyId = CTOBIN(SUBSTR(cTimeStampInfo, 5, 4), "4RS")
    nLenTSAPolicyId = GetStrLenA(ppszTSAPolicyId)
    cpszTSAPolicyId = SYS(2600, ppszTSAPolicyId, nLenTSAPolicyId)
    *------- HashAlgorithm
    bHashAlgorithm = SUBSTR(cTimeStampInfo, 9, 12)
    pAlgorithm1 = CTOBIN(SUBSTR(bHashAlgorithm, 1, 4), "4RS")
    nLenAlgorit = GetStrLenA(pAlgorithm1)
    nParameters = CTOBIN(SUBSTR(bHashAlgorithm, 5, 4), "4RS")
    pParameters = CTOBIN(SUBSTR(bHashAlgorithm, 9, 4), "4RS")
    cAlgorithm1 = SYS(2600, pAlgorithm1, nLenAlgorit)
    cParameters = STRCONV(SYS(2600, pParameters, nParameters), 15)
    *------- HashedMessage
    bHashedMessage  = SUBSTR(cTimeStampInfo, 21, 8)
    nHashedMessage = CTOBIN(SUBSTR(bHashedMessage, 1, 4), "4RS")
    pHashedMessage = CTOBIN(SUBSTR(bHashedMessage, 5, 4), "4RS")
    cHash = SYS(2600, pHashedMessage, nHashedMessage)
    B64Hash = STRCONV(cHash,13)
    *-------- SerialNumber
    bSerialNumber  = SUBSTR(cTimeStampInfo, 29, 8)
    nSerialNumber = CTOBIN(SUBSTR(bSerialNumber, 1, 4), "4RS")
    pSerialNumber = CTOBIN(SUBSTR(bSerialNumber, 5, 4), "4RS")
    cSerialNumber = SYS(2600, pSerialNumber, nSerialNumber)
    hSerialNumber = STRCONV(cSerialNumber, 15)
    *-------- ftTime 
    bftTime  = 0h + SUBSTR(cTimeStampInfo, 37, 8)
    lpSystemTime = SPACE(16)
    IF FileTimeToSystemTime(bftTime, @lpSystemTime)>0
        dwLowDateTime = GetCryptBinaryToDateTime(lpSystemTime)
    ENDIF
    *-------- pvAccuracy
    bpvAccuracy  = SUBSTR(cTimeStampInfo, 45, 4)
    npvAccuracy = CTOBIN(SUBSTR(bpvAccuracy, 1, 4), "4RS")
    *--------- fOrdering
    bfOrdering  = SUBSTR(cTimeStampInfo, 49, 4)
    nfOrdering1 = CTOBIN(SUBSTR(bfOrdering, 1, 4), "4RS")
    *--------- Nonce
    bNonce  = SUBSTR(cTimeStampInfo, 53, 8)
    nNonce = CTOBIN(SUBSTR(bNonce, 1, 4), "4RS")
    pNonce = CTOBIN(SUBSTR(bNonce, 5, 4), "4RS")
    *------- Tsa
    bTsa  = SUBSTR(cTimeStampInfo, 61, 8)
    nTsa = CTOBIN(SUBSTR(bTsa, 1, 4), "4RS")
    pTsa = CTOBIN(SUBSTR(bTsa, 5, 4), "4RS")
    cTSA = SYS(2600, pTsa, nTsa)
    IF !EMPTY(cTSA)
        tsb64 = STRCONV(cTSA,13)
        cSTRTSA=SUBSTR(cTSA, AT("0", cTSA))
        lcTSA = GetStructure_CertNameBlob(bTsa, cTSA)
    ENDIF
    *------- Extensions
    ncExtension = CTOBIN(SUBSTR(cTimeStampInfo, 69, 4), "4RS")
    nrgExtension = CTOBIN(SUBSTR(cTimeStampInfo, 73, 4), "4RS")
ENDPROC

*------- Time Stamp Token
PROCEDURE SetTimeStampToken()
    LPARAMETERS tncbEmcoded AS Long, tppbEncoded AS Long
    cByteString = SYS(2600, tppbEncoded, tncbEmcoded)
    cTimeStampB64 = STRCONV(cByteString,13)
    RETURN cTimeStampB64 
ENDPROC

*------ Estructura CRYPT_TIMESTAMP_PARA 
PROCEDURE SetStructure_CRYPT_TIMESTAMP_PARA()
    pszTSAPolicyId = BINTOC(0, "4RS")
    fRequestCerts = BINTOC(1, "4RS")
    cbNonce = BINTOC(0, "4RS")
    pbNonce = BINTOC(0, "4RS")
    cExtension = BINTOC(0, "4RS")
    rgExtension = BINTOC(0, "4RS")
    CRYPT_TIMESTAMP_PARA = 0h + pszTSAPolicyId + fRequestCerts + cbNonce + pbNonce + cExtension + rgExtension 
    RETURN CRYPT_TIMESTAMP_PARA
ENDPROC

*------ Estructura CERT_NAME_BLOB
PROCEDURE GetStructure_CertNameBlob()
    LPARAMETERS tcNameBlob AS String, tcStringBinary AS String
    lcIssuerStr=""
    IF VARTYPE(tcNameBlob)="C"
        lcIssuerByte = 0h + tcNameBlob
        pbCert_Name_Blob = HeapAlloc(GetProcessHeap(), 0, LEN(lcIssuerByte))
        RtlMoveMemory(pbCert_Name_Blob, @lcIssuerByte, LEN(lcIssuerByte))
        lcIssuerStr = GetCertNameToString(pbCERT_NAME_BLOB)
        HeapFree(GetProcessHeap(), 0, pbCert_Name_Blob)
    ENDIF
    IF EMPTY(lcIssuerStr) AND !EMPTY(tcStringBinary)
        cbData = LEN(tcStringBinary)
          lbIssuer = SUBSTR(tcStringBinary, 1, cbData)
        pbData = HeapAlloc(GetProcessHeap(), 0, cbData)
        RtlMoveMemory(pbData, @lbIssuer, cbData)
        lcIssuerByte = 0h + BINTOC(cbData,"4RS") + BINTOC(pbData, "4RS")
        pbCert_Name_Blob = HeapAlloc(GetProcessHeap(), 0, LEN(lcIssuerByte))
        RtlMoveMemory(pbCert_Name_Blob, @lcIssuerByte, LEN(lcIssuerByte))
        lcIssuerStr = GetCertNameToString(pbCERT_NAME_BLOB)
        HeapFree(GetProcessHeap(), 0, pbCert_Name_Blob)
        HeapFree(GetProcessHeap(), 0, pbData)
    ENDIF    
    RETURN lcIssuerStr
ENDPROC

PROCEDURE GetCertNameToString()
    LPARAMETERS pbCertNameBlob AS Long
    *----- Valores posibles para wDwStrType, pueden ser la suma de varios
    SIMPLENAMESTR = 1
    OIDNAMESTR      = 2
    X500NAMESTR      = 3
    SEMICOLONFLAG = 0x40000000
    CRLFFLAG      = 0x08000000
    NOPLUSFLAG      = 0x20000000
    NOQUOTINGFLAG = 0x10000000
    NAMEREVERSE      = 0x02000000
    DISABLEIE4UTF8= 0x00010000
    ENABLEPUNYCODE= 0x00200000
    *----- Asignamos valores a Parametros
    nCertEncodTyp = X509_ASN_ENCODING
    cpName           = pbCertNameBlob
    nDwStrType       = BITOR(X500NAMESTR, OIDNAMESTR, NAMEREVERSE, SEMICOLONFLAG)
    lcNameDecoded = ""
    lnNameLong    = 0
    *----- Intento 1, obtenemos longitud de cadena
    lnNameLong = CertNameToStr(nCertEncodTyp, cpName, nDwStrType, @lcNameDecoded, @lnNameLong)
    IF lnNameLong <> 0
        *----- Intento 2, conociendo longitud de cadena, Obtenemos el nombre decodificado
        lcNameDecoded= REPLICATE(CHR(0), lnNameLong)
        CertNameToStr(nCertEncodTyp, cpName, nDwStrType, @lcNameDecoded, @lnNameLong)
    ENDIF
    *----- La funci&#243;n devuelve una cadena terminada en nulo, quitamos el CHR(0) que represanta nulo
    RETURN STRTRAN(lcNameDecoded, CHR(0), "")
ENDPROC

PROCEDURE GetCryptBinaryToDateTime()
    PARAMETERS tbSystemTime AS String
    ltDateTime = ""
    IF !EMPTY(tbSystemTime)
        wYear     = CTOBIN(SUBSTR(tbSystemTime,1,2),"2RS")
        wMonth     = CTOBIN(SUBSTR(tbSystemTime,3,2),"2RS")
        wDayWeek = CTOBIN(SUBSTR(tbSystemTime,5,2),"2RS")
        wDay      = CTOBIN(SUBSTR(tbSystemTime,7,2),"2RS")
        wHour      = CTOBIN(SUBSTR(tbSystemTime,9,2),"2RS")
        wMinute  = CTOBIN(SUBSTR(tbSystemTime,11,2),"2RS")
        wSecond  = CTOBIN(SUBSTR(tbSystemTime,13,2),"2RS")
        wMilSec  = CTOBIN(SUBSTR(tbSystemTime,15,2),"2RS")
        ltDateTime = DATETIME(wYear, wMonth, wDay, wHour, wMinute, wSecond)
    ENDIF
    RETURN ltDateTime
ENDPROC

PROCEDURE GetMensajeError()
    lnErrorCode = GetLastError()
    lpBuffer = SPACE(128)
    =FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 'WINERROR.H', lnErrorCode, 0, @lpBuffer, 128 , 0)
    =MESSAGEBOX(lpBuffer, 16, "Error: " + TRANSFORM(lnErrorCode,"@0"))
ENDPROC

PROCEDURE SetDeclarationAPI()
    DECLARE LONG CryptRetrieveTimeStamp IN Crypt32;
        STRING     wszUrl,;
        LONG     dwRetrievalFlags,;
        LONG     dwTimeout,;
        STRING     pszHashId,;
        STRING     pPara,;
        STRING     pbData,;
        LONG     cbData,;
        LONG    @ppTsContext,;
        LONG    @ppTsSigner,;
        LONG    @phStore

    DECLARE LONG CertNameToStr IN Crypt32;
        LONG     dwCertEncodingType, ;
        LONG     pName, ;
        LONG     dwStrType, ;
        STRING    @psz, ;
        LONG     csz

    DECLARE LONG CryptUIDlgViewContext IN Cryptui;
        LONG     dwContextType,;
        LONG     pvContext,;
        LONG     hwnd,;
        STRING     pwszTitle,;
        LONG     dwFlags,;
        LONG      pvReserved

    DECLARE LONG FileTimeToSystemTime IN Kernel32;
        STRING      lpFileTime,;
        STRING    @lpSystemTime

    DECLARE LONG GetLastError IN Kernel32

    DECLARE LONG FormatMessage IN Kernel32;
          LONG      dwFlags, ;
          STRING     @lpSource, ;
          LONG      dwMessageId, ;
          LONG      dwLanguageId, ;
          STRING     @lpBuffer, ;
          LONG      nSize, ;
          LONG      Arguments
    
    DECLARE LONG lstrlenA IN Kernel32 AS GetStrLenA ;
        LONG     lpString 
    
    DECLARE LONG GetProcessHeap IN Kernel32

    DECLARE LONG HeapAlloc IN Kernel32;
        LONG     hHeap,;
        LONG     dwFlags,;
        LONG     dwBytes

    DECLARE LONG HeapFree IN Kernel32;
        LONG     hHeap,;
        LONG     dwFlags,;
        LONG     lpMem

    DECLARE RtlMoveMemory IN Kernel32;
        LONG    Destination,;
        STRING @Source,;
        LONG    Length
ENDPROC