[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 (if (not (keywordp label))
			     label
			     (with-output-to-string (out)
			       (let ((labname (symbol-name label)))
				 (dotimes (i (length labname))
				   (let ((ch (char labname i)))
				     (write-char (if (char= ch #\-) #\_
						     (char-downcase ch))
						 out))))))))
    (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
    ((and vector (not string))
     (print-json-list
       (dotimes (i (length value)) (print-json-simple (aref value i)))))
    (null
     (princ "null"))
    (list
     (print-json-map
       (dolist (i value)
	 (print-json-mapping (car i)
	   (print-json-simple (cdr 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 --------------------------------------------------
Commit	Line	Data
3f6c5992 MW	1	#! /usr/bin/cl-launch -X --
	2	;;; --lisp--
	3
	4	(cl:defpackage #:ansible-inventory
4ee5e366	5	(:use #:common-lisp))
3f6c5992 MW	6
	7	(in-package #:ansible-inventory)
	8
0b0ce183 MW	9	(declaim (optimize debug))
0b0ce183 MW	10
3f6c5992 MW	11	;;;--------------------------------------------------------------------------
	12	;;; General utilities.
	13
	14	(defun compose (&rest funcs)
	15	(reduce (lambda (f g)
	16	(lambda (&rest args) (multiple-value-call g (apply f args))))
	17	funcs :initial-value #'values))
	18
	19	;;;--------------------------------------------------------------------------
	20	;;; JSON machinery.
	21
	22	(defvar print-json-comma)
	23
	24	(defun print-json-itemstart ()
	25	(cond (print-json-comma
	26	(princ ", ")
	27	(pprint-newline :linear))
	28	(t
	29	(setf print-json-comma t))))
	30
	31	(defun print-json-map* (thunk)
	32	(print-json-itemstart)
	33	(princ "{ ")
	34	(pprint-indent :block 2)
	35	(pprint-newline :linear)
	36	(pprint-logical-block (standard-output nil)
	37	(let ((print-json-comma nil)) (funcall thunk)))
	38	(princ " ")
	39	(pprint-indent :block 0)
	40	(pprint-newline :linear)
	41	(princ "}"))
	42
	43	(defmacro print-json-map (&body body)
	44	`(print-json-map* (lambda () ,@body)))
	45
	46	(defun print-json-list* (thunk)
	47	(print-json-itemstart)
	48	(princ "[")
	49	(pprint-indent :block 2)
	50	(pprint-newline :linear)
	51	(pprint-logical-block (standard-output nil)
	52	(let ((print-json-comma nil)) (funcall thunk)))
	53	(pprint-indent :block 0)
	54	(pprint-newline :linear)
	55	(princ "]"))
	56
	57	(defmacro print-json-list (&body body)
	58	`(print-json-list* (lambda () ,@body)))
	59
	60	(defun print-json-mapping* (label thunk)
	61	(print-json-itemstart)
	62	(pprint-logical-block (standard-output nil)
	63	(let ((print-json-comma nil))
06260a4f MW	64	(print-json-simple (if (not (keywordp label))
	65	label
	66	(with-output-to-string (out)
	67	(let ((labname (symbol-name label)))
	68	(dotimes (i (length labname))
	69	(let ((ch (char labname i)))
	70	(write-char (if (char= ch #\-) #\_
	71	(char-downcase ch))
	72	out))))))))
3f6c5992 MW	73	(princ ": ")
	74	(pprint-newline :miser)
	75	(let ((print-json-comma nil))
	76	(funcall thunk))))
	77
	78	(defmacro print-json-mapping (label &body body)
	79	`(print-json-mapping* ,label (lambda () ,@body)))
	80
	81	(defun print-json-simple (value)
	82	(typecase value
aa2cd939 MW	83	((and vector (not string))
	84	(print-json-list
	85	(dotimes (i (length value)) (print-json-simple (aref value i)))))
	86	(null
	87	(princ "null"))
	88	(list
	89	(print-json-map
	90	(dolist (i value)
	91	(print-json-mapping (car i)
	92	(print-json-simple (cdr i))))))
	93	(hash-table
	94	(print-json-map
	95	(maphash (lambda (k v)
	96	(print-json-mapping k
	97	(print-json-simple v)))
	98	value)))
3f6c5992 MW	99	(t
	100	(print-json-itemstart)
	101	(etypecase value
	102	(integer (format t "~A" value))
	103	(float (format t "~G" value))
	104	(rational (format t "~G" (float value 0.0d0)))
	105	(string (format t "~S" value))
	106	((eql t) (princ "true"))
	107	((eql nil) (princ "false"))
	108	((eql :undefined) (princ "undefined"))
	109	(symbol (format t "~S" (string-downcase value)))))))
	110
	111	(defun print-json* (thunk)
	112	(let ((print-json-comma nil))
	113	(pprint-logical-block (standard-output nil)
	114	(funcall thunk))
	115	(terpri)))
	116
	117	(defmacro print-json (&body body)
	118	`(print-json* (lambda () ,@body)))
	119
	120	;;;--------------------------------------------------------------------------
	121	;;; Host definitions.
	122
	123	(defvar hosts (make-hash-table))
	124
	125	(export 'add-host)
	126	(defun addhost (name alist)
	127	(setf (gethash name hosts) alist))
	128
	129	(export 'defhost)
	130	(defmacro defhost (name &body alist)
	131	`(progn (addhost ',name ',alist) ',name))
	132
	133	(export 'host-plist)
	134	(defun host-plist (name)
	135	(multiple-value-bind (plist foundp) (gethash name hosts)
	136	(unless foundp (error "Host ~S not found" name))
	137	plist))
	138
	139	(export 'hostprop)
	140	(defun hostprop (name prop &optional default)
	141	(multiple-value-bind (found-name value tail)
	142	(get-properties (host-plist name) (list prop))
	143	(declare (ignore found-name))
	144	(if tail
	145	(values value t)
	146	(values default nil))))
	147	(defun (setf hostprop) (value name prop &optional default)
	148	(declare (ignore default))
	149	(let ((plist (host-plist name)))
	150	(multiple-value-bind (found-name found-value tail)
	151	(get-properties plist (list prop))
	152	(declare (ignore found-name found-value))
	153	(if tail
	154	(setf (cadr tail) value)
	155	(setf (gethash name hosts)
	156	(cons prop (cons value plist))))
	157	value)))
	158
	159	(export 'hostprop-default)
	160	(defun hostprop-default (host prop value)
	161	(multiple-value-bind (found-value foundp) (hostprop host prop)
	162	(declare (ignore found-value))
163	(unless foundp (setf (hostprop host prop) value))))
164
165	(export 'hostpropp)
166	(defun hostpropp (host prop)
167	(multiple-value-bind (value foundp) (hostprop host prop)
168	(declare (ignore value))
169	foundp))
170
171	(export 'maphosts)
172	(defun maphosts (func)
173	(maphash (lambda (name plist)
174	(declare (ignore plist))
175	(funcall func name))
176	hosts))
177
178	(export 'dohosts)
179	(defmacro dohosts ((hostvar &optional valueform) &body body)
180	`(block nil (maphosts (lambda (,hostvar) ,@body)) ,valueform))
181
182	;;;--------------------------------------------------------------------------
183	;;; Group definitions.
184
185	(defvar groups nil)
186
187	(export 'add-group)
188	(defun add-group (name type func)
189	(let* ((found (assoc name groups))
190	(list (ecase type
191	(:predicate
192	(let ((list nil))
193	(dohosts (host list)
194	(when (funcall func host) (push host list)))))
195	(:list
196	(funcall func)))))
197	(if found
198	(setf (cdr found) list)
199	(push (cons name list) groups))))
200
201	(export 'defgroup)
202	(defmacro defgroup (name type args &body body)
203	`(progn (add-group ',name ,type
204	,(ecase type
205	(:predicate
206	(destructuring-bind (hostvar) args
207	`(lambda (,hostvar) ,@body)))
208	(:list
209	(destructuring-bind () args
210	`(lambda () ,@body)))))
211	',name))
212
213	;;;--------------------------------------------------------------------------
214	;;; Post-processing hooks.
215
216	(defstruct hook-entry
217	prio
218	func)
219
220	(export '(prio-props prio-groups))
221	(defconstant prio-props 10)
222	(defconstant prio-groups 20)
223
224	(defvar hostproc-hooks nil)
225
226	(export 'addhook)
227	(defun addhook (prio func)
228	(push (make-hook-entry :prio prio :func func) hostproc-hooks))
229
230	(export 'defhook)
231	(defmacro defhook ((prio) &body body)
232	`(addhook ,prio (lambda () ,@body)))
233
234	;;;--------------------------------------------------------------------------
235	;;; Read the input file and hook definitions.
236
237	(defvar progname
238	#.(or compile-file-pathname load-pathname))
239
4ee5e366 MW	240	(defvar user-package
	241	(make-package "ANSIBLE-INVENTORY-USER"
	242	:use '("CL" "ANSIBLE-INVENTORY")))
	243
	244	(defun load-input (file)
	245	(let ((package user-package))
	246	(load file :verbose nil)))
	247
	248	(defun parse-command-line (args)
3f6c5992 MW	249	(loop (let* ((arg (pop args))
	250	(len (length arg)))
	251	(cond ((string= arg "--") (return))
	252	((string= arg "-") (push arg args) (return))
	253	((and (plusp (length arg))
	254	(char= (char arg 0) #\-))
	255	(do ((i 1 (1+ i)))
	256	((>= i len))
	257	(flet ((getarg ()
	258	(cond ((< (1+ i) len)
	259	(prog1 (subseq arg (1+ i))
	260	(setf i len)))
	261	(args
	262	(pop args))
	263	(t
d7003518 MW	264	(error "missing argument")))))
	265	(case (char arg i)
	266	(#\h (format t "usage: ~A FILE ...~%"
	267	(pathname-name progname)))
	268	(t (error "unknown option `-~A'" (char arg i)))))))
3f6c5992	269	(t (push arg args) (return)))))
4ee5e366	270	(mapc #'load-input args))
3f6c5992 MW	271
	272	;;;--------------------------------------------------------------------------
	273	;;; Run the hooks.
	274
4ee5e366 MW	275	(defun run-hooks ()
	276	(setf hostproc-hooks (sort hostproc-hooks #'< :key #'hook-entry-prio))
	277	(mapc (compose #'hook-entry-func #'funcall) hostproc-hooks))
3f6c5992 MW	278
	279	;;;--------------------------------------------------------------------------
	280	;;; Output the definitions.
	281
4ee5e366 MW	282	(defun output ()
	283	(let ((print-right-margin 77))
	284	(print-json
3f6c5992	285	(print-json-map
4ee5e366 MW	286	(print-json-mapping "all"
	287	(print-json-list (maphosts #'print-json-simple)))
	288	(dolist (assoc groups)
	289	(print-json-mapping (car assoc)
	290	(print-json-list
	291	(mapc #'print-json-simple (cdr assoc)))))
	292	(print-json-mapping "_meta"
3f6c5992	293	(print-json-map
4ee5e366 MW	294	(print-json-mapping "hostvars"
	295	(print-json-map
	296	(maphash (lambda (host plist)
	297	(print-json-mapping host
	298	(print-json-map
	299	(do ((plist plist (cddr plist)))
	300	((endp plist))
	301	(print-json-mapping (car plist)
	302	(print-json-simple (cadr plist)))))))
	303	hosts)))))))))
	304
	305	;;;--------------------------------------------------------------------------
	306	;;; Main program.
	307
	308	#+cl-launch
	309	(progn
	310	(parse-command-line cl-launch:arguments)
	311	(run-hooks)
	312	(output))
3f6c5992 MW	313
3f6c5992 MW	314	;;;----- That's all, folks --------------------------------------------------