Very early initial commit.

[distorted-ansible] / bin / ansible-inventory

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

(cl:defpackage #:ansible-inventory
  (:use #:common-lisp)
  (:import-from #:cl-launch #:*arguments*))

(in-package #:ansible-inventory)

;;;--------------------------------------------------------------------------
;;; 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*))

(let ((pkg (make-package "ANSIBLE-INVENTORY-USER"
                         :use '("CL" "ANSIBLE-INVENTORY")))
      (args *arguments*))
  (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)))))
  (format t ";; remaining args = ~S~%" args)
  (dolist (arg args)
    (let ((*package* pkg))
      (load arg :verbose nil))))

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

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

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

(setf *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*)))))))

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