デーモン

以前に書いた『HTTPリクエストの中身を表示するだけのHTTPサーバ』を拡張して、デーモンサーバを作成する機会があったので、それをまとめてpackage化した。

プロセス(サーバ)をデーモン化すること自体は、以下のような処理で出来た。

(require :sb-posix)

(defvar *common-lisp-streams*
  '(*standard-input* *standard-output* *query-io* 
    *debug-io* *terminal-io* *error-output* *trace-output*))

;;;;;;;;;;;;
;;; デーモン作成
(unless (zerop (sb-posix:fork))
  (sb-ext:quit)) ; <- 親プロセスは終了

(sb-posix:setsid)

(unless (zerop (sb-posix:fork))
  (sb-ext:quit))

(sb-posix:chdir "/")
(sb-posix:umask 0)

;; file-discriptorを閉じる  ※ MAXFDには適当な上限を設定
(dotimes (fd MAXFD)
  (sb-unix:unix-close fd))

;; common-lispパッケージにあるstreamには、"/dev/null"へのfile-streamを設定する
(let ((null-io (open "/dev/null" :direction :io :if-exists :overwrite)))
  (dolist (s *common-lisp-streams*)
    (setf s null-io))))


;;;;;;;;;;;;
;;; ここ以降に、デーモンプロセスで動かしたいプログラムを記述

forkを二回呼んだり、setsidを使ったり、ファイルディスクリプタを閉じたりするのは、デーモンをターミナル(制御端末)から完全に切り離すのに必要らしい。

作成したもの

上のデーモン化処理に加えて、次のような機能も実装。

• デーモン化の有無フラグ
• pidファイル作成
• ログ用の簡単な関数

後、*standard-output*と*standard-input*は(クライアント)ソケットのstreamにバインドするようにした。

簡単な使用例。

;; 3000番ポートで待機するデーモンプロセス(サーバ)作成
;; deamon:log関数は、*error-output*に出力を行う
(deamon:do-accept (#(0 0 0 0) 3000)
  (deamon:log "==============")
  (deamon:log "リクエスト")
  (read-request *standard-input*)

  (deamon:log "レスポンス")
  (write-response *standard-output*)) 

;;; デーモンプロセスにしない場合
(deamon:do-accept (#(0 0 0 0) 3000 :deamon nil) ...)

;;; pidファイルを作成する場合
(deamon:do-accept (#(0 0 0 0) 3000 :pid "/tmp/3000.pid") ...)

;;; ログをファイルに書き出す場合
(deamon:do-accept (#(0 0 0 0) 3000 :log "/tmp/3000.log") ...)

全部で100行にも満たないので、ソースコードを以下に掲載。
また、asdfを使ってインストールできると便利なので、それも用意: deamon(0.1.0)

(require :sb-bsd-sockets)
(require :sb-posix)

(defpackage :deamon
  (:use :common-lisp :sb-bsd-sockets)
  (:shadow :log)
  (:export :do-accept 
           :log))
(in-package :deamon)

;;; 定数とか
(defconstant MAXFD 64)
(defvar *common-lisp-streams*
  '(*standard-input* *standard-output* *query-io* 
    *debug-io* *terminal-io* *error-output* *trace-output*))

;; 空stream作成
(defun make-null-io-stream ()
  (open "/dev/null" :direction :io :if-exists :overwrite))

;; ログ用のstream作成
(defun make-log-stream (log deamon?)
  (cond ((typep log '(or string pathname))
         (open log :direction :output 
                   :if-exists :append 
                   :if-does-not-exist :create))
        ((or deamon? (null log))
         (make-broadcast-stream))
        (t *error-output*)))

;; pidファイル作成
(defun write-pid-file (pid)
  (check-type pid (or string pathname NULL))
  (when pid
    (with-open-file (out pid :direction :output :if-exists :supersede)
      (princ (sb-posix:getpid) out))))

;; forkして親プロセスを終了
(defun fork-and-exit-parent ()
  (unless (zerop (sb-posix:fork))
    (sb-ext:quit)))

;; デーモンプロセス作成関数
(defun init-deamon ()
  (fork-and-exit-parent)
  (sb-posix:setsid)

  (fork-and-exit-parent)
  (sb-posix:chdir "/")
  (sb-posix:umask 0)

  (dotimes (fd MAXFD)
    (sb-unix:unix-close fd))

  (let ((null-io (make-null-io-stream)))
    (dolist (s *common-lisp-streams*)
      (setf s null-io))))

;; TCPのconnect,listen,acceptを行ってくれるマクロ
(defmacro do-accept-impl ((address port backlog error-output) &body body)
  (let ((server (gensym))
        (client (gensym)))
    `(let ((,server (make-instance 'inet-socket :type :stream :protocol :tcp)))
       (unwind-protect
           (progn 
             (setf (sockopt-reuse-address ,server) t)
             (socket-bind ,server ,address ,port)
             (socket-listen ,server ,backlog)
             (loop
              (let ((,client (socket-accept ,server)))
                (sb-thread:make-thread
                 (lambda ()
                   (let* ((*standard-output* (socket-make-stream ,client 
                                                                 :input t :output t 
                                                                 :element-type '(unsigned-byte 8)))
                          (*error-output*    ,error-output)
                          (*standard-input*  *standard-output*))
                     (unwind-protect
                         (progn ,@body)
                       (close *standard-output*))))))))
         (socket-close ,server)))))

;; 
(defmacro do-accept ((address port &key (backlog 16) (deamon t) pid (log t)) &body body)
  (let ((error-output (gensym)))
    `(progn
       ,(when deamon '(init-deamon))
       (let ((,error-output (make-log-stream ,log ,deamon)))
         (unwind-protect
             (handler-case 
              (progn (write-pid-file ,pid)
                     (do-accept-impl (,address ,port ,backlog ,error-output) ,@body))
              (error (c)
                (format ,error-output "~A: ~A~%" (type-of c) c)))
           (when (typep ,error-output 'sb-sys:fd-stream)
             (close ,error-output)))))))

;; ログ関数
(defun log (fmt-str &rest args)
  (if (typep fmt-str 'string)
      (apply #'format *error-output* fmt-str args)
    (princ fmt-str *error-output*))
  (terpri *error-output*)  
  (force-output *error-output*))

少し更新

若干機能追加。
ほとんど、sb-bsd-sockets:make-socket-stream関数に渡す引数を増やしただけなので、ソースはdeamon(0.1.1)を参照。

;; bivalent-streamを使う
(deamon:do-accept (#(0 0 0 0) 3000 :bivalent t)
  ;; どちらの入力関数でも大丈夫
  (read-char *standard-input*) 
  (read-byte *standard-input*))

;; 読み込みtimeoutを設定
(deamon:do-accept (#(0 0 0 0) 3000 :read-timeout 3)
  (handler-case
      (read)
    (timeout ()
      ...)))

;; serverとclientのソケットを参照できるようにする(名前は適当)
(deamon:do-accept (#(0 0 0 0) 3000 :anaph t)
  ;; シンボル「client」と「server」で参照可能に
  (sb-bsd-sockets:socket-peername client)
  (sb-bsd-sockets:socket-peername server))