registry.lisp 1.99 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;;; Registering machines for use on the farm.

(in-package :philip-jose)

(defparameter *start-time* nil)
(defun get-start-time ()
  (or *start-time* (setf *start-time* (get-real-time))))

(defun read-time (time)
  (date:parse-time time :patterns
                   '((date::year (date::date-divider) date::month (date::date-divider) date::day
                      (date::time-divider) date::hour (date::time-divider) (date::minute)
                      (date::time-divider) (date::secondp)))))

(defun decode-registry-log-line (x)
  (destructuring-bind (op user machine time-string &rest rest) (split-sequence #\SPACE x)
    (let ((time (- (read-time time-string) +unix-epoch+))
          (hash (position "#" rest :test #'string-equal))
          ips limit args)
      (if hash
        (setf ips (subseq rest 0 hash)
              args (subseq rest (1+ hash))
              limit (ignore-errors
                      (+ time
                         (* (parse-number:parse-positive-real-number x)
                            (* 24 60 60)))))
        (setf ips rest))
      (values op user machine time ips limit args))))

(defparameter *registered-hosts* nil)

(defun process-registry-log ()
  (let ((*registered-hosts* (make-hash-table :test 'equal)))
    (with-open-file (s *registry-path*)
      (process-registry-log-stream s))
    (mapcar #'car (sort (hash-table->alist *registered-hosts*) #'< :key #'cdr))))

(defun process-registry-log-stream (s)
  (loop for x = (read-line s nil)
        while x do
    (multiple-value-bind (op user machine time ips limit args) (decode-registry-log-line x)
      (declare (ignore user ips args))
      (when (and (<= time (get-start-time))
                 (or (null limit)
                     (< (get-start-time) limit)))
        (cond
          ((string= "register" op)
           (setf (gethash machine *registered-hosts*) time))
          ((string= "unregister" op)
           (remhash machine *registered-hosts*)))))))