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