Improvements to interceptors

examples/interceptor.scm

@@ -1,30 +1,32 @@
 (use-modules
  (ice-9 filesystem)
+ (srfi srfi-2)
+ (srfi srfi-71)
  (logging logger)
  (ordo connection)
  (ordo interceptor)
- (ordo interceptor tmp-dir)
+ (ordo interceptor install-file)
+ (ordo interceptor create-tmp-dir)
+ (ordo interceptor stat-file)
+ (ordo interceptor user-info)
  (ordo interceptor debug)
- (ordo action filesystem)
  (ordo logger))
 
 (define chain
   (list (connection-interceptor (local-connection))
-        (tmp-dir-interceptor #:tmp-dir)
-        (interceptor
-         "install hello"
-         #:enter (lambda (ctx)
-                   (fs:install-file (context-connection ctx)
-                                    (file-name-join* (var-ref ctx #:tmp-dir) "hello.txt")
-                                    #:content "Hello, world!\n"))
-         #:register #:hello)
-        (interceptor
-         "stat hello"
-         #:enter (lambda (ctx)
-                   (fs:stat (context-connection ctx) (var-ref ctx #:hello)))
-         #:register #:hello-stat)
-        (debug-vars-interceptor #:hello #:hello-stat)
-        (debug-vars-interceptor)))
+        (create-tmp-dir #:register 'tmp-dir)
+        (user-info)
+        (debug-vars 'user-info)
+        (install-file
+         "install-hello"
+         #:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt"))
+         #:content "Hello, world!\n"
+         #:register 'hello)
+        (stat-file
+         "stat-hello"
+         #:path (let-vars (hello) hello)
+         #:register 'hello-stat)
+        (debug-vars 'hello 'hello-stat)))
 
 (setup-logging #:level 'INFO)
 (execute (init-context) chain)

modules/ordo/action/quadlet.scm

@@ -0,0 +1,41 @@
+(define-module (ordo action quadlet)
+  #:use-module (ice-9 filesystem)
+  #:use-module (ini)
+  #:use-module (logging logger)
+  #:use-module (ordo connection)
+  #:use-module (ordo action filesystem)
+  #:export (create-network-quadlet))
+
+(define quadlet-dir "/etc/containers/systemd")
+
+(define default-install-options '(("WantedBy" . "multi-user.target default.target")))
+
+(define (scm->ini-string data)
+  (with-output-to-string (lambda () (scm->ini data))))
+
+(define (build-quadlet quadlet-type name description unit-options quadlet-options install-options)
+  (let* ((description (or description (string-append "Podman " (string-downcase quadlet-type) " " name)))
+         (data `(("Unit" ("Description" . ,description) ,@unit-options)
+                 (,(string-titlecase quadlet-type) ,@quadlet-options)
+                 ("Install" ,@(or install-options default-install-options)))))
+    (scm->ini-string data)))
+
+(define-syntax define-quadlet-type
+  (syntax-rules ()
+    ((define-quadlet-type function-name quadlet-type suffix default-install-options)
+     (define* (function-name conn name #:key description (quadlet-options '()) (unit-options '()) (install-options default-install-options))
+       (fs:install-file conn
+                        (file-name-join* quadlet-dir (string-append name suffix))
+                        #:content (build-quadlet quadlet-type name description quadlet-options unit-options install-options))))))
+
+(define-quadlet-type create-network-quadlet "Network" ".network" default-install-options)
+
+(define-quadlet-type create-pod-quadlet "Pod" ".pod" default-install-options)
+
+(define-quadlet-type create-container-quadlet "Container" ".container" default-install-options)
+
+(define-quadlet-type create-volume-quadlet "Volume" ".volume" '())
+
+(define-quadlet-type create-build-quadlet "Build" ".build" '())
+
+(define-quadlet-type create-image-quadlet "Image" ".image" '())

modules/ordo/context.scm

@@ -1,152 +0,0 @@
-(define-module (ordo context)
-  #:use-module (ice-9 exceptions)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-69)
-  #:use-module (logging logger)
-  #:use-module (ordo host)
-  #:export (init-context!
-            set-current-connection!
-            current-connection
-            current-host
-            set-current-host!
-            init-playbook-vars!
-            get-playbook-var
-            set-playbook-var!
-            reset-playbook-vars!
-            init-play-vars!
-            get-play-var
-            set-play-var!
-            reset-play-vars!
-            get-command-line-var
-            set-command-line-var!
-            $
-            reset-play-triggers!
-            add-play-triggers!
-            play-triggered?
-            set-filter-tag!
-            reset-filter-tags!
-            check-filter-tags
-            add-host!
-            current-inventory))
-
-(define *current-context* #f)
-
-(define-record-type <context>
-  (make-context)
-  context?
-  (connection connection set-connection!)
-  (hostname hostname set-hostname!)
-  (command-line-vars command-line-vars set-command-line-vars!)
-  (play-vars play-vars set-play-vars!)
-  (play-triggers play-triggers set-play-triggers!)
-  (playbook-vars playbook-vars set-playbook-vars!)
-  (filter-tags filter-tags set-filter-tags!)
-  (inventory inventory set-inventory!))
-
-(define (init-context!)
-  (set! *current-context* (make-context)))
-
-(define not-found (cons 'not-found '()))
-
-(define (not-found? x) (eq? x not-found))
-
-(define (set-current-connection! conn)
-  (set-connection! *current-context* conn))
-
-(define (current-connection)
-  (connection *current-context*))
-
-(define (set-current-host! hostname)
-  (set-hostname! *current-context* hostname))
-
-(define (current-host)
-  (hostname *current-context*))
-
-(define (init-playbook-vars! alist)
-  (set-playbook-vars! *current-context* (alist->hash-table alist eqv?)))
-
-(define (get-playbook-var var-name)
-  (if (playbook-vars *current-context*)
-      (hash-table-ref/default (playbook-vars *current-context*) var-name not-found)
-      not-found))
-
-(define (set-playbook-var! var-name val)
-  (unless (playbook-vars *current-context*)
-    (set-playbook-vars! *current-context* (make-hash-table eqv?)))
-  (hash-table-set! (playbook-vars *current-context*) var-name val))
-
-(define (reset-playbook-vars!)
-  (set-playbook-vars! *current-context* #f))
-
-(define (init-play-vars! alist)
-  (set-play-vars! *current-context* (alist->hash-table alist eqv?)))
-
-(define (get-play-var var-name)
-  (if (play-vars *current-context*)
-      (hash-table-ref/default (play-vars *current-context*) var-name not-found)
-      not-found))
-
-(define (set-play-var! var-name val)
-  (unless (play-vars *current-context*)
-    (set-play-vars! *current-context* (make-hash-table equal?)))
-  (hash-table-set! (play-vars *current-context*) var-name val))
-
-(define (reset-play-vars!)
-  (set-play-vars! *current-context* #f))
-
-(define (get-command-line-var var-name)
-  (if (command-line-vars *current-context*)
-      (hash-table-ref/default (command-line-vars *current-context*) var-name not-found)
-      not-found))
-
-(define (set-command-line-var! var-name val)
-  (unless (command-line-vars *current-context*)
-    (set-command-line-vars! *current-context* (make-hash-table eqv?)))
-  (hash-table-set! (command-line-vars *current-context*) var-name val))
-
-(define ($ var-name)
-  "Try to resolve var-name as a command-line variable, a play variable or a
-playbook variable (in that order). Raise an exception if the variable is not
-found."
-  (define (lookup-var procs)
-    (if (null? procs)
-        (raise-exception (make-exception
-                          (make-undefined-variable-error)
-                          (make-exception-with-irritants var-name)))
-        (let ((v ((car procs) var-name)))
-          (if (not-found? v)
-              (lookup-var (cdr procs))
-              v))))
-  (lookup-var (list get-command-line-var get-play-var get-playbook-var)))
-
-(define (reset-play-triggers!)
-  (set-play-triggers! *current-context* #f))
-
-(define (add-play-triggers! triggers)
-  (set-play-triggers! *current-context*
-                      (apply lset-adjoin equal? (or (play-triggers *current-context*) '())
-                             triggers)))
-
-(define (play-triggered? trigger)
-  (and=> (play-triggers *current-context*) (cut member trigger <>)))
-
-(define (set-filter-tag! tag)
-  (set-filter-tags! *current-context*
-                    (lset-adjoin equal? (or (filter-tags *current-context*) '()) tag)))
-
-(define (reset-filter-tags!)
-  (set-filter-tags! *current-context* #f))
-
-(define (check-filter-tags tags)
-  (or (not (filter-tags *current-context*))
-      (not (null? (lset-intersection eqv? (filter-tags *current-context*) tags)))))
-
-(define (current-inventory)
-  (or (inventory *current-context*) '()))
-
-(define (add-host! hostname connection . tags)
-  (log-msg 'DEBUG "Adding host to inventory: " hostname)
-  (set-inventory! *current-context* (cons (make-host hostname connection tags)
-                                          (or (inventory *current-context*) '()))))

modules/ordo/facts.scm

@@ -1,19 +0,0 @@
-(define-module (ordo facts)
-  #:use-module ((srfi srfi-88) #:select (string->keyword))
-  #:use-module (ordo context)
-  #:use-module (ordo facts user)
-  #:export (gather-facts))
-
-(define (set-facts! src keys)
-  (for-each (lambda (k)
-              (set-play-var! (string->keyword (string-append "fact." k))
-                             (assoc-ref src (string->keyword k))))
-            keys))
-
-(define (gather-facts)
-  (let* ((conn (current-connection))
-         (id (fact:id conn))
-         (user-name (assoc-ref id #:user-name))
-         (pwent (fact:pwent conn user-name)))
-    (set-facts! id '("user-name" "user-id" "group-name" "group-id" "groups"))
-    (set-facts! pwent '("gecos" "home-dir" "shell"))))

modules/ordo/facts/user.scm

@@ -1,32 +0,0 @@
-(define-module (ordo facts user)
-  #:use-module (rx irregex)
-  #:use-module (srfi srfi-1)
-  #:use-module (ordo connection)
-  #:export (fact:id
-            fact:pwent))
-
-(define (parse-id-output s)
-  (let ((data (reverse (irregex-fold (irregex '(seq (=> id integer) "(" (=> name (+ alphanumeric)) ")"))
-                                     (lambda (_ m accum)
-                                       (cons `((#:id . ,(string->number (irregex-match-substring m 'id)))
-                                               (#:name . ,(irregex-match-substring m 'name)))
-                                             accum))
-                                     '()
-                                     s))))
-    `((#:user-id . ,(assoc-ref (first data) #:id))
-      (#:user-name . ,(assoc-ref (first data) #:name))
-      (#:group-id . ,(assoc-ref (second data) #:id))
-      (#:group-name . ,(assoc-ref (second data) #:name))
-      (#:groups . ,(drop data 2)))))
-
-(define (fact:id conn)
-  (run conn "id" #:check? #t #:return (compose parse-id-output car)))
-
-(define (parse-passwd-entry s)
-  (map cons
-       '(#:user-name #:password #:user-id #:group-id #:gecos #:home-dir #:shell)
-       (string-split s #\:)))
-
-(define (fact:pwent conn user-name)
-  (run conn "getent" "passwd" user-name
-       #:check? #t #:return (compose parse-passwd-entry car)))

modules/ordo/handler.scm

@@ -1,25 +0,0 @@
-(define-module (ordo handler)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-9) ; records
-  #:use-module (logging logger)
-  #:use-module (ordo context)
-  #:export (handler
-            handler?
-            handler-name
-            handler-action
-            run-handler))
-
-(define-record-type <handler>
-  (make-handler name action)
-  handler?
-  (name handler-name)
-  (action handler-action))
-
-(define (handler name action)
-  (make-handler name action))
-
-(define (run-handler h)
-  (match h
-    (($ <handler> name action)
-     (log-msg 'NOTICE "Running handler: " name)
-     (action (current-connection)))))

modules/ordo/interceptor.scm

@@ -1,11 +1,12 @@
 (define-module (ordo interceptor)
   #:use-module (ice-9 exceptions)
   #:use-module (logging logger)
-  #:use-module (srfi srfi-1)  ; list utils
-  #:use-module (srfi srfi-9)  ; records
-  #:use-module (srfi srfi-26) ; cut
-  #:use-module (srfi srfi-69) ; hash tables
-  #:use-module (srfi srfi-71) ; extended let
+  #:use-module (srfi srfi-1)   ; list utils
+  #:use-module (srfi srfi-9)   ; records
+  #:use-module (srfi srfi-26)  ; cut
+  #:use-module (srfi srfi-69)  ; hash tables
+  #:use-module (srfi srfi-71)  ; extended let
+  #:use-module (srfi srfi-145) ; assume
   #:export (interceptor
             init-context
             context-connection
@@ -18,14 +19,16 @@
             var-ref
             var-set!
             var-delete!
+            let-vars
+            expand-vars
             terminate-when
             execute))
 
 (define (check-var-name name)
-  (unless (keyword? name)
+  (unless (symbol? name)
     (raise-exception (make-exception
                       (make-assertion-failure)
-                      (make-exception-with-message "Variable name should be a keyword")
+                      (make-exception-with-message "Variable name should be a symbol")
                       (make-exception-with-irritants name)))))
 
 (define-record-type <context>
@@ -73,18 +76,34 @@
   (log-msg 'DEBUG "Deleting variable " name)
   (hash-table-delete! (context-vars ctx) name))
 
+(define-syntax let-vars
+  (syntax-rules ()
+    ((let-vars (var-name ...) expr exprs ...)
+     (lambda (ctx)
+       #((delayed-var-ref? . #t))
+       (let ((var-name (hash-table-ref (context-vars ctx) 'var-name)) ...)
+         expr
+         exprs ...)))))
+
+(define-syntax expand-vars
+  (syntax-rules ()
+    ((expand-vars ctx v ...)
+     (values (if (and (procedure? v) (procedure-property v 'delayed-var-ref?))
+                 (v ctx)
+                 v)
+             ...))))
+
 (define-record-type <interceptor>
-  (make-interceptor name enter leave error register)
+  (make-interceptor name enter leave error)
   interceptor?
   (name interceptor-name)
   (enter interceptor-enter)
   (leave interceptor-leave)
-  (error interceptor-error)
-  (register interceptor-register))
+  (error interceptor-error))
 
-(define* (interceptor name #:key enter leave error register)
-  "Create an interceptor with optional enter, leave, and error functions."
-  (make-interceptor name enter leave error register))
+(define* (interceptor name #:key enter leave error)
+  (assume (string? name) "interceptor name should be a string" name)
+  (make-interceptor name enter leave error))
 
 (define-exception-type &interceptor-error &error
   make-interceptor-error
@@ -120,11 +139,8 @@
       (log-msg 'NOTICE "Running #:enter function for " (interceptor-name t))
       (with-exception-handler
           (lambda (e)
-            (set-context-error! ctx
-                                (make-interceptor-error (interceptor-name t) #:enter e)))
-        (lambda ()
-          (let ((result (handler ctx)))
-            (and=> (interceptor-register t) (cut var-set! ctx <> result))))
+            (set-context-error! ctx (make-interceptor-error (interceptor-name t) #:enter e)))
+        (lambda () (handler ctx))
         #:unwind? #t))))
 
 (define (try-leave ctx t)

modules/ordo/interceptor/create-tmp-dir.scm

@@ -0,0 +1,19 @@
+(define-module (ordo interceptor create-tmp-dir)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-145)
+  #:use-module (ordo interceptor)
+  #:use-module (ordo action filesystem)
+  #:export (create-tmp-dir))
+
+(define* (create-tmp-dir #:key (register 'tmp-dir))
+  (assume (symbol? register) "register should be a symbol" register)
+  (define (cleanup ctx)
+    (and-let* ((tmp-dir (var-ref ctx register)))
+      (fs:remove (context-connection ctx) tmp-dir #:recurse? #t)
+      (var-delete! ctx register)))
+  (interceptor
+   (format #f "create-tmp-dir ~a" register)
+   #:enter (lambda (ctx)
+             (var-set! ctx register (fs:create-tmp-dir (context-connection ctx))))
+   #:leave cleanup
+   #:error cleanup))

modules/ordo/interceptor/debug.scm

@@ -3,9 +3,9 @@
   #:use-module ((srfi srfi-1) #:select (concatenate))
   #:use-module ((srfi srfi-69) #:select (hash-table-keys))
   #:use-module (ordo interceptor)
-  #:export (debug-vars-interceptor))
+  #:export (debug-vars))
 
-(define (debug-vars-interceptor . var-names)
+(define (debug-vars . var-names)
   (interceptor
    "debug-vars"
    #:enter (lambda (ctx)

modules/ordo/interceptor/errors.scm

@@ -1,14 +0,0 @@
-(define-module (ordo interceptor errors)
-  #:use-module (logging logger)
-  #:use-module (srfi srfi-26)
-  #:use-module (ordo interceptor)
-  #:export (errors-interceptor))
-
-(define (errors-interceptor)
-  "Interceptor to log (and clear) the context error. This will allow any
-   earlier #:leave handlers in the chain to run normally."
-  (interceptor
-   "handle-errors"
-   #:error (lambda (ctx)
-             (and=> (context-error ctx) (cut log-msg 'ERROR <>))
-             (set-context-error! ctx #f))))

modules/ordo/interceptor/install-file.scm

@@ -0,0 +1,28 @@
+(define-module (ordo interceptor install-file)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-145)
+  #:use-module (ordo interceptor)
+  #:use-module (ordo action filesystem)
+  #:export (install-file))
+
+(define* (install-file name #:key path owner group mode content
+                       local-src remote-src backup? register)
+  (assume path "install path is required")
+  (assume (or (not register) (symbol? register)) "register should be a symbol" register)
+  (assume (= 1 (length (filter identity (list content local-src remote-src))))
+          "exactly one of content, local-src, or remote-src is required")
+  (interceptor
+   name
+   #:enter (lambda (ctx)
+             (let ((path (expand-vars ctx path)))
+               (fs:install-file (context-connection ctx)
+                                path
+                                #:owner (expand-vars ctx owner)
+                                #:group (expand-vars ctx group)
+                                #:mode (expand-vars ctx mode)
+                                #:content (expand-vars ctx content)
+                                #:local-src (expand-vars ctx local-src)
+                                #:remote-src (expand-vars ctx remote-src)
+                                #:backup? (expand-vars ctx backup?))
+               (when register
+                 (var-set! ctx register path))))))

modules/ordo/interceptor/stat-file.scm

@@ -0,0 +1,17 @@
+(define-module (ordo interceptor stat-file)
+  #:use-module (srfi srfi-145)
+  #:use-module (ordo interceptor)
+  #:use-module (ordo action filesystem)
+  #:export (stat-file))
+
+(define* (stat-file name #:key path register)
+  (assume (string? name) "name is required and should be a string" name)
+  (assume path "path is required" path)
+  (assume (or (not register) (symbol? register)) "register should be a symbol" register)
+  (interceptor
+   name
+   #:enter (lambda (ctx)
+             (let* ((path (expand-vars ctx path))
+                    (st (fs:stat (context-connection ctx) path)))
+               (when register
+                 (var-set! ctx register st))))))

modules/ordo/interceptor/tmp-dir.scm

@@ -1,20 +0,0 @@
-(define-module (ordo interceptor tmp-dir)
-  #:use-module (ice-9 format)
-  #:use-module (ordo connection)
-  #:use-module (ordo interceptor)
-  #:export (tmp-dir-interceptor))
-
-(define (tmp-dir-interceptor var-name)
-  (define (create-tmp-dir ctx)
-    (run (context-connection ctx) "mktemp" "--directory" #:check? #t #:return car))
-  (define (cleanup-tmp-dir ctx)
-    (and=> (var-ref ctx var-name #f)
-           (lambda (dir-name)
-             (run (context-connection ctx) "rm" "-rf" dir-name)))
-    (var-delete! ctx var-name))
-  (interceptor
-   (format #f "manage-tmp-dir ~a" var-name)
-   #:enter create-tmp-dir
-   #:register var-name
-   #:leave cleanup-tmp-dir
-   #:error cleanup-tmp-dir))

modules/ordo/interceptor/user-info.scm

@@ -0,0 +1,43 @@
+(define-module (ordo interceptor user-info)
+  #:use-module (rx irregex)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-145)
+  #:use-module (ordo connection)
+  #:use-module (ordo interceptor)
+  #:export (user-info))
+
+(define (parse-id s)
+  (let ((data (reverse (irregex-fold (irregex '(seq (=> id integer) "(" (=> name (+ alphanumeric)) ")"))
+                                     (lambda (_ m accum)
+                                       (cons `((#:id . ,(string->number (irregex-match-substring m 'id)))
+                                               (#:name . ,(irregex-match-substring m 'name)))
+                                             accum))
+                                     '()
+                                     s))))
+    `((#:user-id . ,(assoc-ref (first data) #:id))
+      (#:user-name . ,(assoc-ref (first data) #:name))
+      (#:group-id . ,(assoc-ref (second data) #:id))
+      (#:group-name . ,(assoc-ref (second data) #:name))
+      (#:groups . ,(drop data 2)))))
+
+(define (parse-passwd-entry s)
+  (map cons
+       '(#:user-name #:password #:user-id #:group-id #:gecos #:home-dir #:shell)
+       (string-split s #\:)))
+
+(define* (user-info #:key (register 'user-info))
+  (assume (symbol? register) "register should be a symbol" register)
+  (interceptor
+   "user-info"
+   #:enter (lambda (ctx)
+             (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)
+                                #:check? #t #:return (compose parse-passwd-entry car))))
+               (var-set! ctx register (fold (lambda (key alist)
+                                              (acons key (assoc-ref pwent key) alist))
+                                            id
+                                            (list #:gecos #:home-dir #:shell)))))
+   #:leave (lambda (ctx) (var-delete! ctx register))
+   #:error (lambda (ctx) (var-delete! ctx register))))

modules/ordo/task.scm

@@ -1,48 +0,0 @@
-(define-module (ordo task)
-  #:use-module (srfi srfi-9)
-  #:use-module (logging logger)
-  #:use-module (ordo context)
-  #:export (task
-            task?
-            task-name
-            task-tags
-            task-action
-            task-condition
-            task-register-play-var
-            task-register-playbook-var
-            task-triggers
-            run-task))
-
-(define-record-type <task>
-  (make-task name tags action condition register-play-var register-playbook-var triggers)
-  task?
-  (name task-name)
-  (tags task-tags)
-  (action task-action)
-  (condition task-condition)
-  (register-play-var task-register-play-var)
-  (register-playbook-var task-register-playbook-var)
-  (triggers task-triggers))
-
-(define* (%task name action #:key (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '()))
-  (make-task name tags action condition register-play-var register-playbook-var triggers))
-
-(define-syntax task
-  (syntax-rules ()
-    ((task (f args ...) kwargs ...)
-     (%task (symbol->string 'f) (lambda () (f args ...) kwargs ...)))
-    ((task name (f args ...) kwargs ...)
-     (%task name (lambda () (f args ...)) kwargs ...))))
-
-(define (run-task t)
-  (when (check-filter-tags (task-tags t))
-    (if (not ((task-condition t)))
-        (log-msg 'NOTICE "Skipping task: " (task-name t) " (precondition not met)")
-        (begin
-          (log-msg 'NOTICE "Running task: " (task-name t))
-          (let ((result ((task-action t))))
-            (when (task-register-play-var t)
-              (set-play-var! (task-register-play-var t) result))
-            (when (task-register-playbook-var t)
-              (set-playbook-var! (task-register-playbook-var t) result))
-            (add-play-triggers! (task-triggers t)))))))