mdw@git.distorted.org.uk Git - distorted-ansible/blob - bin/ansible-inventory

   1 #! /usr/bin/cl-launch -X --
   2 ;;; -*-lisp-*-
   3
   4 (cl:defpackage #:ansible-inventory
   5   (:use #:common-lisp))
   6
   7 (in-package #:ansible-inventory)
   8
   9 (declaim (optimize debug))
  10
  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 (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))))))))
  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
  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)))
  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
 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)
 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
 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)))))))
 269                 (t (push arg args) (return)))))
 270   (mapc #'load-input args))
 271
 272 ;;;--------------------------------------------------------------------------
 273 ;;; Run the hooks.
 274
 275 (defun run-hooks ()
 276   (setf *hostproc-hooks* (sort *hostproc-hooks* #'< :key #'hook-entry-prio))
 277   (mapc (compose #'hook-entry-func #'funcall) *hostproc-hooks*))
 278
 279 ;;;--------------------------------------------------------------------------
 280 ;;; Output the definitions.
 281
 282 (defun output ()
 283   (let ((*print-right-margin* 77))
 284     (print-json
 285       (print-json-map
 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"
 293           (print-json-map
 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))
 313
 314 ;;;----- That's all, folks --------------------------------------------------