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