factor/extra/asn1/asn1.factor

220 lines
5.5 KiB
Factor
Raw Normal View History

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> ] }
{ "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
"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
"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
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
] [
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 ;
: <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 ;