bin/ansible-inventory: Make the script loadable into a Lisp system.

[distorted-ansible] / bin / ansible-inventory

#! /usr/bin/cl-launch -X --
;;; -*-lisp-*-

(cl:defpackage #:ansible-inventory
  (:use #:common-lisp))

(in-package #:ansible-inventory)

(declaim (optimize debug))

;;;--------------------------------------------------------------------------
;;; General utilities.

(defun compose (&rest funcs)
  (reduce (lambda (f g)
	    (lambda (&rest args) (multiple-value-call g (apply f args))))
	  funcs :initial-value #'values))

;;;--------------------------------------------------------------------------
;;; JSON machinery.

(defvar *print-json-comma*)

(defun print-json-itemstart ()
  (cond (*print-json-comma*
	 (princ ", ")
	 (pprint-newline :linear))
	(t
	 (setf *print-json-comma* t))))

(defun print-json-map* (thunk)
  (print-json-itemstart)
  (princ "{ ")
  (pprint-indent :block 2)
  (pprint-newline :linear)
  (pprint-logical-block (*standard-output* nil)
    (let ((*print-json-comma* nil)) (funcall thunk)))
  (princ " ")
  (pprint-indent :block 0)
  (pprint-newline :linear)
  (princ "}"))

(defmacro print-json-map (&body body)
  `(print-json-map* (lambda () ,@body)))

(defun print-json-list* (thunk)
  (print-json-itemstart)
  (princ "[")
  (pprint-indent :block 2)
  (pprint-newline :linear)
  (pprint-logical-block (*standard-output* nil)
    (let ((*print-json-comma* nil)) (funcall thunk)))
  (pprint-indent :block 0)
  (pprint-newline :linear)
  (princ "]"))

(defmacro print-json-list (&body body)
  `(print-json-list* (lambda () ,@body)))

(defun print-json-mapping* (label thunk)
  (print-json-itemstart)
  (pprint-logical-block (*standard-output* nil)
    (let ((*print-json-comma* nil))
      (print-json-simple label))
    (princ ": ")
    (pprint-newline :miser)
    (let ((*print-json-comma* nil))
      (funcall thunk))))

(defmacro print-json-mapping (label &body body)
  `(print-json-mapping* ,label (lambda () ,@body)))

(defun print-json-simple (value)
  (typecase value
    (list (print-json-list (dolist (i value) (print-json-simple i))))
    (hash-table (print-json-map (maphash (lambda (k v)
					   (print-json-mapping k
					     (print-json-simple v)))
					 value)))
    (t
     (print-json-itemstart)
     (etypecase value
       (integer (format t "~A" value))
       (float (format t "~G" value))
       (rational (format t "~G" (float value 0.0d0)))
       (string (format t "~S" value))
       ((eql t) (princ "true"))
       ((eql nil) (princ "false"))
       ((eql :undefined) (princ "undefined"))
       (symbol (format t "~S" (string-downcase value)))))))

(defun print-json* (thunk)
  (let ((*print-json-comma* nil))
    (pprint-logical-block (*standard-output* nil)
      (funcall thunk))
    (terpri)))

(defmacro print-json (&body body)
  `(print-json* (lambda () ,@body)))

;;;--------------------------------------------------------------------------
;;; Host definitions.

(defvar *hosts* (make-hash-table))

(export 'add-host)
(defun addhost (name alist)
  (setf (gethash name *hosts*) alist))

(export 'defhost)
(defmacro defhost (name &body alist)
  `(progn (addhost ',name ',alist) ',name))

(export 'host-plist)
(defun host-plist (name)
  (multiple-value-bind (plist foundp) (gethash name *hosts*)
    (unless foundp (error "Host ~S not found" name))
    plist))

(export 'hostprop)
(defun hostprop (name prop &optional default)
  (multiple-value-bind (found-name value tail)
      (get-properties (host-plist name) (list prop))
    (declare (ignore found-name))
    (if tail
	(values value t)
	(values default nil))))
(defun (setf hostprop) (value name prop &optional default)
  (declare (ignore default))
  (let ((plist (host-plist name)))
    (multiple-value-bind (found-name found-value tail)
	(get-properties plist (list prop))
      (declare (ignore found-name found-value))
      (if tail
	  (setf (cadr tail) value)
	  (setf (gethash name *hosts*)
		(cons prop (cons value plist))))
      value)))

(export 'hostprop-default)
(defun hostprop-default (host prop value)
  (multiple-value-bind (found-value foundp) (hostprop host prop)
    (declare (ignore found-value))
    (unless foundp (setf (hostprop host prop) value))))

(export 'hostpropp)
(defun hostpropp (host prop)
  (multiple-value-bind (value foundp) (hostprop host prop)
    (declare (ignore value))
    foundp))

(export 'maphosts)
(defun maphosts (func)
  (maphash (lambda (name plist)
	     (declare (ignore plist))
	     (funcall func name))
	   *hosts*))

(export 'dohosts)
(defmacro dohosts ((hostvar &optional valueform) &body body)
  `(block nil (maphosts (lambda (,hostvar) ,@body)) ,valueform))

;;;--------------------------------------------------------------------------
;;; Group definitions.

(defvar *groups* nil)

(export 'add-group)
(defun add-group (name type func)
  (let* ((found (assoc name *groups*))
	 (list (ecase type
		 (:predicate
		  (let ((list nil))
		    (dohosts (host list)
		      (when (funcall func host) (push host list)))))
		 (:list
		  (funcall func)))))
    (if found
	(setf (cdr found) list)
	(push (cons name list) *groups*))))

(export 'defgroup)
(defmacro defgroup (name type args &body body)
  `(progn (add-group ',name ,type
		     ,(ecase type
			(:predicate
			 (destructuring-bind (hostvar) args
			   `(lambda (,hostvar) ,@body)))
			(:list
			 (destructuring-bind () args
			   `(lambda () ,@body)))))
	  ',name))

;;;--------------------------------------------------------------------------
;;; Post-processing hooks.

(defstruct hook-entry
  prio
  func)

(export '(prio-props prio-groups))
(defconstant prio-props 10)
(defconstant prio-groups 20)

(defvar *hostproc-hooks* nil)

(export 'addhook)
(defun addhook (prio func)
  (push (make-hook-entry :prio prio :func func) *hostproc-hooks*))

(export 'defhook)
(defmacro defhook ((prio) &body body)
  `(addhook ,prio (lambda () ,@body)))

;;;--------------------------------------------------------------------------
;;; Read the input file and hook definitions.

(defvar *progname*
  #.(or *compile-file-pathname* *load-pathname*))

(defvar *user-package*
  (make-package "ANSIBLE-INVENTORY-USER"
		:use '("CL" "ANSIBLE-INVENTORY")))

(defun load-input (file)
  (let ((*package* *user-package*))
    (load file :verbose nil)))

(defun parse-command-line (args)
  (loop (let* ((arg (pop args))
	       (len (length arg)))
	  (cond ((string= arg "--") (return))
		((string= arg "-") (push arg args) (return))
		((and (plusp (length arg))
		      (char= (char arg 0) #\-))
		 (do ((i 1 (1+ i)))
		     ((>= i len))
		   (flet ((getarg ()
			    (cond ((< (1+ i) len)
				   (prog1 (subseq arg (1+ i))
				     (setf i len)))
				  (args
				   (pop args))
				  (t
				   (error "missing argument")))))
		     (case (char arg i)
		       (#\h (format t "usage: ~A FILE ...~%"
				    (pathname-name *progname*)))
		       (t (error "unknown option `-~A'" (char arg i)))))))
		(t (push arg args) (return)))))
  (mapc #'load-input args))

;;;--------------------------------------------------------------------------
;;; Run the hooks.

(defun run-hooks ()
  (setf *hostproc-hooks* (sort *hostproc-hooks* #'< :key #'hook-entry-prio))
  (mapc (compose #'hook-entry-func #'funcall) *hostproc-hooks*))

;;;--------------------------------------------------------------------------
;;; Output the definitions.

(defun output ()
  (let ((*print-right-margin* 77))
    (print-json
      (print-json-map
	(print-json-mapping "all"
	  (print-json-list (maphosts #'print-json-simple)))
	(dolist (assoc *groups*)
	  (print-json-mapping (car assoc)
	    (print-json-list
	      (mapc #'print-json-simple (cdr assoc)))))
	(print-json-mapping "_meta"
	  (print-json-map
	    (print-json-mapping "hostvars"
	      (print-json-map
		(maphash (lambda (host plist)
			   (print-json-mapping host
			     (print-json-map
			       (do ((plist plist (cddr plist)))
				   ((endp plist))
				 (print-json-mapping (car plist)
				   (print-json-simple (cadr plist)))))))
			 *hosts*)))))))))

;;;--------------------------------------------------------------------------
;;; Main program.

#+cl-launch
(progn
  (parse-command-line cl-launch:*arguments*)
  (run-hooks)
  (output))

;;;----- That's all, folks --------------------------------------------------