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 make pack strings sequences accessors ;
   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
  52 : get-id ( -- id )
  53     elements get id>> ;
  54
  55 : (set-tag) ( -- )
  56     elements get id>> 31 bitand
  57     dup elements get (>>tag)
  58     31 < [
  59         [ "unsupported tag encoding: #{" %
  60           get-id # "}" %
  61         ] "" make throw
  62     ] unless ;
  63
  64 : set-tagclass ( -- )
  65     get-id -6 shift tag-classes nth
  66     elements get (>>tagclass) ;
  67
  68 : set-encoding ( -- )
  69     get-id HEX: 20 bitand
  70     zero? "primitive" "constructed" ?
  71     elements get (>>encoding) ;
  72
  73 : set-content-length ( -- )
  74     read1
  75     dup 127 <= [
  76         127 bitand read be>
  77     ] unless elements get (>>contentlength) ;
  78
  79 : set-newobj ( -- )
  80     elements get contentlength>> read
  81     elements get (>>newobj) ;
  82
  83 : set-objtype ( syntax -- )
  84     builtin-syntax 2array [
  85         elements get tagclass>> swap at
  86         elements get encoding>> swap at
  87         elements get tag>>
  88         swap at [
  89             elements get (>>objtype)
  90         ] when*
  91     ] each ;
  92
  93 DEFER: read-ber
  94
  95 SYMBOL: end
  96
  97 : (read-array) ( -- )
  98     elements get id>> [
  99         elements get syntax>> read-ber
 100         dup end = [ drop ] [ , (read-array) ] if
 101     ] when ;
 102
 103 : read-array ( -- array ) [ (read-array) ] { } make ;
 104
 105 : set-case ( -- object )
 106     elements get newobj>>
 107     elements get objtype>> {
 108         { "boolean" [ "\0" = not ] }
 109         { "string" [ "" or ] }
 110         { "integer" [ be> ] }
 111         { "array" [ "" or [ read-array ] with-string-reader ] }
 112     } case ;
 113
 114 : set-id ( -- boolean )
 115     read1 dup elements get (>>id) ;
 116
 117 : read-ber ( syntax -- object )
 118     element new
 119         swap >>syntax
 120     elements set
 121     set-id [
 122         (set-tag)
 123         set-tagclass
 124         set-encoding
 125         set-content-length
 126         set-newobj
 127         elements get 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 (>>value) ;
 185
 186 M: string >ber ( str -- byte-array )
 187     tagnum get 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 ;