basic 認証、digest 認証

gauche で。

basic 認証

(use rfc.http)
(use rfc.base64)

(define *user* "user")
(define *pass* "password")

(define *server* "hoge.com")
(define *request-uri* "/foo/bar.html")

(define (basic-auth user pass)
  (string-append
   "Basic "
   (base64-encode-string (string-append user ":" pass))))

(receive (status header body)
    (http-get *server* *request-uri*
              :authorization (basic-auth *user* *pass*))

digest 認証

取りあえず動いたっぽい。

(use srfi-1 :only (iota))
(use srfi-13 :only (string-concatenate))
(use srfi-14))
(use rfc.http)
(use rfc.md5)
(use text.tree :only (tree->string))
(use util.list :only (intersperse))
(use math.mt-random)


(define *user* "user")
(define *pass* "password")

(define *server* "hoge.com")
(define *request-uri* "/foo/bar/baz.html")

(define *nc* "00000001")


;; --- random string

(define rand
  (let1 m (make <mersenne-twister>)
    (^ (:optional (len 2))
       (mt-random-integer m len))))

(define (random-char src)
  (string-ref src (rand (string-length src))))

(define (random-string src len)
  (let rec ((len len)(acc '()))
    (if (zero? len)
        (list->string acc)
        (rec (- len 1)(cons (random-char src) acc)))))

(define (sequential-src :optional (len 255))
  (list->string (map integer->char (iota len))))


(define (nonce str)
  (regexp-replace-all*
   (rxmatch->string #/nonce=\".+?\"/ str)
   #/nonce=/ "" #/\"/ ""))

(define (realm str)
  (regexp-replace-all*
   (rxmatch->string #/Digest realm=\".+?\"/ str)
   #/Digest realm=/ "" #/\"/ ""))

(define (qop str)
  (regexp-replace-all*
   (rxmatch->string #/qop=\".+?\"/ str)
   #/qop=/ "" #/\"/ ""))

(define (algorithm str)
  (regexp-replace-all*
   (rxmatch->string #/algorithm=.+?\,/ str)
   #/algorithm=/ "" #/\,/ ""))


(define (make-a1 user pass realm)
  (string-concatenate (intersperse ":" (list user realm pass))))

(define (make-a2 method request-uri)
  (string-append method ":" request-uri))

(define (make-responce a1 a2 nonce nc cnonce qop)
  (let1 dh-md5 (^s (digest-hexify (md5-digest-string s)))
    (dh-md5 (string-concatenate
             (intersperse ":" (list (dh-md5 a1) nonce nc
                                    cnonce qop (dh-md5 a2)))))))

(define (make-cnonce)
  (digest-hexify (md5-digest-string (random-string (sequential-src) 8))))


;; --- test
(receive (status header body)
    (http-get *server* *request-uri*)
  (let ((str (tree->string header))
        (cnonce (make-cnonce)))
    (let1 res (make-responce (make-a1 *user* *pass* (realm str))
                             (make-a2 "GET" *request-uri*)
                             (nonce str) *nc*
                             cnonce
                             (qop str))
      (http-get *server* *request-uri* :authorization #`"Digest username=\",|*user*|\", realm=\",(realm str)\", nonce=\",(nonce str)\", uri=\",|*request-uri*|\", algorithm=MD5, qop=,(qop str), nc=00000001,  cnonce=\",|cnonce|\", response=\",|res|\""))))

ちょっと無理がありつつも。。

(define-class <md5-header> ()
  ((header :init-keyword :header)
   (realm)(nonce)(algorithm)(qop)))

(define-class <md5-cred> ()
  ((server :init-keyword :server)
   (request-uri :init-keyword :request-uri)
   (user :init-keyword :user)
   (password :init-keyword :password)
   (nc :init-keyword :nc :init-value "00000001")
   (method :init-keyword :method :init-value "GET")
   (realm)(nonce)(algorithm)(qop)(cnonce)(a1)(a2)(response)))

(define (md5-header-initialize! mh header)
  (let1 header (tree->string header)
    (slot-set! mh 'realm (realm header))
    (slot-set! mh 'nonce (nonce header))
    (slot-set! mh 'algorithm (algorithm header))
    (slot-set! mh 'qop (qop header)))
  mh)

(define (construct-md5-cred! cred mh)
  (slot-set! cred 'realm (~ mh 'realm))
  (slot-set! cred 'nonce (~ mh 'nonce))
  (slot-set! cred 'algorithm (~ mh 'algorithm))
  (slot-set! cred 'qop (~ mh 'qop))
  (slot-set! cred 'cnonce (make-cnonce))
  (slot-set! cred 'a1 (make-a1 (~ cred 'user)
                               (~ cred 'password)(~ cred 'realm)))
  (slot-set! cred 'a2 (make-a2 (~ cred 'method)(~ cred 'request-uri)))
  (slot-set! cred 'response
             (make-responce (~ cred 'a1)(~ cred 'a2)(~ cred 'nonce)
                            (~ cred 'nc)(~ cred 'cnonce)(~ cred 'qop)))
  cred)

(define (construct-cred-string cred)
  (let ((user (~ cred 'user))
        (realm (~ cred 'realm))
        (nonce (~ cred 'nonce))
        (uri (~ cred 'request-uri))
        (algorithm (~ cred 'algorithm))
        (qop (~ cred 'qop))
        (nc (~ cred 'nc))
        (cnonce (~ cred 'cnonce))
        (response (~ cred 'response)))
    #`"Digest username=\",|user|\", realm=\",|realm|\", nonce=\",|nonce|\", uri=\",|uri|\", algorithm=,|algorithm|, qop=,|qop|, nc=,|nc|,  cnonce=\",|cnonce|\", response=\",|response|\""))


;; --- test
(receive (status header body)
    (http-get *server* *request-uri*)
  (let ((mh (make <md5-header>
              :server *server*
              :request-uri *request-uri*))
        (cred (make <md5-cred>
                :server *server*
                :request-uri *request-uri*
                :user *user*
                :password *pass*)))
    (md5-header-initialize! mh header)
    (construct-md5-cred! cred mh)
    (let1 str (construct-cred-string cred)
      (http-get *server* *request-uri* :authorization str))))

不完全文字列

• 不完全文字列 - Gauche ユーザリファレンス: 6.11 文字列
• Gauche ユーザリファレンス: 11.42 util.digest - メッセージダイジェストフレームワーク
• Gauche ユーザリファレンス: 11.27 rfc.md5 - MD5メッセージダイジェスト

不完全文字列・・・って？
md5-digest-string はなんで不完全文字列が返ってくるの。。

参考

• Basic認証 - Wikipedia
• Digest認証 - Wikipedia
• HTTP クライアントを作ってみよう(5) - Basic 認証編 -
• HTTP クライアントを作ってみよう(6) - Digest 認証編 -

追記

すごく参考になりました。ありがとうございます！

• Twitter / SaitoAtsushi: @valvallow 豆知識：正規表現リテラルの中で ...

@valvallow 豆知識：正規表現リテラルの中ではダブルクォートはエスケープしなくてもいいです。 (してもいいです。 正規表現リテラルは Gauche 特有なのでそれを解釈できないエディタの混乱を回避するためにあえてエスケープすることもあります。)

• Twitter / SaitoAtsushi: @valvallow 正規表現でマッチした一部を抜き ...

@valvallow 正規表現でマッチした一部を抜き出したいときは括弧で囲んどけばいいですよ。 こんな感じ。 (define(nonce str)((#/nonce=\"(.+?)\"/ str)1))

これ読みてー・・・