Application Delivery of long running application in Clozure CL

Question

All the basic examples for Application Delivery show how to replace the toplevel function with your own. Once that function is done, the application exits. I was wondering what's the best way to create a toplevel function for an application that is long running. My code is

(ql:quickload :my-app)

(defun main ()
  (swank:create-server :dont-close t)
  (my-app:start-server) ; Essentially creates a hunchentoot handler and returns
  (loop for x = (read-line)
     when (string= x "q") do (quit)
     do (format t "Type q to quit~%" x)))

(save-application "my-app" :toplevel-function #'main :prepend-kernel t)

Is there a better way? I don't like the loop but something which frees up the terminal is also ok.

Answer 1

As you say, once the main function is done, the application exits. Ergo, you need to keep the function running until you wish to exit the application.

The simplest solution is to just leave the main loop in an infinite loop of sleep:

(defun main ()
  (swank:create-server :dont-close t)
  (my-app:start-server)
  (loop (sleep 60)))

As you are starting a Swank server, you might want to include functionality for cleanly exiting the application through a SLIME connection. You could, for example, write something like the following, using the bt-semaphore package:

(defvar *quit-my-app* (bt-semaphore:make-semamphore))

(defun main ()
  (swank:create-server :dont-close t)
  (my-app:start-server)
  (bt-semaphore:wait-on-semaphore *quit-my-app*)
  (my-app:clean-up)) ; or whatever you need to do for cleaning up

(defun quit-my-app ()
  (bt-semaphore:signal-semaphore *quit-my-app*))

Now you can simply evaluate (quit-my-app) on a SLIME connection to shut down the application.

You could also use the main thread for maintenance duties. In my server, I perform simple log rotation there:

(defun seconds-until-tomorrow ()
  (multiple-value-bind (second minute hour day month year daylight-p zone)
      (decode-universal-time (+ (get-universal-time) (* 60 60 26))) ; safely tomorrow
    (declare (ignore second minute hour daylight-p))
    (- (encode-universal-time 0 0 0 day month year zone)
       (get-universal-time))))

(defun main ()
  (swank:create-server :dont-close t)
  (let (cur-logfile
        cur-logfile-name
        ;; assuming that start-server returns the Hunchentoot acceptor
        (acpt (my-app:start-server)))
    (loop
       (let* ((lf-stem (log-file-name))
              (logfile-name (merge-pathnames lf-stem *temp-path*))
              (new-logfile (open logfile-name :direction :output 
                                              :if-exists :append 
                                              :if-does-not-exist :create)))

         (setf (hunchentoot:acceptor-message-log-destination acpt) new-logfile
               (hunchentoot:acceptor-access-log-destination acpt) new-logfile)

         (when cur-logfile
           (close cur-logfile)
           (run-program "/usr/bin/xz" (list (princ-to-string cur-logfile-name))))

         (setf cur-logfile new-logfile
               cur-logfile-name logfile-name)

         (when (bt-semaphore:wait-on-semaphore *quit-my-app* (seconds-until-tomorrow))
           (return)))))