"
 (C) 2011 by Holger Hans Peter Freyther
 All Rights Reserved

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

 This program 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 Affero General Public License for more details.

 You should have received a copy of the GNU Affero General Public License
 along with this program.  If not, see <http://www.gnu.org/licenses/>.
"

Object subclass: BERTag [
    | classType tagValue constructed |
    <category: 'OsmoASN1'>
    <comment: 'I am a TAG as of X.690'>

    BERTag class >> classUniversal [
        <category: 'class'>
        ^ 0
    ]

    BERTag class >> classApplication [
        <category: 'class'>
        ^ 1
    ]

    BERTag class >> classContext [
        <category: 'class'>
        ^ 2
    ]

    BERTag class >> classPrivate [
        <category: 'class'>
        ^ 3
    ]

    BERTag class >> new [
        <category: 'creation'>
        ^ super new initialize
    ]

    BERTag class >> parseFrom: aStream [
        <category: 'creation'>
        ^ self new
            parseFrom: aStream;
            yourself
    ]

    BERTag class >> fromTuple: aTuple [
        <category: 'creation'>
        ^ self new
            fromTuple: aTuple;
            yourself
    ]

    BERTag class >> endOfContents [
        <category: 'x690 types'>
        ^ self fromTuple: #(0 false 0)
    ]

    BERTag class >> boolean [
        <category: 'x690 types'>
        ^ self fromTuple: #(0 false 1)
    ]

    BERTag class >> integer [
        <category: 'x690 types'>
        ^ self fromTuple: #(0 false 2)
    ]

    BERTag class >> octetString [
        <category: 'x690 types'>
        ^ self fromTuple: #(0 false 4)
    ]

    BERTag class >> null [
        <category: 'x690 types'>
        ^ self fromTuple: #(0 false 5)
    ]

    BERTag class >> enumerated [
        <category: 'x690 types'>
        ^ self fromTuple: #(0 false 10)
    ]

    BERTag class >> sequence [
        <category: 'x690 types'>
        ^ self fromTuple: #(0 true 16)
    ]

    BERTag class >> set [
        <category: 'x690 types'>
        ^ self fromTuple: #(0 true 17)
    ]

    initialize [
        <category: 'init'>
        classType := BERTag classUniversal.
        tagValue := 0.
        constructed := false.
    ]

    = aOther [
        <category: 'compare'>

        (aOther isKindOf: self class) ifTrue: [^self asTuple = aOther asTuple].
        ^ self asTuple = aOther.
    ]

    parseExtendedTag: aStream [
        <category: 'decoding'>

        ^ self error: 'Extended tags are not implemented yet'.
    ]

    parseFrom: aStream [
        | tmp |
        <category: 'decoding'>

        tmp := aStream next.
        classType := (tmp bitAnd: 16rC0) bitShift: -6.
        constructed := (tmp bitAnd: 16r20) > 0.
        tagValue := tmp bitAnd: 16r1F.

        "This is an extended tag"
        (tagValue = 16r1F) ifTrue: [
            self parseExtendedTag: aStream.
        ].
    ]

    fromTuple: aTuple [
        <category: 'decoding'>

        classType := aTuple first bitAnd: 16r3.
        constructed := aTuple second.
        tagValue := aTuple third.
    ]

    writeExtendedTag: aStream [
        <category: 'encoding'>
        self error: 'Cannot encode extended tag.'
    ]

    writeOn: aStream [
        <category: 'encoding'>
        tagValue >= 16r1F
            ifTrue:  [self writeExtendedTag: aStream.]
            ifFalse: [| tag |
                tag := classType bitShift: 6.
                self isConstructed ifTrue: [tag := tag bitOr: 16r20].
                tag := tag bitOr: self tagValue.
                aStream nextPut: tag.
            ].
    ]

    classType [
        <category: 'accessing'>
        ^ classType
    ]

    isConstructed [
        <category: 'accessing'>
        ^ constructed
    ]

    isPrimitive [
        <category: 'accessing'>
        ^ self isConstructed not
    ]

    tagValue [
        <category: 'accessing'>
        ^ tagValue
    ]

    asTuple [
        <category: 'conversion'>
        ^ Array with: self classType with: self isConstructed with: self tagValue.
    ]

    printOn: aStream [
        <category: 'printing'>
        ^ aStream nextPutAll: '%1 %2' % {self class. self asTuple.}
    ]
]

Object subclass: BERLength [
    <category: 'OsmoASN1'>
    <comment: 'I can handle the length for definite and indefinite length. I wonder
of myself if I should be class or instance based or even be a SmallInteger or an
extension to a SmallInteger. Should I have a method called isIndefinite. Time will tell.'>

    BERLength class >> new [
        ^ self error: 'Only use the class helper functions'
    ]

    BERLength class >> parseMultiOctet: len from: aStream [
        "I should handle paragraph 8.1.3.5. But I don't."
        <category: 'private-decoding'>
        ^ self error: 'Decoding multi octet length is not implemented'.
    ]

    BERLength class >> parseFrom: aStream [
        | len |
        <category: 'decoding'>

        len := aStream next.
        ^ (len bitAnd: 16r80) > 0
            ifTrue:  [self parseMultiOctet: len from: aStream]
            ifFalse: [len].
    ]

    BERLength class >> writeMultiOctet: aLength on: aStream [
        <category: 'private-encoding'>
        ^ self error: 'Multi octet writing is not implemented yet'.
    ]

    BERLength class >> writeLength: aLength on: aStream [
        <category: 'encoding'>

        ^ aLength > 16r7F
            ifTrue:  [self writeMultiOctet: aLength on: aStream]
            ifFalse: [aStream nextPut: aLength].
    ]
]

Object subclass: BERTLVStream [
    | base |
    <category: 'OsmoASN1'>
    <comment: 'I am a Tag Value Length (TLV) Stream for Basic Encoding Rules (BER)
of X.690 and provide very basic reading of a stream.'>

    BERTLVStream class >> on: aStream [
        <category: 'creation'>
        ^ self new
            stream: aStream;
            yourself
    ]

    stream: aStream [
        <category: 'init'>
        base := aStream.
    ]

    atEnd [
        <category: 'decoding'>
        ^ base atEnd
    ]

    next [
        | tag len dat |
        <category: 'decoding'>

        tag := BERTag parseFrom: base.
        len := BERLength parseFrom: base.
        dat := base next: len.

        ^ Array with: tag with: dat.
    ]

    nextAll [
        | ret |
        ret := OrderedCollection new.

        [self atEnd] whileFalse: [ret add: self next].

        ^ ret
    ]

    nextAllRecursive [
        | ret |
        ret := OrderedCollection new.

        [self atEnd] whileFalse: [| dat |
            dat := self next.
            dat first isConstructed
                ifTrue:  [|other|
                    other := (self class on: dat second readStream) nextAllRecursive.
                    ret add: (Array with: dat first with: other)]
                ifFalse: [ret add: dat].
        ].

        ^ ret
    ]
]

BERTLVStream subclass: DERTLVStream [
    <category: 'OsmoASN1'>
    <comment: 'I am DER Stream. I can produce valid DER streams
from a tupled input.'>

    nextPut: aTuple [
        aTuple first writeOn: base.
        aTuple first isConstructed
            ifTrue: [
                | stream der |
                stream := WriteStream on: (base species new: 1).
                (self class on: stream) nextPutAll: aTuple second.

                BERLength writeLength: stream contents size on: base.
                base nextPutAll: stream contents.
            ]
            ifFalse: [
                BERLength writeLength: aTuple second size on: base.
                base nextPutAll: aTuple second.
            ].
    ]

    nextPutAll: aTupleList [
        aTupleList do: [:each | self nextPut: each].
    ]
]