JWT と愉快な仲間たち

多分2017年くらいにやるかと思って放置していた JWT 周りのサポートをようやく重い腰をあげて完了した。一応、現時点て RFC になってるものは全部入れたはず(EdDSA とか ES256K とか)。ドラフトの ECDH-1PU はそのうちファイナルになったらサポートするかもしれない。

こんな感じで使える。

(import (rnrs)
        (rfc jwt)
        (rfc jwk)
        (rfc jwe)
        (rfc jws)
        (rfc uuid)
        (crypto)
        (srfi :19)
        (math ec) ;; for ec-parameters
        (sagittarius combinators))

(define keypair (generate-key-pair Ed25519))
(define alg 'EdDSA)
;; If you want to use other algorighm and keys
;; (define keypair (generate-key-pair ECDSA :ec-parameter NIST-P-256))
;; (define alg 'ES256)
;; (define keypair (generate-key-pair RSA :size 2048))
;; (define alg 'PS512)

(define claims
  (jwt-claims-builder
   (iss "Sagittarius Scheme")
   (aud "All saints")
   (sub "Use Sagittarius")
   (iat (current-time))
   (nbf (add-duration (current-time) (make-time time-duration 0 -1)))
   (exp (add-duration (current-time) (make-time time-duration 0 600)))
   (jti (uuid->string (make-v4-uuid)))))

(define jws-header
  (jws-header-builder
   (alg alg)))

(define payload (string->utf8 (jwt-claims->json-string claims)))
(define jws-object (make-jws-object jws-header payload))

(define signer (private-key->jws-signer (keypair-private keypair)))

(define jwk
  (public-key->jwk (keypair-public keypair)
                   (jwk-config-builder (kid "my key"))))
(define jwks (make-jwk-set (list jwk)))

(let ((jwt-object (jws:sign jws-object signer)))
  ;; Share the JWT to 3rd party
  ;; (jws:serialize jwt-object)
  ;; (jwk-set->json-string jwks)

  ;; Verify the JWT token with the public key
  (let* ((kid-matcher (jwk-matcher:kid "my key"))
         (verifier (public-key->jws-verifier
                    (jwk-set:find-key jwks kid-matcher)))
         (jwt-consumer (jwt-consumer-builder
                        (verifier verifier)
                        (claims-validator
                         (compose jwt:iss-required-validator
                                  jwt:sub-required-validator
                                  jwt:aud-required-validator
                                  jwt:exp-required-validator
                                  jwt:nbf-required-validator
                                  jwt:iat-required-validator
                                  jwt:jti-required-validator
                                  (jwt:iss-value-validator "Sagittarius Scheme"
                                                           "Sagittarius")
                                  (jwt:sub-value-validator "Use Sagittarius")
                                  (jwt:aud-value-validator "All saints")
                                  (jwt:nbf-validator)
                                  (jwt:exp-validator)))))
         (claims (jwt:consume jwt-consumer jwt-object)))
    ;; use the user claim
    (jwt-claims-aud claims))) ;; retrieve 'aud' field

上記はおそらく 90% 以上くらいの JWT ユーザーが使っているであろう JWS を用いたもの。(個人的に JWE を JWT として使ってるのアプリを見たことがない)

っで、以下が JWE を作る方法

(import (rnrs)
        (rfc jwe)
        (rfc jwk))

(define jwk-bob
  (json-string->jwk
   "{\"kty\":\"EC\",
     \"crv\":\"P-256\",
     \"x\":\"weNJy2HscCSM6AEDTDg04biOvhFhyyWvOHQfeF_PxMQ\",
     \"y\":\"e8lnCO-AlStT-NJVX-crhB7QRYhiix03illJOVAOyck\",
     \"d\":\"VEmDZpDXXK8p8N0Cndsxs924q6nS1RXFASRl6BfUqdw\"}"))

(define jwe-header
  (jwe-header-builder
   (alg 'ECDH-ES+A128KW)
   (enc 'A128GCM)
   (apu "QWxpY2U")
   (apv "Qm9i")))

;; Alice wants to encrypt with Bob's public key
(define alice-encryptor (make-ecdh-jwe-encryptor (jwk->public-key jwk-bob)))

;; Bob needs to decrypt Alice's message with his private key
(define bob-decryptor (make-ecdh-jwe-decryptor jwk-bob))

(define secret-key (string->utf8 "down the rabbit hole"))

(let ((jwe-object (jwe:encrypt alice-encryptor jwe-header secret-key)))
  (jwe:serialize jwe-object)
  (let ((secret-key (jwe:decrypt bob-decryptor jwe-object)))
    (utf8->string secret-key)))

基本的な使用感は Java の Nimbus JOSE + JWT を参考にしているが、JWT Consumer は多分違う。ライブラリがいくつにも分かれているのは単なる趣味。よく使われる JWS を整合性チェックに用いるのは (rfc jwk) と (rfc jws) だけで済むとかまぁ、そういう感じにしたかったからという。

Problem of future-map

I've introduced some future related procedures, in the context of concurrency, not the future in general as I'm not a prophet. The procedures will be available after the next release, version 0.9.8, which I'm planning to release very soon.

When I'm testing or writing scripts with future-map, one of the future related procedures, I've noticed there's a thread blocking issue. The future-map procedure creates a future object from a future object. At this moment, its implementation is pretty much naive, it gets the result of the giving future then apply the procedure passed to the future-map, after that make a new future object. There're no difficult things, it works pretty fine as long as the number of future-map calls is not that high. In other words, it's a toy quality...

The fundamental problem of the current implementation is that the new future depends on the result of the old future. This means the new future waits, blocks, the thread until the old future is done. If the underlying executor has only a couple of futures, this won't be a problem, just very useless to do it concurrently as all the future will be executed or return sequentially. Suppose I have an executor which has 3 threads in its thread pool. Then I call the future-map say 4 times. The execution thread and order of the process would look like this:

As we can see, there are lots of red blocking parts. We can't, probably, help to have the blocking process but at least it should be able to schedule wisely, such as execute the future after the dependents are done or so.

At this moment, I don't have any solution how/what to do, so the problem most like stays on version 0.9.8...

HTTP クライアントライブラリ

前回のポストから二ヶ月近く空いてしまった。要るもの追加してたら時間がかかったのと、まぁ家庭の事情というやつなので仕方ない(と自分に言い訳)

ここ数年、PostMan みたいなので REST API を叩くみたいなことをしていたのだが、それ以前は Scheme で書く元気があったのに急にやらなくなったなぁという気がしていた。原因をなんとなく考えて、多分 Sagittarius に付属している HTTP 周りのライブラリが貧弱かつイマイチ使い勝手が悪いというのが原因だと結論づけた。使い勝手に関しては完全に自分の主観なので、現状の素朴な実装の方がいい場合もあるかもしれないが、本業では Apache Http Client とか Spring Framework の WebClient とか使っているので真面目なアプリ/スクリプトを書く際はその辺の使用感が欲しいというのはある。

ということで作った。(net http-client) がライブラリ名である。こんな感じで使う。

(import (rnrs)
	(srfi :13)
	(rfc pem)
	(rsa pkcs :8)
	(rsa pkcs :12)
	(rfc x.509)
	(crypto)
	(net http-client)
	(util concurrent)
	(security keystore)
	(control threading))

(define pooling-config
  (http-connection-pooling-config-builder
   (connection-request-timeout 100)
   (time-to-live 3)))

(define keys&certs
  '(("eckey.pem" "eccert.pem")
    ("key.pem" "certificate.pem")))

(define (->private-key file)
  (let-values (((param content) (parse-pem-file file)))
    (pki->private-key (import-private-key PKCS8 content))))

(define (->certificate file)
  (let-values (((param content) (parse-pem-file file)))
    (make-x509-certificate content)))

(define (make-key-manager)
  (define (idrix-eu p)
    (define node (socket-parameter-socket-node p))
    (cond ((string=? node "prod.idrix.eu") "eckey.pem")
	  (else #f)))
  (define (badssl-com p)
    (define node (socket-parameter-socket-node p))
    (and (string-suffix? ".badssl.com" node)
	 "1"))
  (let ((ks (load-keystore-file 'pkcs12 "badssl.com-client.p12" "badssl.com")))
    (for-each (lambda (key&certs)
		(keystore-set-key! ks (car key&certs)
				   (->private-key (car key&certs))
				   "password"
				   (map ->certificate (cdr key&certs))))
	      keys&certs)
    (key-manager
     (keystore-key-provider-add-key-retriever!
      (make-keystore-key-provider ks "badssl.com" badssl-com)
      "password" idrix-eu))))

(define client (http:client-builder
		(cookie-handler (http:make-default-cookie-handler))
		(key-manager (make-key-manager))
		(connection-manager
		 (build-http-pooling-connection-manager pooling-config))
		(follow-redirects (http:redirect normal))))

(define url0 "https://prod.idrix.eu/secure/")
(define url1 "https://client.badssl.com/")

(define (run url)
  (define request (http:request-builder (uri url) (method 'GET)))
  (http:client-send-async client request))

(define (print-it f)
  (print (future-get (future-map http:response-status f)))
  (let ((headers (future-get (future-map http:response-headers f))))
    (for-each (lambda (k)
		(for-each (lambda (v) (print k ": " v))
			  (http:headers-ref* headers k)))
	      (http:headers-names headers))
    (newline))
  (~> (future-map http:response-body f)
      (lambda (f) (future-map utf8->string f))
      future-get
      print))

(print-it (run url0))
(print-it (run url1))

頑張ってコネクションプールとかクライアント証明書とかの機能を実装していたので予定より一月遅れた(特に証明書周り、いろんなものが ECDSA 対応してなかった…)。

最近の HTTP ライブラリっぽく非同期で色々やるようにしてある。なので、その恩恵を受けるには (util concurrent) を使う。同期でもリクエストを投げれるので同期処理が必要でも大丈夫。

API はまだアルファ版なので、リリース時には変わっているかもしれないが、そこまで大きく変わることはないはず。ドキュメント書かないとな…

ソケットライブラリ

Sagittarius は随分長らくソケット周りのライブラリが二つ(SRFI も入れると三つ)あった。(sagittarius socket) と (rfc tls) である。どっちもそれなりに良くできていると思っているのだが、タイムアウト系の設定、特にコネクションタイムアウトを入れるのが大変だなぁという感じがしていた。(フラグが全部オプショナル引数なので、コネクションタイムアウトを後方互換を保ったまま入れるには引数の最後につける必要がある)。また、今時普通のソケットと TLS ソケットを分けて作るのも面倒が多いなぁと思いつつあったので、色々統合した感じのライブラリを作った。

(net socket) ライブラリはなんとなく今風な感じでソケットの作成を行うライブラリである。使い方はこんな感じ。

(import (rnrs)
        (net socket))

(define option (tls-socket-options
		(sni* '("google.com"))   ;; SNI
		(read-timeout 1000000))) ;; 1s (the unit is micro second)

(define socket (socket-options->client-socket option "google.com" "443"))

(socket-send socket (string->utf8 "HTTP/1.1\r\n\r\n"))
(utf8->string (socket-recv socket 500)) ;; -> some HTML

(socket-shutdown socket SHUT_RDWR)
(socket-close socket)

ソケット関連のオプションは全てオプションビルダーに押し込めて必要なら指定する感じ。最近(ここ数年、下手すれば十年くらい？)のライブラリはコンフィグをビルダーで作ってみたいな感じが多いので、それっぽくした。使い心地はまぁそれなりに悪くない感じなので、このスタイルとは個人的に相性がいいのだろう。

前回書いたレコードライブラリは主にこのライブラリを作るために作られたと言っても過言ではなかったりする。(まぁ、既に複数ライブラリで使用しているが)

なんでこんなライブラリを作ったかというと今風な HTTP クライアントが欲しかったから。それはまた別の記事で書くつもり。

レコードビルダー

 R6RS のレコードは便利である。またポータブルに継承をしたい場合にはこれしか手がない。不便な点としてはフィールドが増えるとデフォルトのコンストラクタでは引数の数が増大するところだろう。何かしらのクライアントとか、コネクションみたいなものであれば、protocol を使って逃げる手もあるが、データ型だと面倒になってくる。引数の数が片手の数で足りなくなると尚更である。

ということで、そんな悩みを緩く解決するライブラリを作ってみた。これである。使い方は非常に簡単でこんな感じで使える。

(import (rnrs)
        (record builder))

(define-record-type base
  (fields a b))
(define-syntax base-builder
  (make-record-builder base ((a 'ok))))
  
(base-a (base-builder)) ;; -> ok

(define-record-type child
  (parent base)
  (fields c d))
(define-syntax child-builder
  (make-record-builder child ((a 'nok) (c 'ok))))
(base-a (child-builder)) ;; -> nok
(child-c (child-builder)) ;; -> ok
(base-a (base-builder (from (child-builder)))) ;; -> nok

デフォルト値なしかつ、作成時にフィールドを指定しなければ #f になる。

ライブラリ自体は一応ポータブルに書いたつもりではあるので、コピーすればそのまま他の R6RS 処理系でも使えるはず(直接 Record Type Descriptor を eq? せずに record-predicate 辺りを使ってやる必要がある気はするが、まぁ、確認してない)

なんでこんなライブラリを作ったかというと、この次に書く記事で必要になったからである。来週辺りに書けたらいいなぁ。