JSON Web Token for GemStone/S

JWT.gs

! ------------------- Class definition for JWT
expectvalue /Class
doit
Object subclass: 'JWT'
  instVarNames: #( payload)
  classVars: #()
  classInstVars: #( cache)
  poolDictionaries: #()
  inDictionary: UserGlobals
  options: #()
%
! ------------------- Class definition for RsaPublicKey
expectvalue /Class
doit
Object subclass: 'RsaPublicKey'
  instVarNames: #( maxAge publicKey server)
  classVars: #()
  classInstVars: #( cache)
  poolDictionaries: #()
  inDictionary: UserGlobals
  options: #()
%
! ------------------- Remove existing behavior from JWT
expectvalue /Metaclass3       
doit
JWT removeAllMethods.
JWT class removeAllMethods.
%
! ------------------- Class methods for JWT
set compile_env: 0
category: 'other'
classmethod: JWT
_cache

	^cache
%
category: 'other'
classmethod: JWT
cache

	cache ifNil: [cache := StringKeyValueDictionary new].
	cache copy keysAndValuesDo: [:key :value |
		value isValid ifFalse: [cache removeKey: key ifAbsent: []].
	].
	^cache
%
category: 'other'
classmethod: JWT
forToken: aString

	| jwt |
	jwt := self cache
		at: aString
		ifAbsentPut: [self new initialize: aString; yourself].
	jwt isValid ifTrue: [^jwt].
	self cache removeKey: aString ifAbsent: [].
	^nil
%
! ------------------- Instance methods for JWT
set compile_env: 0
category: 'other'
method: JWT
audience

	payload ifNil: [^nil].
	^payload at: 'aud'
%
category: 'other'
method: JWT
bytesFromBase64URL: aString

	| code result values |
	code := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_'.
	values := (Array new: aString size+ 3 // 4 * 4) atAllPut: 0; yourself.
	1 to: aString size do: [:i |
		| char index |
		char := aString at: i.
		index := (code indexOf: char) - 1.
		values at: i put: index.
	].
	result := ByteArray new.
	1 to: values size by: 4 do: [:i |
		| bytes uint24 |
		uint24 := 	((values at: i + 0) bitShift: 6 * 3)
					+	((values at: i + 1) bitShift: 6 * 2)
					+	((values at: i + 2) bitShift: 6 * 1)
					+	((values at: i + 3) bitShift: 6 * 0).
		bytes := ByteArray new: 3.
		bytes unsigned24At: 1 put: uint24.
		result addAll: bytes.
	].
	^result.
%
category: 'other'
method: JWT
email

	payload ifNil: [^nil].
	^payload at: 'email'
%
category: 'other'
method: JWT
emailVerified

	^payload
		ifNil: [false]
		ifNotNil: [payload at: 'email_verified']
%
category: 'other'
method: JWT
initialize: aString

	| header keyPath kid messagePath pieces publicKey result signature signaturePath |
	keyPath := '/tmp/key' , self asOop printString.
	messagePath := '/tmp/message' , self asOop printString.
	signaturePath := '/tmp/signature' , self asOop printString.
	pieces := aString subStrings: $..
	header := JsonParser parse: (self stringFromBase64URL: (pieces at: 1)).
	(header at: 'alg') ~= 'RS256' ifTrue: [self error: 'Unsupported encryption algorithm!'].
	kid := header at: 'kid'.
	publicKey := RsaPublicKey publicKeyFor: kid.
	(GsFile open: keyPath mode: 'w' onClient: false)
		nextPutAll: publicKey;
		close.
	(GsFile open: messagePath mode: 'w' onClient: false)
		nextPutAll: (pieces at: 1) , '.' , (pieces at: 2);
		close.
	signature := self bytesFromBase64URL: (pieces at: 3).	"This was encrypted using the private key"
	(GsFile open: signaturePath mode: 'wb' onClient: false)
		nextPutAll: signature;
		close.
	result := System performOnServer: 'openssl dgst -sha256 -verify ' , keyPath , ' -signature ' , signaturePath , ' ' , messagePath.
	GsFile
		removeServerFile: keyPath;
		removeServerFile: messagePath;
		removeServerFile: signaturePath;
		yourself.
	result trimSeparators = 'Verified OK' ifTrue: [
		payload := JsonParser parse: (self stringFromBase64URL: (pieces at: 2)).
	].
%
category: 'other'
method: JWT
isValid

	^payload notNil and: [System timeGmt < (payload at: 'exp')]
%
category: 'other'
method: JWT
stringFromBase64URL: aString

	^(self bytesFromBase64URL: aString) bytesIntoString reject: [:each | each codePoint == 0]
%

! ------------------- Remove existing behavior from RsaPublicKey
expectvalue /Metaclass3       
doit
RsaPublicKey removeAllMethods.
RsaPublicKey class removeAllMethods.
%
! ------------------- Class methods for RsaPublicKey
set compile_env: 0
category: 'other'
classmethod: RsaPublicKey
_cache

	^cache
%
category: 'other'
classmethod: RsaPublicKey
cache

	cache ifNil: [cache := StringKeyValueDictionary new].
	cache copy keysAndValuesDo: [:key :value |
		value isValid ifFalse: [
			cache removeKey: key ifAbsent: ["This method can be recursive"].
			self readServer: value server.
		].
	].
	^cache
%
category: 'other'
classmethod: RsaPublicKey
maxAgeFrom: aString

	| pieces value |
	pieces := (aString subStrings: $,) collect: [:each | each trimBlanks].
	value := pieces detect: [:each | 8 < each size and: [(each copyFrom: 1 to: 8) = 'max-age=']] ifNone: [self error: 'Invalid response!'].
	value := value copyFrom: 9 to: value size.
	^System timeGmt2005 + value asNumber
%
category: 'other'
classmethod: RsaPublicKey
parse: curlString server: serverString

	| key line pieces maxAge stream value |
	stream := ReadStream on: curlString.
	[
		line := stream nextLine.
		line size < 4 or: [(line copyFrom: 1 to: 4) ~= 'HTTP'].
	] whileTrue: [
		stream atEnd ifTrue: [self error: 'Invalid response!'].
	].
	(line subStrings at: 2) ~= '200' ifTrue: [self error: 'Invalid response!'].
	[
		(line := stream nextLine) notEmpty.
	] whileTrue: [
		pieces := line subStrings: $:.
		key := pieces at: 1.
		value := pieces at: 2.
		key = 'cache-control' ifTrue: [maxAge := self maxAgeFrom: value].	"System timeGmt2005"
	].
	stream nextLine trimBlanks = '{' ifFalse: [self error: 'Invalid response!'].
	[
		line := stream nextLine.
		line trimBlanks ~= '}'.
	] whileTrue: [
		pieces := line subStrings: $:.
		key := (pieces at: 1) trimBlanks.
		value := (pieces at: 2) trimBlanks.
		value last == $, ifTrue: [value := (value copyFrom: 1 to: value size - 1) trimBlanks].
		(key first == $" and: [key last == $" and: [value first == $" and: [value last == $"]]]) ifFalse: [self error: 'Invalid response!'].
		key := key copyFrom: 2 to: key size - 1.
		value := value copyFrom: 2 to: value size - 1.
		value := value copyReplaceAll: '\n' with: Character lf asString.
		self cache at: key put: (self new initialize: value expires: maxAge server: serverString).
	].
%
category: 'other'
classmethod: RsaPublicKey
publicKeyFor: aString
"
	RsaPublicKey publicKeyFor: 'a322b68bce4311e869639533d3a1a2551d5e74c6'.
"
	| publicKey |
	publicKey := self cache
		at: aString
		ifAbsent: [^nil].
	publicKey isValid ifFalse: [self readServer: publicKey server].
	publicKey := self cache at: aString.
	publicKey isValid ifFalse: [^nil].
	^publicKey publicKey
%
category: 'other'
classmethod: RsaPublicKey
readGoogle
"
	RsaPublicKey readGoogle.
"
	self readServer: 'https://www.googleapis.com/robot/v1/metadata/x509/securetoken@system.gserviceaccount.com'.
%
category: 'other'
classmethod: RsaPublicKey
readServer: aString

	self
		parse: (System performOnServer: 'curl -i -s ' , aString)
		server: aString.
%
! ------------------- Instance methods for RsaPublicKey
set compile_env: 0
category: 'other'
method: RsaPublicKey
 initialize: certificateString expires: anInteger server: serverString

	| index string |
	maxAge := anInteger.
	string := System performOnServer: 'echo ' , certificateString printString , ' | openssl x509 -pubkey'.
	index := string indexOfSubCollection: '-----BEGIN CERTIFICATE-----'.
	publicKey := string copyFrom: 1 to: index - 1.
	server := serverString.
%
category: 'other'
method: RsaPublicKey
isValid

	^System timeGmt2005 < maxAge
%
category: 'other'
method: RsaPublicKey
publicKey

	^publicKey
%
category: 'other'
method: RsaPublicKey
server

	^server
%