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

Compare commits

base: ray:main
Branches Tags
ray:main
ray:blueprints
ray:wip/interceptors
ray:wip/podman
ray:wip/prerequisite-data
..
compare: ray:wip/prerequisite-data
Branches Tags
ray:blueprints
ray:main
ray:wip/interceptors
ray:wip/podman
ray:wip/prerequisite-data

No commits in common. "main" and "wip/prerequisite-data" have entirely different histories.
main ... wip/prereq

37 changed files with 491 additions and 1539 deletions
Download patch file Download diff file Expand all files Collapse all files

71
.gitignore vendored
View file

@ -1,66 +1,5 @@
*.eps
*.go
*.log
*.pdf
*.png
*.tar.xz
*.tar.gz
*.tmp
*~
.#*
\#*\#
,*
/ABOUT-NLS
/INSTALL
/aclocal.m4
/autom4te.cache
/build-aux/ar-lib
/build-aux/compile
/build-aux/config.guess
/build-aux/config.rpath
/build-aux/config.sub
/build-aux/depcomp
/build-aux/install-sh
/build-aux/mdate-sh
/build-aux/missing
/build-aux/test-driver
/build-aux/texinfo.tex
/config.status
/configure
/doc/*.1
/doc/.dirstamp
/doc/contributing.*.texi
/doc/*.aux
/doc/*.cp
/doc/*.cps
/doc/*.fn
/doc/*.fns
/doc/*.html
/doc/*.info
/doc/*.info-[0-9]
/doc/*.ky
/doc/*.pg
/doc/*.toc
/doc/*.t2p
/doc/*.tp
/doc/*.vr
/doc/*.vrs
/doc/stamp-vti
/doc/version.texi
/doc/version-*.texi
/m4/*
/pre-inst-env
/test-env
/test-tmp
/tests/*.trs
GPATH
GRTAGS
GTAGS
Makefile
Makefile.in
config.cache
stamp-h[0-9]
tmp
/.version
/doc/stamp-[0-9]
/.config/
scratch/
/.dir-locals.el
/gnu
*-tarball-pack.tar.gz
/mybin

43
bin/play.scm Executable file
View file

@ -0,0 +1,43 @@
#!/usr/bin/env -S guile --no-auto-compile -e main -s
!#
(use-modules (srfi srfi-11)
(ice-9 getopt-long)
(ice-9 format)
(ordo util filesystem))
(define (tar . args)
(unless (zero? (apply system* "tar" args))
(error (format #f "Non-zero exit from tar ~a" args))))
(define* (usage #:optional errmsg)
(with-output-to-port (current-error-port)
(lambda ()
(when errmsg
(format #t "Error: ~a~%~%" errmsg))
(display "Usage: play -t TARGET PLAYBOOK")
(newline)))
(exit (if errmsg EXIT_FAILURE EXIT_SUCCESS)))
(define (process-options args)
(let* ((option-spec '((help (single-char #\h) (value #f))
(target (single-char #\t) (value #t) (required? #t))))
(options (getopt-long args option-spec))
(help-wanted (option-ref options 'help #f))
(target (option-ref options 'target #f))
(args (option-ref options '() '())))
(cond
(help-wanted (usage))
((not (= 1 (length args)))
(usage "Expected exactly one playbook")))
(values (canonicalize-path (car args)) target)))
(define (main args)
(let-values (((playbook-path target) (process-options args)))
(define playbook (load playbook-path))
(define top-dir (dirname (dirname (current-filename))))
(call-with-temporary-directory
(lambda (tmp-dir)
(define tarball (string-append tmp-dir "/payload.tar"))
(tar "--create" "--file" tarball "--directory" top-dir "modules" "bin")
(tar "--append" "--file" tarball "--transform" "s/.*/playbook.scm/" playbook-path)
(tar "tf" tarball)))))

60
examples/forgejo.scm
View file

@ -1,60 +0,0 @@
(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")
#:trigger '("Restart pod"))
(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"
#:pod ((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")))

23
examples/inventory.scm
View file

@ -1,23 +0,0 @@
(use-modules (ordo connection)
(ordo inventory))
(list
(host #:name "little-rascal"
#:connection (local-connection)
#:tags '(#:linux #:guix))
(host #:name "limiting-factor"
#:connection (ssh-connection "limiting-factor" #:user "core")
#:tags '(#:linux #:coreos))
(host #:name "screw-loose"
#:connection (ssh-connection "screw-loose" #:user "core")
#:tags '(#:linux #:coreos))
(host #:name "control-surface"
#:connection (ssh-connection "control-surface" #:user "ray")
#:tags '(#:linux #:debian))
(host #:name "cargo-cult"
#:connection (ssh-connection "cargo-cult" #:user "ray")
#:tags '(#:linux #:synology)))

17
examples/playbook.scm
View file

@ -1,17 +0,0 @@
(use-modules (ordo playbook))
(playbook
#:name "Example playbook"
#:vars '((foo . 1) (bar . "baz"))
#:plays (list
(play #:name "Example play"
#:host "localhost"
#:tasks (list
(task #:name "First task"
#:action (const #t))
(task #:name "Second task"
#:action (lambda (conn)
(trigger-handler! 'foo))))
#:handlers (list
(handler #:name 'foo
#:action (const #f))))))

79
guix.scm
View file

@ -1,79 +0,0 @@
(use-modules
(gnu packages)
(gnu packages bash)
(gnu packages golang-crypto)
(gnu packages guile)
(gnu packages guile-xyz)
(gnu packages ssh)
(gnu packages version-control)
(guix build-system guile)
(guix download)
(guix gexp)
((guix licenses) #:prefix license:)
(guix packages)
(srfi srfi-1))
(package
(name "guile-ordo")
(version "0.1.0")
(source
(local-file
(dirname (current-filename))
#:recursive? #t
#:select? (lambda (file stat)
(not (any (lambda (my-string)
(string-contains file my-string))
(list ".git" ".dir-locals.el" "guix.scm"))))))
(build-system guile-build-system)
(arguments
(list
#:phases #~(modify-phases %standard-phases
(add-after 'build 'link-and-wrap-executable
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((bin (string-append #$output "/bin")) ; bin directory for PATH.
(site-version (target-guile-effective-version))
(scm (lambda (p) (string-append p "/share/guile/site/" site-version)))
(go (lambda (p) (string-append p "/lib/guile/" site-version "/site-ccache")))
(runtime-deps (cons #$output (map (lambda (p) (assoc-ref inputs p)) (list "guile-config"
"guile-dsv"
"guile-filesystem"
"guile-ini"
"guile-irregex"
"guile-libyaml"
"guile-json"
"guile-lib"
"guile-semver"
"guile-srfi-145"
"guile-srfi-158"
"guile-srfi-197"
"guile-srfi-235"
"guile-ssh")))))
(mkdir-p bin)
(let ((source-script (string-append #$output
"/share/guile/site/" site-version "/"
"ordo.scm"))
(target-command (string-append bin "/ordo")))
(symlink source-script target-command)
(wrap-program target-command
#:sh (which "bash")
`("GUILE_LOAD_PATH" prefix ,(map scm runtime-deps))
`("GUILE_LOAD_COMPILED_PATH" prefix ,(map go runtime-deps))))))))))
(inputs (list guile-3.0 bash-minimal git git-lfs age))
(propagated-inputs (list guile-config
guile-dsv
guile-filesystem
guile-ini
guile-irregex
guile-libyaml
guile-json-4
guile-lib
guile-semver
guile-srfi-145
guile-srfi-158
guile-srfi-197
guile-srfi-235
guile-ssh))
(synopsis "Ordo configuration management")
(description "")
(home-page "")
(license license:gpl3+))

26
manifest.scm Normal file
View file

@ -0,0 +1,26 @@
(specifications->manifest '("git"
"git-crypt"
"git-lfs"
"gnupg"
"guile"
"guile-config"
"guile-dsv"
"guile-file-names"
"guile-filesystem"
"guile-gcrypt"
"guile-gnutls"
"guile-ini"
"guile-irregex"
"guile-json"
"guile-lib"
"guile-libyaml"
"guile-quickcheck"
"guile-readline"
"guile-semver"
"guile-sqlite3"
"guile-srfi-145"
"guile-srfi-158"
"guile-srfi-197"
"guile-srfi-235"
"guile-ssh"
"password-store"))

191
modules/ordo/connection.scm Normal file
View file

@ -0,0 +1,191 @@
(define-module (ordo connection)
#:use-module (oop goops)
#:use-module (ice-9 format)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 string-fun)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 textual-ports)
#:use-module (ssh session)
#:use-module (ssh channel)
#:use-module (ssh auth)
#:use-module (ssh popen)
#:use-module (srfi srfi-1) ;; list operations
#:use-module (srfi srfi-71) ;; extended let (multiple values)
#:use-module (srfi srfi-197) ;; chain
#:export (local-connection
ssh-connection
init!
close!
run
command-available?
read-binary-file
read-text-file
write-binary-file
write-text-file
copy-port))
(define-class <connection> ()
(sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?))
(define-class <local-connection> (<connection>))
(define* (local-connection #:key (sudo? #f))
(make <local-connection> #:sudo? sudo?))
(define-class <ssh-connection> (<connection>)
(user #:getter get-user #:init-keyword #:user)
(host #:getter get-host #:init-keyword #:host)
(session #:getter get-session #:setter set-session!))
(define* (ssh-connection user host #:key (sudo? #f))
(make <ssh-connection> #:user user #:host host #:sudo? sudo?))
(define-method (init! (c <local-connection>)) #t)
(define-method (close! (c <local-connection>)) #t)
(define-method (init! (c <ssh-connection>))
(unless (slot-bound? c 'session)
(set-session! c (make-session #:user (get-user c) #:host (get-host c))))
(let ((s (get-session c)))
(unless (connected? s)
(connect! s)
(userauth-public-key/auto! s)))
#t)
(define-method (close! (c <ssh-connection>))
(when (slot-bound? c 'session)
(let ((s (get-session c)))
(when (connected? s)
(disconnect! s)))))
(define (build-command pwd env prog args sudo?)
(let ((cmd (list (if sudo? "sudo" "env"))))
(chain-when cmd
(pwd (append _ (list "--chdir" pwd)))
(env (append _ (map (lambda (x) (format #f "~a=~a" (car x) (cdr x))) env)))
(#t (append _ (list prog)))
(args (append _ args)))))
(define (read-lines port)
(define (loop line result)
(if (eof-object? line) (reverse result) (loop (read-line port) (cons line result))))
(loop (read-line port) '()))
(define-method (%run (c <local-connection>) pwd env prog args)
(let* ((cmd (build-command pwd env prog args (sudo? c)))
(port (apply open-pipe* OPEN_READ cmd))
(output (read-lines port))
(exit-status (status:exit-val (close-pipe port))))
(values output exit-status)))
(define-method (%run (c <ssh-connection>) pwd env prog args)
(let* ((cmd (build-command pwd env prog args (sudo? c)))
(channel (apply open-remote-input-pipe* (get-session c) cmd))
(output (read-lines channel))
(exit-status (channel-get-exit-status channel)))
(close channel)
(values output exit-status)))
(define (find-kw-arg kw kwargs)
(let loop ((kwargs kwargs))
(cond
((null? kwargs) #f)
((equal? (car kwargs) kw) (cadr kwargs))
(else (loop (cddr kwargs))))))
(define (run c prog . rest)
(let ((args (take-while (negate keyword?) rest))
(kwargs (drop-while (negate keyword?) rest)))
(unless (even? (length kwargs))
(error "keyword arguments require a value"))
(let ((pwd (find-kw-arg #:pwd kwargs))
(env (find-kw-arg #:env kwargs)))
(%run c pwd env prog args))))
(define (command-available? c command)
(let ((_ rc (run c "which" command)))
(zero? rc)))
;; These functions for reading and writing files are using cat (with output
;; redirection for writing) rather than opening the files directly so that the
;; command can be invoked under sudo when necessary.
(define-method (read-file (c <local-connection>) (path <string>) (reader <procedure>))
(let* ((cmd (build-command #f #f "cat" (list path) (sudo? c)))
(port (apply open-pipe* OPEN_READ cmd))
(output (reader port))
(exit-status (status:exit-val (close-pipe port))))
(unless (zero? exit-status)
(error (format #f "error reading local text file ~a" path)))
output))
(define-method (read-file (c <ssh-connection>) (path <string>) (reader <procedure>))
(let* ((cmd (build-command #f #f "cat" (list path) (sudo? c)))
(channel (apply open-remote-input-pipe* (get-session c) cmd))
(output (reader channel))
(exit-status (channel-get-exit-status channel)))
(close channel)
(unless (zero? exit-status)
(error (format #f "error reading text file ~a@~a:~a" (get-user c) (get-host c) path)))
output))
(define (read-text-file c path)
(read-file c path get-string-all))
(define (read-binary-file c path)
(read-file c path get-bytevector-all))
(define (shell-quote s)
"Quote string S for sh-compatible shells."
(string-append "'" (string-replace-substring s "'" "'\\''") "'"))
;; These methods for writing files require the file content to be read into memory. They
;; are useful for small files, but prefer COPY-FILE for larger ones.
(define-method (write-file (c <local-connection>) (path <string>) (writer <procedure>) content)
(let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c)))
(port (apply open-pipe* OPEN_WRITE cmd)))
(writer port content)
(unless (zero? (status:exit-val (close-pipe port)))
(error (format #f "error writing local text file ~a" path)))))
(define-method (write-file (c <ssh-connection>) (path <string>) (writer <procedure>) content)
(let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c)))
(channel (apply open-remote-output-pipe* (get-session c) cmd)))
(writer channel content)
(channel-send-eof channel)
(let ((exit-status (channel-get-exit-status channel)))
(close channel)
(unless (zero? exit-status)
(error (format #f "error writing text file ~a@~a:~a" (get-user c) (get-host c) path))))))
(define (write-text-file c path content)
(write-file c path put-string content))
(define (write-binary-file c path content)
(write-file c path put-bytevector content))
(define-method (copy-port (c <local-connection>) (src <port>) (dest-path <string>))
(let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c)))
(dport (apply open-pipe* OPEN_WRITE cmd)))
(let loop ((data (get-bytevector-some src)))
(unless (eof-object? data)
(put-bytevector dport data)
(loop (get-bytevector-some src))))
(unless (zero? (status:exit-val (close-pipe dport)))
(error (format #f "error copying file to ~a" dest-path)))))
(define-method (copy-port (c <ssh-connection>) (src <port>) (dest-path <string>))
(let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c)))
(channel (apply open-remote-output-pipe* (get-session c) cmd)))
(let loop ((data (get-bytevector-some src)))
(unless (eof-object? data)
(put-bytevector channel data)
(loop (get-bytevector-some src))))
(channel-send-eof channel)
(let ((exit-status (channel-get-exit-status channel)))
(close channel)
(unless (zero? exit-status)
(error (format #f "error copying file to ~a@~a:~a" (get-user c) (get-host c) dest-path))))))

17
modules/ordo/prerequisite-data.scm Normal file
View file

@ -0,0 +1,17 @@
(define-module (ordo prerequisite-data)
#:use-module (oop goops))
(define-class <prerequisite-data> ())
(define-class <local-file> (<prerequisite-data>)
(path #:init-keyword #:path #:getter get-path))
(define-method (equal? (x <local-file>) (y <local-file>))
(equal? (get-path x) (get-path y)))
(define (local-file path)
(make <local-file> #:path path))
(define-class <local-lookup> (<prerequisite-data>)
(handler #:init-keyword #:handler #:getter get-handler)
(args #:init-keyword #:args :getter get-args))

60
modules/ordo/task.scm Normal file
View file

@ -0,0 +1,60 @@
(define-module (ordo task)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (make-task task? task-name task-prerequisite-data task-want-skip task-action task-seq))
;; Task
;; name - a descriptive name for the task
;; prerequisite-data - list of prerequisite data (local data
;; that must be copied to the remote host
;; in order for the task to run)
;; want-skip - function of no args that should return #t if the
;; the task should be skipped
;; action - function of no args that runs the task
(define-record-type <task>
(make-task name prerequisite-data want-skip action)
task?
(want-skip task-want-skip)
(name task-name)
(prerequisite-data task-prerequisite-data)
(action task-action))
(define (combine-prerequisite-data tasks)
;; TODO: work out what the equality operator should be, which
;; will depend on how we represent prerequisite data
(apply lset-union = (map task-prerequisite-data tasks)))
;; Combine the want-skips functions from a sequence of tasks.
;; If any task has no want-skip function, the combined task cannot
;; be skipped, so simply return #f. Otherwise, return a function that
;; will only return #t if every task's want-skip function returns true.
;; TODO: With this approach, if the top-level want-skip funciton returns
;; #f (so the task action sequence runs), some of the tests will be repeated.
;; Is it preferable always to have the top-level return #f and simply run
;; the subtasks?
(define (combine-want-skips tasks)
(let ((skips (map task-want-skip tasks)))
(if (every identity skips)
(lambda () (every identity (map (lambda (f) (f)) skips)))
#f)))
;; Return a function that will apply each of the task actions
;; in order.
;; TODO: would it be better to store the list of actions and
;; implement a task runner that would run either a single task
;; or a sequence of tasks with appropriate logging?
;; TODO: the implementation below does not handle skipping
;; tasks in the sequence, this would be handled by a task runner.
(define (combine-actions tasks)
(let ((actions (map task-action tasks)))
(lambda ()
(for-each (lambda (f) (f)) actions))))
;; Return a task consists of a sequence of other tasks.
(define (task-seq name task . task*)
(let ((tasks (cons task task*)))
(make-task
name
(combine-prerequisite-data tasks)
(combine-want-skips tasks)
(combine-actions tasks))))

17
modules/ordo/task/command.scm Normal file
View file

@ -0,0 +1,17 @@
(define-module (ordo task command)
#:use-module (ice-9 format)
#:use-module (srfi srfi-11)
#:use-module (ordo task)
#:use-module (ordo util process)
#:export (command))
(define* (command name cmd #:optional (args '())
#:key (fail-ok? #f) (stdin #f) (cwd #f) (env #f) (skip? #f))
(make-task name
'()
skip?
(lambda ()
(let-values (((exit-code output) (run cmd args #:stdin stdin #:cwd cwd #:env env #:combine-output #t)))
(if (or fail-ok? (zero? exit-code))
(values exit-code output)
(error (format #f "Error running ~a (exit ~d): ~a" cmd exit-code output)))))))

4
modules/ordo/task/file.scm Normal file
View file

@ -0,0 +1,4 @@
(define-module (ordo task file)
#:use-module (ordo task))
(define (file ))

63
modules/ordo/util/filesystem.scm Normal file
View file

@ -0,0 +1,63 @@
(define-module (ordo util filesystem)
#:use-module (system foreign)
#:use-module (srfi srfi-11)
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
#:export (delete-file-recursively
create-temporary-directory
call-with-temporary-directory))
(define* (delete-file-recursively filename #:key (verbose #f))
(define dev (stat:dev (stat filename)))
(define (enter? name stat result)
(= (stat:dev stat) dev))
(define (leaf name stat result)
(if (false-if-exception (delete-file name))
(and verbose (format #t "delete-file ~a OK~%" name))
(format (current-error-port) "warning: delete-file ~a failed~%" name))
result)
(define (down name stat result)
result)
(define (up name stat result)
(if (false-if-exception (rmdir name))
(and verbose (format #t "rmdir ~a OK~%" name))
(format (current-error-port) "warning: rmdir ~a failed~%" name))
result)
(define (skip name state result)
result)
(define (error name stat errno result)
(format (current-error-port) "warning: ~a: ~a~%"
name (strerror errno))
result)
(file-system-fold enter? leaf down up skip error #f filename))
;; This is based on reading guix/build/syscalls.scm but less general
;; than their implementation.
;; TODO: why is this needed? The guile standard library has mkdtemp
;; that seems to do the same thing.
(define mkdtemp!
(let* ((ptr (dynamic-func "mkdtemp" (dynamic-link)))
(proc (pointer->procedure '* ptr '(*) #:return-errno? #t)))
(lambda (tmpl)
(let-values (((result err) (proc (string->pointer tmpl))))
(when (null-pointer? result)
(error (format #f "mkdtemp! ~a: ~a" tmpl (strerror err))))
(pointer->string result)))))
(define (create-temporary-directory)
(let* ((directory (or (getenv "TMPDIR") "/tmp"))
(template (string-append directory "/ordo.XXXXXX")))
(mkdtemp! template)))
;; This is borrowed from guix/util.scm
(define (call-with-temporary-directory proc)
"Call PROC with a name of a temporary directory; close the directory and
delete it when leaving the dynamic extent of this call."
(let ((tmp-dir (create-temporary-directory)))
(dynamic-wind
(const #t)
(lambda ()
(proc tmp-dir))
(lambda ()
(false-if-exception (delete-file-recursively tmp-dir))))))

62
modules/ordo/util/process.scm Normal file
View file

@ -0,0 +1,62 @@
(define-module (ordo util process)
#:use-module (ice-9 textual-ports)
#:export (with-cwd with-env capture))
(define-syntax with-cwd
(syntax-rules ()
((_ new-dir body ...)
(let ((original-dir (getcwd)))
(dynamic-wind
(lambda () (chdir new-dir))
(lambda () body ...)
(lambda () (chdir original-dir)))))))
;; Not needed for CAPTURE, which supports an environment override,
;; but might be useful for SYSTEM and SYSTEM*
(define-syntax with-env
(syntax-rules ()
((_ new-env body ...)
(let ((original-env (environ)))
(dynamic-wind
(lambda () (environ new-env))
(lambda () body ...)
(lambda () (environ original-env)))))))
;; Run a command and capture the output. Currently this only supports
;; text input and output. If necessary, we could use the (rnrs io ports)
;; module and use PUT-BYTEVECTOR / GET-BYTEVECTOR-ALL and examine the type
;; of STDIN to determine whether to call PUT-STRING or PUT-BYTEVECTOR. For
;; STDOUT, we'd need to add a #:binary argument so the caller could indicate
;; they are expecting binary output. Not implemented yet incase YAGNI.
(define* (capture cmd
#:optional (args '())
#:key (combine-output #f) (env #f) (stdin #f) (cwd #f))
(if cwd
(with-cwd cwd (run cmd args #:combine-output combine-output #:env env #:stdin stdin))
(let* ((input-pipe (pipe))
(output-pipe (pipe))
(pid (spawn cmd (cons cmd args)
#:input (car input-pipe)
#:output (cdr output-pipe)
#:error (if combine-output (cdr output-pipe) (current-error-port))
#:environment (or env (environ)))))
(close-port (cdr output-pipe))
(close-port (car input-pipe))
(when stdin (put-string (cdr input-pipe) stdin))
(close-port (cdr input-pipe))
(let ((output (get-string-all (car output-pipe))))
(close-port (car output-pipe))
(values (cdr (waitpid pid)) output)))))
;; Possibly nicer way to do this, suggested by dsmith on IRC: https://bpa.st/3JYTA
;; (use-modules (ice-9 popen)
;; (ice-9 rdelim)
;; (ice-9 receive))
;; (define (filter text)
;; (receive (from to pids) (pipeline '(("the-command")))
;; (write text to)
;; (close to)
;; (read-line from)))
;; See also https://github.com/ray1729/ordo/blob/main/modules/ordo/util/process.scm

48
ordo.scm
View file

@ -1,48 +0,0 @@
#!/usr/bin/guile \
--no-auto-compile -e main -s
!#
(use-modules (config)
(config api)
(config parser sexp)
(ice-9 format)
(ice-9 match)
((ordo cli run) #:prefix run:)
(ordo logger))
(define config
(configuration
(name 'ordo)
(synopsis "From chaos, comes order")
(description "Ordo configuration management.")
(keywords
(list
(setting
(name 'log-level)
(handler string->symbol)
(test valid-log-level?)
(default 'NOTICE)
(example "DEBUG|INFO|NOTICE|WARN|ERROR")
(synopsis "Log level"))))
(parser sexp-parser)
(directory (in-cwd ".config/" #t))
(version "0.1.0")
(author "Ray Miller")
(license gpl3+)
(copyright (list 2025))
(subcommands
(list
run:config))))
(define (main cmd-line)
(let ((options (getopt-config-auto cmd-line config)))
(dynamic-wind
(lambda ()
(setup-logging! #:level (option-ref options 'log-level)))
(lambda ()
(match (full-command options)
(("ordo" "run")
(run:handler options))
(_ (emit-help options))))
(lambda ()
(shutdown-logging!)))))

153
ordo/action/filesystem.scm
View file

@ -1,153 +0,0 @@
#|
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 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
remove-file
create-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* (remove-file conn #:key path (recurse? #f))
(changed-if-stat-changed
conn path
(remote-cmd conn "rm" "-f" (when recurse? "-r") path
#:check? #t)))
(define* (create-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)))))))

75
ordo/action/quadlet.scm
View file

@ -1,75 +0,0 @@
#|
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 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 system-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 (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* (create-network conn #:key name description network (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir))
(fs:install-file conn
#:path (file-name-join* quadlet-dir (string-append name ".network"))
#:content (quadlet "Network" name description unit network service install)))
(define* (create-pod conn #:key name description pod (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir))
(fs:install-file conn
#:path (file-name-join* quadlet-dir (string-append name ".pod"))
#:content (quadlet "Pod" name description unit pod service install)))
(define* (create-container conn #:key name description container (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir))
(fs:install-file conn
#:path (file-name-join* quadlet-dir (string-append name ".container"))
#:content (quadlet "Container" name description unit container service install)))
(define* (create-volume conn #:key name description volume (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir))
(fs:install-file conn
#:path (file-name-join* quadlet-dir (string-append name ".volume"))
#:content (quadlet "Volume" name description unit volume service install)))
(define* (create-build conn #:key name description build (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir))
(fs:install-file conn
#:path (file-name-join* quadlet-dir (string-append name ".build"))
#:content (quadlet "Build" name description unit build service install)))
(define* (create-image conn #:key name description image (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir))
(fs:install-file conn
#:path (file-name-join* quadlet-dir (string-append name ".image"))
#:content (quadlet "Image" name description unit image service install)))

40
ordo/action/systemctl.scm
View file

@ -1,40 +0,0 @@
#|
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 action systemctl)
#:use-module (ordo connection)
#:export (daemon-reload stop start restart reload))
(define* (daemon-reload conn #:key user?)
(remote-cmd conn "systemctl" (when user? "--user") "daemon-reload" #:check? #t)
#t)
(define* (stop conn #:key unit user?)
(remote-cmd conn "systemctl" (when user? "--user") "stop" unit #:check? #t)
#t)
(define* (start conn #:key unit user?)
(remote-cmd conn "systemctl" (when user? "--user") "start" unit #:check? #t)
#t)
(define* (reload conn #:key unit user?)
(remote-cmd conn "systemctl" (when user? "--user") "reload" unit #:check? #t)
#t)
(define* (restart conn #:key unit user?)
(remote-cmd conn "systemctl" (when user? "--user") "restart" unit #:check? #t)
#t)

68
ordo/cli/run.scm
View file

@ -1,68 +0,0 @@
#|
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 cli run)
#:use-module (config)
#:use-module (config api)
#:use-module (ice-9 filesystem)
#:use-module (ordo inventory)
#:use-module (ordo logger)
#:use-module (ordo playbook)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (config handler))
(define (valid-tags? x)
(or (null? x)
(and (list? x) (every keyword? x))))
(define (parse-tags x)
(map (compose symbol->keyword string->symbol)
(if (list? x) x (list x))))
(define config
(configuration
(name 'run)
(wanted '((keywords . (log-level)) directory))
(keywords
(list
(setting
(name 'inventory)
(default "/dev/null")
(example "examples/inventory.scm")
(handler (cut expand-file-name <> #f #t))
(test file-exists?)
(synopsis "Inventory file"))
(switch
(name 'tag)
(default (list))
(test valid-tags?)
(handler parse-tags)
(merge-strategy cons)
(synopsis "Limit operations to specified tag(s)"))))
(arguments
(list
(argument
(name 'playbook)
(handler (cut expand-file-name <> #f #t))
(test file-exists?))))
(synopsis "Run a playbook")))
(define (handler options)
(let ((inventory (load-inventory (option-ref options 'inventory)))
(playbook (load-playbook (option-ref options '(playbook)))))
(run-playbook playbook inventory)))

80
ordo/connection.scm
View file

@ -1,80 +0,0 @@
#|
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 connection)
#:use-module (ice-9 exceptions)
#:use-module (oop goops)
#:use-module (ordo connection base)
#:use-module (ordo connection local)
#:use-module (ordo connection ssh)
#:use-module (ordo connection sudo)
#:use-module (ordo logger)
#:use-module (ordo util flatten)
#:use-module (ordo util keyword-args)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-71)
#:export (connection?
local-connection
ssh-connection
call-with-connection
remote-cmd)
#:re-export (remote-exec with-remote-input-file with-remote-output-file))
(define (connection? c)
(is-a? c <connection>))
(define (local-connection)
(make <local-connection>))
(define* (ssh-connection host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t)
(sudo? #f) (sudo-user #f) (sudo-password #f))
(make <ssh-connection> #:user user #:host host #:password password
#:identity identity #:authenticate-server? authenticate-server?
#:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password))
(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password)
(let ((conn (deep-clone conn)))
(when sudo?
(unless (is-a? conn <sudo-connection>)
(raise-exception
(make-exception
(make-programming-error)
(make-exception-with-message (format #f "connection ~a does not support sudo" conn)))))
(set! (become? conn) sudo?)
(set! (become-user conn) sudo-user)
(set! (become-password conn) sudo-password))
(dynamic-wind
(lambda () (setup conn))
(lambda () (proc conn))
(lambda () (teardown conn)))))
(define (remote-cmd conn prog . args)
(let* ((args options (break keyword? args))
(args (remove unspecified? (flatten args)))
(return (keyword-arg options #:return identity))
(check? (keyword-arg options #:check?))
(command (build-command conn prog args options)))
(log-msg 'INFO "Running command: " command)
(let ((out rc (remote-exec conn command)))
(log-msg 'INFO "Command exit code: " rc)
(if check?
(if (zero? rc)
(return out)
(raise-exception (make-exception
(make-external-error)
(make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog)))))
(values (return out) rc)))))

57
ordo/connection/base.scm
View file

@ -1,57 +0,0 @@
#|
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 connection base)
#:use-module (ice-9 match)
#:use-module (oop goops)
#:use-module (ordo util flatten)
#:use-module (ordo util keyword-args)
#:use-module (ordo util shell-quote)
#:use-module ((srfi srfi-1) #:select (remove))
#:export (<connection>
setup
teardown
build-command
remote-exec
with-remote-input-file
with-remote-output-file))
(define-generic setup)
(define-generic teardown)
(define-generic build-command)
(define-generic remote-exec)
(define-generic with-remote-input-file)
(define-generic with-remote-output-file)
(define-class <connection> ())
(define-method (setup (c <connection>)) #t)
(define-method (teardown (c <connection>)) #t)
(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? #t))
(xs (remove unspecified?
(flatten (list "env"
(when pwd (list "--chdir" (string-shell-quote pwd)))
(when env (map (match-lambda ((k . v) (string-append k "=" (string-shell-quote v)))) env))
prog-name
(map string-shell-quote prog-args)
(when redirect-err? "2>&1"))))))
(string-join xs " ")))

38
ordo/connection/local.scm
View file

@ -1,38 +0,0 @@
#|
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 connection local)
#:use-module (ice-9 popen)
#:use-module (oop goops)
#:use-module (ordo connection base)
#:use-module (ordo connection sudo)
#:use-module (ordo util read-lines)
#:export (<local-connection>))
(define-class <local-connection> (<sudo-connection>))
(define-method (remote-exec (c <local-connection>) (command <string>))
(let* ((port (open-input-pipe command))
(output (read-lines port))
(exit-status (status:exit-val (close-pipe port))))
(values output exit-status)))
(define-method (with-remote-input-file (c <local-connection>) (filename <string>) (proc <procedure>))
(call-with-input-file filename proc))
(define-method (with-remote-output-file (c <local-connection>) (filename <string>) (proc <procedure>))
(call-with-output-file filename proc))

80
ordo/connection/ssh.scm
View file

@ -1,80 +0,0 @@
#|
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 connection ssh)
#:use-module (oop goops)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 popen)
#:use-module (ssh session)
#:use-module (ssh channel)
#:use-module (ssh auth)
#:use-module (ssh popen)
#:use-module (ssh sftp)
#:use-module (ordo connection base)
#:use-module (ordo connection sudo)
#:use-module (ordo util read-lines)
#:export (<ssh-connection>))
(define-class <ssh-connection> (<sudo-connection>)
(user #:getter ssh-connection-user #:init-keyword #:user)
(host #:getter ssh-connection-host #:init-keyword #:host)
(password #:getter ssh-connection-password #:init-keyword #:password #:init-val #f)
(identity #:getter ssh-connection-identity #:init-keyword #:identity #:init-val #f)
(authenticate-server? #:getter ssh-connection-authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t)
(session)
(sftp-session))
(define-method (setup (c <ssh-connection>))
(unless (slot-bound? c 'session)
(slot-set! c 'session (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c)))
(when (ssh-connection-identity c) (session-set! (slot-ref c 'session) 'identity (ssh-connection-identity c))))
(let ((s (slot-ref c 'session)))
(unless (connected? s)
(connect! s)
(when (ssh-connection-authenticate-server? s)
(let ((server-auth (authenticate-server s)))
(unless (equal? 'ok server-auth)
(error (format #f "authenticate-server: ~a" server-auth)))))
(let ((user-auth (if (ssh-connection-password c)
(userauth-password! s (ssh-connection-password c))
(userauth-public-key/auto! s))))
(unless (equal? 'success user-auth)
(error (format #f "userauth: ~a" user-auth)))))))
(define-method (remote-exec (c <ssh-connection>) (command <string>))
(let* ((channel (open-remote-input-pipe (slot-ref c 'session) command))
(output (read-lines channel))
(exit-status (channel-get-exit-status channel)))
(close channel)
(values output exit-status)))
(define-method (sftp-session (c <ssh-connection>))
(unless (slot-bound? c 'sftp-session)
(slot-set! c 'sftp-session (make-sftp-session (session c))))
(slot-ref c 'sftp-session))
(define-method (with-remote-input-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
(call-with-remote-input-file (sftp-session c) filename proc))
(define-method (with-remote-output-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
(call-with-remote-output-file (sftp-session c) filename proc))
(define-method (teardown (c <ssh-connection>))
(when (slot-bound? c 'session)
(let ((s (slot-ref c session)))
(when (connected? s)
(disconnect! s)))))

66
ordo/connection/sudo.scm
View file

@ -1,66 +0,0 @@
#|
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 connection sudo)
#:use-module (oop goops)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-71)
#:use-module (ordo connection base)
#:use-module (ordo util shell-quote)
#:export (<sudo-connection>
become?
become-user
become-password))
(define-class <sudo-connection> (<connection>)
(become? #:accessor become? #:init-keyword become? #:init-form #f)
(become-user #:accessor become-user #:init-keyword #:become-user #:init-form #f)
(become-password #:accessor become-password #:init-keyword #:become-password #:init-form #f)
(password-tmp-file #:accessor password-tmp-file))
(define-method (setup (conn <sudo-connection>))
(when (become-password conn)
(let ((out rc (remote-exec conn "mktemp")))
(unless (zero? rc)
(raise-exception (make-exception
(make-external-error)
(make-exception-with-message (format #f "Failed to create temporary directory: ~a" (car out))))))
(let ((tmp-file (car out)))
(with-remote-output-file conn tmp-file (cut write-line (become-password conn) <>))
(set! (password-tmp-file conn) tmp-file)))))
(define-method (build-command (conn <sudo-connection>) (prog-name <string>) (prog-args <list>) (options <list>))
(cond
((not (become? conn))
(next-method))
((and (become-user conn) (become-password conn))
(format #f "cat ~a - | sudo -k -S -H -u ~a -- ~a" (string-shell-quote (password-tmp-file conn)) (string-shell-quote (become-user conn)) (next-method)))
((become-password conn)
(format #f "cat ~a - | sudo -k -S -H -- ~a" (string-shell-quote (password-tmp-file conn)) (next-method)))
((become-user conn)
(format #f "sudo -k -n -H -u ~a -- ~a" (string-shell-quote (become-user conn)) (next-method)))
(else (format #f "sudo -k -n -H -- ~a" (next-method)))))
(define-method (teardown (conn <sudo-connection>))
(when (slot-bound? conn 'password-tmp-file)
(remote-exec conn (format #f "rm -f ~a" (string-shell-quote (password-tmp-file conn))))))

24
ordo/context.scm
View file

@ -1,24 +0,0 @@
#|
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 context))
(define-public *inventory* (make-parameter #f))
(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
View file

@ -1,69 +0,0 @@
#|
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)))

39
ordo/handler.scm
View file

@ -1,39 +0,0 @@
#|
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 handler)
#:use-module (srfi srfi-9)
#:use-module (ordo logger)
#:export (make-handler
handler?
handler-name
handler-action
handler
run-handler))
(define-record-type <handler>
(make-handler name action)
handler?
(name handler-name)
(action handler-action))
(define* (handler #:key name action)
(make-handler name action))
(define (run-handler h conn)
(log-msg 'NOTICE "Running handler: " (handler-name h))
((handler-action h) conn))

78
ordo/inventory.scm
View file

@ -1,78 +0,0 @@
#|
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 inventory)
#:use-module (ice-9 eval-string)
#:use-module (ice-9 match)
#:use-module (ice-9 textual-ports)
#:use-module (oop goops)
#:use-module ((ordo connection) #:select (local-connection))
#:use-module (ordo logger)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-69)
#:export (host
host?
host-name
host-connection
host-tags
host-vars
resolve-hosts
load-inventory))
(define-record-type <host>
(make-host name connection tags vars)
host?
(name host-name)
(connection host-connection)
(tags host-tags)
(vars host-vars))
(define* (host #:key name connection (tags '()) (vars '()))
(make-host name connection tags (alist->hash-table vars)))
(define (tagged-every? wanted-tags)
(lambda (h)
(lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags))))
(define (tagged-any? wanted-tags)
(lambda (h)
(not (null? (lset-intersection equal? (host-tags h) wanted-tags)))))
(define (named? hostname)
(lambda (h)
(string=? (host-name h) hostname)))
(define (resolve-hosts inventory expr)
(match expr
("localhost" (list (or (find (named? "localhost") inventory)
(host #:name "localhost" #:connection (local-connection)))))
((? string? hostname) (filter (named? hostname) inventory))
('all inventory)
(('tagged tag) (filter (tagged-every? (list tag)) inventory))
(('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) inventory))
(('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) inventory))
((. hostnames) (filter (lambda (h) (member (host-name h) hostnames string=?)) inventory))))
(define (load-inventory filename)
(log-msg 'INFO "Loading inventory " filename)
(let* ((inventory (eval-string (call-with-input-file filename get-string-all)
#:file filename))
(inventory (if (list? inventory) inventory '())))
(when (null? inventory)
(log-msg 'NOTICE "Inventory is empty, only localhost will be available"))
inventory))

46
ordo/logger.scm
View file

@ -1,46 +0,0 @@
#|
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 logger)
#:use-module (oop goops)
#:use-module ((srfi srfi-1) #:select (take-while member))
#:use-module ((srfi srfi-26) #:select (cut))
#:use-module (logging logger)
#:use-module (logging port-log)
#:export (setup-logging!
shutdown-logging!
valid-log-level?)
#:re-export (log-msg))
(define log-levels '(DEBUG INFO NOTICE WARN ERROR))
(define (valid-log-level? level)
(member level log-levels eq?))
(define* (setup-logging! #:key (level 'INFO))
(let ((logger (make <logger>))
(handler (make <port-log> #:port (current-error-port))))
(for-each (cut disable-log-level! handler <>)
(take-while (negate (cut equal? level <>)) log-levels))
(add-handler! logger handler)
(set-default-logger! logger)
(open-log! logger)))
(define (shutdown-logging!)
(flush-log) ; since no args, it uses the default
(close-log!) ; ditto
(set-default-logger! #f))

92
ordo/play.scm
View file

@ -1,92 +0,0 @@
#|
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 play)
#:use-module (ordo connection)
#:use-module (ordo context)
#:use-module (ordo handler)
#:use-module (ordo inventory)
#:use-module (ordo logger)
#:use-module (ordo task)
#:use-module (ordo util flatten)
#: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
play-sudo?
play-sudo-user
play-sudo-password
play-vars
play-tasks
play-handlers
run-play
trigger-handler!))
(define-record-type <play>
(make-play name host sudo? sudo-user sudo-password vars tasks handlers)
play?
(name play-name)
(host play-host)
(sudo? play-sudo?)
(sudo-user play-sudo-user)
(sudo-password play-sudo-password)
(vars play-vars)
(tasks play-tasks)
(handlers play-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* p))
(let ((hosts (resolve-hosts (*inventory*) (play-host p))))
(if (null? hosts)
(log-msg 'WARN "No hosts matched: " (play-host p))
(for-each (cut run-host-play p <>) hosts)))))
(define (run-host-play p h)
(log-msg 'NOTICE "Running play on host: " (host-name h))
(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 (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))

61
ordo/playbook.scm
View file

@ -1,61 +0,0 @@
#|
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 playbook)
#:use-module (ice-9 eval-string)
#:use-module (ice-9 textual-ports)
#:use-module (ordo context)
#:use-module (ordo handler)
#:use-module (ordo logger)
#:use-module (ordo play)
#:use-module (ordo task)
#: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?
playbook-name
playbook-vars
playbook-plays
load-playbook
run-playbook))
(define-record-type <playbook>
(make-playbook name vars plays)
playbook?
(name playbook-name)
(vars playbook-vars)
(plays playbook-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)
(eval-string (call-with-input-file filename get-string-all)
#:file filename))
(define (run-playbook pb inventory)
(log-msg 'NOTICE "Running playbook: " (playbook-name pb))
(parameterize ((*inventory* inventory)
(*playbook* pb))
(for-each run-play (playbook-plays pb))))

43
ordo/task.scm
View file

@ -1,43 +0,0 @@
#|
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 task)
#:use-module (ordo logger)
#:use-module (srfi srfi-9)
#:export (task
task?
task-name
task-pre-condition
task-action
run-task))
(define-record-type <task>
(make-task name action pre-condition)
task?
(name task-name)
(pre-condition task-pre-condition)
(action task-action))
(define* (task #:key name action (pre-condition (const #t)))
(make-task name action pre-condition))
(define (run-task t conn)
(if ((task-pre-condition t) conn)
(begin
(log-msg 'NOTICE "Running task " (task-name t))
((task-action t) conn))
(log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met")))

27
ordo/util/flatten.scm
View file

@ -1,27 +0,0 @@
#|
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 util flatten)
#:export (flatten))
(define (flatten lst)
(cond
((null? lst) '())
((list? (car lst))
(append (flatten (car lst)) (flatten (cdr lst))))
(else
(cons (car lst) (flatten (cdr lst))))))

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

@ -1,23 +0,0 @@
#|
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 util keyword-args)
#:use-module ((srfi srfi-1) #:select (member))
#:export (keyword-arg))
(define* (keyword-arg args kw #:optional (default #f))
(or (and=> (member kw args) cadr) default))

28
ordo/util/read-lines.scm
View file

@ -1,28 +0,0 @@
#|
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 util read-lines)
#:use-module (ice-9 rdelim)
#:export (read-lines))
(define (read-lines port)
"Read lines from port until eof is encountered. Return list of all lines read."
(define (loop line result)
(if (eof-object? line)
(reverse result)
(loop (read-line port) (cons line result))))
(loop (read-line port) '()))

59
ordo/util/shell-quote.scm
View file

@ -1,59 +0,0 @@
#|
This file is part of Ordo.
Shell quoting implementation is based on Perl's String::ShellQuote
Copyright (c) 1997 Roderick Schertler.
Guile implementation 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, either version 3 of the License, or (at your option)
any later version.
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 util shell-quote)
#:use-module (rx irregex)
#:use-module ((srfi srfi-197) #:select (chain))
#:export (string-shell-quote))
(define unsafe-characters (irregex '(~ (or alphanumeric ("!%+,\\-./:=@^")))))
(define (needs-escape? s)
(irregex-search unsafe-characters s))
(define (squash-quotes m)
(let ((n (/ (- (irregex-match-end-index m)
(irregex-match-start-index m))
4)))
(list->string (append
'(#\' #\")
(make-list n #\')
'(#\" #\')))))
(define (escape s)
(chain s
;; ' -> '\''
(irregex-replace/all (irregex "'") _ "'\\''")
;; make multiple ' in a row look simpler
;; '\'''\'''\'' -> '"'''"'
(irregex-replace/all (irregex '(>= 2 "'\\''")) _ squash-quotes)
;; wrap in single quotes
(string-append "'" _ "'")
;; kill leading/trailing pair of single quotes
(irregex-replace (irregex '(seq bos "''")) _ "")
(irregex-replace (irregex '(seq "''" eos)) _ "")))
(define (string-shell-quote s)
"Quote strings for passing through the shell"
(cond
((zero? (string-length s)) "''")
((needs-escape? s) (escape s))
(else s)))

3
playbooks/tryme.scm Normal file
View file

@ -0,0 +1,3 @@
(define x 7)
(lambda () (* x x))