Quicklispをproxy authenticationに対応させたい - その2

Quicklispでproxy authenticationを使うため、Base64へエンコードする機能を作ります。
Base64のエンコード手順はWikipediaを参考にしています。
http://ja.wikipedia.org/wiki/Base64

元データ

ABCDEFG
→ bitをリストで表現する。

(defun to-bit (num)
  (loop for x from 7 downto 0 collect (ldb (byte 1 x) num)))

(to-bit 65)
=> (0 1 0 0 0 0 0 1)


(defun string-to-bit (str)
  (map 'list #'to-bit (map 'list #'char-code str)))

(string-to-bit "ABCDEFG")
=> ((0 1 0 0 0 0 0 1) (0 1 0 0 0 0 1 0) (0 1 0 0 0 0 1 1) (0 1 0 0 0 1 0 0) (0 1 0 0 0 1 0 1) (0 1 0 0 0 1 1 0) (0 1 0 0 0 1 1 1))


(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x) (rec (cdr x) acc))))))
    (rec x nil)))

(flatten (string-to-bit "ABCDEFG"))
=> (0 1 0 0 0 0 0 1 0 1 0 0 0 0 1 0 0 1 0 0 0 0 1 1 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 1 0 1 0 0 0 1 1 0 0 1 0 0 0 1 1 1)

※flattenはOnLispからいただきました。

6ビットずつに分割

まずはリストを指定された長さで分割する関数。多値を使う。

(defun take-list (list num)
  (labels ((take-n (list num acc)
             (if (or (<= num 0)
                     (null list))
                 (values (nreverse acc) list)
                 (take-n (cdr list) (- num 1) (cons (car list) acc)))))
    (take-n list num '())))

(take-list '(1 2 3 4 5) 3)
=> (1 2 3)
   (4 5)

(take-list '(1 2 3 4 5) 6)
=> (1 2 3 4 5)
   NIL

上記の関数を使って、指定された長さでリストをグループ化する。

(defun split (list num)
  (labels ((split (list acc)
             (multiple-value-bind (six rest)
                 (take-list list num)
               (if (null rest)
                   (nreverse (cons six acc))
                   (split rest (cons six acc))))))
    (split list '())))

(split (flatten (string-to-bit "ABCDEFG")) 6)
=> ((0 1 0 0 0 0) (0 1 0 1 0 0) (0 0 1 0 0 1) (0 0 0 0 1 1) (0 1 0 0 0 1) (0 0 0 1 0 0) (0 1 0 1 0 1) (0 0 0 1 1 0) (0 1 0 0 0 1) (1 1))

あまりを補う

リストが指定された長さ未満の場合、詰め物をする関数を定義する。

(defun rpad (list padsize &key (pad 0))
  (labels ((right-padding (list padsize acc)
             (if (null list)
                 (nreverse acc)
                 (let ((item (car list)))
                   (if (< (length item) padsize)
                       (right-padding (cdr list) padsize (cons
                                                           (append
                                                             item
                                                             (make-list
                                                               (- padsize (length item))
                                                               :initial-element pad))
                                                           acc))
                       (right-padding (cdr list) padsize (cons item acc)))))))
    (right-padding list padsize '())))

(rpad '((1 2) (3 4) (5)) 2)
=> ((1 2) (3 4) (5 0))
(rpad '((1 2) (3 4) (5)) 2 :pad "a")
=> ((1 2) (3 4) (5 "a"))

(rpad (split (flatten (string-to-bit "ABCDEFG")) 6) 6)
=> ((0 1 0 0 0 0) (0 1 0 1 0 0) (0 0 1 0 0 1) (0 0 0 0 1 1) (0 1 0 0 0 1) (0 0 0 1 0 0) (0 1 0 1 0 1) (0 0 0 1 1 0) (0 1 0 0 0 1) (1 1 0 0 0 0))

rpadは後に=を追加するのにも使うので、keyでpadを指定できるようにしています。

変換表により、4文字ずつ変換

まずはリストで表現したバイナリを実際の値に戻します。

(defun bit-to-num (list)
  (let ((ms (length list)))
    (loop for x in list
          for y downfrom (1- ms)
          sum (ash x y))))

(bit-to-num '(0 0 0 1))
=> 1
(bit-to-num '(1 0 0 1))
=> 9
(bit-to-num '(1 1 0 1 1 0))
=> 54

値から該当する文字を抽出します。0がA、1がB・・・となっているので、シーケンスからarefで取ることにします。

(map 'list #'bit-to-num (rpad (split (flatten (string-to-bit "ABCDEFG")) 6) 6))
=> (16 20 9 3 17 4 21 6 17 48)
(map 'list #'(lambda (x)
               (aref "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+-" x))
           (map 'list #'bit-to-num (rpad (split (flatten (string-to-bit "ABCDEFG")) 6) 6)))
=> (#\Q #\U #\J #\D #\R #\E #\V #\G #\R #\w)

4文字ずつにまとめます。

(split
  (map 'list #'(lambda (x)
                 (aref "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+-" x))
             (map 'list #'bit-to-num (rpad (split (flatten (string-to-bit "ABCDEFG")) 6) 6)))
  4)
=> ((#\Q #\U #\J #\D) (#\R #\E #\V #\G) (#\R #\w))

2文字余るので、2文字分 = 記号を追加して4文字にする

先ほどのrpadを使います。

(rpad
  (split
    (map 'list #'(lambda (x)
                   (aref "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+-" x))
               (map 'list #'bit-to-num (rpad (split (flatten (string-to-bit "ABCDEFG")) 6) 6)))
    4)
  4 :pad #\=)
=> ((#\Q #\U #\J #\D) (#\R #\E #\V #\G) (#\R #\w #\= #\=))

Base64文字列

formatでリストのリストを文字列にします。

(format nil "~{~{~A~}~}"
  (rpad
    (split
      (map 'list #'(lambda (x)
                     (aref "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+-" x))
                 (map 'list #'bit-to-num (rpad (split (flatten (string-to-bit "ABCDEFG")) 6) 6)))
      4)
    4 :pad #\=))
=> "QUJDREVGRw=="

まとめ

(defvar *BASE64TBL* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+-")

(defun to-bit (num)
  "convert 1 octet to binary(0/1) list"
  (loop for x from 7 downto 0 collect (ldb (byte 1 x) num)))

(defun string-to-bit (str)
  "convert string to binary(0/1) list"
  (map 'list #'to-bit (map 'list #'char-code str)))

(defun flatten (x)
  "flatten list"
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x) (rec (cdr x) acc))))))
    (rec x nil)))

(defun take-list (list num)
  "return taken from list(first arguments) passed as the num(second argument) and rest of the list"
  (labels ((take-n (list num acc)
             (if (or (<= num 0)
                     (null list))
                 (values (nreverse acc) list)
                 (take-n (cdr list) (- num 1) (cons (car list) acc)))))
    (take-n list num '())))

(defun split (list num)
  "split list. each list has num(second arguments) items."
  (labels ((split (list acc)
             (multiple-value-bind (six rest)
                 (take-list list num)
               (if (null rest)
                   (nreverse (cons six acc))
                   (split rest (cons six acc))))))
    (split list '())))

(defun rpad (list padsize &key (pad 0))
  "if each list's length less than padsize(second arguments), padding pad(default 0) on right side."
  (labels ((right-padding (list padsize acc)
             (if (null list)
                 (nreverse acc)
                 (let ((item (car list)))
                   (if (< (length item) padsize)
                       (right-padding (cdr list) padsize (cons
                                                           (append
                                                             item
                                                             (make-list
                                                               (- padsize (length item))
                                                               :initial-element pad))
                                                           acc))
                       (right-padding (cdr list) padsize (cons item acc)))))))
    (right-padding list padsize '())))

(defun bit-to-num (list)
  "convert binary(0/1) list to number"
  (let ((ms (length list)))
    (loop for x in list
          for y downfrom (1- ms)
          sum (ash x y))))

(defun base64-enc (str)
  "create base64 encoded string from argument"
  (format nil "~{~{~A~}~}"
    (rpad
      (split
        (map 'list #'(lambda (x)
                       (aref *BASE64TBL* x))
              (map 'list #'bit-to-num
                   (rpad
                     (split
                       (flatten
                         (string-to-bit str))
                       6)
                     6)))
        4)
    4 :pad #\=)))

(defun make-basic-authentication (user password)
  "create basic authentication string"
  (base64-enc (format nil "~A:~A" user password)))

なんとなくSchemeっぽい書き方になってしまいました。
次はこれをQuicklispに組み込みます。