Compare commits
No commits in common. "main" and "wip/interceptors" have entirely different histories.
main
...
wip/interc
61 changed files with 1385 additions and 1497 deletions
71
.gitignore
vendored
71
.gitignore
vendored
|
|
@ -1,66 +1,5 @@
|
||||||
*.eps
|
scratch/
|
||||||
*.go
|
/.dir-locals.el
|
||||||
*.log
|
/gnu
|
||||||
*.pdf
|
*-tarball-pack.tar.gz
|
||||||
*.png
|
/mybin
|
||||||
*.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/
|
|
||||||
|
|
|
||||||
5
bin/ordo.sh
Executable file
5
bin/ordo.sh
Executable file
|
|
@ -0,0 +1,5 @@
|
||||||
|
#!/usr/bin/env bash
|
||||||
|
|
||||||
|
MODULES_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )/../modules" &> /dev/null && pwd )
|
||||||
|
|
||||||
|
exec guile -L "${MODULES_DIR}" --no-auto-compile -e '(@ (ordo cli) main)' -- "$@"
|
||||||
|
|
@ -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")))
|
|
||||||
41
examples/install-aws-cli.scm
Normal file
41
examples/install-aws-cli.scm
Normal file
|
|
@ -0,0 +1,41 @@
|
||||||
|
(use-modules
|
||||||
|
(ice-9 filesystem)
|
||||||
|
(srfi srfi-71)
|
||||||
|
(ordo playbook)
|
||||||
|
(ordo play)
|
||||||
|
(ordo interceptor)
|
||||||
|
(ordo connection)
|
||||||
|
(ordo interceptor create-tmp-dir)
|
||||||
|
(ordo interceptor require-commands)
|
||||||
|
(ordo interceptor user-info)
|
||||||
|
(ordo interceptor download)
|
||||||
|
(ordo interceptor unzip)
|
||||||
|
(ordo interceptor command))
|
||||||
|
|
||||||
|
;; This example shows that a function can act a bit like an ansible role by
|
||||||
|
;; returning a list of interceptors to be added to the caller's interceptor
|
||||||
|
;; chain. (The list will be flattened to construct the final chain.)
|
||||||
|
(define* (install-aws-cli #:key (url "https://awscli.amazonaws.com/awscli-exe-linux-x86_64.zip") update? install-dir bin-dir)
|
||||||
|
(list (require-commands "wget" "unzip")
|
||||||
|
(create-tmp-dir #:register 'aws-cli-tmp)
|
||||||
|
(download "download-aws-cli" #:url url #:target-dir (var aws-cli-tmp) #:register 'aws-cli-zipfile)
|
||||||
|
(unzip "extract-aws-cli" #:file-name (var aws-cli-zipfile) #:target-dir (var aws-cli-tmp))
|
||||||
|
(command "run-aws-cli-installer"
|
||||||
|
(list
|
||||||
|
(let-vars (aws-cli-tmp) (file-name-join* aws-cli-tmp "aws" "install"))
|
||||||
|
(when install-dir `("-i" ,install-dir))
|
||||||
|
(when bin-dir `("-b" ,bin-dir))
|
||||||
|
(when update? "-u")
|
||||||
|
#:check? #t))))
|
||||||
|
|
||||||
|
(playbook
|
||||||
|
#:name "Test Playbook"
|
||||||
|
#:plays (list
|
||||||
|
(play
|
||||||
|
#:name "Install AWS CLI"
|
||||||
|
#:host "localhost"
|
||||||
|
#:interceptors (list
|
||||||
|
(user-info)
|
||||||
|
(install-aws-cli #:update? #t
|
||||||
|
#:install-dir (let-vars (user-info) (file-name-join* (assoc-ref user-info #:home-dir) ".local" "aws-cli"))
|
||||||
|
#:bin-dir (let-vars (user-info) (file-name-join* (assoc-ref user-info #:home-dir) ".local" "bin")))))))
|
||||||
34
examples/interceptor.scm
Normal file
34
examples/interceptor.scm
Normal file
|
|
@ -0,0 +1,34 @@
|
||||||
|
(use-modules
|
||||||
|
(ice-9 filesystem)
|
||||||
|
(ordo playbook)
|
||||||
|
(ordo play)
|
||||||
|
(ordo interceptor)
|
||||||
|
(ordo interceptor install-file)
|
||||||
|
(ordo interceptor create-tmp-dir)
|
||||||
|
(ordo interceptor stat-file)
|
||||||
|
(ordo interceptor user-info)
|
||||||
|
(ordo interceptor command)
|
||||||
|
(ordo interceptor debug))
|
||||||
|
|
||||||
|
(playbook
|
||||||
|
#:name "Test some basic filesystem operations"
|
||||||
|
#:vars '((file-content . "This is shadowed by the play variable."))
|
||||||
|
#:plays (list (play
|
||||||
|
#:name "Basic filesystem operations"
|
||||||
|
#:host "localhost"
|
||||||
|
#:vars '((file-content . "Hello, world!\n"))
|
||||||
|
#:interceptors (list (create-tmp-dir #:register 'tmp-dir)
|
||||||
|
(user-info)
|
||||||
|
(debug-vars 'user-info)
|
||||||
|
(install-file
|
||||||
|
"install-hello"
|
||||||
|
#:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt"))
|
||||||
|
#:content (var file-content)
|
||||||
|
#:register 'hello)
|
||||||
|
(stat-file
|
||||||
|
"stat-hello"
|
||||||
|
#:path (var hello)
|
||||||
|
#:register 'hello-stat)
|
||||||
|
(command "list-tmp-dir" (list "ls" "-l" (var tmp-dir) #:check? #t) #:register 'dir-list)
|
||||||
|
(command "list-root-dir" (list "ls" "-l" "/root" #:check? #f) #:register 'root-list)
|
||||||
|
(debug-vars)))))
|
||||||
|
|
@ -1,23 +1,14 @@
|
||||||
(use-modules (ordo connection)
|
(use-modules (ordo inventory)
|
||||||
(ordo inventory))
|
(ordo connection))
|
||||||
|
|
||||||
(list
|
(add-host! "little-rascal"
|
||||||
(host #:name "little-rascal"
|
(local-connection)
|
||||||
#:connection (local-connection)
|
#:linux #:guix)
|
||||||
#:tags '(#:linux #:guix))
|
|
||||||
|
|
||||||
(host #:name "limiting-factor"
|
(add-host! "screw-loose"
|
||||||
#:connection (ssh-connection "limiting-factor" #:user "core")
|
(ssh-connection "core" "screw-loose")
|
||||||
#:tags '(#:linux #:coreos))
|
#:linux #:coreos)
|
||||||
|
|
||||||
(host #:name "screw-loose"
|
(add-host! "limiting-factor"
|
||||||
#:connection (ssh-connection "screw-loose" #:user "core")
|
(ssh-connection "core" "limiting-factor")
|
||||||
#:tags '(#:linux #:coreos))
|
#: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)))
|
|
||||||
|
|
|
||||||
|
|
@ -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))))))
|
|
||||||
15
examples/ubuntu.scm
Normal file
15
examples/ubuntu.scm
Normal file
|
|
@ -0,0 +1,15 @@
|
||||||
|
(use-modules
|
||||||
|
(ordo playbook)
|
||||||
|
(ordo play)
|
||||||
|
(ordo interceptor apt))
|
||||||
|
|
||||||
|
(playbook
|
||||||
|
#:name "APT operations"
|
||||||
|
#:plays (list
|
||||||
|
(play
|
||||||
|
#:name "Test APT operations"
|
||||||
|
#:host '(tagged/any #:ubuntu #:debian)
|
||||||
|
#:interceptors (list
|
||||||
|
(apt:update)
|
||||||
|
(apt:dist-upgrade)
|
||||||
|
(map apt:install (list "curl" "ca-certificates"))))))
|
||||||
79
guix.scm
79
guix.scm
|
|
@ -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
26
manifest.scm
Normal 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"))
|
||||||
130
modules/ordo/action/filesystem.scm
Normal file
130
modules/ordo/action/filesystem.scm
Normal file
|
|
@ -0,0 +1,130 @@
|
||||||
|
(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 ((srfi srfi-197) #:select (chain-when))
|
||||||
|
#:use-module ((ordo connection) #:select (run))
|
||||||
|
#:use-module (ordo connection base)
|
||||||
|
#:export (fs:create-tmp-dir
|
||||||
|
fs:install-dir
|
||||||
|
fs:install-file
|
||||||
|
fs:stat
|
||||||
|
fs:remove
|
||||||
|
fs:link))
|
||||||
|
|
||||||
|
(define (fs:stat conn path)
|
||||||
|
(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)
|
||||||
|
(atime . ,atime)
|
||||||
|
(mtime . ,mtime)
|
||||||
|
(ctime . ,ctime))))
|
||||||
|
(let ((result rc (run 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* (fs:remove conn path #:key (recurse? #f) (force? #f) (verbose? #f))
|
||||||
|
(let ((out (run conn "rm" (chain-when '()
|
||||||
|
(verbose? (append _ '("-v")))
|
||||||
|
(recurse? (append _ '("-r")))
|
||||||
|
(force? (append _ '("-f")))
|
||||||
|
(#t (append _ `(,path))))
|
||||||
|
#:check? #t)))
|
||||||
|
(when verbose?
|
||||||
|
(for-each (cut log-msg 'INFO <>) out))))
|
||||||
|
|
||||||
|
(define* (fs:link conn target link-name #:key (symbolic? #f) (force? #f) (backup? #f))
|
||||||
|
"Create a link to @code{target} with the name @code{link-name}."
|
||||||
|
(run conn "ln" (chain-when '()
|
||||||
|
(symbolic? (append _ '("--symbolic")))
|
||||||
|
(force? (append _ '("--force")))
|
||||||
|
(backup? (append _ '("--backup" "numbered")))
|
||||||
|
(#t (append `(,target ,link-name))))
|
||||||
|
#:check? #t))
|
||||||
|
|
||||||
|
(define* (fs:create-tmp-dir conn #:key tmpdir suffix template)
|
||||||
|
(run conn "mktemp" (chain-when
|
||||||
|
'("--directory")
|
||||||
|
(tmpdir (append _ `("--tmpdir" tmpdir)))
|
||||||
|
(suffix (append _ `("--suffix" suffix)))
|
||||||
|
(template (append _ `(template))))
|
||||||
|
#:check? #t
|
||||||
|
#:return car))
|
||||||
|
|
||||||
|
(define* (fs:install-dir conn path #:key owner group mode)
|
||||||
|
(when (integer? mode)
|
||||||
|
(set! mode (number->string mode 8)))
|
||||||
|
(run conn "install" (chain-when
|
||||||
|
'("--directory")
|
||||||
|
(owner (append _ `("--owner" ,owner)))
|
||||||
|
(group (append _ `("--group" ,group)))
|
||||||
|
(mode (append _ `("--mode" ,mode)))
|
||||||
|
(#t (append _ `(,path))))
|
||||||
|
#:check? #t)
|
||||||
|
path)
|
||||||
|
|
||||||
|
(define (upload-tmp-file conn tmp-file)
|
||||||
|
(lambda (input-port)
|
||||||
|
(conn:call-with-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 (fs:stat conn 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)))
|
||||||
|
(run conn
|
||||||
|
"install" (chain-when
|
||||||
|
'()
|
||||||
|
(owner (append _ `("--owner" ,owner)))
|
||||||
|
(group (append _ `("--group" ,group)))
|
||||||
|
(mode (append _ `("--mode" ,mode)))
|
||||||
|
(backup? (append _ '("--backup" "numbered")))
|
||||||
|
(#t (append _ (list src dest))))
|
||||||
|
#:check? #t))
|
||||||
|
|
||||||
|
(define* (fs:install-file conn path #:key owner group mode 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"))
|
||||||
|
(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 (run 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 ()
|
||||||
|
(fs:remove conn tmp-file #:force? #t)))))
|
||||||
|
path)
|
||||||
41
modules/ordo/action/quadlet.scm
Normal file
41
modules/ordo/action/quadlet.scm
Normal file
|
|
@ -0,0 +1,41 @@
|
||||||
|
(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)
|
||||||
|
#:export (create-network-quadlet))
|
||||||
|
|
||||||
|
(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 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)
|
||||||
|
("Install" ,@(or install-options default-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 name #:key description (quadlet-options '()) (unit-options '()) (install-options default-install-options))
|
||||||
|
(fs:install-file conn
|
||||||
|
(file-name-join* quadlet-dir (string-append name suffix))
|
||||||
|
#:content (build-quadlet quadlet-type name description quadlet-options unit-options install-options))))))
|
||||||
|
|
||||||
|
(define-quadlet-type create-network-quadlet "Network" ".network" default-install-options)
|
||||||
|
|
||||||
|
(define-quadlet-type create-pod-quadlet "Pod" ".pod" default-install-options)
|
||||||
|
|
||||||
|
(define-quadlet-type create-container-quadlet "Container" ".container" default-install-options)
|
||||||
|
|
||||||
|
(define-quadlet-type create-volume-quadlet "Volume" ".volume" '())
|
||||||
|
|
||||||
|
(define-quadlet-type create-build-quadlet "Build" ".build" '())
|
||||||
|
|
||||||
|
(define-quadlet-type create-image-quadlet "Image" ".image" '())
|
||||||
20
modules/ordo/cli.scm
Normal file
20
modules/ordo/cli.scm
Normal file
|
|
@ -0,0 +1,20 @@
|
||||||
|
(define-module (ordo cli)
|
||||||
|
#:use-module (ice-9 filesystem)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (logging logger)
|
||||||
|
#:use-module (ordo logger)
|
||||||
|
#:use-module (ordo playbook)
|
||||||
|
#:declarative? #f
|
||||||
|
#:export (main))
|
||||||
|
|
||||||
|
(define (main args)
|
||||||
|
(match-let (((_ inventory-path playbook-path) args))
|
||||||
|
(let ((inventory-path (expand-file-name inventory-path))
|
||||||
|
(playbook-path (expand-file-name playbook-path)))
|
||||||
|
(setup-logging #:level 'INFO)
|
||||||
|
(load inventory-path)
|
||||||
|
(log-msg 'DEBUG "Loaded inventory: " inventory-path)
|
||||||
|
(let ((playbook (load playbook-path)))
|
||||||
|
(log-msg 'DEBUG "Loaded playbook: " playbook-path)
|
||||||
|
(run-playbook playbook))
|
||||||
|
(quit))))
|
||||||
40
modules/ordo/condition.scm
Normal file
40
modules/ordo/condition.scm
Normal file
|
|
@ -0,0 +1,40 @@
|
||||||
|
(define-module (ordo condition)
|
||||||
|
#:use-module (srfi srfi-71)
|
||||||
|
#:use-module (ordo connection)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo action filesystem))
|
||||||
|
|
||||||
|
(define-public (cond:any preds)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let loop ((preds preds))
|
||||||
|
(if (null? preds)
|
||||||
|
#f
|
||||||
|
(let ((p (car preds)))
|
||||||
|
(if (p ctx)
|
||||||
|
#t
|
||||||
|
(loop (cdr preds))))))))
|
||||||
|
|
||||||
|
(define-public (cond:every preds)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let loop ((preds preds))
|
||||||
|
(if (null? preds)
|
||||||
|
#t
|
||||||
|
(let ((p (car preds)))
|
||||||
|
(if (p ctx)
|
||||||
|
(loop (cdr preds))
|
||||||
|
#f))))))
|
||||||
|
|
||||||
|
(define-public (cond:command-available? cmd-name)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let ((_ rc (run (context-connection ctx) "which" cmd-name)))
|
||||||
|
(zero? rc))))
|
||||||
|
|
||||||
|
(define-public (cond:directory? path)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let ((st (fs:stat (context-connection ctx) path)))
|
||||||
|
(and st (string=? "directory" (assoc-ref st 'file-type))))))
|
||||||
|
|
||||||
|
(define-public (cond:regular-file? path)
|
||||||
|
(lambda (ctx)
|
||||||
|
(let ((st (fs:stat (context-connection ctx) path)))
|
||||||
|
(and st (string=? "regular-file" (assoc-ref st 'file-type))))))
|
||||||
69
modules/ordo/connection.scm
Normal file
69
modules/ordo/connection.scm
Normal file
|
|
@ -0,0 +1,69 @@
|
||||||
|
(define-module (ordo connection)
|
||||||
|
#:use-module (oop goops)
|
||||||
|
#:use-module (ice-9 exceptions)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (logging logger)
|
||||||
|
#:use-module (srfi srfi-1) ; list operations
|
||||||
|
#:use-module (srfi srfi-26) ; cut
|
||||||
|
#:use-module (srfi srfi-71) ; extended let
|
||||||
|
#:use-module (ordo connection base)
|
||||||
|
#:use-module (ordo connection local)
|
||||||
|
#:use-module (ordo connection ssh)
|
||||||
|
#:use-module (ordo connection sudo)
|
||||||
|
#:use-module (ordo util flatten)
|
||||||
|
#:use-module (ordo util shell-quote)
|
||||||
|
#:use-module (ordo util keyword-args)
|
||||||
|
#:export (connection?
|
||||||
|
local-connection
|
||||||
|
ssh-connection
|
||||||
|
call-with-connection
|
||||||
|
run)
|
||||||
|
#:re-export (conn:setup conn:teardown))
|
||||||
|
|
||||||
|
(define (connection? c)
|
||||||
|
(is-a? c <connection>))
|
||||||
|
|
||||||
|
(define (local-connection)
|
||||||
|
(make <local-connection>))
|
||||||
|
|
||||||
|
(define* (ssh-connection user host #:key (password #f) (identity #f) (authenticate-server? #t))
|
||||||
|
(make <ssh-connection> #:user user #:host host #:password password
|
||||||
|
#:identity identity #:authenticate-server? authenticate-server?))
|
||||||
|
|
||||||
|
(define* (call-with-connection c sudo? sudo-user sudo-password proc)
|
||||||
|
(let ((c (if sudo?
|
||||||
|
(make <sudo-connection> #:connection c #:become-user sudo-user #:become-password sudo-password)
|
||||||
|
c)))
|
||||||
|
(dynamic-wind
|
||||||
|
(lambda () (conn:setup c))
|
||||||
|
(lambda () (proc c))
|
||||||
|
(lambda () (conn:teardown c)))))
|
||||||
|
|
||||||
|
(define (build-command prog args pwd env redirect-err?)
|
||||||
|
(let ((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
|
||||||
|
(map string-shell-quote args)
|
||||||
|
(when redirect-err? "2>&1"))))))
|
||||||
|
(string-join xs " ")))
|
||||||
|
|
||||||
|
(define (run conn prog . args)
|
||||||
|
(let* ((args kwargs (break keyword? args))
|
||||||
|
(args (remove unspecified? (flatten args)))
|
||||||
|
(pwd (keyword-arg kwargs #:pwd))
|
||||||
|
(env (keyword-arg kwargs #:env))
|
||||||
|
(return (keyword-arg kwargs #:return identity))
|
||||||
|
(check? (keyword-arg kwargs #:check?))
|
||||||
|
(command (build-command prog args pwd env #t)))
|
||||||
|
(log-msg 'INFO "Running command: " command)
|
||||||
|
(let ((out rc (conn:run 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)))))
|
||||||
20
modules/ordo/connection/base.scm
Normal file
20
modules/ordo/connection/base.scm
Normal file
|
|
@ -0,0 +1,20 @@
|
||||||
|
(define-module (ordo connection base)
|
||||||
|
#:use-module (oop goops)
|
||||||
|
#:export (<connection>
|
||||||
|
conn:setup
|
||||||
|
conn:teardown
|
||||||
|
conn:run
|
||||||
|
conn:call-with-input-file
|
||||||
|
conn:call-with-output-file))
|
||||||
|
|
||||||
|
(define-class <connection> ())
|
||||||
|
|
||||||
|
(define-method (conn:setup (c <connection>)) #t)
|
||||||
|
|
||||||
|
(define-method (conn:teardown (c <connection>)) #t)
|
||||||
|
|
||||||
|
(define-generic conn:run)
|
||||||
|
|
||||||
|
(define-generic conn:call-with-input-file)
|
||||||
|
|
||||||
|
(define-generic conn:call-with-output-file)
|
||||||
20
modules/ordo/connection/local.scm
Normal file
20
modules/ordo/connection/local.scm
Normal file
|
|
@ -0,0 +1,20 @@
|
||||||
|
(define-module (ordo connection local)
|
||||||
|
#:use-module (oop goops)
|
||||||
|
#:use-module (ice-9 popen)
|
||||||
|
#:use-module (ordo connection base)
|
||||||
|
#:use-module (ordo util read-lines)
|
||||||
|
#:export (<local-connection>))
|
||||||
|
|
||||||
|
(define-class <local-connection> (<connection>))
|
||||||
|
|
||||||
|
(define-method (conn:run (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 (conn:call-with-input-file (c <local-connection>) (filename <string>) (proc <procedure>))
|
||||||
|
(call-with-input-file filename proc))
|
||||||
|
|
||||||
|
(define-method (conn:call-with-output-file (c <local-connection>) (filename <string>) (proc <procedure>))
|
||||||
|
(call-with-output-file filename proc))
|
||||||
62
modules/ordo/connection/ssh.scm
Normal file
62
modules/ordo/connection/ssh.scm
Normal file
|
|
@ -0,0 +1,62 @@
|
||||||
|
(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 util read-lines)
|
||||||
|
#:export (<ssh-connection>))
|
||||||
|
|
||||||
|
(define-class <ssh-connection> (<connection>)
|
||||||
|
(user #:getter user #:init-keyword #:user)
|
||||||
|
(host #:getter host #:init-keyword #:host)
|
||||||
|
(password #:getter password #:init-keyword #:password #:init-val #f)
|
||||||
|
(identity #:getter identity #:init-keyword #:identity #:init-val #f)
|
||||||
|
(authenticate-server? #:getter authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t)
|
||||||
|
(session #:accessor session)
|
||||||
|
(sftp-session #:accessor sftp-session))
|
||||||
|
|
||||||
|
(define-method (conn:setup (c <ssh-connection>))
|
||||||
|
(unless (slot-bound? c 'session)
|
||||||
|
(set! (session c) (make-session #:user (user c) #:host (host c)))
|
||||||
|
(when (identity c) (session-set! (session c) 'identity (identity c))))
|
||||||
|
(let ((s (session c)))
|
||||||
|
(unless (connected? s)
|
||||||
|
(connect! s)
|
||||||
|
(when (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 (password c)
|
||||||
|
(userauth-password! s (password c))
|
||||||
|
(userauth-public-key/auto! s))))
|
||||||
|
(unless (equal? 'success user-auth)
|
||||||
|
(error (format #f "userauth: ~a" user-auth)))))))
|
||||||
|
|
||||||
|
(define-method (conn:run (c <ssh-connection>) (command <string>))
|
||||||
|
(let* ((channel (open-remote-input-pipe (session c) 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)
|
||||||
|
(set! (sftp-session c) (make-sftp-session (session c))))
|
||||||
|
(sftp-session c))
|
||||||
|
|
||||||
|
(define-method (conn:call-with-input-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||||
|
(call-with-remote-input-file (sftp-session c) filename proc))
|
||||||
|
|
||||||
|
(define-method (conn:call-with-output-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||||
|
(call-with-remote-output-file (sftp-session c) filename proc))
|
||||||
|
|
||||||
|
(define-method (conn:teardown (c <ssh-connection>))
|
||||||
|
(when (slot-bound? c 'session)
|
||||||
|
(let ((s (session c)))
|
||||||
|
(when (connected? s)
|
||||||
|
(disconnect! s)))))
|
||||||
60
modules/ordo/connection/sudo.scm
Normal file
60
modules/ordo/connection/sudo.scm
Normal file
|
|
@ -0,0 +1,60 @@
|
||||||
|
(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>))
|
||||||
|
|
||||||
|
(define-class <sudo-connection> (<connection>)
|
||||||
|
(connection #:getter connection #:init-keyword #:connection)
|
||||||
|
(become-user #:getter become-user #:init-keyword #:become-user #:init-form #f)
|
||||||
|
(become-password #:getter become-password #:init-keyword #:become-password #:init-form #f)
|
||||||
|
(password-tmp-file #:accessor password-tmp-file))
|
||||||
|
|
||||||
|
(define-method (conn:validate (c <sudo-connection>))
|
||||||
|
(conn:validate (connection c)))
|
||||||
|
|
||||||
|
(define-method (conn:setup (c <sudo-connection>))
|
||||||
|
(conn:setup (connection c))
|
||||||
|
(when (become-password c)
|
||||||
|
(let ((out rc (conn:run (connection c) "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)))
|
||||||
|
(conn:call-with-output-file (connection c) tmp-file (cut write-line (become-password c) <>))
|
||||||
|
(set! (password-tmp-file c) tmp-file)))))
|
||||||
|
|
||||||
|
(define-method (sudo-command (c <sudo-connection>))
|
||||||
|
(cond
|
||||||
|
((and (become-user c) (become-password c))
|
||||||
|
(format #f "cat ~a - | sudo -k -S -H -u ~a" (string-shell-quote (password-tmp-file c)) (string-shell-quote (become-user c))))
|
||||||
|
|
||||||
|
((become-password c)
|
||||||
|
(format #f "cat ~a - | sudo -k -S -H" (string-shell-quote (password-tmp-file c))))
|
||||||
|
|
||||||
|
((become-user c)
|
||||||
|
(format #f "sudo -k -n -H -u ~a" (string-shell-quote (become-user c))))
|
||||||
|
|
||||||
|
(else "sudo -k -n -H")))
|
||||||
|
|
||||||
|
(define-method (conn:teardown (c <sudo-connection>))
|
||||||
|
(when (slot-bound? c 'password-tmp-file)
|
||||||
|
(conn:run (connection c) (format #f "rm -f ~a" (string-shell-quote (password-tmp-file c)))))
|
||||||
|
(conn:teardown (connection c)))
|
||||||
|
|
||||||
|
(define-method (conn:run (c <sudo-connection>) (command <string>))
|
||||||
|
(let ((command (string-append (sudo-command c) " -- " command)))
|
||||||
|
(conn:run (connection c) command)))
|
||||||
|
|
||||||
|
;; There is no special sudo handling for file I/O. This means the caller needs to
|
||||||
|
;; ensure that they have read/write access to the target file.
|
||||||
|
(define-method (conn:call-with-input-file (c <sudo-connection>) (filename <string>) (proc <procedure>))
|
||||||
|
(conn:call-with-input-file (connection c) filename proc))
|
||||||
|
|
||||||
|
(define-method (conn:call-with-output-file (c <sudo-connection>) (filename <string>) (proc <procedure>))
|
||||||
|
(conn:call-with-output-file (connection c) filename proc))
|
||||||
226
modules/ordo/interceptor.scm
Normal file
226
modules/ordo/interceptor.scm
Normal file
|
|
@ -0,0 +1,226 @@
|
||||||
|
(define-module (ordo interceptor)
|
||||||
|
#:use-module (ice-9 exceptions)
|
||||||
|
#:use-module (logging logger)
|
||||||
|
#:use-module (srfi srfi-1) ; list utils
|
||||||
|
#:use-module (srfi srfi-9) ; records
|
||||||
|
#:use-module (srfi srfi-26) ; cut
|
||||||
|
#:use-module (srfi srfi-69) ; hash tables
|
||||||
|
#:use-module (srfi srfi-71) ; extended let
|
||||||
|
#:use-module (srfi srfi-145) ; assume
|
||||||
|
#:export (interceptor
|
||||||
|
init-context
|
||||||
|
context-connection
|
||||||
|
set-context-connection!
|
||||||
|
context-error
|
||||||
|
set-context-error!
|
||||||
|
context-suppressed
|
||||||
|
context-vars
|
||||||
|
set-context-vars!
|
||||||
|
var-ref
|
||||||
|
var-set!
|
||||||
|
var-delete!
|
||||||
|
let-vars
|
||||||
|
var
|
||||||
|
expand-vars
|
||||||
|
delayed-var-ref?
|
||||||
|
terminate-when
|
||||||
|
execute))
|
||||||
|
|
||||||
|
(define (check-var-name name)
|
||||||
|
(unless (symbol? name)
|
||||||
|
(raise-exception (make-exception
|
||||||
|
(make-assertion-failure)
|
||||||
|
(make-exception-with-message "Variable name should be a symbol")
|
||||||
|
(make-exception-with-irritants name)))))
|
||||||
|
|
||||||
|
(define-record-type <context>
|
||||||
|
(make-context vars stack queue terminators error suppressed)
|
||||||
|
context?
|
||||||
|
(connection context-connection set-context-connection!)
|
||||||
|
(vars context-vars set-context-vars!)
|
||||||
|
(stack context-stack set-context-stack!)
|
||||||
|
(queue context-queue set-context-queue!)
|
||||||
|
(terminators context-terminators set-context-terminators!)
|
||||||
|
(error context-error set-context-error!)
|
||||||
|
(suppressed context-suppressed set-context-suppressed!))
|
||||||
|
|
||||||
|
(define* (init-context #:key (vars '()))
|
||||||
|
"Initialize a context with optional connection and vars."
|
||||||
|
(for-each check-var-name (map car vars))
|
||||||
|
(make-context
|
||||||
|
;; vars
|
||||||
|
(alist->hash-table vars eqv?)
|
||||||
|
;; stack
|
||||||
|
'()
|
||||||
|
;; queue
|
||||||
|
'()
|
||||||
|
;; terminators
|
||||||
|
'()
|
||||||
|
;; error
|
||||||
|
#f
|
||||||
|
;; suppressed errors
|
||||||
|
'()))
|
||||||
|
|
||||||
|
(define (var-set! ctx name value)
|
||||||
|
(check-var-name name)
|
||||||
|
(log-msg 'DEBUG "Setting variable " name " to " value)
|
||||||
|
(hash-table-set! (context-vars ctx) name value))
|
||||||
|
|
||||||
|
(define* (var-ref ctx name #:optional default)
|
||||||
|
(check-var-name name)
|
||||||
|
(log-msg 'DEBUG "Getting variable " name " with default " default)
|
||||||
|
(hash-table-ref/default (context-vars ctx) name default))
|
||||||
|
|
||||||
|
(define (var-delete! ctx name)
|
||||||
|
(check-var-name name)
|
||||||
|
(log-msg 'DEBUG "Deleting variable " name)
|
||||||
|
(hash-table-delete! (context-vars ctx) name))
|
||||||
|
|
||||||
|
(define-syntax let-vars
|
||||||
|
(syntax-rules ()
|
||||||
|
((let-vars (var-name ...) expr exprs ...)
|
||||||
|
(lambda (ctx)
|
||||||
|
#((delayed-var-ref? . #t))
|
||||||
|
(let ((var-name (hash-table-ref (context-vars ctx) 'var-name)) ...)
|
||||||
|
expr
|
||||||
|
exprs ...)))))
|
||||||
|
|
||||||
|
(define-syntax var
|
||||||
|
(syntax-rules ()
|
||||||
|
((var var-name)
|
||||||
|
(let-vars (var-name) var-name))))
|
||||||
|
|
||||||
|
(define (delayed-var-ref? v)
|
||||||
|
(and (procedure? v) (procedure-property v 'delayed-var-ref?)))
|
||||||
|
|
||||||
|
(define-syntax expand-vars
|
||||||
|
(syntax-rules ()
|
||||||
|
((expand-vars ctx v ...)
|
||||||
|
(values (if (delayed-var-ref? v) (v ctx) v) ...))))
|
||||||
|
|
||||||
|
(define-record-type <interceptor>
|
||||||
|
(make-interceptor name enter leave error)
|
||||||
|
interceptor?
|
||||||
|
(name interceptor-name)
|
||||||
|
(enter interceptor-enter)
|
||||||
|
(leave interceptor-leave)
|
||||||
|
(error interceptor-error))
|
||||||
|
|
||||||
|
(define* (interceptor name #:key enter leave error)
|
||||||
|
(assume (string? name) "interceptor name should be a string" name)
|
||||||
|
(make-interceptor name enter leave error))
|
||||||
|
|
||||||
|
(define-exception-type &interceptor-error &error
|
||||||
|
make-interceptor-error
|
||||||
|
interceptor-error?
|
||||||
|
(interceptor-name interceptor-error-interceptor-name)
|
||||||
|
(stage interceptor-error-stage)
|
||||||
|
(cause interceptor-error-cause))
|
||||||
|
|
||||||
|
(define (enqueue ctx interceptors)
|
||||||
|
"Add interceptors to the context."
|
||||||
|
(unless (every interceptor? interceptors)
|
||||||
|
(error "invalid interceptors"))
|
||||||
|
(set-context-queue! ctx interceptors))
|
||||||
|
|
||||||
|
(define (terminate ctx)
|
||||||
|
"Remove all remaining interceptors from the queue, short-circuiting the
|
||||||
|
enter stage and running the leave stage."
|
||||||
|
(set-context-queue! ctx '()))
|
||||||
|
|
||||||
|
(define (check-terminators ctx)
|
||||||
|
"Check the context terminators and possibly trigger early termination."
|
||||||
|
(let loop ((terminators (context-terminators ctx)))
|
||||||
|
(unless (null? terminators)
|
||||||
|
(let ((t (car terminators)))
|
||||||
|
(if (t ctx)
|
||||||
|
(terminate ctx)
|
||||||
|
(loop (cdr terminators)))))))
|
||||||
|
|
||||||
|
(define (try-enter ctx t)
|
||||||
|
"Run the interceptor's #:enter function."
|
||||||
|
(let ((handler (interceptor-enter t)))
|
||||||
|
(when handler
|
||||||
|
(log-msg 'NOTICE "Running #:enter function for " (interceptor-name t))
|
||||||
|
(with-exception-handler
|
||||||
|
(lambda (e)
|
||||||
|
(set-context-error! ctx (make-interceptor-error (interceptor-name t) #:enter e)))
|
||||||
|
(lambda () (handler ctx))
|
||||||
|
#:unwind? #t))))
|
||||||
|
|
||||||
|
(define (try-leave ctx t)
|
||||||
|
"Run the interceptor's #:leave function."
|
||||||
|
(let ((handler (interceptor-leave t)))
|
||||||
|
(when handler
|
||||||
|
(log-msg 'NOTICE "Running #:leave function for " (interceptor-name t))
|
||||||
|
(with-exception-handler
|
||||||
|
(lambda (e)
|
||||||
|
(set-context-error! ctx
|
||||||
|
(make-interceptor-error (interceptor-name t) #:leave e)))
|
||||||
|
(lambda () (handler ctx))
|
||||||
|
#:unwind? #t))))
|
||||||
|
|
||||||
|
(define (try-error ctx t err)
|
||||||
|
"Run the interceptor's #:error function."
|
||||||
|
(let ((handler (interceptor-error t)))
|
||||||
|
(when handler
|
||||||
|
(log-msg 'NOTICE "Running #:error function for " (interceptor-name t))
|
||||||
|
(with-exception-handler
|
||||||
|
(lambda (e)
|
||||||
|
(log-msg 'WARN "error handler for interceptor '" (interceptor-name t) "' threw error: " e)
|
||||||
|
(set-context-suppressed! ctx
|
||||||
|
(cons (make-interceptor-error (interceptor-name t) #:error e)
|
||||||
|
(context-suppressed ctx))))
|
||||||
|
(lambda () (handler ctx))
|
||||||
|
#:unwind? #t))))
|
||||||
|
|
||||||
|
(define (execute-leave ctx)
|
||||||
|
"Run all the #:leave functions in the queue."
|
||||||
|
(unless (null? (context-queue ctx))
|
||||||
|
(let ((t (car (context-queue ctx)))
|
||||||
|
(err (context-error ctx)))
|
||||||
|
;; Run the error or leave handler, according to whether or not we are
|
||||||
|
;; handling an error
|
||||||
|
(if err
|
||||||
|
(try-error ctx t err)
|
||||||
|
(try-leave ctx t))
|
||||||
|
;; Remove the current interceptor from the queue and add it to the stack
|
||||||
|
(set-context-stack! ctx (cons t (context-stack ctx)))
|
||||||
|
(set-context-queue! ctx (cdr (context-queue ctx)))
|
||||||
|
;; Carry on down the chain
|
||||||
|
(execute-leave ctx))))
|
||||||
|
|
||||||
|
(define (execute-enter ctx)
|
||||||
|
"Run all the #:enter functions in the queue."
|
||||||
|
(if (null? (context-queue ctx))
|
||||||
|
;; Prepare to leave
|
||||||
|
(set-context-queue! ctx (context-stack ctx))
|
||||||
|
(let ((t (car (context-queue ctx))))
|
||||||
|
;; Run the enter handler for the interceptor
|
||||||
|
(try-enter ctx t)
|
||||||
|
;; Remove the current interceptor from the queue and add it to the stack
|
||||||
|
(set-context-stack! ctx (cons t (context-stack ctx)))
|
||||||
|
(set-context-queue! ctx (cdr (context-queue ctx)))
|
||||||
|
(if (context-error ctx)
|
||||||
|
;; If an error was caught, abort the enter phase and set up to run the leave phase
|
||||||
|
(begin
|
||||||
|
(set-context-queue! ctx (context-stack ctx))
|
||||||
|
(set-context-stack! ctx '()))
|
||||||
|
;; Otherwise, check for early termination or carry on down the chain
|
||||||
|
(begin
|
||||||
|
(check-terminators ctx)
|
||||||
|
(execute-enter ctx))))))
|
||||||
|
|
||||||
|
(define (terminate-when ctx pred)
|
||||||
|
"Add a predicate for a termination condition to exit the #:enter chain early."
|
||||||
|
(set-context-terminators! ctx (cons pred (context-terminators ctx))))
|
||||||
|
|
||||||
|
(define (execute ctx interceptors)
|
||||||
|
"Execute all the interceptors on the given context."
|
||||||
|
(log-msg 'DEBUG "Enqueuing interceptors: " (map interceptor-name interceptors))
|
||||||
|
(enqueue ctx interceptors)
|
||||||
|
(log-msg 'DEBUG "Starting #:enter chain: " (map interceptor-name (context-queue ctx)))
|
||||||
|
(execute-enter ctx)
|
||||||
|
(log-msg 'DEBUG "Starting #:leave chain: " (map interceptor-name (context-queue ctx)))
|
||||||
|
(execute-leave ctx)
|
||||||
|
(and=> (context-error ctx) raise-exception))
|
||||||
49
modules/ordo/interceptor/apt.scm
Normal file
49
modules/ordo/interceptor/apt.scm
Normal file
|
|
@ -0,0 +1,49 @@
|
||||||
|
(define-module (ordo interceptor apt)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module ((ordo connection) #:select (run)))
|
||||||
|
|
||||||
|
(define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive")
|
||||||
|
("APT_LISTCHANGES_FRONTEND" . "none")))
|
||||||
|
|
||||||
|
(define-syntax define-apt-interceptor
|
||||||
|
(syntax-rules ()
|
||||||
|
((define-apt-interceptor (name arg) apt-args ...)
|
||||||
|
(define-public (name arg)
|
||||||
|
(interceptor
|
||||||
|
(string-append (symbol->string 'name) " " arg)
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(run (context-connection ctx) "apt-get" "-q" "-y" apt-args ... arg #:env noninteractive-env #:check? #t)))))
|
||||||
|
((define-apt-interceptor name apt-args ...)
|
||||||
|
(define-public (name)
|
||||||
|
(interceptor
|
||||||
|
(symbol->string 'name)
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(run (context-connection ctx) "apt-get" "-q" "-y" apt-args ... #:env noninteractive-env #:check? #t)))))))
|
||||||
|
|
||||||
|
(define-apt-interceptor apt:update "update")
|
||||||
|
|
||||||
|
(define-apt-interceptor apt:upgrade "upgrade")
|
||||||
|
|
||||||
|
(define-apt-interceptor apt:dist-upgrade "dist-upgrade")
|
||||||
|
|
||||||
|
(define-apt-interceptor (apt:install package-name) "install")
|
||||||
|
|
||||||
|
(define-apt-interceptor (apt:install-minimal package-name) "install" "--no-install-recommends")
|
||||||
|
|
||||||
|
(define-apt-interceptor (apt:reinstall package-name) "reinstall")
|
||||||
|
|
||||||
|
(define-apt-interceptor (apt:remove package-name) "remove")
|
||||||
|
|
||||||
|
(define-apt-interceptor (apt:purge package-name) "purge")
|
||||||
|
|
||||||
|
(define-apt-interceptor (apt:build-dep package-name) "build-dep")
|
||||||
|
|
||||||
|
(define-apt-interceptor apt:clean "clean")
|
||||||
|
|
||||||
|
(define-apt-interceptor apt:autoclean "autoclean")
|
||||||
|
|
||||||
|
(define-apt-interceptor apt:distclean "distclean")
|
||||||
|
|
||||||
|
(define-apt-interceptor apt:autoremove "autoremove")
|
||||||
|
|
||||||
|
(define-apt-interceptor apt:autopurge "autopurge")
|
||||||
22
modules/ordo/interceptor/command.scm
Normal file
22
modules/ordo/interceptor/command.scm
Normal file
|
|
@ -0,0 +1,22 @@
|
||||||
|
(define-module (ordo interceptor command)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-145)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo connection)
|
||||||
|
#:use-module (ordo util flatten)
|
||||||
|
#:export (command))
|
||||||
|
|
||||||
|
(define* (command name prog-and-args #:key register)
|
||||||
|
(assume (string? name) "interceptor name should be a string" name)
|
||||||
|
(assume (list? prog-and-args) "prog-and-args should be a list" prog-and-args)
|
||||||
|
(assume (or (not register) (symbol? register)) "register should be a symbol" register)
|
||||||
|
(interceptor
|
||||||
|
name
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(let ((prog-and-args (map (lambda (v) (expand-vars ctx v)) (flatten prog-and-args))))
|
||||||
|
(pk prog-and-args)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (apply run (context-connection ctx) prog-and-args))
|
||||||
|
(lambda result
|
||||||
|
(when register
|
||||||
|
(var-set! ctx register result))))))))
|
||||||
22
modules/ordo/interceptor/connection.scm
Normal file
22
modules/ordo/interceptor/connection.scm
Normal file
|
|
@ -0,0 +1,22 @@
|
||||||
|
(define-module (ordo interceptor connection)
|
||||||
|
#:use-module (oop goops)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo connection)
|
||||||
|
#:use-module (ordo connection sudo)
|
||||||
|
#:export (connection))
|
||||||
|
|
||||||
|
(define* (connection c #:key sudo? sudo-user sudo-password)
|
||||||
|
"Interceptor to manage the current connection."
|
||||||
|
(define (cleanup ctx)
|
||||||
|
(and=> (context-connection ctx) conn:teardown)
|
||||||
|
(set-context-connection! ctx #f))
|
||||||
|
(interceptor
|
||||||
|
"connection"
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(let ((c (if sudo?
|
||||||
|
(make <sudo-connection> #:connection c #:become-user sudo-user #:become-password sudo-password)
|
||||||
|
c)))
|
||||||
|
(conn:setup c)
|
||||||
|
(set-context-connection! ctx c)))
|
||||||
|
#:leave cleanup
|
||||||
|
#:error cleanup))
|
||||||
19
modules/ordo/interceptor/create-tmp-dir.scm
Normal file
19
modules/ordo/interceptor/create-tmp-dir.scm
Normal file
|
|
@ -0,0 +1,19 @@
|
||||||
|
(define-module (ordo interceptor create-tmp-dir)
|
||||||
|
#:use-module (srfi srfi-2)
|
||||||
|
#:use-module (srfi srfi-145)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo action filesystem)
|
||||||
|
#:export (create-tmp-dir))
|
||||||
|
|
||||||
|
(define* (create-tmp-dir #:key (register 'tmp-dir))
|
||||||
|
(assume (symbol? register) "register should be a symbol" register)
|
||||||
|
(define (cleanup ctx)
|
||||||
|
(and-let* ((tmp-dir (var-ref ctx register)))
|
||||||
|
(fs:remove (context-connection ctx) tmp-dir #:recurse? #t)
|
||||||
|
(var-delete! ctx register)))
|
||||||
|
(interceptor
|
||||||
|
(format #f "create-tmp-dir ~a" register)
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(var-set! ctx register (fs:create-tmp-dir (context-connection ctx))))
|
||||||
|
#:leave cleanup
|
||||||
|
#:error cleanup))
|
||||||
16
modules/ordo/interceptor/debug.scm
Normal file
16
modules/ordo/interceptor/debug.scm
Normal file
|
|
@ -0,0 +1,16 @@
|
||||||
|
(define-module (ordo interceptor debug)
|
||||||
|
#:use-module (ice-9 pretty-print)
|
||||||
|
#:use-module ((srfi srfi-1) #:select (concatenate))
|
||||||
|
#:use-module ((srfi srfi-69) #:select (hash-table-keys))
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:export (debug-vars))
|
||||||
|
|
||||||
|
(define (debug-vars . var-names)
|
||||||
|
(interceptor
|
||||||
|
"debug-vars"
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(let ((var-names (if (null? var-names)
|
||||||
|
(hash-table-keys (context-vars ctx))
|
||||||
|
var-names)))
|
||||||
|
(pretty-print (map (lambda (v) (list v (var-ref ctx v 'not-found)))
|
||||||
|
var-names))))))
|
||||||
22
modules/ordo/interceptor/download.scm
Normal file
22
modules/ordo/interceptor/download.scm
Normal file
|
|
@ -0,0 +1,22 @@
|
||||||
|
(define-module (ordo interceptor download)
|
||||||
|
#:use-module (ice-9 filesystem)
|
||||||
|
#:use-module (srfi srfi-71)
|
||||||
|
#:use-module (srfi srfi-145)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo connection)
|
||||||
|
#:export (download))
|
||||||
|
|
||||||
|
(define* (download name #:key url target-dir register)
|
||||||
|
(assume (string? name) "interceptor name should be a string" name)
|
||||||
|
(assume (or (string? url) (delayed-var-ref? url)) "url is required and should be a string" url)
|
||||||
|
(assume (or (not register) (symbol? register)) "register should be a symbol" register)
|
||||||
|
(interceptor
|
||||||
|
name
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(let* ((url target-dir (expand-vars ctx url target-dir))
|
||||||
|
(file-name (file-name-join* target-dir (file-basename url))))
|
||||||
|
(run (context-connection ctx) "wget" "-O" file-name url #:check? #t)
|
||||||
|
(when register
|
||||||
|
(var-set! ctx register file-name))))
|
||||||
|
#:leave (lambda (ctx) (when register (var-delete! ctx register)))
|
||||||
|
#:error (lambda (ctx) (when register (var-delete! ctx register)))))
|
||||||
28
modules/ordo/interceptor/install-file.scm
Normal file
28
modules/ordo/interceptor/install-file.scm
Normal file
|
|
@ -0,0 +1,28 @@
|
||||||
|
(define-module (ordo interceptor install-file)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-145)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo action filesystem)
|
||||||
|
#:export (install-file))
|
||||||
|
|
||||||
|
(define* (install-file name #:key path owner group mode content
|
||||||
|
local-src remote-src backup? register)
|
||||||
|
(assume path "install path is required")
|
||||||
|
(assume (or (not register) (symbol? register)) "register should be a symbol" register)
|
||||||
|
(assume (= 1 (length (filter identity (list content local-src remote-src))))
|
||||||
|
"exactly one of content, local-src, or remote-src is required")
|
||||||
|
(interceptor
|
||||||
|
name
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(let ((path (expand-vars ctx path)))
|
||||||
|
(fs:install-file (context-connection ctx)
|
||||||
|
path
|
||||||
|
#:owner (expand-vars ctx owner)
|
||||||
|
#:group (expand-vars ctx group)
|
||||||
|
#:mode (expand-vars ctx mode)
|
||||||
|
#:content (expand-vars ctx content)
|
||||||
|
#:local-src (expand-vars ctx local-src)
|
||||||
|
#:remote-src (expand-vars ctx remote-src)
|
||||||
|
#:backup? (expand-vars ctx backup?))
|
||||||
|
(when register
|
||||||
|
(var-set! ctx register path))))))
|
||||||
28
modules/ordo/interceptor/require-commands.scm
Normal file
28
modules/ordo/interceptor/require-commands.scm
Normal file
|
|
@ -0,0 +1,28 @@
|
||||||
|
(define-module (ordo interceptor require-commands)
|
||||||
|
#:use-module (ice-9 exceptions)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-71)
|
||||||
|
#:use-module (srfi srfi-145)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo connection)
|
||||||
|
#:export (require-commands))
|
||||||
|
|
||||||
|
(define-exception-type &missing-command-error &external-error
|
||||||
|
make-missing-command-error
|
||||||
|
missing-command-error?
|
||||||
|
(command-name missing-command-error-command-name))
|
||||||
|
|
||||||
|
(define (require-commands . commands)
|
||||||
|
(assume (every string? commands) "commands should be strings" commands)
|
||||||
|
(interceptor
|
||||||
|
(string-append "require-commands " (string-join commands ","))
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(for-each (lambda (cmd)
|
||||||
|
(let ((out rc (run (context-connection ctx) "which" cmd)))
|
||||||
|
(unless (zero? rc)
|
||||||
|
(if (string-contains (car out) (format #f "which: no ~a in" cmd))
|
||||||
|
(raise-exception (make-missing-command-error cmd))
|
||||||
|
(raise-exception (make-exception
|
||||||
|
(make-external-error)
|
||||||
|
(make-exception-with-message (string-append "error running which: " (car out)))))))))
|
||||||
|
commands))))
|
||||||
17
modules/ordo/interceptor/stat-file.scm
Normal file
17
modules/ordo/interceptor/stat-file.scm
Normal file
|
|
@ -0,0 +1,17 @@
|
||||||
|
(define-module (ordo interceptor stat-file)
|
||||||
|
#:use-module (srfi srfi-145)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo action filesystem)
|
||||||
|
#:export (stat-file))
|
||||||
|
|
||||||
|
(define* (stat-file name #:key path register)
|
||||||
|
(assume (string? name) "name is required and should be a string" name)
|
||||||
|
(assume path "path is required" path)
|
||||||
|
(assume (or (not register) (symbol? register)) "register should be a symbol" register)
|
||||||
|
(interceptor
|
||||||
|
name
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(let* ((path (expand-vars ctx path))
|
||||||
|
(st (fs:stat (context-connection ctx) path)))
|
||||||
|
(when register
|
||||||
|
(var-set! ctx register st))))))
|
||||||
16
modules/ordo/interceptor/unzip.scm
Normal file
16
modules/ordo/interceptor/unzip.scm
Normal file
|
|
@ -0,0 +1,16 @@
|
||||||
|
(define-module (ordo interceptor unzip)
|
||||||
|
#:use-module (srfi srfi-71)
|
||||||
|
#:use-module (srfi srfi-145)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo connection)
|
||||||
|
#:export (unzip))
|
||||||
|
|
||||||
|
(define* (unzip name #:key file-name target-dir)
|
||||||
|
(assume (string? name) "interceptor name is required and should be a string" name)
|
||||||
|
(assume (or (string? file-name) (delayed-var-ref? file-name)) "file-name is required and should be a string" file-name)
|
||||||
|
(assume (or (string? target-dir) (delayed-var-ref? target-dir)) "target-dir is required and should be a string" target-dir)
|
||||||
|
(interceptor
|
||||||
|
name
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(let ((file-name target-dir (expand-vars ctx file-name target-dir)))
|
||||||
|
(run (context-connection ctx) "unzip" file-name "-d" target-dir #:check? #t)))))
|
||||||
44
modules/ordo/interceptor/user-info.scm
Normal file
44
modules/ordo/interceptor/user-info.scm
Normal file
|
|
@ -0,0 +1,44 @@
|
||||||
|
(define-module (ordo interceptor user-info)
|
||||||
|
#:use-module (rx irregex)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-145)
|
||||||
|
#:use-module (ordo connection)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo util shell-quote)
|
||||||
|
#:export (user-info))
|
||||||
|
|
||||||
|
(define (parse-id s)
|
||||||
|
(let ((data (reverse (irregex-fold (irregex '(seq (=> id integer) "(" (=> name (+ alphanumeric)) ")"))
|
||||||
|
(lambda (_ m accum)
|
||||||
|
(cons `((#:id . ,(string->number (irregex-match-substring m 'id)))
|
||||||
|
(#:name . ,(irregex-match-substring m 'name)))
|
||||||
|
accum))
|
||||||
|
'()
|
||||||
|
s))))
|
||||||
|
`((#:user-id . ,(assoc-ref (first data) #:id))
|
||||||
|
(#:user-name . ,(assoc-ref (first data) #:name))
|
||||||
|
(#:group-id . ,(assoc-ref (second data) #:id))
|
||||||
|
(#:group-name . ,(assoc-ref (second data) #:name))
|
||||||
|
(#:groups . ,(drop data 2)))))
|
||||||
|
|
||||||
|
(define (parse-passwd-entry s)
|
||||||
|
(map cons
|
||||||
|
'(#:user-name #:password #:user-id #:group-id #:gecos #:home-dir #:shell)
|
||||||
|
(string-split s #\:)))
|
||||||
|
|
||||||
|
(define* (user-info #:key (register 'user-info))
|
||||||
|
(assume (symbol? register) "register should be a symbol" register)
|
||||||
|
(interceptor
|
||||||
|
"user-info"
|
||||||
|
#:enter (lambda (ctx)
|
||||||
|
(let* ((conn (context-connection ctx))
|
||||||
|
(id (run conn "id"
|
||||||
|
#:check? #t #:return (compose parse-id car)))
|
||||||
|
(pwent (run conn "getent" "passwd" (string-shell-quote (assoc-ref id #:user-name))
|
||||||
|
#:check? #t #:return (compose parse-passwd-entry car))))
|
||||||
|
(var-set! ctx register (fold (lambda (key alist)
|
||||||
|
(acons key (assoc-ref pwent key) alist))
|
||||||
|
id
|
||||||
|
(list #:gecos #:home-dir #:shell)))))
|
||||||
|
#:leave (lambda (ctx) (var-delete! ctx register))
|
||||||
|
#:error (lambda (ctx) (var-delete! ctx register))))
|
||||||
47
modules/ordo/inventory.scm
Normal file
47
modules/ordo/inventory.scm
Normal file
|
|
@ -0,0 +1,47 @@
|
||||||
|
(define-module (ordo inventory)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-9)
|
||||||
|
#:use-module ((ordo connection) #:select (local-connection))
|
||||||
|
#:export (make-host
|
||||||
|
host?
|
||||||
|
host-name
|
||||||
|
host-connection
|
||||||
|
host-tags
|
||||||
|
add-host!
|
||||||
|
resolve-hosts))
|
||||||
|
|
||||||
|
(define *inventory* '())
|
||||||
|
|
||||||
|
(define-record-type <host>
|
||||||
|
(make-host name connection tags)
|
||||||
|
host?
|
||||||
|
(name host-name)
|
||||||
|
(connection host-connection)
|
||||||
|
(tags host-tags))
|
||||||
|
|
||||||
|
(define (add-host! name connection . tags)
|
||||||
|
(set! *inventory* (cons (make-host name connection tags)
|
||||||
|
*inventory*)))
|
||||||
|
|
||||||
|
(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
|
||||||
|
(match-lambda
|
||||||
|
("localhost" (list (or (find (named? "localhost") *inventory*)
|
||||||
|
(make-host "localhost" (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*))))
|
||||||
24
modules/ordo/logger.scm
Normal file
24
modules/ordo/logger.scm
Normal file
|
|
@ -0,0 +1,24 @@
|
||||||
|
(define-module (ordo logger)
|
||||||
|
#:use-module (oop goops)
|
||||||
|
#:use-module ((srfi srfi-1) #:select (take-while drop-while))
|
||||||
|
#:use-module ((srfi srfi-26) #:select (cut))
|
||||||
|
#:use-module (logging logger)
|
||||||
|
#:use-module (logging port-log)
|
||||||
|
#:export (setup-logging
|
||||||
|
shutdown-logging))
|
||||||
|
|
||||||
|
(define log-levels '(TRACE DEBUG INFO NOTICE WARN ERROR))
|
||||||
|
|
||||||
|
(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))
|
||||||
65
modules/ordo/password-store.scm
Normal file
65
modules/ordo/password-store.scm
Normal file
|
|
@ -0,0 +1,65 @@
|
||||||
|
(define-module (ordo password-store)
|
||||||
|
#:use-module (ice-9 exceptions)
|
||||||
|
#:use-module (ice-9 format)
|
||||||
|
#:use-module (ice-9 popen)
|
||||||
|
#:use-module ((srfi srfi-1) #:select (last))
|
||||||
|
#:use-module ((srfi srfi-9) #:select (define-record-type))
|
||||||
|
#:use-module (ordo util read-lines)
|
||||||
|
#:use-module (ordo util shell-quote)
|
||||||
|
#:export (make-password-store
|
||||||
|
get-password
|
||||||
|
generate-password))
|
||||||
|
|
||||||
|
(define-exception-type &password-store-error &external-error
|
||||||
|
make-password-store-error
|
||||||
|
password-store-error?
|
||||||
|
(message password-store-error-message)
|
||||||
|
(cause password-store-error-cause))
|
||||||
|
|
||||||
|
(define-record-type <password-store>
|
||||||
|
(make-password-store dir)
|
||||||
|
password-store?
|
||||||
|
(dir password-store-dir))
|
||||||
|
|
||||||
|
(define (pass-command store . args)
|
||||||
|
(let ((base-cmd (if (password-store-dir store)
|
||||||
|
(format #f "env PASSWORD_STORE_DIR=~a pass" (string-shell-quote (password-store-dir store)))
|
||||||
|
"pass")))
|
||||||
|
(string-append base-cmd
|
||||||
|
" "
|
||||||
|
(string-join (map string-shell-quote args) " ")
|
||||||
|
" 2>&1")))
|
||||||
|
|
||||||
|
(define (get-password store path)
|
||||||
|
(let* ((command (pass-command store "show" path))
|
||||||
|
(port (open-input-pipe command))
|
||||||
|
(data (read-lines port))
|
||||||
|
(status (close-pipe port)))
|
||||||
|
(unless (zero? (status:exit-val status))
|
||||||
|
(raise-exception (make-password-store-error (format #f "Error getting password ~a" path) data)))
|
||||||
|
(car data)))
|
||||||
|
|
||||||
|
(define (password-exists? store path)
|
||||||
|
(and (false-if-exception (get-password store path)) #t))
|
||||||
|
|
||||||
|
(define* (generate-password store path #:key (overwrite? #f) (password-length 25))
|
||||||
|
;; WARNING: there is a race condition here between checking the password
|
||||||
|
;; exists and calling pass generate to create it. We have to pass the
|
||||||
|
;; -f option to generate in case we hit this race condition, when pass will prompt
|
||||||
|
;; for confirmation to overwrite an existing file. With the -f option, we will
|
||||||
|
;; go ahead and overwrite it, which seems the lesser of two evils.
|
||||||
|
(unless (or overwrite? (not (password-exists? store path)))
|
||||||
|
(raise-exception (make-password-store-error (format #f "Error generating password ~a" path)
|
||||||
|
"Password already exists")))
|
||||||
|
(let* ((command (pass-command store "generate" "-f" path (number->string password-length)))
|
||||||
|
(port (open-input-pipe command))
|
||||||
|
(data (read-lines port))
|
||||||
|
(status (close-pipe port)))
|
||||||
|
(unless (zero? (status:exit-val status))
|
||||||
|
(raise-exception (make-password-store-error (format #f "Error generating password for ~a" path) data)))
|
||||||
|
(let ((password (last data)))
|
||||||
|
;; Pass wraps the generated password in an escape sequence to change the
|
||||||
|
;; displayed colour: we strip this from the result.
|
||||||
|
(define prefix-len (string-length "\x1b[1m\x1b[93m"))
|
||||||
|
(define suffix-len (string-length "\x1b[0m"))
|
||||||
|
(substring password prefix-len (- (string-length password) suffix-len)))))
|
||||||
49
modules/ordo/play.scm
Normal file
49
modules/ordo/play.scm
Normal file
|
|
@ -0,0 +1,49 @@
|
||||||
|
(define-module (ordo play)
|
||||||
|
#:use-module (srfi srfi-9)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
|
#:use-module (logging logger)
|
||||||
|
#:use-module (ordo connection)
|
||||||
|
#:use-module (ordo interceptor)
|
||||||
|
#:use-module (ordo interceptor connection)
|
||||||
|
#:use-module (ordo inventory)
|
||||||
|
#:use-module (ordo util flatten)
|
||||||
|
#:export (play
|
||||||
|
play?
|
||||||
|
play-host
|
||||||
|
play-sudo?
|
||||||
|
play-sudo-user
|
||||||
|
play-sudo-password
|
||||||
|
play-vars
|
||||||
|
play-interceptors
|
||||||
|
run-play))
|
||||||
|
|
||||||
|
(define-record-type <play>
|
||||||
|
(make-play name host sudo? sudo-user sudo-password vars interceptors)
|
||||||
|
play?
|
||||||
|
(name play-name)
|
||||||
|
(host play-host)
|
||||||
|
(sudo? play-sudo?)
|
||||||
|
(sudo-user play-sudo-user)
|
||||||
|
(sudo-password play-sudo-password)
|
||||||
|
(vars play-vars)
|
||||||
|
(interceptors play-interceptors))
|
||||||
|
|
||||||
|
(define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (interceptors '()))
|
||||||
|
(make-play name host sudo? sudo-user sudo-password vars interceptors))
|
||||||
|
|
||||||
|
(define (run-play p playbook-vars)
|
||||||
|
(log-msg 'NOTICE "Running play: " (play-name p))
|
||||||
|
(let ((hosts (resolve-hosts (play-host p))))
|
||||||
|
(if (null? hosts)
|
||||||
|
(log-msg 'WARN "No hosts matched: " (play-host p))
|
||||||
|
(for-each (lambda (h) (run-host-play p h playbook-vars)) hosts))))
|
||||||
|
|
||||||
|
(define (run-host-play p h playbook-vars)
|
||||||
|
(log-msg 'NOTICE "Running play: " (play-name p) " on host: " (host-name h))
|
||||||
|
(let ((chain (flatten (cons (connection (host-connection h)
|
||||||
|
#:sudo? (play-sudo? p)
|
||||||
|
#:sudo-user (play-sudo-user p)
|
||||||
|
#:sudo-password (play-sudo-password p))
|
||||||
|
(play-interceptors p))))
|
||||||
|
(ctx (init-context #:vars (append (play-vars p) playbook-vars))))
|
||||||
|
(execute ctx chain)))
|
||||||
26
modules/ordo/playbook.scm
Normal file
26
modules/ordo/playbook.scm
Normal file
|
|
@ -0,0 +1,26 @@
|
||||||
|
(define-module (ordo playbook)
|
||||||
|
#:use-module (srfi srfi-9)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
|
#:use-module (logging logger)
|
||||||
|
#:use-module (ordo play)
|
||||||
|
#:export (playbook
|
||||||
|
playbook?
|
||||||
|
playbook-name
|
||||||
|
playbook-vars
|
||||||
|
playbook-plays
|
||||||
|
run-playbook))
|
||||||
|
|
||||||
|
(define-record-type <playbook>
|
||||||
|
(make-playbook name vars plays)
|
||||||
|
playbook?
|
||||||
|
(name playbook-name)
|
||||||
|
(vars playbook-vars)
|
||||||
|
(plays playbook-plays))
|
||||||
|
|
||||||
|
(define* (playbook #:key name (vars '()) plays)
|
||||||
|
(make-playbook name vars plays))
|
||||||
|
|
||||||
|
(define (run-playbook pb)
|
||||||
|
(log-msg 'NOTICE "Running playbook: " (playbook-name pb))
|
||||||
|
(for-each (cut run-play <> (playbook-vars pb))
|
||||||
|
(playbook-plays pb)))
|
||||||
10
modules/ordo/util/flatten.scm
Normal file
10
modules/ordo/util/flatten.scm
Normal file
|
|
@ -0,0 +1,10 @@
|
||||||
|
(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))))))
|
||||||
27
modules/ordo/util/keyword-args.scm
Normal file
27
modules/ordo/util/keyword-args.scm
Normal file
|
|
@ -0,0 +1,27 @@
|
||||||
|
(define-module (ordo util keyword-args)
|
||||||
|
#:use-module (ice-9 exceptions)
|
||||||
|
#:export (keyword-arg
|
||||||
|
select-keyword-args
|
||||||
|
validate-keyword-args))
|
||||||
|
|
||||||
|
(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")))))
|
||||||
11
modules/ordo/util/read-lines.scm
Normal file
11
modules/ordo/util/read-lines.scm
Normal file
|
|
@ -0,0 +1,11 @@
|
||||||
|
(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) '()))
|
||||||
|
|
@ -1,23 +1,21 @@
|
||||||
#|
|
;; This file is part of Ordo.
|
||||||
This file is part of Ordo.
|
;;
|
||||||
|
;; Shell quoting implementation is based on Perl's String::ShellQuote
|
||||||
Shell quoting implementation is based on Perl's String::ShellQuote
|
;; Copyright (c) 1997 Roderick Schertler.
|
||||||
Copyright (c) 1997 Roderick Schertler.
|
;;
|
||||||
|
;; Guile implementation Copyright (c) 2025 Ray Miller.
|
||||||
Guile implementation Copyright (c) 2025 Ray Miller.
|
;;
|
||||||
|
;; Ordo is free software: you can redistribute it and/or modify it under
|
||||||
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
|
||||||
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)
|
||||||
Software Foundation, either version 3 of the License, or (at your option)
|
;; any later version.
|
||||||
any later version.
|
;;
|
||||||
|
;; Ordo is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||||
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
|
||||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
|
;; A PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||||
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
|
||||||
You should have received a copy of the GNU General Public License along with
|
;; Ordo. If not, see <https://www.gnu.org/licenses/>.
|
||||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
|
||||||
|#
|
|
||||||
|
|
||||||
(define-module (ordo util shell-quote)
|
(define-module (ordo util shell-quote)
|
||||||
#:use-module (rx irregex)
|
#:use-module (rx irregex)
|
||||||
48
ordo.scm
48
ordo.scm
|
|
@ -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!)))))
|
|
||||||
|
|
@ -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)))))))
|
|
||||||
|
|
@ -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)))
|
|
||||||
|
|
@ -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)
|
|
||||||
|
|
@ -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)))
|
|
||||||
|
|
@ -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)))))
|
|
||||||
|
|
@ -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 " ")))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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)))))
|
|
||||||
|
|
@ -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))))))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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)))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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))))
|
|
||||||
|
|
@ -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")))
|
|
||||||
|
|
@ -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))))))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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) '()))
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue