unit Frm_PKCSDemo;
{=========================================================================

	Copyright(C) Feitian Technologies Co., Ltd.
	All rights reserved.
File:
  Frm_PKCSDemo.pas
Author:
  Allen
CreatedTime:
  20090630
DESC:
	implementation of the TFrmMain class.

=========================================================================}
interface

uses
  ShareMem,Windows,SysUtils, Types, Classes, Variants, QTypes, QGraphics, QControls, QForms,
  QDialogs, QStdCtrls,pkcs11,Frm_Login;

type
  TFrmMain = class(TForm)
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    Memo: TMemo;
    ButtClearMsg: TButton;
    ButtConnectToken: TButton;
    ButtGenerateKey: TButton;
    ButtSign: TButton;
    ButtVerify: TButton;
    ButtEncrypt: TButton;
    ButtDecrypt: TButton;
    ButtExit: TButton;
    procedure FormShow(Sender: TObject);
    procedure ButtClearMsgClick(Sender: TObject);
    procedure ButtConnectTokenClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ButtExitClick(Sender: TObject);
    procedure ButtGenerateKeyClick(Sender: TObject);
    procedure ButtSignClick(Sender: TObject);
    procedure ButtVerifyClick(Sender: TObject);
    procedure ButtEncryptClick(Sender: TObject);
    procedure ButtDecryptClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
     
  private
    m_hSession:CK_SESSION_HANDLE;
    m_hPubKey:CK_OBJECT_HANDLE;
	  m_hPriKey:CK_OBJECT_HANDLE;
    m_pSignature: array[0..1023] of CK_BYTE;
    m_ulSignatureLen:CK_ULONG;
    
    function nByteToStr(dataSize:longword; pData:pointer; count: longword; nSplit: longword):string;
  public
    { Public declarations }
  end;


var
  FrmMain : TFrmMain;

  keyType : CK_ULONG = CKK_RSA;
  subject : string = 'Sample RSA Key Pair';
  bTrue   : Boolean=TRUE;
  ulModulusBits : CK_ULONG = 1024;
  pEncryptedData: array[0..1023] of CK_BYTE;
  m_ulCipherLen:CK_ULONG;

  keyGenMechanism : CK_MECHANISM = (mechanism:0;pParameter:nil;ulParameterLen:0);
  priClass : CK_OBJECT_CLASS = CKO_PRIVATE_KEY;

  //initialize private template
  priTemplate : array[0..8] of CK_ATTRIBUTE = (
	  (attrtype:CKA_CLASS;       pValue:@priClass;	ulValueLen:sizeof(priClass)),
	  (attrtype:CKA_KEY_TYPE;	   pValue:@keyType;   ulValueLen:sizeof(keyType)),
	  (attrtype:CKA_SUBJECT;     pValue:@subject;   ulValueLen:sizeof(subject)),
	  (attrtype:CKA_DECRYPT;	   pValue:@bTrue;		  ulValueLen:sizeof(bTrue)),
	  (attrtype:CKA_PRIVATE;	   pValue:@bTrue;		  ulValueLen:sizeof(bTrue)),
	  (attrtype:CKA_SENSITIVE;   pValue:@bTrue;		  ulValueLen:sizeof(bTrue)),
	  (attrtype:CKA_TOKEN;		   pValue:@bTrue;		  ulValueLen:sizeof(bTrue)),
	  (attrtype:CKA_EXTRACTABLE; pValue:@bTrue;		  ulValueLen:sizeof(bTrue)),
	  (attrtype:CKA_UNWRAP;		   pValue:@bTrue;		  ulValueLen:sizeof(bTrue))
    );

  pubClass : CK_OBJECT_CLASS = CKO_PUBLIC_KEY;

  //initialize public template
  pubTemplate : array[0..6] of CK_ATTRIBUTE = (
	(attrtype:CKA_CLASS;		    pValue:@pubClass;		  ulValueLen:sizeof(pubClass)),
	(attrtype:CKA_KEY_TYPE;		  pValue:@keyType;		    ulValueLen:sizeof(keyType)),
	(attrtype:CKA_SUBJECT;	    pValue:@subject;		    ulValueLen:sizeof(subject)),
	(attrtype:CKA_MODULUS_BITS;	pValue:@ulModulusBits;  ulValueLen:sizeof(ulModulusBits)),
	(attrtype:CKA_ENCRYPT;		  pValue:@bTrue;			    ulValueLen:sizeof(bTrue)),
	(attrtype:CKA_TOKEN;			  pValue:@bTrue;			    ulValueLen:sizeof(bTrue)),
	(attrtype:CKA_WRAP;			    pValue:@bTrue;			    ulValueLen:sizeof(bTrue))
  );

  sDataToSign:string = 'USB token bring you more security.' ;
  ckMechanism:CK_MECHANISM = (mechanism:CKM_RSA_PKCS; pParameter:nil; ulParameterLen:0);

//--------------------------------------------------------------------

implementation

{$R *.xfm}

//--------------------------------------------------------------------
function TFrmMain.nByteToStr(dataSize:longword; pData:pointer; count: longword; nSplit: longword):string;
var
  pBuf: array of byte;
  nLine,nLines,nRest,nBlock:longword;
  bNeedSplit:Boolean;
  szTemp:array[0..19] of Char;
  strRet:string;
  i,j,k,m,index:integer;
  nRestTemp,nByteBlock:longword;

begin

  nLine := 0;
	nLines := 0;
	nRest := 0;
	bNeedSplit := true;
  nBlock := 0;
  ZeroMemory(@szTemp,20);


  pBuf:=pData;
	if(0 = nSplit) then begin
		nSplit := dataSize;
		bNeedSplit := false;
	end;

	nRest := dataSize mod nSplit;
	nLines := dataSize div nSplit;

	for i := 0 to nLines-1 do begin
		nRestTemp := nSplit mod count;
		nByteBlock := nSplit div count;
		for j := 0 to nByteBlock-1 do begin
			for k := 0 to count-1 do begin
        ZeroMemory(@szTemp,20);
        index:=i * nSplit + j * count + k;
				strRet := strRet+Format('%.2x',[pBuf[index]]);
			end;
			strRet := strRet+' ';
		end;
		if(nRestTemp <> 0) then begin
			for m := 0 to nRestTemp-1 do begin
        index:=i * nSplit + j * count + k - 3 + nRestTemp;
        ZeroMemory(@szTemp,20);
			  strRet := strRet+Format('%.2x',[pBuf[index]]);
			end
		end;
		if(bNeedSplit) then
			strRet := strRet + #13#10
  end;

	if(nRest <> 0) then begin
		nRestTemp := nRest mod count;
		nByteBlock := nRest div count;
		for j := 0 to nByteBlock-1 do begin
			for k := 0 to count-1 do begin
        index :=dataSize - nRest + k;
			 	strRet := strRet+Format('%.2x',[pBuf[index]]);
			end;
			strRet :=strRet + '';
		end;
		if(nRestTemp <> 0) then begin
			for m := 0 to nRestTemp-1 do begin
        index :=dataSize - nRest + k - 1 + nRestTemp;
				strRet := strRet+Format('%.2x',[pBuf[index]]);
			end;
    end;
		if(bNeedSplit) then
			strRet :=strRet+#13#10;
	end;
  result:=strRet;
  exit;
end;
//--------------------------------------------------------------------
procedure TFrmMain.FormShow(Sender: TObject);
begin
  Memo.Lines.Add('Before any operation, you should connect to token!');
end;

//--------------------------------------------------------------------
//clear information in the memo
procedure TFrmMain.ButtClearMsgClick(Sender: TObject);
begin
  Memo.Clear;
end;
//--------------------------------------------------------------------
procedure TFrmMain.ButtConnectTokenClick(Sender: TObject);
var
  rv:CK_RV;
  ulCount:CK_ULONG;
  SlotList:array of longword;
  pSlotList:CK_SLOT_ID_PTR;
  sMsg:string;
begin
  ulCount:=0;
  if(m_hSession<>0) then
    exit;
  Screen.Cursor := crHourGlass;
  Memo.Lines.Add('================================================');

  //obtains a list of slots in the system
  rv := C_GetSlotList(1, nil, ulCount);
  if(rv<>CKR_OK) then begin
    sMsg:=Format('Can not acquire information of slot, Error Code: 0x%.8x',[rv]);
    Memo.Lines.Add(sMsg);
    Screen.Cursor := crDefault;
    exit
  end;
  if(ulCount<=0) then begin
    sMsg:= 'Can not connect to token, make sure one token has been inserted.';
    Memo.Lines.Add(sMsg);
    Screen.Cursor := crDefault;
    exit
  end;
  //set length of dynamic-array,SlotList.
  SetLength(SlotList,ulCount);
  pSlotList:=@SlotList[0];
  rv := C_GetSlotList(1, pSlotList,ulCount);
  if(rv<>CKR_OK) then begin
    sMsg:=Format('Can not acquire information of slot, Error Code: 0x%.8x',[rv]);
    Memo.Lines.Add(sMsg);
    Screen.Cursor:=crDefault;
    exit
  end;
  if(ulCount<=0) then begin
    sMsg:= 'Can not connect to token, make sure one token has been inserted.';
    Memo.Lines.Add(sMsg);
    Screen.Cursor := crDefault;
    exit
  end;

  //open a session between the app and the token
  rv := C_OpenSession(SlotList[0],CKF_RW_SESSION or CKF_SERIAL_SESSION,0,0,m_hSession);
  if(rv<>CKR_OK) then begin
    sMsg:=Format('Can not acquire information of slot, Error Code: 0x%.8x',[rv]);
    Memo.Lines.Add(sMsg);
    Screen.Cursor:=crDefault;
    exit
  end;
  ButtGenerateKey.Enabled:=true;
  ButtConnectToken.Enabled:=false;
  sMsg:='Connect to token Successfully !';
  Memo.Lines.Add(sMsg);
  sMsg:='Before next test step, need to generate RSA key pair!';
  Memo.Lines.Add(sMsg);
  Screen.Cursor := crDefault;
end;

//------------------------------------------------------------------------
procedure TFrmMain.FormCreate(Sender: TObject);
var
  rv:longword;
begin
  rv:=C_Initialize(0);
  if(rv<>CKR_OK) then begin
     MessageBox(0,'Library initialization failed!','ERROR',MB_ICONERROR);
     exit
  end;

end;

//------------------------------------------------------------------------
procedure TFrmMain.ButtExitClick(Sender: TObject);
begin
  Close();
end;

//------------------------------------------------------------------------
procedure TFrmMain.ButtGenerateKeyClick(Sender: TObject);
var
  sMsg:string;
  pUserPin:PChar;
  rv:longword;
  ulPIN:CK_ULONG;
  ulPrivateKeyAttributeCount:CK_ULONG;
  ulPublicKeyAttributeCount:CK_ULONG;

begin
  Memo.Lines.Add('================================================');
  FrmLogin.EditPin.Clear;
  FrmLogin.ShowModal;
  if(g_strUserPin='') then begin
    Memo.Lines.Add('You should enter User PIN before generating RSA Key pair!');
    exit
  end;

  ulPIN := Length(g_strUserPin);
  pUserPin:=PChar(g_strUserPin);

  Screen.Cursor := crHourGlass;

  // log into the token with user pin
  rv:=C_Login(m_hSession,1,pUserPin,ulPIN);
  
  if(rv<>CKR_OK) then begin
    sMsg:=Format('Can not use your User PIN login to token ,Error Code: 0x%.8x.',[rv]);
    Memo.Lines.Add(sMsg);
    Screen.Cursor := crDefault;
    exit
  end;

  sMsg:='Logging in to token Successfully!';
  Memo.Lines.Add(sMsg);

  ulPublicKeyAttributeCount := sizeof(pubTemplate) div sizeof(CK_ATTRIBUTE);
  ulPrivateKeyAttributeCount:= sizeof(priTemplate) div sizeof(CK_ATTRIBUTE);

  //generates a public-key/private-key pair.
  rv := C_GenerateKeyPair(
		m_hSession, @keyGenMechanism,
		@pubTemplate, ulPublicKeyAttributeCount,
		@priTemplate, ulPrivateKeyAttributeCount,
		@m_hPubKey, @m_hPriKey);
	if(CKR_OK <> rv) then begin
		sMsg :=Format('Can not generate RSA key pair, Error Code: 0x%.8x.', [rv]);
    Memo.Lines.Add(sMsg);
    Screen.Cursor := crDefault;
		exit;
	end;

  ButtSign.Enabled := true;
  ButtEncrypt.Enabled := true;
  ButtGenerateKey.Enabled := false;
  sMsg := 'Generate Key Pair Successfully!';
  Memo.Lines.Add(sMsg);
  sMsg := 'Now,You can Sign,Verify,Encrypt and Decrypt use the Key Pair!';
  Memo.Lines.Add(sMsg);
  Screen.Cursor := crDefault;

end;

//-------------------------------------------------------------------------
procedure TFrmMain.ButtSignClick(Sender: TObject);
var
  rv:CK_RV;
  sTmp,sMsg:string;
  arrDataToSign : array of byte;
  len:integer;
begin
	Memo.Lines.Add('================================================');

  //before calling C_Sign,you should call C_SignInit.
	rv := C_SignInit(m_hSession, @ckMechanism, m_hPriKey);
	if(CKR_OK <> rv) then begin
    sMsg := Format('Fail to call SignInit!Error code 0x%.8x',[rv]);
    Memo.Lines.Add(sMsg);
    exit
  end;
  len:= Length(sDataToSign);
  SetLength(arrDataToSign,len+1);
  ZeroMemory(arrDataToSign,len+1);
  CopyMemory(arrDataToSign, @sDataToSign[1],len);
  ZeroMemory(@m_pSignature,1024);

  //if you don't initialize it with proper value,you should call C_Sign twice.
  //firt time to get buffer size and second time to sign data.
  m_ulSignatureLen:=1024; 
	rv := C_Sign(m_hSession,@arrDataToSign[0],len,@m_pSignature[0], @m_ulSignatureLen);
	if(CKR_OK <> rv) then begin
		sMsg := Format('Fail to Sign!Error code 0x%x.',[rv]);
    Memo.Lines.Add(sMsg);
    exit
  end
	else begin
    sMsg:='Data:';
    Memo.Lines.Add(sMsg);
    Memo.Lines.Add(sDataToSign);
    Memo.Lines.Add('   was Signed successfully!');
    sMsg :=nByteToStr(m_ulSignatureLen,@m_pSignature[0], 1, 16);
    Memo.Lines.Add('Signed Data is:');
    Memo.Lines.Add(sMsg);
    ButtVerify.Enabled := true;
  end
end;

//---------------------------------------------------------------------------
procedure TFrmMain.ButtVerifyClick(Sender: TObject);
var
  rv:CK_RV;
  sMsg:string;
  ulDataLen:longword;
begin
  Memo.Lines.Add('================================================');
	rv := C_VerifyInit(m_hSession, @ckMechanism, m_hPubKey);
	if(CKR_OK <> rv) then begin
    sMsg:= Format('Failed to call VerifyInit!Error code 0x%.8x',[rv]);
    Memo.Lines.Add(sMsg);
		exit;
	end;
  ulDataLen:= Length(sDataToSign);
	rv := C_Verify(m_hSession,@sDataToSign[1], ulDataLen,@m_pSignature[0], m_ulSignatureLen);
	if(CKR_OK <> rv) then begin
    sMsg:=Format('Failed to call verify! Error code 0x%.8x.',[rv]);
		Memo.Lines.Add(sMsg);
    exit;
  end
	else
		Memo.Lines.Add('Verify Successfully!');
end;


//---------------------------------------------------------------------------
procedure TFrmMain.ButtEncryptClick(Sender: TObject);
var
  rv:CK_RV;
  sTmp,sMsg:string;
  arrDataToEncrypt : array of byte;
  dataLen:longword;
begin
	Memo.Lines.Add('================================================');

  //before calling C_Encrypt,you should call C_EncryptInit.
	rv := C_EncryptInit(m_hSession,@ckMechanism,m_hPubKey);
	if(CKR_OK <> rv) then begin
    sMsg:=Format('Failed to call EncryptInit! Error code 0x%.8x.',[rv]);
		Memo.Lines.Add(sMsg);
    exit;
	end;

  dataLen:=Length(sDataToSign);
  SetLength(arrDataToEncrypt,dataLen+1);
  ZeroMemory(arrDataToEncrypt,dataLen+1);
  CopyMemory(arrDataToEncrypt, @sDataToSign[1],dataLen);


	rv := C_Encrypt(m_hSession, @arrDataToEncrypt[0], dataLen, nil, @m_ulCipherLen);
	if(CKR_OK <> rv) then begin
    sMsg:=Format('Can not acquire the size of Data After encrypt! Error code 0x%.8x.',[rv]);
    Memo.Lines.Add(sMsg);
		exit;
 	end;

	ZeroMemory(@pEncryptedData, 1024);

 	rv := C_Encrypt(m_hSession, @arrDataToEncrypt[0], dataLen, @pEncryptedData[0], @m_ulCipherLen);
	if (CKR_OK <> rv) then begin
    sMsg:=Format('Failed to encrypt! Error code 0x%.8x',[rv]);
		Memo.Lines.Add(sMsg);
		exit;
	end;
  Memo.Lines.Add('Data :');
  sMsg:=sDataToSign;
  Memo.Lines.Add(sMsg);
  Memo.Lines.Add('was encrypted successfully!');
  Memo.Lines.Add('Encryted Data is:');
  sMsg:=nByteToStr(m_ulCipherLen, @pEncryptedData[0], 1, 16);
	Memo.Lines.Add(sMsg);
  Memo.Lines.Add('Now you can decrypt by using RSA private key!');
  ButtDecrypt.Enabled :=true;

end;

//---------------------------------------------------------------------------
procedure TFrmMain.ButtDecryptClick(Sender: TObject);
var
  pbRestoredMsg:array[0..1023] of char;
  ulRestoredMsgLen:CK_ULONG;
  rv:CK_RV;
  sMsg:string;
begin

  Memo.Lines.Add('================================================');

  //before calling C_Decrypt,you should call C_DecryptInit.
	rv := C_DecryptInit(m_hSession,@ckMechanism,m_hPriKey);
	if(CKR_OK <> rv) then begin
		sMsg:=Format('Failed to call DecryptInit! Error code 0x%.8x.',[rv]);
    Memo.Lines.Add(sMsg);
    exit;
	end;
  //if you don't initialize ulRestoredMsgLen,you should call C_Decrypt twice.
  //first time to get data buffer size and second time to Decrypt.
  ulRestoredMsgLen:=1024;
	ZeroMemory(@pbRestoredMsg[0],1024);
	rv := C_Decrypt(m_hSession, @pEncryptedData, m_ulCipherLen, @pbRestoredMsg[0], @ulRestoredMsgLen);
	if (CKR_OK <> rv) then begin
    sMsg:=Format('Failed to call decrypt,Error code 0x%.8x.',[rv]);
    Memo.Lines.Add(sMsg);
    exit;
	end;
  Memo.Lines.Add('Decrypt Successfulluy, Data after Decrypt is :');
  Memo.Lines.Add(string(pbRestoredMsg));

end;

//---------------------------------------------------------------------------
procedure TFrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  C_CloseSession(m_hSession);
  C_Finalize(nil);
end;

end.
