examples/web-server/base64.scm

   1 ;==============================================================================
   2
   3 ; File: "base64.scm", Time-stamp: <2008-12-15 11:54:22 feeley>
   4
   5 ; Copyright (c) 2005-2008 by Marc Feeley, All Rights Reserved.
   6
   7 ;==============================================================================
   8
   9 (##namespace ("base64#"))
  10
  11 (##include "~~lib/gambit#.scm")
  12
  13 (##include "base64#.scm")
  14
  15 (declare
  16   (standard-bindings)
  17   (extended-bindings)
  18   (block)
  19   (not safe)
  20   (fixnum)
  21 )
  22
  23 ;==============================================================================
  24
  25 ; Representation of fifos.
  26
  27 (##define-macro (macro-make-fifo)
  28   `(let ((fifo (##cons '() '())))
  29      (macro-fifo-tail-set! fifo fifo)
  30      fifo))
  31
  32 (##define-macro (macro-fifo-next fifo)        `(##cdr ,fifo))
  33 (##define-macro (macro-fifo-next-set! fifo x) `(##set-cdr! ,fifo ,x))
  34 (##define-macro (macro-fifo-tail fifo)        `(##car ,fifo))
  35 (##define-macro (macro-fifo-tail-set! fifo x) `(##set-car! ,fifo ,x))
  36 (##define-macro (macro-fifo-elem fifo)        `(##car ,fifo))
  37 (##define-macro (macro-fifo-elem-set! fifo x) `(##set-car! ,fifo ,x))
  38
  39 (##define-macro (macro-fifo->list fifo)
  40   `(macro-fifo-next ,fifo))
  41
  42 (##define-macro (macro-fifo-remove-all! fifo)
  43   `(let ((fifo ,fifo))
  44
  45      (##declare (not interrupts-enabled))
  46
  47      (let ((head (macro-fifo-next fifo)))
  48        (macro-fifo-tail-set! fifo fifo)
  49        (macro-fifo-next-set! fifo '())
  50        head)))
  51
  52 (##define-macro (macro-fifo-remove-head! fifo)
  53   `(let ((fifo ,fifo))
  54
  55      (##declare (not interrupts-enabled))
  56
  57      (let ((head (macro-fifo-next fifo)))
  58        (if (##pair? head)
  59          (let ((next (macro-fifo-next head)))
  60            (if (##null? next)
  61              (macro-fifo-tail-set! fifo fifo))
  62            (macro-fifo-next-set! fifo next)
  63            (macro-fifo-next-set! head '())))
  64        head)))
  65
  66 (##define-macro (macro-fifo-insert-at-tail! fifo elem)
  67   `(let ((fifo ,fifo) (elem ,elem))
  68      (let ((x (##cons elem '())))
  69
  70        (##declare (not interrupts-enabled))
  71
  72        (let ((tail (macro-fifo-tail fifo)))
  73          (macro-fifo-next-set! tail x)
  74          (macro-fifo-tail-set! fifo x)
  75          (##void)))))
  76
  77 (##define-macro (macro-fifo-insert-at-head! fifo elem)
  78   `(let ((fifo ,fifo) (elem ,elem))
  79      (let ((x (##cons elem '())))
  80
  81        (##declare (not interrupts-enabled))
  82
  83        ; To obtain an atomic update of the fifo, we must force a
  84        ; garbage-collection to occur right away if needed by the
  85        ; ##cons, so that any finalization that might mutate this fifo
  86        ; will be done before updating the fifo.
  87
  88        (##check-heap-limit)
  89
  90        (let ((head (macro-fifo-next fifo)))
  91          (if (##null? head)
  92            (macro-fifo-tail-set! fifo x))
  93          (macro-fifo-next-set! fifo x)
  94          (macro-fifo-next-set! x head)
  95          (##void)))))
  96
  97 (##define-macro (macro-fifo-advance-to-tail! fifo)
  98   `(let ((fifo ,fifo))
  99      ; It is assumed that the fifo contains at least one element
 100      ; (i.e. the fifo's tail does not change).
 101      (let ((new-head (macro-fifo-tail fifo)))
 102        (macro-fifo-next-set! fifo new-head)
 103        (macro-fifo-elem new-head))))
 104
 105 (##define-macro (macro-fifo-advance! fifo)
 106   `(let ((fifo ,fifo))
 107      ; It is assumed that the fifo contains at least two elements
 108      ; (i.e. the fifo's tail does not change).
 109      (let* ((head (macro-fifo-next fifo))
 110             (new-head (macro-fifo-next head)))
 111        (macro-fifo-next-set! fifo new-head)
 112        (macro-fifo-elem new-head))))
 113
 114 (##define-macro (fifo->u8vector fifo start end)
 115   `(##fifo->u8vector ,fifo ,start ,end))
 116
 117 (##define-macro (u8vector-shrink! u8vect len)
 118   `(##u8vector-shrink! ,u8vect ,len))
 119
 120 (##define-macro (fifo->string fifo start end)
 121   `(##fifo->string ,fifo ,start ,end))
 122
 123 (##define-macro (string-shrink! str len)
 124   `(##string-shrink! ,str ,len))
 125
 126 ;==============================================================================
 127
 128 (define base64-string->u8vector
 129   (lambda (str)
 130     (base64-substring->u8vector str 0 (string-length str))))
 131
 132 (define base64-substring->u8vector
 133   (lambda (str start end)
 134
 135     (define err
 136       (lambda ()
 137         (error "base64 decoding error")))
 138
 139     (define chunk-len 64) ; must be a power of 2
 140
 141     (define state
 142       (vector 0
 143               (macro-make-fifo)))
 144
 145     (define (wr-u8 x)
 146       (let ((ptr (vector-ref state 0)))
 147         (vector-set! state 0 (+ ptr 1))
 148         (let ((fifo (vector-ref state 1))
 149               (i (bitwise-and ptr (- chunk-len 1))))
 150           (u8vector-set!
 151            (if (= i 0)
 152                (let ((chunk (make-u8vector chunk-len)))
 153                  (macro-fifo-insert-at-tail! fifo chunk)
 154                  chunk)
 155                (macro-fifo-elem (macro-fifo-tail fifo)))
 156            i
 157            x))))
 158
 159     (define (get-output-u8vector)
 160       (let ((ptr (vector-ref state 0))
 161             (fifo (vector-ref state 1)))
 162         (if (and (< 0 ptr) (<= ptr chunk-len))
 163             (let ((u8vect (macro-fifo-elem (macro-fifo-tail fifo))))
 164               (u8vector-shrink! u8vect ptr)
 165               u8vect)
 166             (fifo->u8vector fifo 0 ptr))))
 167
 168     (define decode
 169       (lambda (c)
 170         (cond ((and (char>=? c #\A) (char<=? c #\Z))
 171                (- (char->integer c) (char->integer #\A)))
 172               ((and (char>=? c #\a) (char<=? c #\z))
 173                (+ 26 (- (char->integer c) (char->integer #\a))))
 174               ((and (char>=? c #\0) (char<=? c #\9))
 175                (+ 52 (- (char->integer c) (char->integer #\0))))
 176               ((char=? c #\+)
 177                62)
 178               ((char=? c #\/)
 179                63)
 180               (else
 181                #f))))
 182
 183     (define done
 184       (lambda ()
 185         (get-output-u8vector)))
 186
 187     (define add1
 188       (lambda (x0 x1)
 189         (add (+ (arithmetic-shift x0 2)
 190                 (arithmetic-shift x1 -4)))))
 191
 192     (define add2
 193       (lambda (x0 x1 x2)
 194         (add1 x0 x1)
 195         (add (bitwise-and #xff
 196                           (+ (arithmetic-shift x1 4)
 197                              (arithmetic-shift x2 -2))))))
 198
 199     (define add3
 200       (lambda (x0 x1 x2 x3)
 201         (add2 x0 x1 x2)
 202         (add (bitwise-and #xff
 203                           (+ (arithmetic-shift x2 6)
 204                              x3)))))
 205
 206     (define add
 207       (lambda (x)
 208         (wr-u8 x)))
 209
 210     (let loop0 ((i start))
 211       (if (>= i end)
 212           (done)
 213           (let* ((c0 (string-ref str i))
 214                  (x0 (decode c0)))
 215             (if x0
 216                 (let loop1 ((i (+ i 1)))
 217                   (if (>= i end)
 218                       (err)
 219                       (let* ((c1 (string-ref str i))
 220                              (x1 (decode c1)))
 221                         (if x1
 222                             (let loop2 ((i (+ i 1)))
 223                               (if (>= i end)
 224                                   (err)
 225                                   (let* ((c2 (string-ref str i))
 226                                          (x2 (decode c2)))
 227                                     (if x2
 228                                         (let loop3 ((i (+ i 1)))
 229                                           (if (>= i end)
 230                                               (err)
 231                                               (let* ((c3 (string-ref str i))
 232                                                      (x3 (decode c3)))
 233                                                 (if x3
 234                                                     (begin
 235                                                       (add3 x0 x1 x2 x3)
 236                                                       (loop0 (+ i 1)))
 237                                                     (if (char=? c3 #\=)
 238                                                         (begin
 239                                                           (add2 x0 x1 x2)
 240                                                           (done))
 241                                                         (loop3 (+ i 1)))))))
 242                                         (if (char=? c2 #\=)
 243                                             (begin
 244                                               (add1 x0 x1)
 245                                               (done))
 246                                             (loop2 (+ i 1)))))))
 247                             (if (char=? c1 #\=)
 248                                 (err)
 249                                 (loop1 (+ i 1)))))))
 250                 (if (char=? c0 #\=)
 251                     (err)
 252                     (loop0 (+ i 1)))))))))
 253
 254 (define u8vector->base64-string
 255   (lambda (u8vect #!optional (width 0))
 256     (subu8vector->base64-string u8vect 0 (u8vector-length u8vect) width)))
 257
 258 (define subu8vector->base64-string
 259   (lambda (u8vect start end #!optional (width 0))
 260
 261     (define chunk-len 64) ; must be a power of 2
 262
 263     (define state
 264       (vector 0
 265               (macro-make-fifo)))
 266
 267     (define (wr-char c)
 268       (let ((ptr (vector-ref state 0)))
 269         (vector-set! state 0 (+ ptr 1))
 270         (let ((fifo (vector-ref state 1))
 271               (i (bitwise-and ptr (- chunk-len 1))))
 272           (string-set!
 273            (if (= i 0)
 274                (let ((chunk (make-string chunk-len)))
 275                  (macro-fifo-insert-at-tail! fifo chunk)
 276                  chunk)
 277                (macro-fifo-elem (macro-fifo-tail fifo)))
 278            i
 279            c))))
 280
 281     (define (get-output-string)
 282       (let ((ptr (vector-ref state 0))
 283             (fifo (vector-ref state 1)))
 284         (if (and (< 0 ptr) (<= ptr chunk-len))
 285             (let ((str (macro-fifo-elem (macro-fifo-tail fifo))))
 286               (string-shrink! str ptr)
 287               str)
 288             (fifo->string fifo 0 ptr))))
 289
 290     (define add
 291       (lambda (c)
 292         (wr-char c)))
 293
 294     (define out
 295       (lambda (x n)
 296         (let ((new-n
 297                (cond ((= -1 n)
 298                       n)
 299                      ((= 0 n)
 300                       (add #\newline)
 301                       (- width 1))
 302                      (else
 303                       (- n 1)))))
 304           (add (cond ((<= x 25)
 305                       (integer->char (+ x (char->integer #\A))))
 306                      ((<= x 51)
 307                       (integer->char (+ (- x 26) (char->integer #\a))))
 308                      ((<= x 61)
 309                       (integer->char (+ (- x 52) (char->integer #\0))))
 310                      ((= x 62)
 311                       #\+)
 312                      ((= x 63)
 313                       #\/)
 314                      (else
 315                       #\=)))
 316           new-n)))
 317
 318     (let loop ((i start)
 319                (n (if (> width 0) width -1)))
 320       (if (<= (+ i 3) end)
 321           (let ((b0 (u8vector-ref u8vect i))
 322                 (b1 (u8vector-ref u8vect (+ i 1)))
 323                 (b2 (u8vector-ref u8vect (+ i 2))))
 324             (let ((x0
 325                    (arithmetic-shift b0 -2))
 326                   (x1
 327                    (bitwise-and #x3f
 328                                 (+ (arithmetic-shift b0 4)
 329                                    (arithmetic-shift b1 -4))))
 330                   (x2
 331                    (bitwise-and #x3f
 332                                 (+ (arithmetic-shift b1 2)
 333                                    (arithmetic-shift b2 -6))))
 334                   (x3
 335                    (bitwise-and #x3f b2)))
 336               (loop (+ i 3)
 337                     (out x3 (out x2 (out x1 (out x0 n)))))))
 338           (let ((rest (- end i)))
 339             (cond ((= rest 2)
 340                    (let ((b0 (u8vector-ref u8vect i))
 341                          (b1 (u8vector-ref u8vect (+ i 1))))
 342                      (let ((x0
 343                             (arithmetic-shift b0 -2))
 344                            (x1
 345                             (bitwise-and #x3f
 346                                          (+ (arithmetic-shift b0 4)
 347                                             (arithmetic-shift b1 -4))))
 348                            (x2
 349                             (bitwise-and #x3f
 350                                          (arithmetic-shift b1 2)))
 351                            (x3
 352                             64))
 353                        (out x3 (out x2 (out x1 (out x0 n)))))))
 354                   ((= rest 1)
 355                    (let ((b0 (u8vector-ref u8vect i)))
 356                      (let ((x0
 357                             (arithmetic-shift b0 -2))
 358                            (x1
 359                             (bitwise-and #x3f
 360                                          (arithmetic-shift b0 4)))
 361                            (x2
 362                             64)
 363                            (x3
 364                             64))
 365                        (out x3 (out x2 (out x1 (out x0 n))))))))
 366             (get-output-string))))))
 367
 368 ;==============================================================================