Update modules to work with interceptors

bin/ordo.sh

@@ -0,0 +1,5 @@
+#!/usr/bin/env bash
+
+MODULES_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )/../modules" &> /dev/null && pwd )
+
+exec guile -L "${MODULES_DIR}" --no-auto-compile -e '(@ (ordo cli) main)' -- "$@"

bin/play.scm

@@ -1,43 +0,0 @@
-#!/usr/bin/env -S guile --no-auto-compile -e main -s
-!#
-(use-modules (srfi srfi-11)
-             (ice-9 getopt-long)
-             (ice-9 format)
-             (ordo util filesystem))
-
-(define (tar . args)
-  (unless (zero? (apply system* "tar" args))
-    (error (format #f "Non-zero exit from tar ~a" args))))
-
-(define* (usage #:optional errmsg)
-  (with-output-to-port (current-error-port)
-    (lambda ()
-      (when errmsg
-        (format #t "Error: ~a~%~%" errmsg))
-      (display "Usage: play -t TARGET PLAYBOOK")
-      (newline)))
-  (exit (if errmsg EXIT_FAILURE EXIT_SUCCESS)))
-
-(define (process-options args)
-  (let* ((option-spec '((help   (single-char #\h) (value #f))
-                        (target (single-char #\t) (value #t) (required? #t))))
-         (options (getopt-long args option-spec))
-         (help-wanted (option-ref options 'help #f))
-         (target (option-ref options 'target #f))
-         (args   (option-ref options '() '())))
-    (cond
-     (help-wanted (usage))
-     ((not (= 1 (length args)))
-      (usage "Expected exactly one playbook")))
-    (values (canonicalize-path (car args)) target)))
-
-(define (main args)
-  (let-values (((playbook-path target) (process-options args)))
-    (define playbook (load playbook-path))
-    (define top-dir (dirname (dirname (current-filename))))
-    (call-with-temporary-directory
-     (lambda (tmp-dir)
-       (define tarball (string-append tmp-dir "/payload.tar"))
-       (tar "--create" "--file" tarball "--directory" top-dir "modules" "bin")
-       (tar "--append" "--file" tarball "--transform" "s/.*/playbook.scm/" playbook-path)
-       (tar "tf" tarball)))))

examples/interceptor.scm

@@ -1,33 +1,31 @@
 (use-modules
  (ice-9 filesystem)
- (srfi srfi-2)
+ (ordo playbook)
- (srfi srfi-71)
+ (ordo play)
- (logging logger)
- (ordo connection)
  (ordo interceptor)
  (ordo interceptor install-file)
  (ordo interceptor create-tmp-dir)
  (ordo interceptor stat-file)
  (ordo interceptor user-info)
- (ordo interceptor debug)
+ (ordo interceptor debug))
- (ordo logger))
 
-(define chain
+(playbook
-  (list (connection-interceptor (local-connection))
+ #:name "Test some basic filesystem operations"
-        (create-tmp-dir #:register 'tmp-dir)
+ #:vars '((file-content . "This is shadowed by the play variable."))
-        (user-info)
+ #:plays (list (play
-        (debug-vars 'user-info)
+                #:name "Basic filesystem operations"
-        (install-file
+                #:host "localhost"
-         "install-hello"
+                #:vars '((file-content . "Hello, world!\n"))
-         #:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt"))
+                #:interceptors (list (create-tmp-dir #:register 'tmp-dir)
-         #:content "Hello, world!\n"
+                                     (user-info)
-         #:register 'hello)
+                                     (debug-vars 'user-info)
-        (stat-file
+                                     (install-file
-         "stat-hello"
+                                      "install-hello"
-         #:path (let-vars (hello) hello)
+                                      #:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt"))
-         #:register 'hello-stat)
+                                      #:content (let-vars (file-content) file-content)
-        (debug-vars 'hello 'hello-stat)))
+                                      #:register 'hello)
-
+                                     (stat-file
-(setup-logging #:level 'INFO)
+                                      "stat-hello"
-(execute (init-context) chain)
+                                      #:path (let-vars (hello) hello)
-(shutdown-logging)
+                                      #:register 'hello-stat)
+                                     (debug-vars)))))

examples/inventory.scm

@@ -1,4 +1,5 @@
-(use-modules (ordo))
+(use-modules (ordo inventory)
+             (ordo connection))
 
 (add-host! "little-rascal"
            (local-connection)

modules/ordo.scm

@@ -1,10 +0,0 @@
-(define-module (ordo)
-  #:use-module (ice-9 match)
-  #:use-module (ordo playbook)
-  #:use-module (ordo play)
-  #:use-module (ordo task)
-  #:use-module (ordo handler)
-  #:use-module (ordo connection)
-  #:use-module (ordo context)
-  #:use-module (ordo logger)
-  #:re-export (add-host! local-connection ssh-connection current-connection run playbook play task handler $))

modules/ordo/cli.scm

@@ -1,16 +1,20 @@
 (define-module (ordo cli)
+  #:use-module (ice-9 filesystem)
   #:use-module (ice-9 match)
+  #:use-module (logging logger)
   #:use-module (ordo logger)
-  #:use-module (ordo context)
   #:use-module (ordo playbook)
   #:declarative? #f
   #:export (main))
 
 (define (main args)
   (match-let (((_ inventory-path playbook-path) args))
-    (setup-logging #:level 'DEBUG)
+    (let ((inventory-path (expand-file-name inventory-path))
-    (init-context!)
+          (playbook-path (expand-file-name playbook-path)))
-    (load inventory-path)
+      (setup-logging #:level 'INFO)
-    (let ((playbook (load playbook-path)))
+      (load inventory-path)
-      (run-playbook playbook))
+      (log-msg 'DEBUG "Loaded inventory: " inventory-path)
-    (quit)))
+      (let ((playbook (load playbook-path)))
+        (log-msg 'DEBUG "Loaded playbook: " playbook-path)
+        (run-playbook playbook))
+      (quit))))

modules/ordo/condition.scm

@@ -1,6 +1,7 @@
 (define-module (ordo condition)
   #:use-module (srfi srfi-71)
-  #:use-module (ordo context)
+  #:use-module (ordo connection)
+  #:use-module (ordo interceptor)
   #:use-module (ordo action filesystem))
 
 (define-public (cond:any preds)
@@ -25,15 +26,15 @@
 
 (define-public (cond:command-available? cmd-name)
   (lambda (ctx)
-    (let ((_ rc (run "which" `(,cmd-name))))
+    (let ((_ rc (run (context-connection ctx) "which" cmd-name)))
       (zero? rc))))
 
 (define-public (cond:directory? path)
   (lambda (ctx)
-    (let ((st ((action:stat path) ctx)))
+    (let ((st (fs:stat (context-connection ctx) path)))
       (and st (string=? "directory" (assoc-ref st 'file-type))))))
 
 (define-public (cond:regular-file? path)
   (lambda (ctx)
-    (let ((st ((action:stat path) ctx)))
+    (let ((st (fs:stat (context-connection ctx) path)))
       (and st (string=? "regular-file" (assoc-ref st 'file-type))))))

modules/ordo/connection.scm

@@ -9,16 +9,15 @@
   #:use-module (ordo connection local)
   #:use-module (ordo connection ssh)
   #:use-module (ordo connection sudo)
-  #:use-module (ordo interceptor)
   #:use-module (ordo util flatten)
   #:use-module (ordo util shell-quote)
   #:use-module (ordo util keyword-args)
-  #:export (connection-interceptor
+  #:export (connection?
-            connection?
             local-connection
             ssh-connection
             call-with-connection
-            run))
+            run)
+  #:re-export (conn:setup conn:teardown))
 
 (define (connection? c)
   (is-a? c <connection>))
@@ -68,17 +67,3 @@
                                 (make-external-error)
                                 (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog)))))
           (values (return out) rc)))))
-
-(define* (connection-interceptor c #:key sudo? sudo-user sudo-password)
-  "Interceptor to manage the current connection."
-  (interceptor
-   "manage-connection"
-   #:enter (lambda (ctx)
-             (let ((c (if sudo?
-                          (make <sudo-connection> #:connection c #:become-user sudo-user #:become-password sudo-password)
-                          c)))
-               (conn:setup c)
-               (set-context-connection! ctx c)))
-   #:leave (lambda (ctx)
-             (and=> (context-connection ctx) conn:teardown)
-             (set-context-connection! ctx #f))))

modules/ordo/interceptor.scm

@@ -32,7 +32,7 @@
                       (make-exception-with-irritants name)))))
 
 (define-record-type <context>
-  (make-context connection vars stack queue terminators error suppressed)
+  (make-context vars stack queue terminators error suppressed)
   context?
   (connection context-connection set-context-connection!)
   (vars context-vars set-context-vars!)
@@ -42,14 +42,12 @@
   (error context-error set-context-error!)
   (suppressed context-suppressed set-context-suppressed!))
 
-(define* (init-context #:key conn (vars '()))
+(define* (init-context #:key (vars '()))
   "Initialize a context with optional connection and vars."
   (for-each check-var-name (map car vars))
   (make-context
-   ;; connection
-   conn
    ;; vars
-   (alist->hash-table vars equal?)
+   (alist->hash-table vars eqv?)
    ;; stack
    '()
    ;; queue

modules/ordo/interceptor/connection.scm

@@ -0,0 +1,22 @@
+(define-module (ordo interceptor connection)
+  #:use-module (oop goops)
+  #:use-module (ordo interceptor)
+  #:use-module (ordo connection)
+  #:use-module (ordo connection sudo)
+  #:export (connection))
+
+(define* (connection c #:key sudo? sudo-user sudo-password)
+  "Interceptor to manage the current connection."
+  (define (cleanup ctx)
+    (and=> (context-connection ctx) conn:teardown)
+    (set-context-connection! ctx #f))
+  (interceptor
+   "connection"
+   #:enter (lambda (ctx)
+             (let ((c (if sudo?
+                          (make <sudo-connection> #:connection c #:become-user sudo-user #:become-password sudo-password)
+                          c)))
+               (conn:setup c)
+               (set-context-connection! ctx c)))
+   #:leave cleanup
+   #:error cleanup))

modules/ordo/interceptor/user-info.scm

@@ -4,6 +4,7 @@
   #:use-module (srfi srfi-145)
   #:use-module (ordo connection)
   #:use-module (ordo interceptor)
+  #:use-module (ordo util shell-quote)
   #:export (user-info))
 
 (define (parse-id s)
@@ -33,7 +34,7 @@
              (let* ((conn (context-connection ctx))
                     (id (run conn "id"
                              #:check? #t #:return (compose parse-id car)))
-                    (pwent (run conn "getent" "passwd" (assoc-ref id #:user-name)
+                    (pwent (run conn "getent" "passwd" (string-shell-quote (assoc-ref id #:user-name))
                                 #:check? #t #:return (compose parse-passwd-entry car))))
                (var-set! ctx register (fold (lambda (key alist)
                                               (acons key (assoc-ref pwent key) alist))

modules/ordo/inventory.scm

@@ -1,15 +1,18 @@
-(define-module (ordo host)
+(define-module (ordo inventory)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
-  #:use-module (ordo connection)
+  #:use-module ((ordo connection) #:select (local-connection))
   #:export (make-host
             host?
             host-name
             host-connection
             host-tags
+            add-host!
             resolve-hosts))
 
+(define *inventory* '())
+
 (define-record-type <host>
   (make-host name connection tags)
   host?
@@ -17,6 +20,10 @@
   (connection host-connection)
   (tags host-tags))
 
+(define (add-host! name connection . tags)
+  (set! *inventory* (cons (make-host name connection tags)
+                          *inventory*)))
+
 (define (tagged-all? wanted-tags)
   (lambda (h)
     (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags))))
@@ -29,11 +36,11 @@
   (lambda (h)
     (string=? (host-name h) hostname)))
 
-(define (resolve-hosts inventory)
+(define resolve-hosts
   (match-lambda
-    ("localhost" (list (or (find (named? "localhost") inventory)
+    ("localhost" (list (or (find (named? "localhost") *inventory*)
                            (make-host "localhost" (local-connection) '()))))
-    ((? string? hostname) (filter (named? hostname) inventory))
+    ((? string? hostname) (filter (named? hostname) *inventory*))
-    ('all inventory)
+    ('all *inventory*)
-    (('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) inventory))
+    (('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) *inventory*))
-    (('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) inventory))))
+    (('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) *inventory*))))

modules/ordo/play.scm

@@ -3,12 +3,10 @@
   #:use-module (srfi srfi-26)
   #:use-module (logging logger)
   #:use-module (ordo connection)
-  #:use-module (ordo context)
+  #:use-module (ordo interceptor)
-  #:use-module (ordo task)
+  #:use-module (ordo interceptor connection)
-  #:use-module (ordo handler)
+  #:use-module (ordo inventory)
-  #:use-module (ordo context)
+  #:use-module (ordo util flatten)
-  #:use-module (ordo host)
-  #:use-module (ordo facts)
   #:export (play
             play?
             play-host
@@ -16,13 +14,11 @@
             play-sudo-user
             play-sudo-password
             play-vars
-            play-tasks
+            play-interceptors
-            play-handlers
-            play-gather-facts
             run-play))
 
 (define-record-type <play>
-  (make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers)
+  (make-play name host sudo? sudo-user sudo-password vars interceptors)
   play?
   (name play-name)
   (host play-host)
@@ -30,42 +26,24 @@
   (sudo-user play-sudo-user)
   (sudo-password play-sudo-password)
   (vars play-vars)
-  (tasks play-tasks)
+  (interceptors play-interceptors))
-  (handlers play-handlers)
-  (gather-facts play-gather-facts))
 
-(define* (play name #:key host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (gather-facts #t) . more)
+(define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (interceptors '()))
-  (let ((tasks (filter task? more))
+  (make-play name host sudo? sudo-user sudo-password vars interceptors))
-        (handlers (filter handler? more)))
-    (make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers)))
 
-(define (run-play p)
+(define (run-play p playbook-vars)
   (log-msg 'NOTICE "Running play: " (play-name p))
-  (let ((hosts ((resolve-hosts (current-inventory)) (play-host p))))
+  (let ((hosts (resolve-hosts (play-host p))))
     (if (null? hosts)
         (log-msg 'WARN "No hosts matched: " (play-host p))
-        (for-each (lambda (h) (run-host-play p h)) hosts))))
+        (for-each (lambda (h) (run-host-play p h playbook-vars)) hosts))))
 
-(define (run-host-play p h)
+(define (run-host-play p h playbook-vars)
   (log-msg 'NOTICE "Running play: " (play-name p) " on host: " (host-name h))
-  (call-with-connection
+  (let ((chain (flatten (cons (connection (host-connection h)
-   (host-connection h)
+                                          #:sudo? (play-sudo? p)
-   (play-sudo? p)
+                                          #:sudo-user (play-sudo-user p)
-   (play-sudo-user p)
+                                          #:sudo-password (play-sudo-password p))
-   (play-sudo-password p)
+                              (play-interceptors p))))
-   (lambda (conn)
+        (ctx (init-context #:vars (append (play-vars p) playbook-vars))))
-     (dynamic-wind
+    (execute ctx chain)))
-       (lambda ()
-         (set-current-connection! conn)
-         (set-current-host! (host-name h))
-         (init-play-vars! (play-vars p)))
-       (lambda ()
-         (when (play-gather-facts p) (gather-facts))
-         (for-each run-task (play-tasks p))
-         (for-each run-handler
-                   (filter (compose play-triggered? handler-name) (play-handlers p))))
-       (lambda ()
-         (set-current-connection! #f)
-         (set-current-host! #f)
-         (reset-play-vars!)
-         (reset-play-triggers!))))))

modules/ordo/playbook.scm

@@ -1,8 +1,8 @@
 (define-module (ordo playbook)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
   #:use-module (logging logger)
   #:use-module (ordo play)
-  #:use-module (ordo context)
   #:export (playbook
             playbook?
             playbook-name
@@ -17,15 +17,10 @@
   (vars playbook-vars)
   (plays playbook-plays))
 
-(define* (playbook name #:key (vars '()) . plays)
+(define* (playbook #:key name (vars '()) plays)
   (make-playbook name vars plays))
 
 (define (run-playbook pb)
   (log-msg 'NOTICE "Running playbook: " (playbook-name pb))
-  (dynamic-wind
+  (for-each (cut run-play <> (playbook-vars pb))
-    (lambda ()
+            (playbook-plays pb)))
-      (init-playbook-vars! (playbook-vars pb)))
-    (lambda ()
-      (for-each run-play (playbook-plays pb)))
-    (lambda ()
-      (reset-playbook-vars!))))