Composable continuation (3)

Dynamic winder is always a headache. It doesn't matter in which situation. For the composable continuation, it's not an exception at all.

For example the below script

(define saved #f)
(define count 0)
(call/prompt
 (lambda ()
   (dynamic-wind
       (lambda () (display "pre1\n"))
       (lambda ()
         (call/prompt
          (lambda ()
            (dynamic-wind
                (lambda () (display "pre2\n"))
                (lambda () #t)
                (lambda ()
                  (call/comp (lambda (k) (set! saved k) ))
                  (display "post2\n"))))))
       (lambda () (display "post1\n")))
   (unless (= count 1)
     (set! count (+ count 1))
     (saved 'again))))

This results like this

pre1
pre2
post2
post1
post2

And if I swap call/comp with call/cc then it'd print this

pre1
pre2
post2
post1
pre1
post2
post1

The second post2 is wrapped with pre1 and post1 which are the winders of the outer dynamic-wind.

If I see how it's written, it makes sense. The captured continuation is in the second prompt, so it shouldn't invoke the outer prompt winders. It makes sense, that doesn't mean it's easy to achieve.

Prompt as winder boundary

The winders are basically chains managed on VM. At the deepest location of the above example, the winder looks like this

[pre2 . post2] - [pre1 . post1] - [... system winders]
              ^^^
             prompt

The prompt is in between the first and the second winders. So, when the composable continuation is captured, then it only considers the first winder.

Though, if I replace only the first winder but without the rest of the [... system winders], then it'd cause a problem. So, it has to have some sort of filtering.

Filtering winders

One of the easiest filtering is that if the captured continuation is partial a.k.a composable, then no before thunk is needed. I'm not entirely sure if this assumption is actually correct, but it seems working. So, keep it like that...

Then the next one is that comparing the current winders and capture winders.

Captured:
[pre2 . post2] - [pre1 . post1] - [... system winders]
              ^^^
             prompt

Current:
[... system winders]

After exiting from the both dynamic-winds, then the current winders contains only the [... system winders] for the above example. So, it should take up until the prompt, then append the current winder.

Again, I'm not sure if the current implementation is correct, but it's working. So, I'm fine for now until I find a bug...

Composable continuation (2)

I've written how it works (as my memo), so now it's time to write what I've done (as my memo, again).

Capture composable continuation

Capturing a composable continuation is basically the same as capturing a full continuation. This means, we copy the entire stack frame into the heap area. In theory, we can copy up until the target prompt, so that we don't have to allocate unnecessary heap. Though, it wasn't that easy to achieve partial copy due to the process of popping a heap allocated continuation frame.

Currently, when a heap allocated continuation frame is popped, then it resets the stack pointer and frame pointer to the bottom of the stack, however if the stack contains both heap and stack allocated continuation frame, this can happen if we do the partial copy, then then popping a heap allocated continuation frame results incorrect state of the stack.

At this moment, I don't have a good way of avoiding this situation, I decided to copy the entire stack to the heap. This means capturing a composable continuation is as expensive as capturing a full continuation. I handed over this problem to the future me, which I already know I would suffer...

Splicing continuation frame

Composable continuation splices the continuation frame on top of the current continuation frame as the diagram below (copied from the previous article)

~ before invocation ~
  [ call frame a ]
  [ call frame b ]
      :
  [ call frame z ]

captured continuation: [ call frame 0 ] -> [ call frame 1 ] -> [ prompt 0 ]

~ after invocation ~
  [ call frame 0 ]
  [ call frame 1 ]
  [   prompt 0   ]
  [ call frame a ]
  [ call frame b ]
      :
  [ call frame z ]

When continuation frames are spliced, then the previous pointer of the bottom continuation frame needs to be updated to the top of the current continuation frame. It's okay to do it, if the continuation is oneshot, however it's not so we need to freshly create a copy of the captured continuation frames.

This indicates that invocation of a composable continuation is more expensive than invocation of a ful continuation. So, composable continuation is more expensive than full continuation. I feel something is not quite right, but this will be resolved by the future me, I'm believing myself...

Closest prompt

Resolving closes prompt was not an intuitive to me. As the previous article says, the spliced prompt needs to be inserted after the one inserted by the call-with-continuation-prompt. This means, searching from top of the stack does not meet the requirement. So, introduced an extra field prompts to the VM structure.

The prompts field is a linked list whoes the head is the closest prompt. Searching the closest prompt tag means follow the list until the tag is found. When the call-with-continuation-prompt is called, then a prompt is created and prepend to the prompts. When a composable continuation is spliced, then first take the closest prompt, then insert the captured prompts after the prompt found. If multiple prompts are captured, then the top most prompt becomes the 2nd closest prompt.

~ call/prompt ~ 
[   prompt 1   ] <- added to the call frame
[ cont frame 1 ]
--- call here --
[   prompt 0   ]
[ cont frame 0 ]

prompts: [ prompt 1 ] -> [ prompt 0 ]


~ splice continuation  ~ 
[ cont frame 3 ]
[   prompt 2   ] <- added to the call frames
[ cont frame 2 ]
[   prompt 1   ] <- added to the call frames
=== spliced ====
[ cont frame 1 ]
[   prompt 0   ]
[ cont frame 0 ]

prompts: [ prompt 0 ] -> [ prompt 2 ] -> [ prompt 1 ]
                         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                        append after the closest prompt
The top most captured prompt is the 2nd closest prompt

Prompts are removed from the prompts when the corresponding prompt frame is popped from the stack. When abort-current-continuation is called, the same bookkeeping happens.

As my memo, I also need to mention dynamic-wind which was a nightmere to solve. I'm too tired to write, so to be continued.

Composable continuation (1)

After 2 weeks of fighting, I've finished implementing composable continuation. This is my memo of how I understand composable continuation and what I've done to implement it.

How it works

If I google it, I can find a lot of (maybe not so many) articles and/or papers regarding composable continuation. All those papers are, of course, very abstracted, means it wasn't intuitive for me. (I'm not good at those symbols, unfortunately.) So, let me illustrate a bit more concretely.

CAVEAT: This is how I understand and how it works on Sagittarius.

First, Sagittarius is a VM machine using stack as its call frames. The same model as previous article. When call/cc is called, then the call frames are move to the heap with the same structure. It'd be like this:

~ before call/cc ~
 [ call frame 0] <-- VM's cont register
 [ call frame 1]
 [ call frame 2]
  :
 [ call frame n]
 
~ after call/cc ~
 [ call frame 0] -> [ call frame 1] -> [ call frame 2] -..> [ call frame n]

This only means, stack call frames became heap call frames. When the captured continuation is invoked, then it'd simply replaces the VM's current cont frame to captured one.

[ call frame 0] -> [ call frame 1] -> [ call frame 2] -..> [ call frame n]
~~~~~~~~~~~~~~~
VM's cont register

When the heap call frame is returned, then the call frame will be poped. Then the saved arguments will be pushed into the bottom of the stack, like this:

[ call frame 0] -> [ call frame 1] -> [ call frame 2] -..> [ call frame n]
~~~~~~~~~~~~~~~
This is poped

[ arg n ] <- stack pointer
 :
[ arg 1 ]
[ arg 0 ] <- frame pointer = bottom of stack
~~~~~~~~~~
These arguments are form [ call frame 1 ]

In this way, the local argument reference doesn't require special handling, but just refering the same relative location. (i.e. LREF 0 always refers *fp, LREF 1 is *(fp + 1).)

Now, we have composable continuation. A composable continuation captures the call frames up until the specified prompt. So, conceptionally, the captured call frames are like this:

~ before call/comp ~
  [ call frame 0 ]
  [ call frame 1 ]
  [   prompt 0   ] <- capture until here
  [ call frame 2 ]
   :
  [ call frame n ]
 
~ captured continuation ~
[ call frame 0 ] -> [ call frame 1 ] -> [ prompt 0 ]

And when the captured continuation is invoked, then call frames will be like this.

~ before invocation ~
  [ call frame a ]
  [ call frame b ]
      :
  [ call frame z ]

captured continuation: [ call frame 0] -> [ call frame 1] -> [ prompt 0 ]

~ after invocation ~
  [ call frame 0 ]
  [ call frame 1 ]
  [   prompt 0   ]
  [ call frame a ]
  [ call frame b ]
      :
  [ call frame z ]

So, the captured continuation will be stack up on top of the current call frames. This means, it returns to the same location from the invocation. For example, this shows 1,3,2,3, instead of 1,3,

(call-with-continuation-prompt
 (lambda ()
   (call-with-composable-continuation
    (lambda (k)
      (display "1,")
      (k 1)
      (display "2")))
   (display "3,")))

If you replace call-with-composable-continuation with call/cc, then it shows 1,3,.

Closest prompt

When it comes with abort-current-continuation, composable continuations are not that much intuitive. See the script below:

;; invoking captured k means calling the thunk passed as an argument
(let ((k (call-with-continuation-prompt ;; (1)
          (lambda ()
            ((call-with-composable-continuation
              (lambda (k) (lambda () k))))))))
  (call-with-continuation-prompt ;; (2)
   (lambda ()
     (+ 99 (k (lambda () (abort-current-continuation 
                          (default-continuation-prompt-tag)
                          8)))))
   (default-continuation-prompt-tag)
   values))

Initially, I thought this would be like this cont frame transition.

prompt/handler notation, #f means no handler

~ capture ~ 
[ cont frame 0 ]
[  prompt/#f   ] <- default prompt tag + #f

~ invocation ~
[  cont frame 0 ]
[   prompt/#f   ]
[  cont frame 1 ] <- (+ 99 ...)
[ prompt/values ] <- default prompt tag + values

So, my mind said this should throw an error. But it ends up returning 8. Why?

The prompet inserted by the continuation invocation should come after the one inserted by the call-with-continuation-prompt (2). If I only see the call frame stack, the prompt/#f is the closest, but because it's composable continuation, the stacked up prompt must be after.

;; prompt order
~ my intuition ~
[ prompt/#f ] -> [ prompt/values ]

~ how it should be ~
[ prompt/values ] -> [ prompt/#f ]

This means, I need to manage the prompt insertion order separately as well.

It's getting longer than I though, so to be continnued.

Continuation prompt

Since long time ago, I was thinking if Sagittarius can have some nice async/await equivalent things. I'm using Java/Kotlin at my work, occasionally TypeScript, they, execpt Java, have nice async/await thing. So, I asked my new shiny friends, Copilot or ChatGPT, if it's possible to implement it with continuation. And the answer was yes, also it'd be cleaner if I use delimited continuation.

Now, I remember that SRFI-226 defines delimited continuation. And I vaguely remember one of the discussions saying it can be implemented with continuation prommpt and composable continuation. I've been avoiding to touching the continuation, but it seems it's time for me to have some courage.

With my shallow understanding, composable continuation requires continuation prompt, so I decided to implement continuation prompt first. A continuation prompt can be implemented as a boundary frame. Currently, Sagittarius's call frame is implementented like this:

[  cont 0  ] <-- top
[  cont 1  ]
[  cont 2  ]
[ boundary ] <-- when C calling Scheme procedure
[  cont 3  ]
  :
[  cont n  ] <-- bottom

Now, I should be able to implement prompt as an extra frame like this:

[  cont 0  ] <-- top
[  cont 1  ]
[  cont 2  ]
[  prompt  ] <-- prompt frame
[  cont 3  ]
  :
[  cont n  ] <-- bottom

There's a very good reason why I should do this. Sagittarius' compiler optimises let with very advanced (I want to believe) way. It takes frame size into account. This means, I can't add extra field into the call frame structure. Because of this reason, I can't annotate the call frame with prompt tag by adding an extra struct member. The boundary frame is already using one of the members to hold a mark. In other words, I can use one member to hold prompt information.

Now, inserting prompt seems easy job, then next step, abort-current-continuation. It seems this is required to implement delimited continuation. Reading the document doen't really click what it does. So checked the behaviour with Racket. Started with the very simple example below.

(call-with-continuation-prompt
  (lambda ()
    (abort-current-continuation (default-continuation-prompt-tag) 1)
    (display 'not-reached) (newline))
  (default-continuation-prompt-tag)
  values)
;; -> 1

My easily get hallucinated brain understood that abort-current-continuation aborts the current continuation up to the specified prompt tag and invokes the abort-handler... this is what the document says... If I draw a diagram then it looks like this

[  cont 0  ] <-- abort/cc
[  cont 1  ]
[  cont 2  ]
[  prompt  ] <-- target   == after  ==>  ;; the rest of the call frame
[  cont 3  ]					         [  cont 3  ]
  :								           :
[  cont n  ]           			         [  cont n  ]

Okay, it looks easy enough to do it.

(Until I fell into a lots of pitfalls...)

Memo: Socket selector on Windows

Sagittarius has (net socket) library which defines socket selector. A socket selector takes arbitary number of sockets and waits until one or more of the given sockets are readable. The concept was there quit a long time, however it wasn't really working on Windows unfortunately. Now, I put some effort to make it work as I expected.

The requirement of the socket selector is below:

• Interruptible
• No limits of the number of sockets
• Timeout on socket level and procedure call itself

Windows has nice functions to archive it. Only I couldn't find anything similar to my solution, so it might worth to share.

The below piece of code shows essence of the actual implementation. It doesn't handle timeout for the sake of simplicity. What it does is the following;

• Associstes the given sockets to the given event
• Waits the event
• Once an event is received, then associates the sockets to other event, this time an event per socket
• Check if the socket is readable (passing 0 timeout value)
• If it's readable, add to the list

It doesn't do much, the only important part is checking by batch due to the limitation of WSA_MAXIMUM_WAIT_EVENTS.

#include <winsock2.h>
#include <windows.h>

typedef struct socket_list_rec
{
  SOCKET socket;
  struct socket_list_rec *next;        /* NULL = term */
} socket_list_t;

socket_list_t * selector_wait(int n, SOCKET *sockets, WSAEVENT event)
{
  socket_list_t *list = NULL;
  for (int i = 0; i < n; i++) {
    WSAEventSelect(sockets[i], event, FD_READ | FD_OOB);
  }
  int r = WSAWaitForMultipleEvents(1, event, FALSE, INFINITE, FALSE);
  if (r == WSA_WAIT_FAILED) {
    return NULL;
  }
  if (r == WSA_WAIT_EVENT_0) {
    WSAResetEvent(event);
    for (int i = 0; i < n; i++) {
      WSAEventSelect(sockets[i], NULL, 0);
    }
    int rem = (n % WSA_MAXIMUM_WAIT_EVENTS) > 0 ? 1 : 0;
    int batch = (n / WSA_MAXIMUM_WAIT_EVENTS) + rem;
    int size = min(n, WSA_MAXIMUM_WAIT_EVENTS);
    WSAEVENT events[WSA_MAXIMUM_WAIT_EVENTS];
    for (int i = 0; i < size; i++) {
      events[i] = WSACreateEvent();
    }
    for (int i = 0; i < batch; i++) {
      int count = 0;
      int offset = i * WSA_MAXIMUM_WAIT_EVENTS;
      for (int j = 0; j < size; j++) {
        int m = offset + j;
        if (m < n) {
          WSAEventSelect(sockets[m], events[j], FD_READ | FD_OOB);
          count++;
        } else {
          break;
        }
      }
      int r = WSAWaitForMultipleEvents(count, events, FALSE, 0, FALSE);
      if (r != WSA_WAIT_FAILED && r != WSA_WAIT_TIMEOUT) {
        WSANETWORKEVENTS ne;
        for (int j = 0; j < count; j++) {
          if (WSAEnumNetworkEvents(sockets[offset + j], events[j], &ne) == 0) {
            if ((ne.lNetworkEvents & (FD_READ | FD_OOB)) != 0) {
              socket_list_t *n = (socket_list_t *)malloc(sizeof(socket_list_t));
              n->socket = sockets[offset + j];
              n->next = list;
              list = n;
            }
          }
        }
      }
    }
    for (int i = 0; i < n; i++) WSAEventSelect(sockets[i], NULL, 0);
    for (int i = 0; i < size; i++) WSACloseEvent(events[i]);
  }
  return list;
}

The above code creates events per call, this might be too expensive and wasteful. The actual code pre-allocates the event array during the initialisation.

cond-expand enchancement

When I'm writing a library or tools, I usually write them working on the current release version of Sagittarius, unless R6RS portable one. However, I often want to use the development branch version of the features as well, especially with the new procedures.

Since R7RS, cond-expand has the library clause, which checks if the library specified in the clause exists or not. If you are handling multiple implementations, this feature is useful, for example, if one of the implementations doesn't support SRFI-1, then you can write a compatible layer easily. However, if there's a new procedure and/or macro added in a new version of Sagittarius, this library clause doesn't work as I want. To resolve this dilemma, I've added the new version clause to cond-expand.

The version clause can be used to cooperate among Sagittarius versions. The below example shows how to split the process between 0.9.12 and earlier.

(import (rnrs)
        (sagittarius) ;; for cond-expand
        (sagittarius crypto keys))

(cond-expand
 ((and cond-expand.version (version (>= "0.9.12")))
  ;; secp160r1 is supported since 0.9.12
  (generate-key-pair *key:ecdsa*
                     :ec-parameter *ec-parameter:secp160r1*))
 (else
  ;; default ECDSA key pair for earlier version
  (generate-key-pair *key:ecdsa*)))

The cond-expand.version is required to make it work on Sagittarius version earlier than 0.9.12.

I personally think this feature should be incorporated into R7RS but I'm too lazy to write a SRFI.

OAS stub

ここ数ヶ月Kotlinを書いていたのだが、なんとなく形になったしちょっと紹介記事を書こうかなぁと。

Swagger/OpenAPI Specificationは多分誰でも知っているだろう。Microserviceな流れになっていた前職で10を超えるバックエンドサービスに接続する必要があったのだが、毎回stubを書くのは馬鹿らしいと思い提供されているAPI定義(たいていSwaggerかOAS)を読み込んだらリクエストの検査からレスポンスの生成をやってくれないかなぁと思って作ったものの焼き増しがOAS stubになる。実際にこのアプリはかなり便利で、恐ろしく時間の短縮が可能だった^*1ので多分OSSにしても需要があるんじゃないかなぁと。

基本的な使用方法は今のところ二つ、Spring Bootアプリとしてスタンドアローンにするか、テスト用フレームワークとして使うか。

スタンドアローンアプリ

スタンドアローンなアプリを作るにはまず以下の依存関係をpom.xmlに入れる。ちなみにSpring Bootは3.1.xが必須。2.x.x系では動かないので注意。

<dependency>
    <groupId>io.github.ktakashi.oas.stub.spring</groupId>
    <artifactId>oas-stub-spring-boot-starter-web</artifactId>
    <version>1.2.0</version>
</dependency>

一応BOMもあるのでそっちがいいならBOMをio.github.ktakashi.oas.stub:oas-stub-bom:1.2.0をdependencyManagementに入れると良い。この依存を入れるとAutoConfigurationが勝手に動くので、後は普通にSpring Bootアプリケーションを書くだけ。こんな感じ。

package com.example;

import org.springframework.boot.SpringApplication;
import org.springframework.boot.autoconfigure.SpringBootApplication;

@SpringBootApplication
public class ExampleApplication {
    public static void main(String[] args) {
        SpringApplication.run(ExampleApplication.class, args);
    }
}

これでドキュメントに書いてあるエンドポイントが有効になる。アノテーションを明示的につけるようにした方がいいかなぁとも思ったけど、あまりメリットがない気がしたのでこの形。

一応、ブートストラップ時にクラスパスから読み取って設定するということも可能。これはそのうちドキュメントに書く。

テストフレームワーク

BDDを使って結合テスト的なテストをビルド時にやるのはとても効率が良いので是非やるべき^*2、ということで結合テスト用のフレームワーク的なものもある。まずは以下の依存をpom.xmlに入れる。

<dependency>
    <groupId>io.github.ktakashi.oas.stub.spring</groupId>
    <artifactId>oas-stub-spring-boot-starter-test</artifactId>
    <version>1.2.0</version>
    <scope>test</test>
</dependency>

っで、Spring Bootテストに以下のアノテーションとサービスを追加する。

package com.example;

import io.github.ktakashi.oas.test.OasStubTestService;
import io.github.ktakashi.oas.test.server.AutoConfigureOasStubServer;
import org.springframework.boot.test.context.SpringBootTest;

@SpringBootTest
@AutoConfigureOasStubServer
public class ExampleApplicationTest {
    @Autowired
    private OasStubTestService oasStubTestService; 
}

OasStubTestServiceはテスト用の便利サービスでAPIを増やしたり呼び出し回数を検査したりできる。機能的にはまだ足りないかなぁと思っているが、適宜追加する方向にしている。

これでどういうことができるのかというのは多分例を見た方が早いと思うので、そっちを参照してもらう感じで。Cucumber使ったBBDだからそんなに癖とかないだろう、きっと。

WireMock？

WireMockはよくお世話になったんだけど、モック書くのが結構面倒だったり細かくやるとWireMock自体を知らないといけなかったりで、ちょっと面倒があったりする。例えば、レスポンスは署名が付いてくるとかだと静的なファイルだけでは無理なんだけど、これを解決するのに結構面倒だった。っで、この辺をプラグイン^*3で解決してしまおうというのもこのアプリの特徴で、Groovyが書ければかなり柔軟に色々できたりする。

まとめ

OASファイルをアップロードすればそのままスタブができるというアプリの紹介。

今のところ自分が入りそうな機能しか入っていないので、使ってもらってフィードバックがあるととても嬉しい。

---

[1]: それまではスタブ一個追加するのに一週間とかかかってたのが、5分で済むようになった。

[2]: BDDいいよ、ビジネスアプリならユニットテストよりまずこっちを入れるべき。

[3]: まぁ、このプラグイン機構はセキュリティとか一切考慮していないので、このアプリを本番環境に置くのは全くお勧めしてない。

転職して一ヶ月で異動、または履歴書に前職の経歴を書く功罪

転職して一ヶ月で異動になった話。ちょっと個人的にツボったので後で振り返るように書いておく。

2023年9月から銀行Iで働くことになった。前職である銀行Rではオランダで最も使われているペイメントスキームの一つであるiDealのメンテナンス及びメジャーバージョンアップに多大に貢献した。当然ではあるが、履歴書にそのことを載せていた。ちなみに、銀行Iはオランダ最大手の銀行かつ銀行Rの競合他社であるが、iDealのメジャーバージョンアップ(以降iDeal 2.0)において銀行Rの後塵を配していた。自慢になるが、銀行RがiDeal 2.0において他の追随を許さない勢いで成功を収めたのは、僕の功績が大きい*1。ちなみに銀行Iに転職する前の面接では一応そのことを仄めかしていたが、大きくは取り上げなかった。個人的にiDeal 2.0に関わりたくなかったし*2。

転職直後の月曜日に別のチームのマネージャからなぜか「coffee catch up」というタイトルのミーティングが飛んでくる。そして、その直後のマネージャから同様の招待がその前日にスケージュールされる。ぶっちゃけ、なんだこれ状態に陥る。よくわからんなぁと思いつつ、マネージャからの話を聞くと、

• iDeal 2.0を仕切っているマネージャからであること
• 要は引き抜きを行いたいということ

という話であった。いや、まだ開発環境のセットアップすら終わってませんが。銀行Rを辞める直前くらいに元同僚と、銀行IはiDeal 2.0で悲惨な結果を残したからうっかりすると引き抜かれるんじゃね？みたいな笑い話をしていたのだが、これが冗談でなくった瞬間であった。

っで、当日のミーティング。基本的には顔合わせみたいな意味合いだと言われて臨んだのだが、そもそも別のチームのマネージャと顔合わせを自分のマネージャより前にするとか今までやったことないよなぁ、と思いつつ話を聞く。要点は、まぁ上記にプラスしてEPIのチームが結成されるがどう？みたいな話。iDeal 2.0には難色を示しつつ、EPIは興味あると答える。実際興味あるし。この時すでに、半々くらいでiDeal 2.0を手伝ってほしいみたいなことを言われる。いや、まだ開発環境すら…

一週間後、部長みたいな地位の人と顔合わせさせられる。この時点で異動ケテーイ。ぶっちゃけ笑うしかないスピード感。この時に、どうやら7、8月に既に取り合いが発生していたという話を聞く。どうも、僕の履歴書をiDeal 2.0やらEPIやらのマネージャが見たらしい。そして、銀行Rでの立役者ならこっちでも同じことやってほしいみたいな話になったとかなんとか。

その後、マネージャとフィードバック面接をした際に、前職の経歴が履歴書に載せてなかったらという無理ゲーな不満を言われるなどされる。いや、それなかったら多分歯牙にもかかってないと思うの。ちなみに、チームメンバーの一人はこの決定に大激怒で、これが続くなら辞めるとまで言っている。色々秘密裏に行われた感じはあるから、わからんでもない。

*1: なんだけど、当時のマネージャは全くそれを認めずあまつさえ、僕いなくてもいいんじゃね？という扱いをしてくれた。これが決め手となり転職を決意。ぶっちゃけ、どんなけ功績立てても評価(主に給料アップとか)されないならいる意味ないしね。

*2: 24/7かつ稼働率99.5%が義務付けられていたので、結構夜中の電話とかくらうのですよ。

英語の勉強のお供に？

同僚のスクリーンセーバが英単語とその意味を表示するやつなのをみて、こういうのあると便利かなぁと思い始めたのでなんとなく似た感じのものを作ってみた。まぁそこまで似ているというほどでもないのだが、起動するとコンソールに単語の意味と例文をなんちゃってカード形式で表示するというもの。ちなみに単語はUrban Dictionaryの非公式APIを使って取得していたりするので、このスクリプトがある日突然使えなくなっても泣かないようにしないといけない。

Gistに載せたのはコピペしたものなので、色がついてたり太字になってたり下線がついてたりするのが見えないのが残念。実際にどのように見えるのかは実行すればわかるということで。

別段特筆すべきこともないのだが、これを書くために使ったライブラリ達(当然だが全部Sagittariusに付属している)

• (net http-client): モダン(なつもり)な非同期HTTPライブラリ
• (text json jmespath): JMESPathライブラリ
• (rfc uri-template): RFC 6570準拠なURIテンプレートライブラリ
• (sagittarius combinators): コンビネーターライブラリ
• (util concurrent): 並列処理ライブラリ

処理のために書いた小道具とかもライブラリにするといいのかもと思いつつ(非同期http-getとか、コンソールの色付けとか)あまりいいアイデアもないのでとりあえず放置。

Remote debugger(ish)

In the previous post, I've mentioned that I needed to collect all threads to see which one is hanging. After implementing it, I've also noticed that all threads were hanging. So I've decided to implement a better remote debugger(ish).

CAVEAT

The functions and interface are experimental, so it might get changed in the future.

Suppose we have this script:

(import (rnrs)
        (srfi :1)
        (srfi :18)
        (sagittarius)
        (sagittarius debug))

;; Creating a remote debugger. You can specify a specific port number as well
(define remote-debugger (make-remote-debugger "0"))
;; Showing the port.
(print "Debugger port: " (remote-debugger-port remote-debugger))

(define ((sleep-in-deep name time))
  (define (before-sleep)
    (format #t "~a wants to sleep~%" name))
  (define (after-sleep time)
    (format #t "~a slept for ~a but wants to sleep more~%" name time))
  (define (sleep time) (thread-sleep! time))
  (before-sleep)
  (sleep time)
  (after-sleep time))

(define threads
  (map thread-start!
       (map (lambda (i)
              (make-thread (sleep-in-deep i (* i 1800))
                           (string-append "sleep-" (number->string i))))
            (iota 3))))
(for-each thread-join! threads)

It doesn't do anything but just sleeps. Now, if you run the script, it shows this kind of message on the cosole.

Debugger port: 50368
0 wants to sleep
0 slept for 0 but wants to sleep more
2 wants to sleep
1 wants to sleep

At this moment, remote debugger is just a type of remote REPL, so open Emacs and run sagittarius (can be older one). Then do like this

sash> (import (sagittarius remote-repl))
sash> (connect-remote-repl "localhost" "50368")

connect: localhost:50368 (enter ^D to exit) 

It's connected, then I want to check hanging threads.

sash> (for-each print (sleeping-threads))
#<thread root runnable 0x10ac6dc80>
#<thread remote-debugger-thread-1295 runnable 0x10bdb8640>
#<thread sleep-1 runnable 0x10bdb8000>
#<thread sleep-2 runnable 0x10c6e0c80>
#<unspecified>

I have 4 threads hanging. root is the main thread, so I can ignore. remote-debugger-thread-1295, the number varies, is a remote debugger's server thread, I can ignore this as well. So, the rest of the threads are the targets. I want to filter it for the later usage. I can simply do this:

sash> (define t* (filter (lambda (t) (and (string? (thread-name t)) (string-prefix? "sleep-" (thread-name t)))) (sleeping-threads)))

Now, let's see the backtrace of the threads.

(for-each print (map thread->pretty-backtrace-string t*))
Thread sleep-1
stack trace:
  [1] thread-sleep!
  [2] sleep-in-deep
    src: (thread-sleep! time)
    "sleep.scm":15

Thread sleep-2
stack trace:
  [1] thread-sleep!
  [2] sleep-in-deep
    src: (thread-sleep! time)
    "sleep.scm":15

#<unspecified>

It seems the sleep-in-deep is calling the thread-sleep! procedure. Okay, what's the value of the time?

To see those variables, I need to collect the backtrace of the threads. Like this:

sash> (define bt* (map thread-backtrace t*))

A backtrace contains multiple frames, in this example, each backtrace of the threads contains 2 frames. I want to see the first one which is the thread-sleep! frame. So, doing this:

sash> (for-each print (map (lambda (bt) (thread-backtrace-arguments bt 1)) bt*))
((local (0 . 1800)))
((local (0 . 3600)))
#<unspecified>

1800 and 3600 seconds! That's why the threads are hanging (obviously...).

In this example, I only showed how to see the arguments (local variables and free variables), but the remote debugger has a bit more functionality, such as inspecting objects and accessing its slots. Using this debugger, I found the root cause of the bug made me suffer for a couple of weeks.

Thread monitoring

When I write multi thread programs, it's always a trouble to debug whenever a thread hangs. That's because:

1. You don't see what's going on. I don't put logging when I write a library and I don't usually use raw thread.
2. The problem is gone away if I put a debug print
3. And/or it happens only once in a hundred

So, I started thinking that if I want to resolve this, it has to be a fundamental solution instead of AdHoc one.

Now, what could be a fundamental solution for this? Before forming ideas, which may not even be applicable, I need to think what's the requirements to debug hanged threads. So, things what I want to see are:

1. State of the thread If it's running, sleeping, waiting whatsoever
2. Where the location is or which procedure is being called.
3. Who the caller of the procedure is

Looking at these, it's basically thread introspection. This means, I need to know the thread, even though once a thread is created, then we just release it to dark space hoping he can manage his wellness (I feel like a parent looking at my own child leaving the house 😢). If you need to be a worrying parent, you need to let your children have a GPS to track where they are. Okay then, let Sagittarius be a good parent for his own children (threads).

The idea came up in my mind is to change the VM architecture. Currently, a VM, as we all know it's an abbreviation of Virtual Machine, is a thread. So, whenever a thread is created, then we have a new VM. Now, there must be a manager to holds / monitor the threads. I don't dare to change names, so let's the manager kernel. Then the architecture should look like this:

+------------------------------------+
|              kernel                |
+---+--------------------------------+
    | threads
  +-+-+------+---+
  |   | main | * |
  +---+------+-|-+
               |
             +-+-+-------+---+
             | * | child | * |
             +---+-------+-|-+
                           |
                         +-+-+-------+---+
                         | * | child | * |
                         +---+-------+---+

Threads should be stored in a double-linked list and each threads should have the reference of the kernel to make my life easier. With this architecture, it seems I can add extra thread to monitor other siblings from Scheme world.

I feel I'm overlooking something but probably a good starting point.

New crypto library

Last year, I've written a portable cryptographic library Springkussen. And then I've also noticed that (crypto) and (math) libraries are not really well designed. For example, a cipher object must support both encryption and signing operations which can only be applied to RSA operations. So, I decided to rewrite Sagittarius' cryptograpihc library and now I can show what it looks like.

Library structure

The old (crypto) and (math) libraries are basically aggregated libraries. This means it exports a lot of bindings even if you don't need them. The new cryptographic libraries are per components, for example, if you only need cipher operations, then you only need to import (sagittarius crypto ciphers) library. So, users need to combine the libraries to achieve the target operation.

(math) library is also integrated to (sagittarius crypto *). For example, message digest operations are located in (sagittarius crypto digests).

Most of the cryptographic operations are now provided by one of the (sagittarius crypto *) libraries. The existing libraries are replaced by them and some of them are deprecated. For example, (rfc x.509) library now re-exports the (sagittarius crypto *) procedures.

Example of block cipher operations

This is an example of how to use block cipher operations provided by (sagittarius crypto ciphers) library. Suppose, you want to encrypt a message with a randomly generated key and export the key as plain text. (Don't do this kind of operation in production, exporting a plain key is not a good practice...)

The library doesn't provide key operations, such as generating a symmetric key. So, you need to import (sagittarius crypto keys) library as well. To combine them, you can do it like this:

(import (rnrs)
        (sagittarius crypto ciphers)
        (sagittarius crypto keys))

;; Generate a random key suitable for AES-256
(define key (generate-symmetric-key *scheme:aes-256*))

;; Using ECB mode, with PKCS7 padding
;; Don't do it in production code :)
(define aes-cipher (make-block-cipher *scheme:aes-256* *mode:ecb* pkcs7-padding))

(define msg (string->utf8 "Hello new crypto library"))

;; No parameter needed
(block-cipher-init! aes-cipher (cipher-direction encrypt) key)
(block-cipher-encrypt-last-block aes-cipher msg)
;; -> bytevector length of 32 (2 blocks), the result is always different

;; Clean up
(block-cipher-done! aes-cipher)

;; A symmetric key is exportable, so you can export
(exportable->bytevector key)
;; -> bytevector length of 32

To see how the current development branch looks, you can also use the Docker image of edge tag. If you put the above script into crypto.scm file, then you can execute it with the below command:

docker run -it --mount src=$(pwd),target=/scripts,type=bind ktakashi/sagittarius:edge scripts/crypto.scm

Though the cache is not available, so loading a script may take a lot of time...

AMQP

Sagittarius supports AMQP, Advanced Message Queue Protocol, since probably 0.6.x, I don't recall which version, to be honest. The reason I wanted to support this was because I was using QM, I think IBM MQ, at that moment at my work and wanted to send a message from a command-line, instead of using a Web browser. Unfortunately, the version of MQ was too old and didn't support AMQP yet. So, I couldn't use it for the purpose that I wanted. Nevertheless, it's there and it's supported.

Now, I want to write a demo application to show what Sagittarius can do out of the box. One of the main reasons I've made Sagittarius is that I can use it for daily commercial work. So, I thought it's nice to have a demo of integration with external systems, not only for HTTP but also some other protocols which Sagittarius supports out of the box. Then, I realised that the current implementation of AMQP client is not really efficient nor doesn't work as I expected.

To explain what doesn't work, I first need to explain how the AMQP connection and session work. An AMCP connection is a physical connection, which holds an actual socket. Now, under a connection, there are sessions. A session is a virtual separation of input and output channels. This means if a connection has multiple sessions, input or output messages need to be dispatched properly to the associated session. It's easier to see it in a diagram:

Session under connection

  Client App                                        Broker
+-------------+                                +-------------+
|             |################################|             |
|   +---+     |--------------------------------|    +---+    |
|   | C |     |            Session             |    | Q |    |
|   +---+     |--------------------------------|    +---+    |
|             |################################|             |
+-------------+                                +-------------+

Multiple sessions

    Session<------+                           +------>Session
(ICH=1, OCH=1)    |                           |    (ICH=1, OCH=1)
                 \|/                         \|/
    Session<--> Connection <---------> Connection <-->Session
(ICH=2, OCH=3)   /|\                         /|\   (ICH=3, OCH=2)
                  |                           |
    Session<------+                           +------>Session
(ICH=3, OCH=2)                                     (ICH=2, OCH=3)

        Key: ICH -> Input Channel, OCH -> Output Channel 
      

For the original diagram and the specification, you can refer 2.1.2 Communication Endpoints

The point is that the physical connection is only one, however virtual connection/session can be multiple simultaneously. However, the current implementation of AMQP on Sagittarius can't handle this due to the fact that the socket is shared by the sessions (or underlying receivers).

So, if I want to do it properly, the design must be changed sort of like this:

      +------------------+
      |    Connection    |  +--> Session1
<IN>  |  +------------+  |  |
======+==+=> socket  -+--+--+--> Session2
      |  +------------+  |  |
      |     |     /|\    |  +--> Session3
      +-----+------+-----+
            |      |
           \|/     |
       +---------------+
       |  Frame reader |
       +---------------+

And possibly, the reading frame process is running on a background thread, once the connection is established.

Let's see what I can do...

Markdown support

On Sagittarius, I was, well still am, using scribble, which the parser is ported from Chibi Scheme, to write the document. Recently, though it's been already a couple of years, I've been thinking that using one of the documentation formats might be better so that users can read better on the repository if they want to use the latest version.

So, I've updated (text markdown) library to support better Markdown. The library is based on commonmark-java, and more or less compliant with Commonmark specifications. The library keeps the old behaviour, which generates a sort of old intermediate format and HTML, though that should be considered deprecated.

The basic usage of the library can be like this:

(import (rnrs)
        (text markdown)
        (text sxml serializer))

(define (main args)
  (let ((file (cadr args)))
    (call-with-input-file file
      (lambda (in)
        (let ((node (parse-markdown markdown-parser in)))
          (srl:sxml->html-noindent
           (markdown-converter:convert default-markdown-converter 'html node)
           (current-output-port)))))))

So parse-markdown procedure parses the input textual port according to the given markdown-parser, which is one of the default parsers provided by the library. The other default parser is commonmark-parser, which strictly conforms Commonmark specification.

markdown-parser

This supports most of the GFM, footnotes and definition list

commonmark-parser

This only supports things listed on Commonmark specification. So, no table, no strikethrough or others.

The above script is actually used to generate this post. This means, obviously, the markdown-parser is used (as the code already shows :D)

NOTE: Below is the convenient (also for my memo) command to generate an HTML post.

# For Mac
sash blogpost-markdown.scm post.md | pbcopy

There's also a library called (text markdown extensions) and (text markdown converters). These libraries provide an API / framework to provide custom extensions, such as GFM, which is mostly supported by the library.

Next step

Sagittarius document requires a bit more tweaks. Below are the requirements

• Table of contents
• Index table
• eval expression
• Page split per section
• Proper anchor per pages
• Navigation bar

Most of the things are done already, just a bit more. I think after this is done, I can finally release 0.9.9.

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 辺りを使ってやる必要がある気はするが、まぁ、確認してない)

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

XML signature

It's been a while writing a blog post. I wasn't really actively working on Sagittarius or Scheme, so there was nothing I can write. (and I was super busy with my life, incl. work). That's the excuse. I hope I will keep posting something, but I can't promise.

Even though I wasn't actively writing Scheme, I've been trying to enrich XML related libraries of Sagittarius. As we, probably, all know, Scheme has a great de-facto standard SXML and its libraries such as SSAX or SXPath. However, if you really need to handle serious XML which requires a lot of namespace handling, these libraries are not enough. So, I started working on writing a DOM library 2 years ago (though it's not even an introduction article :p). At that moment, the final destination of XML library was handling SAML, so XML signature.

After those 2 years, I've finally implemented a very simple XML signature library. While I was reaching this, I thought I needed to implement XPath, which is incomplete by the way, and spent more than a year for that. But at least, there's finally something I can show. Let's see how it looks like.

(import (rnrs)
        (text xml dom)
        (text xml dom writer)
        (text xml dsig)
        (rfc base64)
        (crypto)
        (rsa pkcs :10)
        (math))
;; RSA private key
(define private-key
  "MIIBPAIBAAJBAM7xaDmTsYZj1ZxJOVpAkCXKp/2SmprG1IA90cGs4wr1fiCRWHQ+\
   sdJwiX2j932CW7DpjOg4GEn2CrPwWIQLfdkCAwEAAQJBAInnc5YS5xVwiBPq8+5B
   4g1dHE+tl5uW7ls7VwGijXZp6Mi7D+GJJ57w6wo1vzjGNIFUAs07+17XBRpPeqaW
   MVECIQDz2t+jH7zB/wSbf3titZtyRIaYGCiV20sb9Xc/56QWHQIhANk/6Ncem83E
   wJpJTS3r+QFgkPVhQF0VEZJ0bI7fDAntAiEAuStZqH/AELu6Xu2V3uWyjTl1zuaB
   YxHrXeauT8tw8Q0CIQDVjbMuM1JodO33O/L4HywIpIoaC10fouRBGNzVnH/TCQIg
   ZoOzTnUmv2X4DaxbH4kfBg5/9e/mwK8wLZy2gn+a2A0=")
;; PKCS 10 format RSA public key
(define public-key
  "MFwwDQYJKoZIhvcNAQEBBQADSwAwSAJBAM7xaDmTsYZj1ZxJOVpAkCXKp/2SmprG\
   1IA90cGs4wr1fiCRWHQ+sdJwiX2j932CW7DpjOg4GEn2CrPwWIQLfdkCAwEAAQ==")
(define signing-key
  (import-private-key RSA
   (base64-decode-string private-key :transcoder #f)))
(define verify-key
  (subject-public-key-info->public-key
   (import-public-key PKCS10
    (base64-decode-string public-key :transcoder #f))))

(define keypair (make-keypair signing-key verify-key))

(define dom (xml-file->dom-tree "test1.xml"))

;; signing context, using exclude c14n canonicalisation, SHA256
;; and RSAWithSHA256 signature
(define sc (ds:make-signing-context ""
                                    *xmldsig:canonicalization-exc-c14n*
                                    *xmldsig:digest-sha256*
                                    *xmldsig:rsa-sha256*))
;; writing the signed DOM
(xmldsig:sign! dom sc keypair) ;; also return the given DOM
((make-dom-writer) dom)
#|
The above would write something like this (may change in the future 
due to the fact that the writing option is not decided yet)
<doc xmlns="http://www.ietf.org" xmlns:w3c="http://www.w3.org" xml:base="something/else">
    <e1>
        <e2 xmlns="" xml:base="bar/" xml:id="abc">
            <e3 id="E3" xml:base="foo"/>
        </e2>
    </e1>
<Signature xmlns="http://www.w3.org/2000/09/xmldsig#"><SignedInfo><CanonicalizationMethod Algorithm="http://www.w3.org/2001/10/xml-exc-c14n#"/><SignatureMethod Algorithm="http://www.w3.org/2001/04/xmldsig-more#rsa-sha256"/><Reference URI=""><DigestMethod Algorithm="http://www.w3.org/2001/04/xmlenc#sha256"/><DigestValue>d1AgwW6w5CuCx4jqTM3zZBheHCg0AdEt93OiG599yHQ=</DigestValue></Reference></SignedInfo><SignatureValue>KrNNBtxw4ppGVOCWWndW6INDexdXs5Ei1/GqiUFwofjwrGmKmEw4hrCLG7p86StJ5kfGHYncezvr
exggfQSVZw==</SignatureValue><KeyInfo><KeyValue><RSAKeyValue><Modulus>zvFoOZOxhmPVnEk5WkCQJcqn/ZKamsbUgD3RwazjCvV+IJFYdD6x0nCJfaP3fYJbsOmM6DgYSfYK
s/BYhAt92Q==</Modulus><Exponent>AQAB</Exponent></RSAKeyValue></KeyValue></KeyInfo></Signature></doc>
|#

The test1.xml looks like this

<?xml version="1.0" encoding="utf-8" ?>
<doc xmlns="http://www.ietf.org" xmlns:w3c="http://www.w3.org" xml:base="something/else">
    <e1>
        <e2 xmlns="" xml:id="abc" xml:base="bar/">
            <e3 id="E3" xml:base="foo"/>
        </e2>
    </e1>
</doc>

I'm trying to keep the user level API as simple as possible. So the only thing users need to do is preparing a key pair and choosing the signing algorithms. At this moment, it doesn't handle references and transformers. But this is good enough as the first step. (And implementing transformer requires XPath, so may come veeeeery later). Now, I can sign an XML document, so the next step would be verifying the signature. I hope I can write a post soon enough before I forget what I've done.

It took me more than 2 years to reach here, during the period, I was more or less demotivated to write Scheme for some reason and recently, I decided to write something every day (only weekday, weekends are too busy with family life...). It was very small steps I've been making but at some point, I could reach somewhere. I'm a bit touched by this :D