Some actions, and fleshing out playbook/tasks

examples/forgejo.scm

@@ -0,0 +1,62 @@
+(use-modules
+ ((ordo action filesystem) #:prefix fs:)
+ ((ordo action quadlet) #:prefix quadlet:)
+ ((ordo action systemctl) #:prefix systemctl:))
+
+(define* (install-forgejo #:key (version "11"))
+  (list
+   (task "Install configuration directory"
+         #:action fs:install-dir
+         #:args '((#:path . "/etc/forgejo"))
+         #:trigger '("Restart pod"))
+   (task "Install timezone configuration"
+         #:action fs:install-file
+         #:args '((#:path . "/etc/forgejo/timezone")
+                  (#:local-src . "files/timezone"))
+         #:trigger '("Restart pod"))
+   (task "Install localtime configuration"
+         #:action fs:install-file
+         #:args '((#:path . "/etc/forgejo/localtime")
+                  (#:local-src . "files/localtime")))
+   (task "Create data volume quadlet"
+         #:action quadlet:create-volume
+         #:args '((#:name . "forgejo")
+                  (#:description . "Forgejo data volume"))
+         #:trigger '("Reload systemd" "Restart pod"))
+   (task "Create pod quadlet"
+         #:action quadlet:create-pod
+         #:args '((#:name . "forgejo")
+                  (#:quadlet-options . ((PodName . "forge")
+                                        (Volume . "forgejo.volume:U,Z")
+                                        (PodmanArgs . "--userns auto"))))
+         #:trigger '("Reload systemd" "Restart pod"))
+   (task "Create image quadlet"
+         #:action quadlet:create-image
+         #:args `((#:name . "forgejo")
+                  (#:image . (Image . ,(format #f "codeberg.org/forgejo/forgejo:~a" version))))
+         #:trigger '("Reload systemd" "Restart pod"))
+   (task "Create container quadlet"
+         #:action quadlet:create-container
+         #:args '((#:name . "forgejo")
+                  (#:container . ((Pod . "forgejo.pod")
+                                  (Image . "forgejo.image")
+                                  (Network . "services.network")
+                                  (Volume . "/etc/forgejo/timezone:/etc/timezone:ro,U,Z")
+                                  (Volume . "/etc/forgejo/localtime:/etc/localtime:ro,U,Z")
+                                  (Environment . "USER_UID=1000")
+                                  (Environment . "USER_GID=1000")
+                                  (Environment . "FORGEJO__service__DISABLE_REGISTRATION=true")
+                                  (Environment . "FORGEJO__webhook__ALLOWED_HOST_LIST=private"))))
+         #:trigger '("Reload systemd" "Restart pod"))
+   (handler "Reload systemd"
+            #:action systemctl:daemon-reload)
+   (handler "Restart pod"
+            #:action systemctl:restart-unit
+            #:args '((#:unit . "forgejo-pod.service")))))
+
+(playbook "Install Forgejo on limiting-factor"
+          ;; #:vars '((forgejo-version . "11.0.2"))
+          (play
+           #:host "limiting-factor"
+           #:become? #t
+           (install-forgejo #:version "11")))

ordo/action/filesystem.scm

@@ -0,0 +1,138 @@
+(define-module (ordo action filesystem)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 match)
+  #:use-module (logging logger)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1) ; list utils
+  #:use-module (srfi srfi-26) ; cut
+  #:use-module (srfi srfi-71) ; extended let
+  #:use-module ((ordo connection) #:select (remote-cmd))
+  #:use-module (ordo connection base)
+  #:export (create-tmp-dir
+            install-dir
+            install-file
+            file-info
+            delete
+            link))
+
+(define* (file-info conn #:key path (atime? #t) (ctime? #t))
+  (define (parse-stat-result s)
+    (match-let* (((file-type user group . rest) (string-split s #\:))
+                 ((uid gid size mode atime mtime ctime) (map string->number rest)))
+      `((file-type . ,file-type)
+        (user . ,user)
+        (group . ,group)
+        (uid . ,uid)
+        (gid . ,gid)
+        (size . ,size)
+        (mode . ,mode)
+        ,@(if atime? (list (cons 'atime atime)) '())
+        (mtime . ,mtime)
+        ,@(if ctime? (list (cons 'ctime ctime)) '()))))
+  (let ((result rc (remote-cmd conn "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path))))
+    (cond
+     ((zero? rc) (parse-stat-result (first result)))
+     ((string-contains (first result) "No such file or directory") #f)
+     (else (error (format #f "stat ~a: ~a" path (first result)))))))
+
+(define-syntax changed-if-stat-changed
+  (syntax-rules ()
+    ((changed-if-stat-changed conn path expr ...)
+     (let ((st-before (file-info conn #:path path #:atime? #f #:ctime? #f)))
+       expr ...
+       (let ((st-after (file-info conn #:path path #:atime? #f #:ctime? #f)))
+         (not (equal? st-before st-after)))))))
+
+(define* (delete conn #:key path (recurse? #f))
+  (changed-if-stat-changed
+   conn path
+   (remote-cmd conn "rm" "-f"
+               (when recurse? "-r")
+               path
+               #:check? #t)))
+
+(define* (link conn #:key target link-name (symbolic? #f) (force? #t) (backup? #f))
+  "Create a link to @code{target} with the name @code{link-name}."
+  (changed-if-stat-changed
+   conn link-name
+   (remote-cmd conn "ln"
+               (when symbolic? "--symbolic")
+               (when force? "--force")
+               (when backup? "--backup=numbered")
+               target
+               link-name
+               #:check? #t)))
+
+(define* (create-tmp-dir conn #:key tmpdir suffix template)
+  (remote-cmd conn "mktemp" "--directory"
+              (when tmpdir '("--tmpdir" tmpdir))
+              (when suffix '("--suffix" suffix))
+              (when template template)
+              #:check? #t
+              #:return car))
+
+(define* (install-dir conn #:key path owner group mode)
+  (when (integer? mode)
+    (set! mode (number->string mode 8)))
+  (changed-if-stat-changed
+   conn path
+   (remote-cmd conn "install" "--directory"
+               (when owner `("--owner" ,owner))
+               (when group `("--group" ,group))
+               (when mode `("--mode" ,mode))
+               path
+               #:check? #t)))
+
+(define (upload-tmp-file conn tmp-file)
+  (lambda (input-port)
+    (with-remote-output-file conn tmp-file
+                             (lambda (output-port)
+                               (let loop ((data (get-bytevector-some input-port)))
+                                 (unless (eof-object? data)
+                                   (put-bytevector output-port data)
+                                   (loop (get-bytevector-some input-port))))
+                               (close-port output-port)))))
+
+(define (install-remote-file conn src dest owner group mode backup?)
+  ;; If owner/group/mode is unspecified and the destination file already exists,
+  ;; preserve the current ownership and mode.
+  (unless (and owner group mode)
+    (let ((st (file-info conn #:path dest)))
+      (when st
+        (set! owner (or owner (assoc-ref st 'owner)))
+        (set! group (or group (assoc-ref st 'group)))
+        (set! mode (or mode (assoc-ref st 'mode))))))
+  (when (integer? mode)
+    (set! mode (number->string mode 8)))
+  (remote-cmd conn "install"
+              "--compare"
+              (when owner `("--owner" ,owner))
+              (when group `("--group" ,group))
+              (when mode `("--mode" ,mode))
+              (when backup? "--backup=numbered")
+              src
+              dest
+              #:check? #t))
+
+(define* (install-file conn #:key path owner group (mode #o644) content local-src remote-src backup?)
+  (when (not (= 1 (length (filter identity (list content local-src remote-src)))))
+    (error "exactly one of #:content, #:local-src, or #:remote-src is required"))
+  (changed-if-stat-changed
+   conn path
+   (if remote-src
+       (install-remote-file conn remote-src path owner group mode backup?)
+       ;; Because we might need sudo to install the remote file, we first
+       ;; upload the source to a temporary file, then call @code{install-remote-file} to
+       ;; install the temporary file to the target path.
+       (let ((tmp-file (remote-cmd conn "mktemp" #:check? #t #:return car)))
+         (dynamic-wind
+           (const #t)
+           (lambda ()
+             (cond
+              (local-src (call-with-input-file local-src (upload-tmp-file conn tmp-file)))
+              ((string? content) (call-with-input-string content (upload-tmp-file conn tmp-file)))
+              ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn tmp-file)))
+              (else (error "unsupported type for #:content")))
+             (install-remote-file conn tmp-file path owner group mode backup?))
+           (lambda ()
+             (remote-cmd conn "rm" "-f" tmp-file)))))))

ordo/action/quadlet.scm

@@ -0,0 +1,53 @@
+(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) #:prefix fs:)
+  #:use-module ((srfi srfi-1) #:select (remove))
+  #:export (create-network
+            create-pod
+            create-container
+            create-volume
+            create-image
+            create-build))
+
+(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 service-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)
+                  ,@(if (null? service-options) '() (list (cons "Service" service-options)))
+                  ,@(if (null? install-options) '() (list (cons "Install" 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
+                             #:key name description
+                             (quadlet-options '())
+                             (unit-options '())
+                             (service-options '())
+                             (install-options default-install-options))
+       (fs:install-file conn
+                        #:path (file-name-join* quadlet-dir (string-append name suffix))
+                        #:content (build-quadlet quadlet-type name description quadlet-options unit-options service-options install-options))))))
+
+(define-quadlet-type create-network "Network" ".network" default-install-options)
+
+(define-quadlet-type create-pod "Pod" ".pod" default-install-options)
+
+(define-quadlet-type create-container "Container" ".container" default-install-options)
+
+(define-quadlet-type create-volume "Volume" ".volume" '())
+
+(define-quadlet-type create-build "Build" ".build" '())
+
+(define-quadlet-type create-image "Image" ".image" '())

ordo/connection.scm

@@ -31,7 +31,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
             local-connection
             ssh-connection
             call-with-connection
-            run)
+            remote-cmd)
   #:re-export (remote-exec with-remote-input-file with-remote-output-file))
 
 (define (connection? c)
@@ -62,7 +62,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
       (lambda () (proc conn))
       (lambda () (teardown conn)))))
 
-(define (run conn prog . args)
+(define (remote-cmd conn prog . args)
   (let* ((args options (break keyword? args))
          (args (remove unspecified? (flatten args)))
          (return (keyword-arg options #:return identity))

ordo/connection/base.scm

@@ -46,7 +46,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
 (define-method (build-command (c <connection>) (prog-name <string>) (prog-args <list>) (options <list>))
   (let* ((pwd (keyword-arg options #:pwd))
          (env (keyword-arg options #:env))
-         (redirect-err? (keyword-arg options #:redirect-err?))
+         (redirect-err? (keyword-arg options #:redirect-err? #t))
          (xs (remove unspecified?
                      (flatten (list "env"
                                     (when pwd (list "--chdir" (string-shell-quote pwd)))

ordo/context.scm

@@ -15,70 +15,10 @@ You should have received a copy of the GNU General Public License along with
 this program. If not, see <https://www.gnu.org/licenses/>.
 |#
 
-(define-module (ordo context)
+(define-module (ordo context))
-  #:use-module (ice-9 exceptions)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-69))
 
-;;
-;; Inventory
-;;
 (define-public *inventory* (make-parameter #f))
-
+(define-public *playbook* (make-parameter #f))
-;;
+(define-public *play* (make-parameter #f))
-;; Playbook vars
+(define-public *host* (make-parameter #f))
-;;
+(define-public *triggered-handlers* (make-parameter #f))
-(define-public *playbook-vars* (make-parameter #f))
-
-(define-public (playbook-var-ref key)
-  (hash-table-ref (*playbook-vars*) key))
-
-(define-public (playbook-var-ref/default key default)
-  (hash-table-ref/default (*playbook-vars*) key default))
-
-(define-public (playbook-var-set! key value)
-  (hash-table-set! (*playbook-vars*) key value))
-
-;;
-;; Play vars
-;;
-(define-public *play-vars* (make-parameter #f))
-
-(define-public (play-var-ref key)
-  (hash-table-ref (*play-vars*) key))
-
-(define-public (play-var-ref/default key default)
-  (hash-table-ref/default (*play-vars*) key default))
-
-(define-public (play-var-set! key value)
-  (hash-table-set! (*play-vars*) key value))
-
-;;
-;; Host vars
-;;
-(define-public *host-vars* (make-parameter #f))
-
-(define-public (host-var-ref key)
-  (hash-table-ref (*host-vars*) key))
-
-(define-public (host-var-ref/default key default)
-  (hash-table-ref/default (*host-vars*) key default))
-
-(define-public (host-var-set! key value)
-  (hash-table-set! (*host-vars*) key value))
-
-;;
-;; Play handlers
-;;
-(define-public *play-handlers* (make-parameter #f))
-(define-public *play-triggers* (make-parameter #f))
-
-(define-public (trigger-handler! handler-name)
-  (let ((ix (list-index (cut equal? handler-name <>) (*play-handlers*))))
-    (if ix
-        (bitvector-set-bit! (*play-triggers*) ix)
-        (raise-exception
-         (make-exception
-          (make-programming-error)
-          (make-exception-with-message (format #f "no such handler: ~a" handler-name)))))))

ordo/core.scm

@@ -0,0 +1,69 @@
+#|
+This file is part of Ordo.
+
+Copyright (C) 2025 Ray Miller
+
+This program is free software: you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free Software
+Foundation, version 3.
+
+This program is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License along with
+this program. If not, see <https://www.gnu.org/licenses/>.
+|#
+(define-module (ordo core)
+  #:use-module (ordo connection)
+  #:use-module (ordo context)
+  #:use-module (ordo handler)
+  #:use-module (ordo inventory)
+  #:use-module (ordo logger)
+  #:use-module (ordo playbook)
+  #:use-module (ordo play)
+  #:use-module (ordo task)
+  #:use-module ((srfi srfi-26) #:select (cut)))
+
+(define (run-playbook ctx pb)
+  (log-msg 'NOTICE "Running playbook: " (playbook-name pb))
+  (set-ctx-playbook! ctx pb)
+  (for-each (cut run-play ctx <>) (playbook-plays pb)))
+
+(define (run-play ctx p)
+  (log-msg 'NOTICE "Running play: " (play-name p))
+  (set-ctx-play! ctx p)
+  (let ((hosts (resolve-hosts (ctx-inventory ctx) (play-host p))))
+    (if (null? hosts)
+        (log-msg 'WARN "No hosts matched: " (play-host p))
+        (for-each (cut run-host-play ctx p <>) hosts))))
+
+(define (run-host-play ctx p h)
+  (log-msg 'NOTICE "Running play on host: " (host-name h))
+  (set-ctx-host! ctx h)
+  (call-with-connection
+   (host-connection h)
+   (lambda (conn)
+     (dynamic-wind
+       (lambda ()
+         (set-ctx-connection! ctx conn))
+       (lambda ()
+         (for-each (cut run-task ctx <>) (play-tasks p))
+         (for-each (cut run-handler ctx <>) (play-handlers p)))
+       (lambda ()
+         (set-ctx-connection! ctx #f))))
+   #:sudo? (play-sudo? p)
+   #:sudo-user (play-sudo-user p)
+   #:sudo-password (play-sudo-password p)))
+
+(define (run-task ctx t)
+  (if ((task-pre-condition t) ctx)
+      (begin
+        (log-msg 'NOTICE "Running task " (task-name t))
+        ((task-action t) ctx))
+      (log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met")))
+
+(define (run-handler ctx h)
+  (when (member (ctx-triggers ctx) (handler-name h))
+    (log-msg 'NOTICE "Running handler: " (handler-name h))
+    ((handler-action h) ctx)))

ordo/play.scm

@@ -23,9 +23,12 @@ this program. If not, see <https://www.gnu.org/licenses/>.
   #:use-module (ordo logger)
   #:use-module (ordo task)
   #:use-module (ordo util flatten)
-  #:use-module (srfi srfi-9)
+  #:use-module (ordo util keyword-args)
-  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-1)  ; lists
-  #:use-module (srfi srfi-69)
+  #:use-module (srfi srfi-9)  ; records
+  #:use-module (srfi srfi-26) ; cut/cute
+  #:use-module (srfi srfi-69) ; hash tables
+  #:use-module (srfi srfi-71) ; extended let
   #:export (play
             play?
             play-host
@@ -35,7 +38,8 @@ this program. If not, see <https://www.gnu.org/licenses/>.
             play-vars
             play-tasks
             play-handlers
-            run-play))
+            run-play
+            trigger-handler!))
 
 (define-record-type <play>
   (make-play name host sudo? sudo-user sudo-password vars tasks handlers)
@@ -49,13 +53,21 @@ this program. If not, see <https://www.gnu.org/licenses/>.
   (tasks play-tasks)
   (handlers play-handlers))
 
-(define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (tasks '()) (handlers '()))
+(define (play name . args)
-  (make-play name host sudo? sudo-user sudo-password (alist->hash-table vars) tasks handlers))
+  (let* ((tasks args (partition task? args))
+         (handlers kwargs (partition handler? args)))
+    (make-play name
+               (keyword-arg #:host kwargs)
+               (keyword-arg #:sudo? kwargs)
+               (keyword-arg #:sudo-user kwargs)
+               (keyword-arg #:sudo-password kwargs)
+               (and=> (keyword-arg #:vars kwargs) alist->hash-table)
+               tasks
+               handlers)))
 
 (define (run-play p)
   (log-msg 'NOTICE "Running play: " (play-name p))
-  (parameterize ((*play-handlers* (map handler-name (play-handlers p)))
+  (parameterize ((*play* p))
-                 (*play-vars* (play-vars p)))
     (let ((hosts (resolve-hosts (*inventory*) (play-host p))))
       (if (null? hosts)
           (log-msg 'WARN "No hosts matched: " (play-host p))
@@ -63,17 +75,18 @@ this program. If not, see <https://www.gnu.org/licenses/>.
 
 (define (run-host-play p h)
   (log-msg 'NOTICE "Running play on host: " (host-name h))
-  (parameterize ((*host-vars* (host-vars h))
+  (parameterize ((*host* h)
-                 (*play-handlers* (play-handlers p))
+                 (*triggered-handlers* (make-hash-table)))
-                 (*play-triggers* (make-bitvector (length (play-handlers p)) #f)))
     (call-with-connection
      (host-connection h)
      (lambda (conn)
        (for-each (cut run-task <> conn) (play-tasks p))
-       (for-each (lambda (h i)
+       (for-each (cut run-handler <> conn)
-                   (when (bitvector-bit-set? (*play-triggers*) i)
+                 (filter (compose (cut hash-table-ref/default *triggered-handlers* <> #f) handler-name)
-                     (run-handler h conn)))
+                         (play-handlers p))))
-                 (play-handlers p) (iota (length (play-handlers p)))))
      #:sudo? (play-sudo? p)
      #:sudo-user (play-sudo-user p)
      #:sudo-password (play-sudo-password p))))
+
+(define (trigger-handler! handler-name)
+  (hash-table-set! *triggered-handlers* handler-name #t))

ordo/playbook.scm

@@ -23,9 +23,12 @@ this program. If not, see <https://www.gnu.org/licenses/>.
   #:use-module (ordo logger)
   #:use-module (ordo play)
   #:use-module (ordo task)
-  #:use-module (srfi srfi-9)
+  #:use-module (ordo util keyword-args)
-  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-1)  ; lists
-  #:use-module (srfi srfi-69)
+  #:use-module (srfi srfi-9)  ; records
+  #:use-module (srfi srfi-26) ; cut/cute
+  #:use-module (srfi srfi-69) ; hash tables
+  #:use-module (srfi srfi-71) ; extended let
   #:export (<playbook>
             playbook
             playbook?
@@ -33,11 +36,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
             playbook-vars
             playbook-plays
             load-playbook
-            run-playbook)
+            run-playbook))
-  #:re-export (play
-               task
-               handler
-               trigger-handler!))
 
 (define-record-type <playbook>
   (make-playbook name vars plays)
@@ -46,8 +45,9 @@ this program. If not, see <https://www.gnu.org/licenses/>.
   (vars playbook-vars)
   (plays playbook-plays))
 
-(define* (playbook #:key name (vars '()) (plays '()))
+(define (playbook name . args)
-  (make-playbook name (alist->hash-table vars) plays))
+  (let ((plays kwargs (partition play? args)))
+    (make-playbook name (alist->hash-table (keyword-arg #:vars kwargs '())) plays)))
 
 (define (load-playbook filename)
   (log-msg 'INFO "Loading playbook " filename)
@@ -57,5 +57,5 @@ this program. If not, see <https://www.gnu.org/licenses/>.
 (define (run-playbook pb inventory)
   (log-msg 'NOTICE "Running playbook: " (playbook-name pb))
   (parameterize ((*inventory* inventory)
-                 (*playbook-vars* (playbook-vars pb)))
+                 (*playbook* pb))
     (for-each run-play (playbook-plays pb))))

ordo/util/keyword-args.scm

@@ -16,29 +16,8 @@ this program. If not, see <https://www.gnu.org/licenses/>.
 |#
 
 (define-module (ordo util keyword-args)
-  #:use-module (ice-9 exceptions)
+  #:use-module ((srfi srfi-1) #:select (member))
-  #:export (keyword-arg
+  #:export (keyword-arg))
-            select-keyword-args
-            validate-keyword-args))
 
 (define* (keyword-arg args kw #:optional (default #f))
-  (cond
+  (or (and=> (member kw args) cadr) default))
-   ((< (length args) 2) default)
-   ((equal? (car args) kw) (cadr args))
-   (else (keyword-arg (cddr args) kw default))))
-
-(define (select-keyword-args kwargs wanted)
-  (let loop ((kwargs kwargs) (accum '()))
-    (cond
-     ((null? kwargs)
-      (reverse accum))
-     ((member (car kwargs) wanted)
-      (loop (cddr kwargs) (cons* (car kwargs) (cadr kwargs) accum)))
-     (else (loop (cddr kwargs) accum)))))
-
-(define (validate-keyword-args kwargs)
-  (unless (even? (length kwargs))
-    (raise-exception
-     (make-exception
-      (make-programming-error)
-      (make-exception-with-message "keyword args should have an even number of elements")))))