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))