2007-09-20 18:09:08 -04:00
|
|
|
! Copyright (C) 2007 Elie CHAFTARI
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
|
|
|
|
USING: arrays asn1.ldap assocs byte-arrays combinators
|
|
|
|
continuations io io.binary io.streams.string kernel math
|
2008-08-30 21:38:07 -04:00
|
|
|
math.parser namespaces pack strings sequences accessors ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
IN: asn1
|
|
|
|
|
|
|
|
: tag-classes ( -- seq )
|
|
|
|
{ "universal" "application" "context_specific" "private" } ;
|
|
|
|
|
|
|
|
: builtin-syntax ( -- hashtable )
|
|
|
|
H{
|
|
|
|
{ "universal"
|
|
|
|
H{
|
|
|
|
{ "primitive"
|
|
|
|
H{
|
|
|
|
{ 1 "boolean" }
|
|
|
|
{ 2 "integer" }
|
|
|
|
{ 4 "string" }
|
|
|
|
{ 5 "null" }
|
|
|
|
{ 6 "oid" }
|
|
|
|
{ 10 "integer" }
|
|
|
|
{ 13 "string" } ! relative OID
|
|
|
|
}
|
|
|
|
}
|
|
|
|
{ "constructed"
|
|
|
|
H{
|
|
|
|
{ 16 "array" }
|
|
|
|
{ 17 "array" }
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
{ "context_specific"
|
|
|
|
H{
|
|
|
|
{ "primitive"
|
|
|
|
H{
|
|
|
|
{ 10 "integer" }
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
} ;
|
|
|
|
|
|
|
|
SYMBOL: elements
|
|
|
|
|
|
|
|
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
|
|
|
|
|
|
|
|
|
|
|
|
: get-id ( -- id )
|
2008-08-30 21:38:07 -04:00
|
|
|
elements get id>> ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: (set-tag) ( -- )
|
2008-08-30 21:38:07 -04:00
|
|
|
elements get id>> 31 bitand
|
2008-08-31 03:51:31 -04:00
|
|
|
dup elements get (>>tag)
|
2007-09-20 18:09:08 -04:00
|
|
|
31 < [
|
|
|
|
[ "unsupported tag encoding: #{" %
|
|
|
|
get-id # "}" %
|
|
|
|
] "" make throw
|
|
|
|
] unless ;
|
|
|
|
|
|
|
|
: set-tagclass ( -- )
|
|
|
|
get-id -6 shift tag-classes nth
|
2008-08-31 03:51:31 -04:00
|
|
|
elements get (>>tagclass) ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: set-encoding ( -- )
|
|
|
|
get-id HEX: 20 bitand
|
|
|
|
zero? "primitive" "constructed" ?
|
2008-08-31 03:51:31 -04:00
|
|
|
elements get (>>encoding) ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: set-content-length ( -- )
|
|
|
|
read1
|
|
|
|
dup 127 <= [
|
|
|
|
127 bitand read be>
|
2008-08-31 03:51:31 -04:00
|
|
|
] unless elements get (>>contentlength) ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: set-newobj ( -- )
|
2008-08-30 21:38:07 -04:00
|
|
|
elements get contentlength>> read
|
2008-08-31 03:51:31 -04:00
|
|
|
elements get (>>newobj) ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: set-objtype ( syntax -- )
|
|
|
|
builtin-syntax 2array [
|
2008-08-30 21:38:07 -04:00
|
|
|
elements get tagclass>> swap at
|
|
|
|
elements get encoding>> swap at
|
|
|
|
elements get tag>>
|
2007-09-20 18:09:08 -04:00
|
|
|
swap at [
|
2008-08-31 03:51:31 -04:00
|
|
|
elements get (>>objtype)
|
2007-09-20 18:09:08 -04:00
|
|
|
] when*
|
|
|
|
] each ;
|
|
|
|
|
|
|
|
DEFER: read-ber
|
|
|
|
|
|
|
|
SYMBOL: end
|
|
|
|
|
2008-05-05 05:32:01 -04:00
|
|
|
: (read-array) ( -- )
|
2008-08-30 21:38:07 -04:00
|
|
|
elements get id>> [
|
2008-08-31 03:51:31 -04:00
|
|
|
elements get syntax>> read-ber
|
2007-09-20 18:09:08 -04:00
|
|
|
dup end = [ drop ] [ , (read-array) ] if
|
|
|
|
] when ;
|
|
|
|
|
|
|
|
: read-array ( -- array ) [ (read-array) ] { } make ;
|
|
|
|
|
2008-05-05 05:32:01 -04:00
|
|
|
: set-case ( -- object )
|
2008-08-31 03:51:31 -04:00
|
|
|
elements get newobj>>
|
|
|
|
elements get objtype>> {
|
2007-09-20 18:09:08 -04:00
|
|
|
{ "boolean" [ "\0" = not ] }
|
|
|
|
{ "string" [ "" or ] }
|
|
|
|
{ "integer" [ be> ] }
|
2008-02-15 23:20:31 -05:00
|
|
|
{ "array" [ "" or [ read-array ] with-string-reader ] }
|
2007-09-20 18:09:08 -04:00
|
|
|
} case ;
|
|
|
|
|
2008-08-30 21:38:07 -04:00
|
|
|
: set-id ( -- boolean )
|
2008-08-31 03:51:31 -04:00
|
|
|
read1 dup elements get (>>id) ;
|
2008-08-30 21:38:07 -04:00
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: read-ber ( syntax -- object )
|
2008-08-30 21:38:07 -04:00
|
|
|
element new
|
|
|
|
swap >>syntax
|
|
|
|
elements set
|
2007-09-20 18:09:08 -04:00
|
|
|
set-id [
|
|
|
|
(set-tag)
|
|
|
|
set-tagclass
|
|
|
|
set-encoding
|
|
|
|
set-content-length
|
|
|
|
set-newobj
|
2008-08-31 03:51:31 -04:00
|
|
|
elements get syntax>> set-objtype
|
2007-09-20 18:09:08 -04:00
|
|
|
set-case
|
|
|
|
] [ end ] if ;
|
|
|
|
|
|
|
|
! =========================================================
|
|
|
|
! Fixnum
|
|
|
|
! =========================================================
|
|
|
|
|
|
|
|
GENERIC: >ber ( obj -- byte-array )
|
|
|
|
M: fixnum >ber ( n -- byte-array )
|
|
|
|
>128-ber dup length 2 swap 2array
|
2008-03-19 20:15:32 -04:00
|
|
|
"cc" pack-native prepend ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: >ber-enumerated ( n -- byte-array )
|
|
|
|
>128-ber >byte-array dup length 10 swap 2array
|
2008-03-19 20:15:32 -04:00
|
|
|
"CC" pack-native prepend ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: >ber-length-encoding ( n -- byte-array )
|
|
|
|
dup 127 <= [
|
|
|
|
1array "C" pack-be
|
|
|
|
] [
|
|
|
|
1array "I" pack-be 0 swap remove dup length
|
2008-03-19 20:15:32 -04:00
|
|
|
HEX: 80 + 1array "C" pack-be prepend
|
2007-09-20 18:09:08 -04:00
|
|
|
] if ;
|
|
|
|
|
|
|
|
! =========================================================
|
|
|
|
! Bignum
|
|
|
|
! =========================================================
|
|
|
|
|
|
|
|
M: bignum >ber ( n -- byte-array )
|
|
|
|
>128-ber >byte-array dup length
|
|
|
|
dup 126 > [
|
|
|
|
"range error in bignum" throw
|
|
|
|
] [
|
2008-03-19 20:15:32 -04:00
|
|
|
2 swap 2array "CC" pack-native prepend
|
2007-09-20 18:09:08 -04:00
|
|
|
] if ;
|
|
|
|
|
|
|
|
! =========================================================
|
|
|
|
! String
|
|
|
|
! =========================================================
|
|
|
|
|
|
|
|
! Universal octet-string has tag number 4, we should however
|
|
|
|
! still be able to assign an arbitrary code number.
|
|
|
|
! >ber words should be called within a with-ber.
|
|
|
|
SYMBOL: tagnum
|
|
|
|
|
|
|
|
TUPLE: tag value ;
|
|
|
|
|
2008-04-13 16:06:27 -04:00
|
|
|
: <tag> ( -- <tag> ) 4 tag boa ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: with-ber ( quot -- )
|
|
|
|
[
|
|
|
|
<tag> tagnum set
|
|
|
|
call
|
|
|
|
] with-scope ; inline
|
|
|
|
|
|
|
|
: set-tag ( value -- )
|
2008-08-31 03:51:31 -04:00
|
|
|
tagnum get (>>value) ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
M: string >ber ( str -- byte-array )
|
|
|
|
tagnum get tag-value 1array "C" pack-native swap dup
|
|
|
|
length >ber-length-encoding swapd append swap
|
|
|
|
>byte-array append ;
|
|
|
|
|
|
|
|
: >ber-application-string ( n str -- byte-array )
|
|
|
|
>r HEX: 40 + set-tag r> >ber ;
|
|
|
|
|
|
|
|
GENERIC: >ber-contextspecific ( n obj -- byte-array )
|
|
|
|
M: string >ber-contextspecific ( n str -- byte-array )
|
|
|
|
>r HEX: 80 + set-tag r> >ber ;
|
|
|
|
|
|
|
|
! =========================================================
|
|
|
|
! Array
|
|
|
|
! =========================================================
|
|
|
|
|
|
|
|
: >ber-seq-internal ( array code -- byte-array )
|
|
|
|
1array "C" pack-native swap dup length >ber-length-encoding
|
|
|
|
swapd append swap [ number>string ] map "" join >array append ;
|
|
|
|
|
|
|
|
M: array >ber ( array -- byte-array )
|
|
|
|
HEX: 30 >ber-seq-internal ;
|
|
|
|
|
|
|
|
: >ber-set ( array -- byte-array )
|
|
|
|
HEX: 31 >ber-seq-internal ;
|
|
|
|
|
|
|
|
: >ber-sequence ( array -- byte-array )
|
|
|
|
HEX: 30 >ber-seq-internal ;
|
|
|
|
|
|
|
|
: >ber-appsequence ( array -- byte-array )
|
|
|
|
HEX: 60 >ber-seq-internal ;
|
|
|
|
|
|
|
|
M: array >ber-contextspecific ( array -- byte-array )
|
|
|
|
HEX: A0 >ber-seq-internal ;
|