guile-base64server/server.scm

#!/usr/bin/env bash
exec guile -s $0 $@
!#
(import (rnrs)
        (only (srfi :13 strings)
              string-index
              string-prefix? string-suffix?
              string-concatenate string-trim-both)
        (fibers web server)
        (web request)
        (web uri))

(define base64-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(define base64url-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
;; Create a lookup table for the alphabet and remember the latest table.
(define get-decode-table
  (let ((ascii-table #f)
        (extra-table '())     ;in the unlikely case of unicode chars
        (table-alphabet #f))
    (lambda (alphabet)
      (unless (eq? alphabet table-alphabet)
        ;; Rebuild the table.
        (do ((ascii (make-vector 128 #f))
             (extra '())
             (i 0 (+ i 1)))
            ((= i (string-length alphabet))
             (set! ascii-table ascii)
             (set! extra-table extra))
          (let ((c (char->integer (string-ref alphabet i))))
            (if (fx<=? c 127)
                (vector-set! ascii c i)
                (set! extra (cons (cons c i) extra)))))
        (set! table-alphabet alphabet))
      (values ascii-table extra-table))))
;; Decodes a correctly padded base64 string, optionally ignoring
;; non-alphabet characters.
(define base64-decode
  (case-lambda
    ((str)
     (base64-decode str base64-alphabet #f))
    ((str alphabet)
     (base64-decode str alphabet #f))
    ((str alphabet port)
     (base64-decode str alphabet port #t))
    ((str alphabet port strict?)
     (define (pad? c) (eqv? c (char->integer #\=)))
     (let-values (((p extract) (if port
                                   (values port (lambda () (values)))
                                   (open-bytevector-output-port)))
                  ((ascii extra) (get-decode-table alphabet)))
       (define-syntax lookup
         (syntax-rules ()
           ((_ c) (or (and (fx<=? c 127) (vector-ref ascii c))
                      (cond ((assv c extra) => cdr)
                            (else #f))))))
       (let* ((len (if strict?
                       (string-length str)
                       (let lp ((i (fx- (string-length str) 1)))
                         ;; Skip trailing invalid chars.
                         (cond ((fxzero? i) 0)
                               ((let ((c (char->integer (string-ref str i))))
                                  (or (lookup c) (pad? c)))
                                (fx+ i 1))
                               (else (lp (fx- i 1))))))))
         (let lp ((i 0))
           (cond
            ((fx=? i len)
             (extract))
            ((fx<=? i (fx- len 4))
             (let lp* ((c1 (char->integer (string-ref str i)))
                       (c2 (char->integer (string-ref str (fx+ i 1))))
                       (c3 (char->integer (string-ref str (fx+ i 2))))
                       (c4 (char->integer (string-ref str (fx+ i 3))))
                       (i i))
               (let ((i1 (lookup c1)) (i2 (lookup c2))
                     (i3 (lookup c3)) (i4 (lookup c4)))
                 (cond
                  ((and i1 i2 i3 i4)
                   ;; All characters present and accounted for.
                   ;; The most common case.
                   (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                   (fxarithmetic-shift-left i2 12)
                                   (fxarithmetic-shift-left i3 6)
                                   i4)))
                     (put-u8 p (fxbit-field x 16 24))
                     (put-u8 p (fxbit-field x 8 16))
                     (put-u8 p (fxbit-field x 0 8))
                     (lp (fx+ i 4))))
                  ((and i1 i2 i3 (pad? c4) (= i (- len 4)))
                   ;; One padding character at the end of the input.
                   (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                   (fxarithmetic-shift-left i2 12)
                                   (fxarithmetic-shift-left i3 6))))
                     (put-u8 p (fxbit-field x 16 24))
                     (put-u8 p (fxbit-field x 8 16))
                     (lp (fx+ i 4))))
                  ((and i1 i2 (pad? c3) (pad? c4) (= i (- len 4)))
                   ;; Two padding characters.
                   (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                   (fxarithmetic-shift-left i2 12))))
                     (put-u8 p (fxbit-field x 16 24))
                     (lp (fx+ i 4))))
                  ((not strict?)
                   ;; Non-alphabet characters.
                   (let lp ((i i) (c* '()) (n 4))
                     (cond ((fxzero? n)
                            ;; Found four valid characters.
                            (lp* (cadddr c*) (caddr c*) (cadr c*) (car c*)
                                 (fx- i 4)))
                           ((fx=? i len)
                            (error 'base64-decode
                                   "Invalid input in non-strict mode."
                                   i c*))
                           (else
                            ;; Gather alphabetic (or valid
                            ;; padding) characters.
                            (let ((c (char->integer (string-ref str i))))
                              (cond ((or (lookup c)
                                         (and (pad? c)
                                              (fx<=? n 2)
                                              (fx=? i (fx- len n))))
                                     (lp (fx+ i 1) (cons c c*) (fx- n 1)))
                                    (else
                                     (lp (fx+ i 1) c* n))))))))
                  (else
                   (error 'base64-decode
                          "Invalid input in strict mode."
                          c1 c2 c3 c4))))))
            (else
             (error 'base64-decode
                    "The input is too short, it may be missing padding."  i)))))))))

(define (handler request body)
  (let* ((path* (uri-path (request-uri request)))
         (path (string-drop path* (min 1 (string-length path*))))
         (err #f)
         (errparams '())
         (res ""))
    (catch #t
      (lambda ()
        (set! res (utf8->string (base64-decode path))))
      (lambda (key . parameters) (set! err key) (set! errparams parameters)))
    (if err
        (values '((content-type . (text/plain)))
                (format #f "Hello, Error! \n\n~a\n\nCould not decode base64: ~a" err path))
        (values '((content-type . (text/plain)))
                (format #f "I am just a simple, overloaded homeserver. But come, try me! \n\nDecoded base64: ~a" res)))))

(run-server handler #:host "192.168.178.101" #:port 2342)