Checksum PR preview.red

;-- In %natives.reds

	checksum*: func [
		check?		[logic!]
		_tcp		[integer!]
		_hash		[integer!]
		_method		[integer!]
		_key		[integer!]
		/local
			arg		[red-value!]
			str		[red-string!]
			bin		[red-binary!]
			method	[red-word!]
			key		[byte-ptr!]
			data	[byte-ptr!]
			b		[byte-ptr!]
			len		[integer!]
			type	[integer!]
			key-len [integer!]
			hash-size [red-integer!]
	][
		#typecheck [checksum _tcp _hash _method _key]
		arg: stack/arguments
		len: -1
		switch TYPE_OF(arg) [
			TYPE_STRING [
				str: as red-string! arg
				;-- Passing len of -1 tells to-utf8 to convert all chars,
				;	and it mods len to hold the length of the UTF8 result.
				data: as byte-ptr! unicode/to-utf8 str :len
			]
			default [
				;print-line "** Script Error: checksum expected data argument of type: string! binary! file!"
				fire [TO_ERROR(script invalid-arg) data]
			]
		]

		case [
			_tcp >= 0 [
				integer/box crypto/CRC_IP data len
			]
			_hash >= 0 [
				hash-size: as red-integer! arg + _hash
				integer/box crypto/HASH_STRING data len hash-size/value
			]
			any [_method >= 0 _key >= 0] [
				method: as red-word! arg + _method
				type: symbol/resolve method/symbol
				if not crypto/known-method? type [
					fire [TO_ERROR(script invalid-arg) method]
					exit
				]
				b: either _key >= 0 [
					key-len: -1							;-- Tell to-utf8 to decode everything
					key: as byte-ptr! unicode/to-utf8 as red-string! arg + _key :key-len
					;-- Now key-len contains the decoded key length
					crypto/calc-hmac type data len key key-len
				][
					crypto/calc-hash type data len
				]
				;!! len is reused here, being set to the expected result size of
				;	the hash call. So you can't set it before making that call.
				case [
					type = crypto/_md5    	[len: 16]
					type = crypto/_sha1   	[len: 20]
					type = crypto/_sha256 	[len: 32]
					type = crypto/_sha384 	[len: 48]
					type = crypto/_sha512 	[len: 64]
					type = crypto/_crc32	[integer/box as integer! b	exit]
					type = crypto/_tcp		[integer/box as integer! b  exit]
					true [
						fire [TO_ERROR(script invalid-arg) method]
						exit
					]
				]
				stack/set-last as red-value! binary/load b len
			]
			true [
				integer/box crypto/CRC32 data len
			]
		]
	]

;-- In %crypto.reds

	CRC_IP: func [
		"Calculate IP CRC per RFC1071"
		data	[byte-ptr!]
		len		[integer!]
		return:	[integer!]
		/local
			sum [integer!]
	][
		sum: 0
		
		while [len > 1][
			;-- Operate on 2 separate bytes. We don't have a UINT16 type.
			sum: sum + (((as-integer data/1) << 8) or as-integer data/2)
			data: data + 2
			len: len - 2
		]

		;-- Add left-over byte, if any
		if len > 0 [sum: sum + data/value]

		;-- Fold 32-bit sum to 16 bits
		sum: (sum >> 16) + (sum and FFFFh)		;-- Add high-16 to low-16
		sum: sum + (sum >> 16)					;-- Add carry
		FFFFh and not sum						;-- 1's complement, then truncate
	]

	calc-hash: func [
		alg-sym		[integer!]	"Algorithm symbol value"
		data		[byte-ptr!]
		len			[integer!]
		return:		[byte-ptr!]
	][
		case [
			alg-sym = _crc32 [as byte-ptr! CRC32 data len]
			alg-sym = _tcp   [as byte-ptr! CRC_IP data len]
			true [get-digest data len alg-from-symbol alg-sym]
		]
	]

	calc-hmac: func [
		alg-sym		[integer!]	"Algorithm symbol value"
		data		[byte-ptr!]
		len			[integer!]
		key-data	[byte-ptr!]
		key-len		[integer!]
		return:		[byte-ptr!]
	][
		either any [alg-sym = _crc32  alg-sym = _tcp][
			print-line "The selected algorithm doesn't support HMAC calculation"
			return as byte-ptr! ""
		][
			get-hmac  data len  key-data key-len  alg-from-symbol alg-sym
		]
	]

	get-hmac: func [
		data		[byte-ptr!]						;-- message
		len			[integer!]					
		key-data	[byte-ptr!]						;-- key/password
		key-len		[integer!]
		type		[crypto-algorithm!]
		return:		[byte-ptr!]
		/local
			block-size	[integer!]					
			n			[integer!]
			hash-len	[integer!]					;-- set based on the algorithm used
			hkey-data	[byte-ptr!]					;-- hashed key (used if key > block-size)
			ipad		[byte-ptr!]					;-- inner padding - key XORd with ipad
			opad		[byte-ptr!]					;-- outer padding - key XORd with opad
			idata		[byte-ptr!]					;-- holds ipad+data for hashing
			odata		[byte-ptr!]					;-- holds opad+ihash for hashing
			ihash		[byte-ptr!]					;-- hash of ipad+data
			ohash		[byte-ptr!]					;-- hash of opad+ihash
	][
		block-size: 64								;-- 64 works for MD5 and SHA1-512
		hash-len: alg-hash-size type

		hkey-data: null
		if key-len > block-size [					;-- Keys longer than block size get digested
			key-data: get-digest key-data key-len type
			hkey-data: key-data						;-- Use this to free hashed key later
			key-len: hash-len
		]

		ipad: allocate block-size					;-- Set up inner and outer padding blocks
		opad: allocate block-size
		set-memory ipad #"^@" block-size			;-- Zero them out
		set-memory opad #"^@" block-size
		copy-memory ipad key-data key-len			;-- Put the key data in them
		copy-memory opad key-data key-len

		n: 0
		loop block-size [							;-- XOR the padding blocks with their fixed byte value
			n: n + 1
			ipad/n: ipad/n xor #"^(36)"
			opad/n: opad/n xor #"^(5C)"
		]

		;-- Pseudocode of what we want to do to get the final result:
		;		return hash(join opad hash(join ipad data))

		idata: allocate block-size + len					;-- Space for ipad + message-data
		set-memory idata #"^@" block-size + len
		copy-memory idata ipad block-size					;-- Put ipad data in
		copy-memory (idata + block-size) data len			;-- Append message data

		ihash: get-digest idata (block-size + len) type		;-- Hash ipad+data

		odata: allocate block-size + hash-len				;-- Space for opad + hash result
		set-memory odata #"^@" block-size + hash-len
		copy-memory odata opad block-size					;-- Put opad data in
		copy-memory (odata + block-size) ihash hash-len		;-- Append ipad + message-data hash result

		ohash: get-digest odata (block-size + hash-len) type	;-- Hash opad + hash(ipad data)

		if hkey-data <> null [free hkey-data]				;-- Only done if the key was big and got hashed

		free ipad
		free opad
		free idata
		free odata			
		free ihash

		ohash			;?? Who frees this?
	]

	HASH_STRING: func [
		;"Return a case insensitive hash value"
		;"Return a case sensitive hash value"
		data	[byte-ptr!]
		len		[integer!]	"Data length"
		size	[integer!]	"Size of the hash table."
		return:	[integer!]
	][
		print-line "** /hash support not yet implemented; algorithm TBD."
		if size < 1 [size: 1]
		return 0
	]

	known-method?: func [
		"Return true if the given symbol is supported."
		sym		[integer!]
		return: [logic!]
	][
		any [
			sym = _tcp
			sym = _crc32
			sym = _md5
			sym = _sha1
			sym = _sha256
			sym = _sha384
			sym = _sha512
		]
	]