ray/ordo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Some actions, and fleshing out playbook/tasks

Browse source
This commit is contained in:
Ray Miller 2025-06-22 18:31:36 +01:00
parent 407613152b
commit 54564ec19f
Signed by: ray
GPG key ID: 043F786C4CD681B8
10 changed files with 372 additions and 118 deletions
Download patch file Download diff file Expand all files Collapse all files

62
examples/forgejo.scm Normal file
View file

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

138
ordo/action/filesystem.scm Normal file
View file

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

53
ordo/action/quadlet.scm Normal file
View file

@ -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" '())

4
ordo/connection.scm
View file

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

2
ordo/connection/base.scm
View file

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

70
ordo/context.scm
View file

@ -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)
#: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))

69
ordo/core.scm Normal file
View file

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

43
ordo/play.scm
View file

@ -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 (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 <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 '()))
(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 <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))
(*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))

22
ordo/playbook.scm
View file

@ -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 (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
playbook?
@ -33,11 +36,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
playbook-vars
playbook-plays
load-playbook
run-playbook)
#:re-export (play
task
handler
trigger-handler!))
run-playbook))
(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 '()))
(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 <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))))

27
ordo/util/keyword-args.scm
View file

@ -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)
#: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))