From 54564ec19f61a3d5cc48013d10901d48569555d5 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 22 Jun 2025 18:31:36 +0100 Subject: [PATCH] Some actions, and fleshing out playbook/tasks --- examples/forgejo.scm | 62 +++++++++++++++++ ordo/action/filesystem.scm | 138 +++++++++++++++++++++++++++++++++++++ ordo/action/quadlet.scm | 53 ++++++++++++++ ordo/connection.scm | 4 +- ordo/connection/base.scm | 2 +- ordo/context.scm | 70 ++----------------- ordo/core.scm | 69 +++++++++++++++++++ ordo/play.scm | 43 ++++++++---- ordo/playbook.scm | 22 +++--- ordo/util/keyword-args.scm | 27 +------- 10 files changed, 372 insertions(+), 118 deletions(-) create mode 100644 examples/forgejo.scm create mode 100644 ordo/action/filesystem.scm create mode 100644 ordo/action/quadlet.scm create mode 100644 ordo/core.scm diff --git a/examples/forgejo.scm b/examples/forgejo.scm new file mode 100644 index 0000000..2f3dff5 --- /dev/null +++ b/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"))) diff --git a/ordo/action/filesystem.scm b/ordo/action/filesystem.scm new file mode 100644 index 0000000..009363d --- /dev/null +++ b/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))))))) diff --git a/ordo/action/quadlet.scm b/ordo/action/quadlet.scm new file mode 100644 index 0000000..b1f79e7 --- /dev/null +++ b/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" '()) diff --git a/ordo/connection.scm b/ordo/connection.scm index f9b2886..4c31470 100644 --- a/ordo/connection.scm +++ b/ordo/connection.scm @@ -31,7 +31,7 @@ this program. If not, see . 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 . (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)) diff --git a/ordo/connection/base.scm b/ordo/connection/base.scm index 6803f20..d853fdb 100644 --- a/ordo/connection/base.scm +++ b/ordo/connection/base.scm @@ -46,7 +46,7 @@ this program. If not, see . (define-method (build-command (c ) (prog-name ) (prog-args ) (options )) (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))) diff --git a/ordo/context.scm b/ordo/context.scm index 4a0157b..94c6290 100644 --- a/ordo/context.scm +++ b/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 . |# -(define-module (ordo context) - #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-69)) +(define-module (ordo context)) -;; -;; Inventory -;; (define-public *inventory* (make-parameter #f)) - -;; -;; Playbook vars -;; -(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))))))) +(define-public *playbook* (make-parameter #f)) +(define-public *play* (make-parameter #f)) +(define-public *host* (make-parameter #f)) +(define-public *triggered-handlers* (make-parameter #f)) diff --git a/ordo/core.scm b/ordo/core.scm new file mode 100644 index 0000000..d12c7c1 --- /dev/null +++ b/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 . +|# +(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))) diff --git a/ordo/play.scm b/ordo/play.scm index 95532f6..326d5c6 100644 --- a/ordo/play.scm +++ b/ordo/play.scm @@ -23,9 +23,12 @@ this program. If not, see . #:use-module (ordo logger) #:use-module (ordo task) #:use-module (ordo util flatten) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-69) + #:use-module (ordo util keyword-args) + #:use-module (srfi srfi-1) ; lists + #: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 . play-vars play-tasks play-handlers - run-play)) + run-play + trigger-handler!)) (define-record-type (make-play name host sudo? sudo-user sudo-password vars tasks handlers) @@ -49,13 +53,21 @@ this program. If not, see . (tasks play-tasks) (handlers play-handlers)) -(define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (tasks '()) (handlers '())) - (make-play name host sudo? sudo-user sudo-password (alist->hash-table vars) tasks handlers)) +(define (play name . args) + (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))) - (*play-vars* (play-vars p))) + (parameterize ((*play* 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 . (define (run-host-play p h) (log-msg 'NOTICE "Running play on host: " (host-name h)) - (parameterize ((*host-vars* (host-vars h)) - (*play-handlers* (play-handlers p)) - (*play-triggers* (make-bitvector (length (play-handlers p)) #f))) + (parameterize ((*host* h) + (*triggered-handlers* (make-hash-table))) (call-with-connection (host-connection h) (lambda (conn) (for-each (cut run-task <> conn) (play-tasks p)) - (for-each (lambda (h i) - (when (bitvector-bit-set? (*play-triggers*) i) - (run-handler h conn))) - (play-handlers p) (iota (length (play-handlers p))))) + (for-each (cut run-handler <> conn) + (filter (compose (cut hash-table-ref/default *triggered-handlers* <> #f) handler-name) + (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)) diff --git a/ordo/playbook.scm b/ordo/playbook.scm index b9b3b4e..b22fc3c 100644 --- a/ordo/playbook.scm +++ b/ordo/playbook.scm @@ -23,9 +23,12 @@ this program. If not, see . #:use-module (ordo logger) #:use-module (ordo play) #:use-module (ordo task) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-69) + #:use-module (ordo util keyword-args) + #:use-module (srfi srfi-1) ; lists + #: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? @@ -33,11 +36,7 @@ this program. If not, see . playbook-vars playbook-plays load-playbook - run-playbook) - #:re-export (play - task - handler - trigger-handler!)) + run-playbook)) (define-record-type (make-playbook name vars plays) @@ -46,8 +45,9 @@ this program. If not, see . (vars playbook-vars) (plays playbook-plays)) -(define* (playbook #:key name (vars '()) (plays '())) - (make-playbook name (alist->hash-table vars) plays)) +(define (playbook name . args) + (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 . (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)))) diff --git a/ordo/util/keyword-args.scm b/ordo/util/keyword-args.scm index e194140..95de5eb 100644 --- a/ordo/util/keyword-args.scm +++ b/ordo/util/keyword-args.scm @@ -16,29 +16,8 @@ this program. If not, see . |# (define-module (ordo util keyword-args) - #:use-module (ice-9 exceptions) - #:export (keyword-arg - select-keyword-args - validate-keyword-args)) + #:use-module ((srfi srfi-1) #:select (member)) + #:export (keyword-arg)) (define* (keyword-arg args kw #:optional (default #f)) - (cond - ((< (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"))))) + (or (and=> (member kw args) cadr) default))