cvspserver: daemon to run "cvs pserver" on an arbitrary port

[Thien-Thi Nguyen]

murphy's law sez, of course, the day you find a workaround, the ISP
decides to end the eight month delay and upgrade the vulnerable
cvs...  so it goes.  :-/

thi


_____________________________________________________
#!/bin/sh
exec guile -e main -s $0 "$@" # -*- scheme -*-
!#
;;; cvspserver --- daemon to run "cvs pserver" on an arbitrary port

;; Copyright (C) 2003 Thien-Thi Nguyen
;; This program is part of ttn-do, released under GNU GPL v2 with ABSOLUTELY
;; NO WARRANTY.  See http://www.gnu.org/copyleft/gpl.txt for details.

;;; Commentary:

;; Usage: cvspserver SETTINGS...
;;
;; Run a "cvs pserver" daemon based on SETTINGS:
;;
;;  -p, --port NUMBER   -- which tcp port to listen on (default: 38383)
;;  -r, --root CVSROOT  -- repo dir (default: taken from CVSROOT env var)
;;  -b, --bin PROGRAM   -- full path to cvs binary (*required*)
;;  -l, --log FILENAME  -- where to write important log info (*required*)
;;
;; Before automatically placing itself in the background, cvspserver
;; summarizes the settings to stdout, including the pid of the child
;; daemon process (useful for "kill -1 PID" to kill it later).

;;; Code:

(define PORT 38383)
(define ROOT (getenv "CVSROOT"))
(define BIN  #f)
(define LOG  #f)

(define get object-property)
(define put set-object-property!)

(define (now) (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))

(define counted-fork
  (let ((count 0))
    (lambda ()
      (let ((pid (primitive-fork)))
        (put pid 'count count)
        (set! count (1+ count))
        pid))))

(define (handle port conn)
  (let ((pid (counted-fork)))
    (cond ((= 0 pid)
           (redirect-port port (current-input-port))
           (redirect-port port (current-output-port))
           (execl BIN BIN "-f"
                  (format #f "--allow-root=~A" ROOT)
                  "pserver"))
          (else
           (format LOG "~A [~A|~A]: child pid is: ~A\n"
                   (now) (getpid) (get pid 'count) pid)
           (format LOG "~A [~A|~A]: waitpid: ~S\n"
                   (now) (getpid) (get pid 'count) (waitpid pid))
           (flush-all-ports)))))

(use-modules ((ttn listener) #:select (make-listener)))

(define (main/qop qop)
  (qop 'port (lambda (p) (set! PORT (string->number p))))
  (qop 'root (lambda (d) (set! ROOT d)))
  (qop 'bin  (lambda (b) (set! BIN  b)))
  (qop 'log  (lambda (l) (set! LOG  (open-file l (if (file-exists? l)
                                                     "a" "w")))))
  (let ((pid (primitive-fork)))
    (cond ((= 0 pid)
           (redirect-port LOG (current-error-port))
           (format LOG "~A [~A]: restart\n" (now) (getpid))
           ((make-listener PORT #:nqueue 1 #:handle handle)))
          (else
           (format #t "port: ~A\nroot: ~A\nbin: ~A\nlog: ~A\npid: ~A\n"
                   PORT ROOT BIN (port-filename LOG) pid)))
    (exit #t)))

(use-modules ((scripts PROGRAM) #:select (HVQC-MAIN)))

(define (main args)
  (HVQC-MAIN
   args main/qop
   '(usage . commentary)
   '(version . "1.0")
   `(option-spec (port (single-char #\p) (value #t))
                 (root (single-char #\r) (value #t)
                       (predicate
                        ,(lambda (d)
                           (and (string? d)
                                (file-exists? d)
                                (file-is-directory? d)
                                (let ((sub (in-vicinity d "CVSROOT")))
                                  (and (file-exists? sub)
                                       (file-is-directory? sub)))))))
                 (bin  (single-char #\b) (value #t) (required? #t))
                 (log  (single-char #\l) (value #t) (required? #t)))))

;;; cvspserver ends here