From 3ec380a106985c5cb59df495bcc86e5d3ab64355 Mon Sep 17 00:00:00 2001 From: Holger Hans Peter Freyther Date: Sat, 16 Oct 2010 22:53:28 +0200 Subject: [PATCH] Add the BER code from the ported LDAP project --- BER.st | 492 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ Tests.st | 287 ++++++++++++++++++++++++++++++++ 2 files changed, 779 insertions(+) create mode 100644 BER.st create mode 100644 Tests.st diff --git a/BER.st b/BER.st new file mode 100644 index 0000000..44ca348 --- /dev/null +++ b/BER.st @@ -0,0 +1,492 @@ +"====================================================================== +| +| Copyright (c) 2004-2009 +| Ragnar Hojland Espinosa , +| +| Contributions by: +| Göran Krampe +| Andreas Raab +| +| Ported by: +| Stephen Woolerton +| +| Permission is hereby granted, free of charge, to any person obtaining +| a copy of this software and associated documentation files (the +| 'Software'), to deal in the Software without restriction, including +| without limitation the rights to use, copy, modify, merge, publish, +| distribute, sublicense, and/or sell copies of the Software, and to +| permit persons to whom the Software is furnished to do so, subject to +| the following conditions: +| +| The above copyright notice and this permission notice shall be +| included in all copies or substantial portions of the Software. +| +| THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, +| EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +| MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +| IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +| CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +| TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +| SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +| + ======================================================================" + + +Object subclass: BERElement [ + | length lengthLength value tagHeader tagLength | + + + + + BERElement class >> elementClasses [ + ^ + {BERInteger. + BEROctetString. + BERSequence. + BEREnumerated. + BERBoolean. + BERSet. + BERNull. + + } + ] + + BERElement class >> identifyIncomingElement: firstByte [ + "so why are we doing this in a comparision here, instead of asking the class wether it handles the element?" + + | type | + type := self elementClasses + detect: [:each | each tagValue = firstByte asInteger] + ifNone: [nil]. + ^type + ] + + BERElement class >> new [ + "this is here only to easily see who is using it down the heriarchy through the browser" + + ^self basicNew initialize + ] + + BERElement class >> newFrom: aStream [ + | firstByte element elementClass | + firstByte := aStream next. + "Transcript show: '*** Next byte is: ', firstByte asString; cr." + elementClass := self identifyIncomingElement: firstByte. + elementClass ifNil: + [(LDAPException new) + messageText: 'invalid tag -- make sure class is in identifyIncomingElements'; + signal]. + element := elementClass new setTag: firstByte. + "we should read the tag here, instead of just the first byte" + element readLengthFrom: aStream. + element decode: aStream. + ^element + ] + + BERElement class >> tagValue [ + self subclassResponsibility + ] + + decode: aStream [ + self subclassResponsibility + ] + + initialize [ + tagHeader := 0 + ] + + length [ + ^length + ] + + lengthLength [ + ^lengthLength + ] + + readLengthFrom: aStream [ + | octets firstOctet | + firstOctet := aStream next asInteger. + firstOctet < 128 + ifTrue: + ["short definite length" + + length := firstOctet. + lengthLength := 1] + ifFalse: + ["long definite length" + + octets := aStream next: (firstOctet bitXor: 128). + lengthLength := (firstOctet bitXor: 128) + 1. "the lengthlenghlength byte.. ugh." + length := octets contents inject: 0 + into: [:injectedValue :each | (injectedValue bitShift: 8) + each asInteger]]. + ^length + ] + + setTag: aTag [ + tagHeader := aTag. + tagLength := 1 + ] + + tagLength [ + ^1 + ] + + tagSetApplication [ + tagHeader := tagHeader bitOr: 64 + ] + + tagSetContext [ + tagHeader := tagHeader bitOr: 128 + ] + + totalLength [ + ^self length + self lengthLength + self tagLength + ] + + value [ + ^value + ] + + value: aValue [ + value := aValue + ] + + writeBodyOn: aStream [ + self subclassResponsibility + ] + + writeLength: aLength on: aStream [ + | octets octetsIndex remainderValue netOctets | + octetsIndex := 1. + aLength < 128 + ifTrue: + ["short definite length" + + aStream nextPut: (Character value: aLength) + + "long definite length"] + ifFalse: + ["why were we using value in this block, instead of aLength?" + + octets := ByteArray new: (self intDigitLength: aLength) + 1. + remainderValue := aLength. + [remainderValue > 0] whileTrue: + [octets at: octetsIndex put: (remainderValue bitAnd: 255). + octetsIndex := octetsIndex + 1. + remainderValue := remainderValue bitShift: -8]. + octets at: octetsIndex put: (octetsIndex - 1 bitOr: 128). + + "hton" + netOctets := ByteArray new: octetsIndex. + (1 to: octetsIndex) + do: [:i | netOctets at: i put: (octets at: octetsIndex + 1 - i)]. + aStream nextPutAll: netOctets asString]. + ^octetsIndex + ] + + writeOn: aStream [ + aStream nextPut: (Character value: (self class tagValue bitOr: tagHeader)). + self writeBodyOn: aStream + ] + + writeOn: aStream withTag: aTag [ + | combinedTag | + combinedTag := self class tagValue bitOr: tagHeader. + + "here we are supposing that if we are given a tag, we dont need the universal tag value + im not really sure on wether its correct or not ." + + "however, we are in .25 and its proved to be correct so far" + aTag ifNotNil: + [combinedTag := (combinedTag bitOr: 31) bitXor: 31. + combinedTag := combinedTag bitOr: aTag]. + aStream nextPut: (Character value: combinedTag). + self writeBodyOn: aStream + ] +] + + + + +BERElement subclass: BERBoolean [ + + + + + BERBoolean class >> tagValue [ + ^1 + ] + + decode: aStream [ + value := aStream next. + value := value > 0 + ] + + writeBodyOn: aStream [ + self writeLength: 1 on: aStream. + (value = 0 or: [value = false]) + ifTrue: [aStream nextPut: (Character value: 0)] + ifFalse: [aStream nextPut: (Character value: 255)] + ] +] + + + + +BERElement subclass: BERConstruct [ + | elements | + + + + + BERConstruct class >> new [ + ^self basicNew initialize + ] + + addElement: anElement [ + self addElement: anElement withTag: nil + ] + + addElement: anElement withTag: aContextTag [ + | taggedElement | + taggedElement := Association + new; + key: aContextTag value: anElement. + elements addLast: taggedElement + ] + + decode: aStream [ + | elementLen part | + elementLen := self length. + [elementLen > 0] whileTrue: + [part := self class newFrom: aStream. + elementLen := elementLen - part totalLength. + self addElement: part] + ] + + elements [ + ^elements + ] + + initialize [ + super initialize. + elements := OrderedCollection new + ] + + writeBodyOn: aStream [ + | data dataStream | + data := Array new. + dataStream := WriteStream on: data. + elements + do: [:taggedElement | taggedElement value writeOn: dataStream withTag: taggedElement key]. + + "shouldnt we move this somewhere else?" + self writeLength: dataStream contents size on: aStream. + aStream nextPutAll: dataStream contents + ] +] + + + + +BERElement subclass: BERInteger [ + + + + + BERInteger class >> tagValue [ + ^2 + ] + + decode: aStream [ + | highBitPos xorMask | + value := 0. + (1 to: length) + do: [:i | value := (value bitShift: 8) + aStream next asInteger]. + + "if the high bit is set, we have negative" + highBitPos := value highBit. + highBitPos = (length * 8) + ifTrue: + [xorMask := (1 bitShift: highBitPos) - 1. + value := value bitXor: xorMask. + value := (value + 1) negated] + ] + + intDigitLength: anInt [ + "From Squeak: SmallInteger digitlength. + Called from BERInteger writeBodyOn: " + + "Answer the number of indexable fields in the receiver. This value is the + same as the largest legal subscript. Included so that a SmallInteger can + behave like a LargePositiveInteger or LargeNegativeInteger." + + (anInt < 16r100 and: [anInt > -16r100]) ifTrue: [^ 1]. + (anInt < 16r10000 and: [anInt > -16r10000]) ifTrue: [^ 2]. + (anInt < 16r1000000 and: [anInt > -16r1000000]) ifTrue: [^ 3]. + ^ 4 + ] + + writeBodyOn: aStream [ + | octets netOctets isNegative remainderValue octetsIndex | + isNegative := value < 0. + octets := ByteArray new: (self intDigitLength: value) + 2. + + "put value into octet array, covert negatives as appropiate" + isNegative not + ifTrue: + [value = 0 + ifTrue: + [octetsIndex := 1. + octets at: octetsIndex put: 0] + ifFalse: + [remainderValue := value. + octetsIndex := 0. + [remainderValue > 0] whileTrue: + [octetsIndex := octetsIndex + 1. + octets at: octetsIndex put: (remainderValue bitAnd: 255). + remainderValue := remainderValue bitShift: -8]]] + ifFalse: + ["negatives are in two's complement -- to convert: 1. change to positive. 2. substract 1, 3. xor everythnig" + + remainderValue := value negated. + remainderValue := remainderValue - 1. + octetsIndex := 0. + + [octetsIndex := octetsIndex + 1. + octets at: octetsIndex put: ((remainderValue bitXor: 255) bitAnd: 255). + remainderValue := remainderValue bitShift: -8. + remainderValue > 0] + whileTrue]. + + "if originally we had a positive, and highest bit is set in the beginning of the array, we prefix the array with a zero byte" + "if said bit is set and original was negative, prefix with a all-ones byte" + "we actually test the end of the array because we are switching it around later for network order" + value > 0 + ifTrue: + [((octets at: octetsIndex) bitAnd: 128) > 0 + ifTrue: + [octetsIndex := octetsIndex + 1. + octets at: octetsIndex put: 0]]. + value < 0 + ifTrue: + [((octets at: octetsIndex) bitAnd: 128) = 0 + ifTrue: + [octetsIndex := octetsIndex + 1. + octets at: octetsIndex put: 255]]. + + "hton" + netOctets := ByteArray new: octetsIndex. + (1 to: octetsIndex) + do: [:i | netOctets at: i put: (octets at: octetsIndex + 1 - i)]. + self writeLength: octetsIndex on: aStream. + aStream nextPutAll: netOctets asString. + ^octetsIndex + ] +] + + + + +BERInteger subclass: BEREnumerated [ + + + + + BEREnumerated class >> tagValue [ + ^10 + ] + + decode: aStream [ + super decode: aStream + ] +] + + + + +BERElement subclass: BERNull [ + + + + + BERNull class >> tagValue [ + ^5 + ] + + decode: aStream [ + "not sure about this.. should it be 0?" + + "length := 1." + + value := nil + ] + + writeBodyOn: aStream [ + self writeLength: 0 on: aStream + ] +] + + + + +BERElement subclass: BEROctetString [ + + + + + BEROctetString class >> tagValue [ + ^4 + ] + + decode: aStream [ + value := aStream next: length + ] + + writeBodyOn: aStream [ + self writeLength: value size on: aStream. + aStream nextPutAll: value. + "theorically we should convert it to UTF8" + ^value size + ] +] + + + + +BERConstruct subclass: BERSequence [ + + + + + BERSequence class >> tagValue [ + "SEQUENCE + Constructed" + + ^16 + 32 + ] + + decode: aStream [ + ^super decode: aStream + ] +] + + + + +BERConstruct subclass: BERSet [ + + + + + BERSet class >> tagValue [ + "SET + Constructed" + + ^17 + 32 + ] + + decode: aStream [ + ^super decode: aStream + ] +] + + diff --git a/Tests.st b/Tests.st new file mode 100644 index 0000000..eb683de --- /dev/null +++ b/Tests.st @@ -0,0 +1,287 @@ +"====================================================================== +| +| Copyright (c) 2004-2009 +| Ragnar Hojland Espinosa , +| +| Contributions by: +| Göran Krampe +| Andreas Raab +| +| Ported by: +| Stephen Woolerton +| +| Permission is hereby granted, free of charge, to any person obtaining +| a copy of this software and associated documentation files (the +| 'Software'), to deal in the Software without restriction, including +| without limitation the rights to use, copy, modify, merge, publish, +| distribute, sublicense, and/or sell copies of the Software, and to +| permit persons to whom the Software is furnished to do so, subject to +| the following conditions: +| +| The above copyright notice and this permission notice shall be +| included in all copies or substantial portions of the Software. +| +| THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, +| EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +| MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +| IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +| CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +| TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +| SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +| + ======================================================================" + +TestCase subclass: BERTest [ + + BERTest class >> getBooleanTestSet [ + ^ { { 0 . '010100' }. + { 1 . '0101FF' }. + { 255 . '0101FF' }. + { 1000 . '0101FF' }. + { false . '010100' }. + { true . '0101FF' }. + } + ] + + testBooleanEncoding [ + |ber stream tests output | + ber := BERBoolean new. + stream := ReadWriteStream on: (String new). + + tests := self class getBooleanTestSet. + tests do: [:test | + stream := ReadWriteStream on: (String new). + ber value: (test at: 1). + Transcript cr; showCr: ('value: %1, BooleanEncoded: %2' bindWith: (test at: 1) with: (test at: 2)). + ber writeOn: stream. + output := self stringHex: stream contents asString. + Transcript show: 'Expected: ', (test at: 2), ' Got: ', output; cr. + self assert: (output = (test at: 2)) ] + ] + + stringHex: aString [ + | stream | + stream := WriteStream on: (String new: self size * 4). + aString do: [ :ch | stream nextPutAll: (self charHex: ch) ]. + ^stream contents + ] + + charHex: ch [ + | hexVal | + ^(ch value < 16) + ifTrue: ['0',(ch value printString: 16)] + ifFalse: [ch value printString: 16] + ] + + BERTest class >> getIntegerTestSet [ + ^ { {27066 . '020269BA'}. + {-27066 . '02029646'}. + {72 . '020148' }. + {127 . '02017F'}. + {-128. '020180'}. + {128 . '02020080'}. + { 0 . '020100' }. + { 256 . '02020100'}. + {4294967290 . '020500FFFFFFFA'}. + { 1 . '020101'}. + {-1 . '0201FF'}. + { -129 . '0202FF7F'}. + } + ] + + testIntegerEncoding [ + | ber byte stream tests output valueStream value | + + ber := BERInteger new. + stream := ReadWriteStream on: (String new). + + tests := self class getIntegerTestSet. + + + tests do: [:test | + valueStream := ReadStream on: (test at: 2). + value := test at: 1. + "made stream a string as notthing in it. Have found asCharacter + is the problem so TODO is put stream declaration back how it was" + stream := ReadWriteStream on: (String new). + Transcript cr; showCr: 'value: ', value printString, ' IntegerEncoded: ',valueStream contents. + + [valueStream atEnd] whileFalse: [ + byte := (valueStream next digitValue ) * 16. + byte := byte + valueStream next digitValue. + "code below, don't use 'byte asCharacter' since if + value >127 get UnicodeCharacter returned" + stream nextPut: (Character value: byte) ] . + stream reset. + ber := BERInteger newFrom: stream. + "(ber class = BERInteger) ifTrue: [Transcript showCr: 'isBERInt']." + Transcript showCr: 'Expected: ', (value printString),' Got: ', (ber value printString). + self assert: (ber value = value ) + ] + ] + +testOctetStringEncoding [ + |ber stream tests| + ber := BEROctetString new. + stream := ReadWriteStream on: (String new). + + tests := { { 'hello' . 5 . '040568656C6C6F' } }. + + tests do: [:test | + stream := ReadWriteStream on: (String new). + ber value: (test at: 1). + ber writeOn: stream. + self assert: ((self stringHex: stream contents asString) = (test at: 3)) ] +] + + testSequenceEncoding [ + |ber0 ber1 ber2 stream| + ber0 := BERSequence new. + ber1 := BERInteger new value: 17. + ber2 := BERInteger new value: 170. + + ber0 addElement: ber1. + ber0 addElement: ber2. + stream := ReadWriteStream on: (String new). + + ber0 writeOn: stream. + '' displayNl.'Sequence Encoding Test ...' displayNl. stream contents inspect displayNl. + "self assert: (stream contents asString asHex = '3007020111020200AA') " + self assert: ((self stringHex: (stream contents asString)) = '3007020111020200AA') + ] + + + + + testIntegerDecoding [ + "changes are + 1. no stream reset command in GST so just reinitialize same as the first time + 2. No asCharacter, use Character value: byte instread + 3. Instead as asString in the Transcript, use printString" + + |ber stream tests value valueStream byte | + stream := ReadWriteStream on: (String new). + + tests := self class getIntegerTestSet. + '' displayNl.'Integer Decoding Test ...' displayNl. + tests do: [:test | + valueStream := ReadStream on: (test at: 2). + value := test at: 1. + stream := ReadWriteStream on: (String new). + + [valueStream atEnd] whileFalse: [ + byte := (valueStream next digitValue * 16). + byte := byte + valueStream next digitValue. + "stream nextPut: (byte asCharacter) + code below, don't use 'byte asCharacter' since if + value >127 get UnicodeCharacter returned" + stream nextPut: (Character value: byte) ] . + + stream reset. + ber := BERInteger newFrom: stream. + "self assert: (ber class = BERInteger)." + + Transcript show: 'Expected: ', (value printString), ' Got: ', (ber value printString); cr. "stream contents inspect displayNl." + self assert: (ber value = value ) + ] + ] + + testBindRequest [ + | encoded | + '' displayNl.'Beginning testBindRequest...' displayNl. + + encoded _ LDAPEncoder bindRequest: 1 username: 'cn=admin,dc=linalco,dc=test' credentials: 'secret' method: nil. + "encoded _ encoded asString asHex." + encoded := self stringHex: encoded asString. + + Transcript show: 'testBindRequest got: ', encoded; cr. + self assert: (encoded = '302D0201016028020103041B636E3D61646D696E2C64633D6C696E616C636F2C64633D746573748006736563726574') + ] + + + + testBindRequestHere [ + | stream mesg req encoded | + stream := ReadWriteStream on: String new. + mesg := BERSequence new. + mesg addElement: (BERInteger new value: 1). + + req := BERSequence new tagSetApplication. + req addElement: (BERInteger new value: 3). + req addElement: (BEROctetString new value: 'cn=admin,dc=linalco,dc=test'). + req addElement: ((BEROctetString new) + tagSetContext; + value: 'secret') + withTag: 0. + mesg addElement: req withTag: 0. + mesg writeOn: stream. + encoded := stream contents. + encoded inspect. + encoded := self stringHex: encoded asString. + + Transcript show: 'testBindRequest got: ', encoded; cr. + self assert: (encoded = '302D0201016028020103041B636E3D61646D696E2C64633D6C696E616C636F2C64633D746573748006736563726574') + ] + + testAddRequest [ + | encoded attrs | + attrs := Dictionary new. + attrs at: 'objectClass' put: (OrderedCollection new addLast: 'person'; yourself). + attrs at: 'cn' put: (OrderedCollection new addLast: 'test2'; yourself). + attrs at: 'sn' put: (OrderedCollection new addLast: 'test2'; yourself). + + encoded := LDAPEncoder addRequest: 1 dn: 'cn=test2,dc=linalco,dc=test' attrs: attrs. + encoded := self stringHex: encoded asString ."original code uses an 'asHex' method" + + '' displayNl. Transcript show: 'testAddRequest got: ', encoded; cr; cr. + self assert: (encoded = '305B0201016856041B636E3D74657374322C64633D6C696E616C636F2C64633D7465737430373017040B6F626A656374436C61737331080406706572736F6E300D0402636E310704057465737432300D0402736E310704057465737432') + ] + + testDelRequest [ + | encoded | + encoded := LDAPEncoder delRequest: 1 dn: 'cn=test2,dc=linalco,dc=test'. + encoded := self stringHex: encoded asString ."original code uses an 'asHex' method" + + Transcript show: 'testDelRequest got: ', encoded; cr; cr. + self assert: (encoded = '30200201014A1B636E3D74657374322C64633D6C696E616C636F2C64633D74657374') + ] + + testModifyRequest [ + | encoded ops | + ops := { + LDAPAttrModifier set: 'sn' to: { 'test5sn' . 'foo' . 'bar' } . + LDAPAttrModifier addTo: 'description' values: {'rchueo'} }. + encoded := LDAPEncoder modifyRequest: 1 dn: 'cn=test5,dc=linalco,dc=test' ops: ops. + encoded := self stringHex: encoded asString ."original code uses an 'asHex' method" + + Transcript show: 'testModifyRequest got: ', encoded; cr. + self assert: (encoded = '3062020101665D041B636E3D74657374352C64633D6C696E616C636F2C64633D74657374303E301E0A010230190402736E311304077465737435736E0403666F6F0403626172301C0A01003017040B6465736372697074696F6E3108040672636875656F') + + ] + + testSearchRequest [ + | encoded | + encoded := LDAPEncoder searchRequest: 1 base: 'dc=linalco, dc=test' scope: (LDAPConnection wholeSubtree) deref: (LDAPConnection derefNever) filter: (LDAPFilter with: 'objectclass' ) attrs: (OrderedCollection new) wantAttrsOnly: false. + encoded := self stringHex: encoded asString ."original code uses an 'asHex' method" + + '' displayNl. Transcript show: 'testSearchRequest got: ', encoded; cr. + self assert: (encoded = '30380201016333041364633D6C696E616C636F2C2064633D746573740A01020A0100020100020100010100870B6F626A656374636C6173733000') + ] + + +] + +" ------------------------------------- " +| suite tester | +suite := TestSuite named: 'Set Tests'. +suite addTest: (BERTest selector: #testIntegerEncoding). +suite addTest: (BERTest selector: #testBooleanEncoding). +suite addTest: (BERTest selector: #testOctetStringEncoding). +suite addTest: (BERTest selector: #testSequenceEncoding). +suite addTest: (BERTest selector: #testIntegerDecoding). +suite addTest: (BERTest selector: #testBindRequest) . +suite addTest: (BERTest selector: #testAddRequest). +suite addTest: (BERTest selector: #testDelRequest). +suite addTest: (BERTest selector: #testModifyRequest). +suite addTest: (BERTest selector: #testSearchRequest). +