// ********* NOT REAL DES *************
// ********* NOT REAL DES *************
// ********* NOT REAL DES *************
// ********* NOT REAL DES *************
// ********* NOT REAL DES *************
// ********* NOT REAL DES *************
// ********* NOT REAL DES *************

// I'm not distributing encryption algorithms :(
// See des.c if you want to incorporate real encryption code.
// A simple nibble swap algorithm is implemented in des.c

// implement the following 3 functions in des.c with the real stuff...
// void desinit(char *k);
// void endes(char *in, char *out);
// void dedes(char *in, char *out);

// Another option would be to use whatever MS Windows offers.

// This module provides mechanisms to encypher/decypher

// When it boils right down to it, I think I'm more confused about the processes I implemente below than a would be attacker<g>.
// This mechanism is a light weight deterent that SHOULD NOT be used to guard information your not willing to let others view.
// Use it with an understanding of what's happening. IMPORTANT NOTE: des.c is NOT real DES. It contains a NIBBLE swap
// algorithm; however, real encryption can be used in it's place.



{ -----------------------------------------------------------------------
Tcl Scripting Language Components (Tslc)
Copyright (C) 1996-2002 William Byrne

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit TslcDes;

///////////////////////////////////////////////////////////////////////////////
//
//  TslcDes.pas
//	Copyright(c) 1996-1997 William Byrne
//		WilliamB@ByrneLitho.com
//		76262.13@CompuServe.com
//
//	All rights reserved.
//  	William Byrne makes no representations about the suitability of this
//    	software for any purpose.  It is provided "as is" without express or
//    	implied warranty.
//
//	Usage
//      I hereby grant to the legal purchasors of the source code contained
//      herein a non-exclusive license for the use of said source code in
//      developing compiled, executable software, and for the distribution of
//      said source code as part of said developed, compiled, executable software.
//
//	Editor:
//		Tab stops = 4
//		Page width = 132 characters
//		Font = Courier New, 8pt
//
//  Misc:
//      ??? = Note to self


interface
uses Windows, Classes, SysUtils;

type
	EDESError = class(Exception);


type
	TDES_ReadProc = function(data: pChar; cbLen: integer; clientData: pointer): integer; cdecl;
    TDES_WriteProc = function(const data: pChar; cbLen: integer; clientData: pointer): integer; cdecl;
	TDES_Garbage = function: char;


function DES_MaxPasswordLen: integer; cdecl; external; // key
function DES_Encrypt(const key: pChar; fnRead: TDES_ReadProc; readClientData: pointer;
	fnWrite: TDES_WriteProc; writeClientData: pointer; fnGarbage: TDES_Garbage): integer; cdecl; external;
function DES_Decrypt(const key: pChar; fnRead: TDES_ReadProc; readClientData: pointer;
	fnWrite: TDES_WriteProc; writeClientData: pointer): integer; cdecl; external;

function DES_About: {const} pChar; cdecl; external;
function DES_Version: {const} pChar; cdecl; external;

function Bytes2Hex(dest: pChar; destLen: integer; src: pChar; srcLen: integer): integer; cdecl; external;
function Hex2Bytes(dest: pChar; destLen: integer; src: pChar; srcLen: integer): integer; cdecl; external;


function GenStaticKey(const key: pChar; cypherHexBuf: pChar; cypherHexBufLen: integer): integer; cdecl; external;
// SetStaticKey is the most important phase for security using the implicit key scheme in this module.
// In situations where the process will not be attacked, providing a custom StaticKey would offer a more
// secure key scheme. For the sake of demonstration, I provided a static key in the TslcKey.pas file.
// When I use this module for real world apps, I'll SetStaticKey at runtime using a secondary secure storage for the StaticKey. If
// the StaticKey is attained by an attack, it could be used in conjunction with a copy of this distribution to decypher script keys
// that accompanied the attacked application.
function SetStaticKey(const cypherHex: pChar; staticLock: integer): integer; cdecl; external; // passing nil resets StaticKey to default.


// Prevents the use of StaticDecrypt until StaticUnlock is called. No effect when default StaticKey is set, SetStaticKey(nil, 0)
procedure StaticLock; cdecl; external;
// To unlock, submit clear key that was passed to GenStaticKey that resulted in cypherHex passed to SetStaticKey.
function StaticUnlock(const key: pChar): integer; cdecl; external;


// Secondary Key functions.
// StaticEncrypt creates a cypherhex string from a clear key of maximum cMaxKeyLen character length.
// The resulting key is used in StaticHexDecode and StaticHexEncode. StaticDecrypt will decypher the cypherHex string that was
// generated by StaticEncrypt. Return values less than zero indicate error, values greater than zero specify the minimum buffer
// size, and zero on success. The cypherHex passed to StaticDecrypt is typically the value returned into cypherHexBuf by
// StaticEncrypt. This value is a hex string representation of the cypher-key (secondary key.)
// cypherHexBufLen should be >= cCypherHexLen
// keyBufLen should be > cMaxKeyLen; will not write NULL at buf[keyBufLen]
function StaticEncrypt(const key: pChar; cypherHexBuf: pChar; cypherHexBufLen: integer): integer; cdecl; external;
function StaticDecrypt(const cypherHex: pChar; keyBuf: pChar; keyBufLen: integer): integer; cdecl; external;

// Need binary versions of following, future...
procedure StaticHexDecode(cypherKey: pChar; cypher: string; var clear: string); // Throws EDESError
procedure StaticHexEncode(cypherKey: pChar; clear: string; var cypher: string); // Throws EDESError

procedure DESError(msg: string);
procedure DESStream(key: string; srcStrm, destStrm: TStream; bEncrypt, bVerifyKey: boolean);
procedure DESFile(key, srcFile, destFile: string; bEncrypt, bVerifyKey, bOverwrite: boolean);


const
	cCypherHexLen = 49;
    cMaxKeyLen = 8;

type
	TDESKey = array[0..cMaxKeyLen] of char;

implementation
//uses TslcKey;

// DES stuff...
procedure DESError(msg: string);
begin
	raise EDESError.Create(msg);
end;

// This is not the real thing; however, the 56 bit version is available for U.S.
// In place of the DES encryption code is a simple nibble swap algorithm xor'd with
// key on 8 byte cycles. Decryption xor's then swaps. Short keys are zero padded.
{$L des.obj}

type
	pPasswordData = ^TPasswordData;
	TPasswordData = record
    	ReadLen, ReadPos: integer;
        ReadBuf: pChar;
        WriteLen, WritePos: integer;
		WriteBuf: pChar;
    end;

function PasswordGarbage: char; cdecl;
begin
	result := char(Random(255));
end;


// StaticRead and StaticWrite are callback functions implemented in StaticEncode and StaticDecode
function StaticRead(data: pChar; cbLen: integer; clientData: pointer): integer; cdecl;
var
	d: pPasswordData;
begin
	d := pPasswordData(clientData);
    if cbLen > d^.ReadLen - d^.ReadPos then
    	cbLen := d^.ReadLen - d^.ReadPos;
    Move((d^.ReadBuf + d^.ReadPos)^, data^, cbLen);
    inc(d^.ReadPos, cbLen);
    result := cbLen;
end;

function StaticWrite(data: pChar; cbLen: integer; clientData: pointer): integer; cdecl;
var
	d: pPasswordData;
begin
	d := pPasswordData(clientData);
    if cbLen > d^.WriteLen - d^.WritePos then
    	cbLen := d^.WriteLen - d^.WritePos;
    Move(data^, (d^.WriteBuf + d^.WritePos)^, cbLen);
    inc(d^.WritePos, cbLen);
    result := cbLen;
end;


const
	cMinStaticWrite = 16;

// pass in cypher text in *cypher* param
// returns clear text in *clear* param
// *cypherKey* generated by StaticEncrypt.
procedure StaticHexDecode(cypherKey: pChar; cypher: string; var clear: string);

var
	key: array[0..8] of char;
    data: TPasswordData;
    len, r: integer;
begin
	r := StaticDecrypt(cypherKey, key, 9);
    if r <> 0 then
    	DESError(format('Unable to access key (%d)', [r]));
    len := strlen(pChar(cypher));
    if len mod 2 <> 0 then
    	DESError('Invalid clear length. Expecting cypher hex format.');
    len := len div 2;
	GetMem(data.ReadBuf, len + 1);
    try
	    GetMem(data.WriteBuf, len + 1 + cMinStaticWrite);
    except
    	FreeMem(data.ReadBuf);
        raise;
    end;
	try
		if Hex2Bytes(data.ReadBuf, len + 1, pChar(cypher), len * 2) <> 0 then
        	DESError('Unable to parse cypher hex');
        data.ReadPos := 0;
        data.ReadLen := len;
        data.WritePos := 0;
        data.WriteLen := len + cMinStaticWrite;
	    DES_Decrypt(key, @StaticRead, @data, @StaticWrite, @data);
        clear := data.WriteBuf;
	finally
    	try
        	FreeMem(data.ReadBuf);
        finally
	    	FreeMem(data.WriteBuf);
        end;
    end;
end;

// pass in clear text using *clear* param
// returns cypher hex in *cypher* param for later use in StaticHexDecode above.
// *cypherKey* generated by StaticEncrypt.
procedure StaticHexEncode(cypherKey: pChar; clear: string; var cypher: string);
var
	key: array[0..8] of char;
    data: TPasswordData;
    len, r: integer;
begin
	r := StaticDecrypt(cypherKey, key, 9);
    if r <> 0 then
    	DESError(format('Unable to access key (%d)', [r]));
    len := strlen(pChar(clear));
    GetMem(data.WriteBuf, len + 1 + cMinStaticWrite);
	try
        data.ReadPos := 0;
        data.ReadLen := len + 1;
        data.ReadBuf := pChar(clear);
        data.WritePos := 0;
        data.WriteLen := len + cMinStaticWrite;
	    DES_Encrypt(key, @StaticRead, @data, @StaticWrite, @data, @PasswordGarbage);
        SetString(cypher, nil, data.WritePos * 2); // multiply by 2 because cypher is hex-text
		if Bytes2Hex(pChar(cypher), data.WritePos * 2 + 1, data.WriteBuf, data.WritePos) <> 0 then
        	DESError('Unable to hex encode cypher');
	finally
    	FreeMem(data.WriteBuf);
    end;
end;


function Garbage: char;
begin
	result := char(Random(255));
end;


const
	cMaxPWord = cMaxKeyLen; // ??? taking advantage of ~known~ characteristics
	cHeaderSz = 16;
    cVerOffset = 4;

type
	pTDESData = ^TDESData;
	TDESData = record
    	hSrc:  TStream;
        hDest: TStream;
        hdrData, verData: array[0..cHeaderSz] of char;
        cbRead, cbWritten: integer;
        verify: boolean; // Store the password instead of a magic number to help in determining if the
        headerSz: integer; // correct password key was given for decryption. However difficult it is to
        keyErr: boolean; // attack the first eight bytes against a password pool is better than a magic
        encrypting: boolean; // number which is ultimately more predictable. Setting the header flag below
        				// to off will result in not writing password data; though, no verification will
                        // occur at the machine level. Ofcourse the header is encrypted with the same
                        // password that is stored in the header.
    end;

function DES_WriteCallback(const buf: pChar; cbLen: integer; clientData: pointer): integer; cdecl;
var
	p: pChar;
    x, n: integer;
begin
	with pTDESData(clientData)^ do
    begin
        if (headerSz > 0) and not encrypting then
        begin
        	n := headerSz;
            if n > cbLen then
            	n := cbLen;
			dec(headerSz, cbLen);
            for x:= cbWritten to n - 1 do
            	verData[x] := buf[x];

            if (headerSz <= 0) then // the entire header was read
            	if verify then
	            begin
                    keyErr := strcomp(@verData[cVerOffset], @hdrData[cVerOffset]) <> 0;
                    if keyErr then
                    begin
                    	result := -1;
                        exit;
                    end;
                end else
                	keyErr := False;

            p := @buf[n];
        	result := hDest.Write(p^, cbLen - n);
            if result >= 0 then // retain error info ( if result < 0, then we'd want to return the negative number for error )
            	inc(result, n);
        end else
			result := hDest.Write(buf^, cbLen);
        inc(cbWritten, result);
    end;
end;

function DES_ReadCallback(buf: pChar; cbLen: integer; clientData: pointer): integer; cdecl;
var
	x, n: integer;
    p: pChar;
begin
	with pTDESData(clientData)^ do
    begin
        if (headerSz > 0) and encrypting then
        begin
        	n := headerSz;
            if n > cbLen then
            	n := cbLen;
			dec(headerSz, cbLen);
            for x:= cbRead to n - 1 do
            	buf[x] := hdrData[x];
            p := @buf[n];
        	result := hSrc.Read(p^, cbLen - n);
            if result >= 0 then // retain error info ( if result < 0, then we'd want to return the negative number for error )
            	inc(result, n);
            if headerSz <= 0 then // the entire header was written
            	keyErr := False;
        end else
			result := hSrc.Read(buf^, cbLen);
        inc(cbRead, result);
    end;
end;

procedure DESStream(key: string; srcStrm, destStrm: TStream; bEncrypt, bVerifyKey: boolean);
var
	data: TDESData;
    x: integer;
begin
    Randomize;
    FillChar(data, sizeof(TDESData), 0); // prepare our callback data
 	data.hSrc := srcStrm;
    data.hDest := destStrm;
    data.cbRead := 0;
    data.cbWritten := 0;
    data.headerSz := cHeaderSz; // as of now, always write header info
    data.keyErr := cHeaderSz > 0; // will be reset for normal operations
    data.verify := bVerifyKey; // only used for decryption
	data.encrypting := bEncrypt;
	for x:= 0 to cHeaderSz - 1 do
    	data.hdrData[x] := Garbage;
    x := strlen(pChar(key));
    if x > cMAXPword then
        DESError('Password too long');
    if cVerOffset + cMaxPWord + 1 > cHeaderSz then // Assertion
    	DESError('Constants in error');

    Move(pChar(key)^, data.hdrData[cVerOffset], x + 1);
    try
		if bEncrypt then
        begin
			x := DES_Encrypt(pChar(key), @DES_ReadCallback, @data, @DES_WriteCallback, @data, @Garbage);
            if x < 0 then
    	    	DESError(format('Unable to encrypt: %d', [x]));
        end else
        begin
        	x := DES_Decrypt(pChar(key), @DES_ReadCallback, @data, @DES_WriteCallback, @data);
            if x < 0 then
            	DESError(format('Unable to decrypt: %d', [x]));
        end;
    except
    	if data.keyErr then
        	DESError('Invalid key')
        else
        	raise;
    end;
end;

procedure DESFile(key, srcFile, destFile: string; bEncrypt, bVerifyKey, bOverwrite: boolean);
var
	hSrc, hDest: TStream;
    destExists: boolean;
begin
	if not FileExists(srcFile) then
    	DESError(format('%s does not exist', [srcFile]));
    destExists :=  FileExists(destFile);
    if destExists and not bOverwrite then
    	DESError(format('Cannot overwrite %s', [destFile]));
    hSrc := TFileStream.Create(srcFile, fmOpenRead);

	if destExists and not DeleteFile(destFile) then
    	DESError(format('Cannot pre-delete %s', [destFile]));
	try
	    hDest := TFileStream.Create(destFile, fmCreate);
    except
    	hSrc.Free;
        raise;
    end;
	try
        DESStream(key, hSrc, hDest, bEncrypt, bVerifyKey);
    finally
    	try
        	hSrc.Free;
        finally
        	hDest.Free;
        end;
    end;
end;

initialization
 	// Commenting out next line would result in the usage of the default StaticKey.
    // The following key is an arbitrary key that can be loaded at runtime helping to prevent a
    // a successful attack (file analysis) on the key that would otherwise be embedded in the DLL or EXE.
    // The StaticKey should be protected; with it, anything generated by StaticEncrypt can be decyphered.
    // And with the Secondary StaticKey, StaticEncode text could be decyphered.

//	SetStaticKey(TslcGetStaticKey, 0);

end.
