;;; senz-altro.scm

;; Copyright (C) 2007, 2009, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Code:

(define-module (ttn-do zzz senz-altro)
  #:export (daemonize)
  #:use-module ((ttn-do zzz personally) #:select (FE)))

;; If @var{pidfile} is non-@code{#f}, check that it (filename) does not
;; exist, and that its directory is writeable.  Signal "already exists"
;; or "directory not writeable", respectively, otherwise.  Then, do a
;; @code{primitive-fork}.
;;
;; @noindent
;; For parent:
;;
;; @itemize
;; @item If @var{pidfile} is non-@code{#f}, @code{write} child pid
;; and elements of @var{etc} to @var{pidfile}, one element per line.
;;
;; @item Call @var{rest} with one arg, the child pid.
;; Return what @var{rest} returns.
;; @end itemize
;;
;; @noindent
;; For child:
;;
;; @itemize
;; @item Set the session id with @code{setsid}.
;;
;; @item Close i/o ports, as determined by @code{current-input-port},
;; @code{current-output-port} and @code{current-error-port}.
;;
;; @item Construct a proc @code{bye} like so:
;; @lisp
;; (lambda ignored
;;   (and (file-exists? pidfile)
;;        (delete-file pidfile))
;;   (raise SIGKILL))
;; @end lisp
;;
;; @item Do @code{(sigaction SIGTERM bye)}.
;;
;; @item Call proc @var{play} with one arg, proc @code{bye}.
;; Return what @var{play} returns.
;; @end itemize
;;
(define (daemonize rest play pidfile . etc)
  (cond (pidfile
         (and (file-exists? pidfile)
              (error "pidfile already exists:" pidfile))
         (let ((dir (dirname pidfile)))
           (or (access? dir W_OK)
               (error "pidfile directory not writeable:" dir)))))
  (let ((pid (primitive-fork)))
    (cond ((zero? pid)
           ;; child
           (setsid)
           (close-port (current-input-port))
           (let ((same? (eq? (current-output-port) (current-error-port))))
             (and (port? (current-output-port))
                  (close-port (current-output-port)))
             (and (not same?) (port? (current-error-port))
                  (close-port (current-error-port))))
           (let ((bye (lambda ignored
                        (and (file-exists? pidfile)
                             (delete-file pidfile))
                        (raise SIGKILL))))
             (sigaction SIGTERM bye)
             (play bye)))
          (else
           ;; parent
           (and pidfile
                (call-with-output-file pidfile
                  (lambda (port)
                    (FE (cons pid etc)
                        (lambda (x)
                          (write x port)
                          (newline port))))))
           (rest pid)))))

;;; senz-altro.scm ends here