jsonで来たコマンドを、マクロで構文を作って関数の引数に対応させる

後輩のpythonistaと連携するためにとった手法。
socket経由で送られてくる、下のようなjsonを読み込んで、対応する関数 solve を走らせ、返信します。
コマンド名は command に書く感じ。

{
  "command": "solve",
  "domain-path":"~/repos/pddl/data/costs/domain.pddl",
  "problem-path":"~/repos/pddl/data/costs/model2a1.pddl",
  "time":60
}

socket 立ち上げ

まずusocketでサーバを立ち上げてcl-jsonでパースする。

@export
(defvar +port+ 3000)
@export
(defvar +host+ "127.0.0.1")

(defun json-handler (stream)
  (handler-return ((error (lambda (e)
                            (encode-json `((:error . "serious error occured!")
                                           (:type . ,(type-of e)))
                                         stream)
                            (format *shared-output*
                                    "~3% error occured! :~% ~w" e))))
    (print :received! *shared-output*)
    (handler-return ((json-syntax-error
                      (lambda (e)
                        (apply #'format stream
                               (simple-condition-format-control e)
                               (simple-condition-format-arguments e)))))
      (let ((decoded (decode-json stream)))
        (print decoded *shared-output*)
        (if-let ((command (cdr (assoc :command decoded))))
          (if-let ((fn (gethash (string-upcase command) *command-functions*)))
            (funcall fn stream decoded)
            (progn
              (push `(:error . ((:message . "no such command exists.")
                                (:command . ,command)))
                    decoded)
              (encode-json decoded stream)))
          (progn
            (push `(:error . ((:message . "command not specified.")))
                  decoded)
            (encode-json-alist decoded stream)))))
    (terpri stream)))

@export
(defvar *socket*
  (socket-server +host+ +port+ (lambda (s) (json-handler s)) nil
                 :in-new-thread t
                 :multi-threading t
                 :reuse-address t))

(defparameter *command-functions*
  (make-hash-table :test #'equal))

jsonコマンドに対応する関数を書き、ハッシュテーブルに保存。。

(defun json-lisp-implementation-type (stream decoded)
  (encode-json-alist
   `(,(assoc :command decoded)
     (:lisp-implementation-type . ,(lisp-implementation-type)))
   stream))
(setf (gethash "JSON-LISP-IMPLEMENTATION-TYPE" *command-functions*)
         #'json-lisp-implementation-type)

シェルから確認します。

[guicho src]$ nc 127.0.0.1 3000
{"command":"json-lisp-implementation-type"}
{"command":"json-lisp-implementation-type","lispImplementationType":"SBCL"}

ちゃんと返信が帰って来ました。

マクロを書く

でも、パースされた素のリストからチマチマ要素を取得していくのは嫌なので、DSLを作っちゃう。

(defmacro define-command (name arguments &body body)
  (assert (= 2 (length arguments)) nil "interface should be a 2-arg function!")
  `(progn
     ,(if (symbolp (second arguments))
          (let ((decoded (second arguments)))
            `(defun ,name ,arguments
               (declare (ignorable ,@arguments))
               (let ((*the-command* (assoc :command ,decoded))
                     (*the-id* (assoc :id ,decoded)))
                 ,@body)))
          (%function-definition-destructuring-json name arguments body))
     (setf (gethash ,(symbol-name name) *command-functions*)
           (function ,name))))

(defvar *the-command*)
(defvar *the-id*)

(defun %function-definition-destructuring-json (name arguments body)
  (destructuring-bind (stream json-bindings) arguments
    (with-gensyms (decoded)
      `(defun ,name (,stream ,decoded)
         (declare (ignorable ,stream ,decoded))
         (let ((*the-command* (assoc :command ,decoded))
               (*the-id* (assoc :id ,decoded)))
           ,(%build-bindings json-bindings decoded body))))))

(defun %build-bindings (json-bindings decoded body)
  (iter (for binding in json-bindings)
        (collect
            (ematch binding
              ((type symbol)
               `(,binding (cdr (assoc ,(intern (string-upcase binding)
                                               (find-package :keyword))
                                      ,decoded))))
              ((list binding '&subtree subtree)
               (collect (list binding subtree) into bind-subtrees)
               `(,binding (cdr (assoc ,(intern (string-upcase binding)
                                               (find-package :keyword))
                                      ,decoded))))
              ((list binding '&optional default)
               `(,binding (or (cdr (assoc ,(intern (string-upcase binding)
                                                   (find-package :keyword))
                                          ,decoded))
                              ,default))))
          into bindings)
        (finally
         (return
           `(let* ,bindings
              ,@(reduce (lambda (prev bind-subtree)
                          (destructuring-bind (binding subtree) bind-subtree
                            (%build-bindings subtree binding prev)))
                        bind-subtrees :initial-value body))))))

これを使って書いてみた関数が以下。

(define-command solve (stream (domain-path
                               problem-path
                               (option &optional "ipc seq-sat-lama-2011")
                               (memory &optional 200000)
                               (time &optional 15)))
  (let ((domain (parse-file domain-path))
        (problem (parse-file problem-path))
        (paths (test-problem problem-path domain-path
                             :stream *shared-output*
                             :options option :memory memory :time-limit time)))
    (encode-json-alist
     `(,*the-command*
       ,*the-id*
       (:domain . ,domain)
       (:problem . ,problem)
       (:paths . ,paths))
     stream)))

マクロのおかげで、関数 solve はjsonの要素を直接引数にとれているかのように見えます。
オレオレ構文ですけれどね。 solve の展開型は以下。

(PROGN
 (DEFUN SOLVE (STREAM #:DECODED1316)
   (DECLARE (IGNORABLE STREAM #:DECODED1316))
   (LET ((*THE-COMMAND* (ASSOC :COMMAND #:DECODED1316))
         (*THE-ID* (ASSOC :ID #:DECODED1316)))
     (LET* ((DOMAIN-PATH (CDR (ASSOC :DOMAIN-PATH #:DECODED1316)))
            (PROBLEM-PATH (CDR (ASSOC :PROBLEM-PATH #:DECODED1316)))
            (OPTION
             (OR (CDR (ASSOC :OPTION #:DECODED1316)) "ipc seq-sat-lama-2011"))
            (MEMORY (OR (CDR (ASSOC :MEMORY #:DECODED1316)) 200000))
            (TIME (OR (CDR (ASSOC :TIME #:DECODED1316)) 15)))
       (LET ((DOMAIN (PARSE-FILE DOMAIN-PATH))
             (PROBLEM (PARSE-FILE PROBLEM-PATH))
             (PATHS
              (TEST-PROBLEM PROBLEM-PATH DOMAIN-PATH :STREAM *SHARED-OUTPUT*
                            :OPTIONS OPTION :MEMORY MEMORY :TIME-LIMIT TIME)))
         (ENCODE-JSON-ALIST
          `(,*THE-COMMAND* ,*THE-ID* (:DOMAIN ,@DOMAIN) (:PROBLEM ,@PROBLEM)
            (:PATHS ,@PATHS))
          STREAM)))))
 (SETF (GETHASH "SOLVE" *COMMAND-FUNCTIONS*) #'SOLVE))

実は JSON-BIND ってのが既に用意されてたんですが、
見た目使いにくそうだったので今回はパス。

書き捨て御免