Quicklispをproxy authenticationに対応させたい - その4 →対応させました

今回も結論から。 __この修正でProxyAuthenticationに対応したQuicklisp環境を構築できます。__

https://github.com/tamurashingo/quicklisp-client/tree/ProxyAuth
修正済みファイルはgithubにあげてあります。


前回までで、ホームディレクトリのquicklispディレクトリに初期ファイルがダウンロードされた状態になっているはずです。ここからファイルを修正して、ProxyAuthenticateに対応させていきます。
修正は以下の３ファイルです。

 - $HOME/quicklisp/quicklisp/http.lisp
 - $HOME/quicklisp/quicklisp/package.lisp
 - $HOME/quicklisp/quicklisp/setup.lisp

http.lispはProxy-Authorizationヘッダの付与に必要な関数の追加。
package.lispおよびsetup.lispは```*proxy-url*```と同様の記述を追加です。

```cl:http.lisp
;; ここから追加
(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)))

;; ここまで追加

(defun make-request-buffer (host port path &key (method "GET"))
  "Return an octet vector suitable for sending as an HTTP 1.1 request."
  (setf method (string method))
  (when *proxy-url*
    (setf path (full-proxy-path host port path)))
  (let ((sink (make-instance 'octet-sink)))
    (flet ((add-line (&rest strings)
             (apply #'add-strings sink strings)
             (add-newline sink)))
      (add-line method " " path " HTTP/1.1")
      (add-line "Host: " host (if (= port 80) ""
                                  (format nil ":~D" port)))
      ;; この2行を追加
      (when (and *proxy-url* *proxy-user* *proxy-pass*)
        (add-line "Proxy-Authorization: Basic " (make-basic-authentication *proxy-user* *proxy-pass*)))
      (add-line "Connection: close")
      (add-line "User-Agent: " (user-agent-string))
      (add-newline sink)
      (sink-buffer sink))))
```

```cl:package.lisp
(defpackage #:ql-http
  (:documentation
   "A simple HTTP client.")
  (:use #:cl #:ql-network #:ql-progress #:ql-config)
  (:export #:*proxy-url*
           #:*proxy-user*  ; 追加
           #:*proxy-pass*  ; 追加
           #:fetch
           #:hostname
           #:port
           #:path
           #:url
           #:*maximum-redirects*
           #:*default-url-defaults*)
  (:export #:fetch-error
           #:unexpected-http-status
           #:unexpected-http-status-code
           #:unexpected-http-status-url
           #:too-many-redirects
           #:too-many-redirects-url
           #:too-many-redirects-count))

(defpackage #:quicklisp-client
  (:documentation
   "The Quicklisp client package, intended for end-user Quicklisp
   commands and configuration parameters.")
  (:nicknames #:quicklisp #:ql)
  (:use #:cl
        #:ql-util
        #:ql-impl-util
        #:ql-dist
        #:ql-http
        #:ql-setup
        #:ql-config
        #:ql-minitar
        #:ql-gunzipper)
  (:shadow #:uninstall)
  (:export #:quickload
           #:*quickload-prompt*
           #:*quickload-verbose*
           #:*quickload-explain*
           #:system-not-found
           #:system-not-found-name
           #:uninstall
           #:uninstall-dist
           #:qmerge
           #:*quicklisp-home*
           #:*initial-dist-url*
           #:*proxy-url*
           #:*proxy-user*  ; 追加
           #:*proxy-pass*  ; 追加
           #:config-value
           #:setup
           #:provided-systems
           #:system-apropos
           #:system-list
           #:update-client
           #:update-dist
           #:update-all-dists
           #:add-to-init-file
           #:use-only-quicklisp-systems
           #:write-asdf-manifest-file
           #:where-is-system
           #:help
           #:register-local-projects
           #:local-projects-searcher
           #:*local-project-directories*
           #:list-local-projects
           #:list-local-systems
           #:who-depends-on))
```

```cl:setup.lisp
(defun maybe-initial-setup ()
  ;; Is this running under the quicklisp bootstrap?
  (let ((bootstrap-package (find-package 'quicklisp-quickstart)))
    (when bootstrap-package
      (let* ((proxy (find-symbol (string '#:*proxy-url*) bootstrap-package))
             (proxy-value (and proxy (symbol-value proxy)))

             ;; proxy-userの取得
             (puser (find-symbol (string '#:*proxy-user*) bootstrap-package))
             (puser-value (and puser (symbol-value puser)))
             ;; proxy-passの取得
             (ppass (find-symbol (string '#:*proxy-pass*) bootstrap-package))
             (ppass-value (and ppass (symbol-value ppass))))
        (when (and proxy-value (not *proxy-url*))
          (setf *proxy-url* proxy-value)
          (setf (config-value "proxy-url") proxy-value))

        ;; proxy-userの退避
        (when (and puser-value (not *proxy-user*))
          (setf *proxy-user* puser-value)
          (setf (config-value "proxy-user") puser-value))
        ;; proxy-passの退避
        (when (and ppass-value (not *proxy-pass*))
          (setf *proxy-pass* ppass-value)
          (setf (config-value "proxy-pass") ppass-value)))))
  (unless (ignore-errors (truename (qmerge "dists/")))
    (let ((target (qmerge "dists/quicklisp/distinfo.txt")))
      (ensure-directories-exist target)
      (fetch *initial-dist-url* target)
      (enable (find-dist "quicklisp")))))
```

# セットアップ続き

この状態で ```(ql:system-apropos "ppcre")``` とかやっても何も返ってきません。まだセットアップの途中だからです。セットアップを手動で続けていきます。

## ファイルの配置

$HOME/quicklisp/config下にproxy-url.txtができているはずです。
あわせて、proxy-user.txtとproxy-pass.txtを作成します。中身はそれぞれProxyサーバのユーザ名とProxyサーバのパスワードを記載します。

確認します。

```cl:
CL-USER> (load "/home/shingo/quicklisp/setup.lisp")
#P"/home/shingo/quicklisp/setup.lisp"
CL-USER> (in-package :quicklisp)
#<Package "QUICKLISP-CLIENT">
QL> (config-value "proxy-user")
"admin"
QL> (config-value "proxy-pass")
"password"
```

入力した内容が返ってくれば大丈夫です。


## 関数の上書き

Lispが認識しているmake-request-bufferはProxy-Authorizationヘッダを作成しないものになっているはずなので、
必要な値や関数を上書きしていきます。

```cl:
QL> (in-package #:ql-http)

#<Package "QL-HTTP">
QL-HTTP> (setq *proxy-user* (config-value "proxy-user"))
"admin"
QL-HTTP> (setq *proxy-pass* (config-value "proxy-pass"))
"password"
QL-HTTP> (defvar *BASE64TBL* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+-")
...
;; 以下、今回追加、変更した関数を貼り付ける。
```

## distinfoの取得

前回はdistinfo.txtの取得でエラーになっていたので、そこを手動でやり直します。

```cl:
QL-HTTP> (in-package :quicklisp)
#<Package "QUICKLISP-CLIENT">
QL> (let ((target (qmerge "dists/quicklisp/distinfo.txt")))
      (ensure-directories-exist target)
      (fetch *initial-dist-url* target)
      (enable (find-dist "quicklisp")))
; Fetching #<URL "http://beta.quicklisp.org/dist/quicklisp.txt">
; 0.40KB
==================================================
408 bytes in 0.00 seconds (199.22KB/sec)
T
```

## initfileの生成

```cl:
CL-USER> (ql:add-to-init-file)
```

これで完了です。


## 確認

CL-PPCREを落としてみます。

```cl:
CL> (in-package :cl-user)
#<Package "COMMON-LISP-USER">
CL-USER> (ql:system-apropos "cl-ppcre")
#<SYSTEM arnesi+.cl-ppcre-extras / arnesi+-20120909-darcs / quicklisp 2013-07-22>
#<SYSTEM arnesi.cl-ppcre-extras / arnesi-20101006-darcs / quicklisp 2013-07-22>
#<SYSTEM cl-ppcre / cl-ppcre-2.0.4 / quicklisp 2013-07-22>
#<SYSTEM cl-ppcre-template / cl-unification-20130128-cvs / quicklisp 2013-07-22>
#<SYSTEM cl-ppcre-test / cl-ppcre-2.0.4 / quicklisp 2013-07-22>
#<SYSTEM cl-ppcre-unicode / cl-ppcre-2.0.4 / quicklisp 2013-07-22>
#<SYSTEM parser-combinators-cl-ppcre / cl-parser-combinators-20121125-git / quicklisp 2013-07-22>
; No value
CL-USER> (ql:quickload :cl-ppcre)
; Fetching #<URL "http://beta.quicklisp.org/dist/quicklisp/2013-07-22/systems.txt">
; 150.36KB
==================================================
153,969 bytes in 1.33 seconds (113.05KB/sec)
; Fetching #<URL "http://beta.quicklisp.org/dist/quicklisp/2013-07-22/releases.txt">
; 223.71KB
==================================================
229,074 bytes in 1.45 seconds (154.28KB/sec)
To load "cl-ppcre":
  Install 1 Quicklisp release:
    cl-ppcre
; Fetching #<URL "http://beta.quicklisp.org/archive/cl-ppcre/2013-04-20/cl-ppcre-2.0.4.tgz">
; 154.37KB
==================================================
158,070 bytes in 1.41 seconds (109.56KB/sec)
; Loading "cl-ppcre"
[package cl-ppcre]................................
..................................................
...................
(:CL-PPCRE)
```

Lispを再起動させたあともライブラリを取ってこれていれば大丈夫です。

```cl:
CL-USER> (ql:system-apropos "alexandria")
#<SYSTEM alexandria / alexandria-20130128-git / quicklisp 2013-07-22>
#<SYSTEM alexandria-tests / alexandria-20130128-git / quicklisp 2013-07-22>
; No value
CL-USER> (ql:quickload :alexandria)
To load "alexandria":
  Install 1 Quicklisp release:
    alexandria
; Fetching #<URL "http://beta.quicklisp.org/archive/alexandria/2013-01-28/alexandria-20130128-git.tgz">
; 48.22KB
==================================================
49,374 bytes in 0.01 seconds (4821.68KB/sec)
; Loading "alexandria"
[package alexandria.0.dev]........................
..................................................
.......
(:ALEXANDRIA)
```