extra/asn1/asn1.factor

   1 ! Copyright (C) 2007 Elie CHAFTARI
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: arrays asn1.ldap assocs byte-arrays combinators
   5 continuations io io.binary io.streams.string kernel math
   6 math.parser namespaces pack strings sequences ;
   7
   8 IN: asn1
   9
  10 : tag-classes ( -- seq )
  11     { "universal" "application" "context_specific" "private" } ;
  12
  13 : builtin-syntax ( -- hashtable )
  14     H{
  15         { "universal"
  16             H{
  17                 { "primitive"
  18                     H{
  19                         { 1 "boolean" }
  20                         { 2 "integer" }
  21                         { 4 "string" }
  22                         { 5 "null" }
  23                         { 6 "oid" }
  24                         { 10 "integer" }
  25                         { 13 "string" }   ! relative OID
  26                      }
  27                 }
  28                 { "constructed"
  29                     H{
  30                         { 16 "array" }
  31                         { 17 "array" }
  32                     }
  33                 }
  34              }
  35         }
  36         { "context_specific"
  37             H{
  38                 { "primitive"
  39                     H{
  40                         { 10 "integer" }
  41                     }
  42                 }
  43             }
  44         }
  45      } ;
  46
  47 SYMBOL: elements
  48
  49 TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
  50
  51 : <element> ( -- element ) element new ;
  52
  53 : set-id ( -- boolean )
  54     read1 dup elements get set-element-id ;
  55
  56 : get-id ( -- id )
  57     elements get element-id ;
  58
  59 : (set-tag) ( -- )
  60     elements get element-id 31 bitand
  61     dup elements get set-element-tag
  62     31 < [
  63         [ "unsupported tag encoding: #{" %
  64           get-id # "}" %
  65         ] "" make throw
  66     ] unless ;
  67
  68 : set-tagclass ( -- )
  69     get-id -6 shift tag-classes nth
  70     elements get set-element-tagclass ;
  71
  72 : set-encoding ( -- )
  73     get-id HEX: 20 bitand
  74     zero? "primitive" "constructed" ?
  75     elements get set-element-encoding ;
  76
  77 : set-content-length ( -- )
  78     read1
  79     dup 127 <= [
  80         127 bitand read be>
  81     ] unless elements get set-element-contentlength ;
  82
  83 : set-newobj ( -- )
  84     elements get element-contentlength read
  85     elements get set-element-newobj ;
  86
  87 : set-objtype ( syntax -- )
  88     builtin-syntax 2array [
  89         elements get element-tagclass swap at
  90         elements get element-encoding swap at
  91         elements get element-tag
  92         swap at [
  93             elements get set-element-objtype
  94         ] when*
  95     ] each ;
  96
  97 DEFER: read-ber
  98
  99 SYMBOL: end
 100
 101 : (read-array) ( -- )
 102     elements get element-id [
 103         elements get element-syntax read-ber
 104         dup end = [ drop ] [ , (read-array) ] if
 105     ] when ;
 106
 107 : read-array ( -- array ) [ (read-array) ] { } make ;
 108
 109 : set-case ( -- object )
 110     elements get element-newobj
 111     elements get element-objtype {
 112         { "boolean" [ "\0" = not ] }
 113         { "string" [ "" or ] }
 114         { "integer" [ be> ] }
 115         { "array" [ "" or [ read-array ] with-string-reader ] }
 116     } case ;
 117
 118 : read-ber ( syntax -- object )
 119     <element> elements set
 120     elements get set-element-syntax
 121     set-id [
 122         (set-tag)
 123         set-tagclass
 124         set-encoding
 125         set-content-length
 126         set-newobj
 127         elements get element-syntax set-objtype
 128         set-case
 129     ] [ end ] if ;
 130
 131 ! =========================================================
 132 ! Fixnum
 133 ! =========================================================
 134
 135 GENERIC: >ber ( obj -- byte-array )
 136 M: fixnum >ber ( n -- byte-array )
 137     >128-ber dup length 2 swap 2array
 138     "cc" pack-native prepend ;
 139
 140 : >ber-enumerated ( n -- byte-array )
 141     >128-ber >byte-array dup length 10 swap 2array
 142     "CC" pack-native prepend ;
 143
 144 : >ber-length-encoding ( n -- byte-array )
 145     dup 127 <= [
 146         1array "C" pack-be
 147     ] [
 148         1array "I" pack-be 0 swap remove dup length
 149         HEX: 80 + 1array "C" pack-be prepend
 150     ] if ;
 151
 152 ! =========================================================
 153 ! Bignum
 154 ! =========================================================
 155
 156 M: bignum >ber ( n -- byte-array )
 157     >128-ber >byte-array dup length
 158     dup 126 > [
 159         "range error in bignum" throw
 160     ] [
 161         2 swap 2array "CC" pack-native prepend
 162     ] if ;
 163
 164 ! =========================================================
 165 ! String
 166 ! =========================================================
 167
 168 ! Universal octet-string has tag number 4, we should however
 169 ! still be able to assign an arbitrary code number.
 170 ! >ber words should be called within a with-ber.
 171 SYMBOL: tagnum
 172
 173 TUPLE: tag value ;
 174
 175 : <tag> ( -- <tag> ) 4 tag boa ;
 176
 177 : with-ber ( quot -- )
 178     [
 179         <tag> tagnum set
 180         call
 181     ] with-scope ; inline
 182
 183 : set-tag ( value -- )
 184     tagnum get set-tag-value ;
 185
 186 M: string >ber ( str -- byte-array )
 187     tagnum get tag-value 1array "C" pack-native swap dup
 188     length >ber-length-encoding swapd append swap
 189     >byte-array append ;
 190
 191 : >ber-application-string ( n str -- byte-array )
 192     >r HEX: 40 + set-tag r> >ber ;
 193
 194 GENERIC: >ber-contextspecific ( n obj -- byte-array )
 195 M: string >ber-contextspecific ( n str -- byte-array )
 196     >r HEX: 80 + set-tag r> >ber ;
 197
 198 ! =========================================================
 199 ! Array
 200 ! =========================================================
 201
 202 : >ber-seq-internal ( array code -- byte-array )
 203     1array "C" pack-native swap dup length >ber-length-encoding
 204     swapd append swap [ number>string ] map "" join >array append ;
 205
 206 M: array >ber ( array -- byte-array )
 207     HEX: 30 >ber-seq-internal ;
 208
 209 : >ber-set ( array -- byte-array )
 210     HEX: 31 >ber-seq-internal ;
 211
 212 : >ber-sequence ( array -- byte-array )
 213     HEX: 30 >ber-seq-internal ;
 214
 215 : >ber-appsequence ( array -- byte-array )
 216     HEX: 60 >ber-seq-internal ;
 217
 218 M: array >ber-contextspecific ( array -- byte-array )
 219     HEX: A0 >ber-seq-internal ;