Compare commits
No commits in common. "wip/interceptors" and "main" have entirely different histories.
wip/interc
...
main
61 changed files with 1497 additions and 1385 deletions
71
.gitignore
vendored
71
.gitignore
vendored
|
|
@ -1,5 +1,66 @@
|
|||
scratch/
|
||||
/.dir-locals.el
|
||||
/gnu
|
||||
*-tarball-pack.tar.gz
|
||||
/mybin
|
||||
*.eps
|
||||
*.go
|
||||
*.log
|
||||
*.pdf
|
||||
*.png
|
||||
*.tar.xz
|
||||
*.tar.gz
|
||||
*.tmp
|
||||
*~
|
||||
.#*
|
||||
\#*\#
|
||||
,*
|
||||
/ABOUT-NLS
|
||||
/INSTALL
|
||||
/aclocal.m4
|
||||
/autom4te.cache
|
||||
/build-aux/ar-lib
|
||||
/build-aux/compile
|
||||
/build-aux/config.guess
|
||||
/build-aux/config.rpath
|
||||
/build-aux/config.sub
|
||||
/build-aux/depcomp
|
||||
/build-aux/install-sh
|
||||
/build-aux/mdate-sh
|
||||
/build-aux/missing
|
||||
/build-aux/test-driver
|
||||
/build-aux/texinfo.tex
|
||||
/config.status
|
||||
/configure
|
||||
/doc/*.1
|
||||
/doc/.dirstamp
|
||||
/doc/contributing.*.texi
|
||||
/doc/*.aux
|
||||
/doc/*.cp
|
||||
/doc/*.cps
|
||||
/doc/*.fn
|
||||
/doc/*.fns
|
||||
/doc/*.html
|
||||
/doc/*.info
|
||||
/doc/*.info-[0-9]
|
||||
/doc/*.ky
|
||||
/doc/*.pg
|
||||
/doc/*.toc
|
||||
/doc/*.t2p
|
||||
/doc/*.tp
|
||||
/doc/*.vr
|
||||
/doc/*.vrs
|
||||
/doc/stamp-vti
|
||||
/doc/version.texi
|
||||
/doc/version-*.texi
|
||||
/m4/*
|
||||
/pre-inst-env
|
||||
/test-env
|
||||
/test-tmp
|
||||
/tests/*.trs
|
||||
GPATH
|
||||
GRTAGS
|
||||
GTAGS
|
||||
Makefile
|
||||
Makefile.in
|
||||
config.cache
|
||||
stamp-h[0-9]
|
||||
tmp
|
||||
/.version
|
||||
/doc/stamp-[0-9]
|
||||
/.config/
|
||||
|
|
|
|||
|
|
@ -1,5 +0,0 @@
|
|||
#!/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)' -- "$@"
|
||||
60
examples/forgejo.scm
Normal file
60
examples/forgejo.scm
Normal file
|
|
@ -0,0 +1,60 @@
|
|||
(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")))
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
(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")))))))
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
(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,14 +1,23 @@
|
|||
(use-modules (ordo inventory)
|
||||
(ordo connection))
|
||||
(use-modules (ordo connection)
|
||||
(ordo inventory))
|
||||
|
||||
(add-host! "little-rascal"
|
||||
(local-connection)
|
||||
#:linux #:guix)
|
||||
(list
|
||||
(host #:name "little-rascal"
|
||||
#:connection (local-connection)
|
||||
#:tags '(#:linux #:guix))
|
||||
|
||||
(add-host! "screw-loose"
|
||||
(ssh-connection "core" "screw-loose")
|
||||
#:linux #:coreos)
|
||||
(host #:name "limiting-factor"
|
||||
#:connection (ssh-connection "limiting-factor" #:user "core")
|
||||
#:tags '(#:linux #:coreos))
|
||||
|
||||
(add-host! "limiting-factor"
|
||||
(ssh-connection "core" "limiting-factor")
|
||||
#:linux #:coreos)
|
||||
(host #:name "screw-loose"
|
||||
#:connection (ssh-connection "screw-loose" #:user "core")
|
||||
#:tags '(#:linux #:coreos))
|
||||
|
||||
(host #:name "control-surface"
|
||||
#:connection (ssh-connection "control-surface" #:user "ray")
|
||||
#:tags '(#:linux #:debian))
|
||||
|
||||
(host #:name "cargo-cult"
|
||||
#:connection (ssh-connection "cargo-cult" #:user "ray")
|
||||
#:tags '(#:linux #:synology)))
|
||||
|
|
|
|||
17
examples/playbook.scm
Normal file
17
examples/playbook.scm
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
(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))))))
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
(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
Normal file
79
guix.scm
Normal file
|
|
@ -0,0 +1,79 @@
|
|||
(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
26
manifest.scm
|
|
@ -1,26 +0,0 @@
|
|||
(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"))
|
||||
|
|
@ -1,130 +0,0 @@
|
|||
(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)
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
(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" '())
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
(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))))
|
||||
|
|
@ -1,40 +0,0 @@
|
|||
(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))))))
|
||||
|
|
@ -1,69 +0,0 @@
|
|||
(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)))))
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
(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)
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
(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))
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
(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)))))
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
(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))
|
||||
|
|
@ -1,226 +0,0 @@
|
|||
(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))
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
(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")
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
(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))))))))
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
(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))
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
(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))
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
(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))))))
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
(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)))))
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
(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))))))
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
(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))))
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
(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))))))
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
(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)))))
|
||||
|
|
@ -1,44 +0,0 @@
|
|||
(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))))
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
(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*))))
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
(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))
|
||||
|
|
@ -1,65 +0,0 @@
|
|||
(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)))))
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
(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)))
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
(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)))
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
(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,27 +0,0 @@
|
|||
(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")))))
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
(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) '()))
|
||||
48
ordo.scm
Executable file
48
ordo.scm
Executable file
|
|
@ -0,0 +1,48 @@
|
|||
#!/usr/bin/guile \
|
||||
--no-auto-compile -e main -s
|
||||
!#
|
||||
|
||||
(use-modules (config)
|
||||
(config api)
|
||||
(config parser sexp)
|
||||
(ice-9 format)
|
||||
(ice-9 match)
|
||||
((ordo cli run) #:prefix run:)
|
||||
(ordo logger))
|
||||
|
||||
(define config
|
||||
(configuration
|
||||
(name 'ordo)
|
||||
(synopsis "From chaos, comes order")
|
||||
(description "Ordo configuration management.")
|
||||
(keywords
|
||||
(list
|
||||
(setting
|
||||
(name 'log-level)
|
||||
(handler string->symbol)
|
||||
(test valid-log-level?)
|
||||
(default 'NOTICE)
|
||||
(example "DEBUG|INFO|NOTICE|WARN|ERROR")
|
||||
(synopsis "Log level"))))
|
||||
(parser sexp-parser)
|
||||
(directory (in-cwd ".config/" #t))
|
||||
(version "0.1.0")
|
||||
(author "Ray Miller")
|
||||
(license gpl3+)
|
||||
(copyright (list 2025))
|
||||
(subcommands
|
||||
(list
|
||||
run:config))))
|
||||
|
||||
(define (main cmd-line)
|
||||
(let ((options (getopt-config-auto cmd-line config)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(setup-logging! #:level (option-ref options 'log-level)))
|
||||
(lambda ()
|
||||
(match (full-command options)
|
||||
(("ordo" "run")
|
||||
(run:handler options))
|
||||
(_ (emit-help options))))
|
||||
(lambda ()
|
||||
(shutdown-logging!)))))
|
||||
153
ordo/action/filesystem.scm
Normal file
153
ordo/action/filesystem.scm
Normal file
|
|
@ -0,0 +1,153 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo action filesystem)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (logging logger)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (srfi srfi-1) ; list utils
|
||||
#:use-module (srfi srfi-26) ; cut
|
||||
#:use-module (srfi srfi-71) ; extended let
|
||||
#:use-module ((ordo connection) #:select (remote-cmd))
|
||||
#:use-module (ordo connection base)
|
||||
#:export (create-tmp-dir
|
||||
install-dir
|
||||
install-file
|
||||
file-info
|
||||
remove-file
|
||||
create-link))
|
||||
|
||||
(define* (file-info conn #:key path (atime? #t) (ctime? #t))
|
||||
(define (parse-stat-result s)
|
||||
(match-let* (((file-type user group . rest) (string-split s #\:))
|
||||
((uid gid size mode atime mtime ctime) (map string->number rest)))
|
||||
`((file-type . ,file-type)
|
||||
(user . ,user)
|
||||
(group . ,group)
|
||||
(uid . ,uid)
|
||||
(gid . ,gid)
|
||||
(size . ,size)
|
||||
(mode . ,mode)
|
||||
,@(if atime? (list (cons 'atime atime)) '())
|
||||
(mtime . ,mtime)
|
||||
,@(if ctime? (list (cons 'ctime ctime)) '()))))
|
||||
(let ((result rc (remote-cmd conn "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path))))
|
||||
(cond
|
||||
((zero? rc) (parse-stat-result (first result)))
|
||||
((string-contains (first result) "No such file or directory") #f)
|
||||
(else (error (format #f "stat ~a: ~a" path (first result)))))))
|
||||
|
||||
(define-syntax changed-if-stat-changed
|
||||
(syntax-rules ()
|
||||
((changed-if-stat-changed conn path expr ...)
|
||||
(let ((st-before (file-info conn #:path path #:atime? #f #:ctime? #f)))
|
||||
expr ...
|
||||
(let ((st-after (file-info conn #:path path #:atime? #f #:ctime? #f)))
|
||||
(not (equal? st-before st-after)))))))
|
||||
|
||||
(define* (remove-file conn #:key path (recurse? #f))
|
||||
(changed-if-stat-changed
|
||||
conn path
|
||||
(remote-cmd conn "rm" "-f" (when recurse? "-r") path
|
||||
#:check? #t)))
|
||||
|
||||
(define* (create-link conn #:key target link-name (symbolic? #f) (force? #t) (backup? #f))
|
||||
"Create a link to @code{target} with the name @code{link-name}."
|
||||
(changed-if-stat-changed
|
||||
conn link-name
|
||||
(remote-cmd conn "ln"
|
||||
(when symbolic? "--symbolic")
|
||||
(when force? "--force")
|
||||
(when backup? "--backup=numbered")
|
||||
target
|
||||
link-name
|
||||
#:check? #t)))
|
||||
|
||||
(define* (create-tmp-dir conn #:key tmpdir suffix template)
|
||||
(remote-cmd conn "mktemp" "--directory"
|
||||
(when tmpdir '("--tmpdir" tmpdir))
|
||||
(when suffix '("--suffix" suffix))
|
||||
(when template template)
|
||||
#:check? #t
|
||||
#:return car))
|
||||
|
||||
(define* (install-dir conn #:key path owner group mode)
|
||||
(when (integer? mode)
|
||||
(set! mode (number->string mode 8)))
|
||||
(changed-if-stat-changed
|
||||
conn path
|
||||
(remote-cmd conn "install" "--directory"
|
||||
(when owner `("--owner" ,owner))
|
||||
(when group `("--group" ,group))
|
||||
(when mode `("--mode" ,mode))
|
||||
path
|
||||
#:check? #t)))
|
||||
|
||||
(define (upload-tmp-file conn tmp-file)
|
||||
(lambda (input-port)
|
||||
(with-remote-output-file conn tmp-file
|
||||
(lambda (output-port)
|
||||
(let loop ((data (get-bytevector-some input-port)))
|
||||
(unless (eof-object? data)
|
||||
(put-bytevector output-port data)
|
||||
(loop (get-bytevector-some input-port))))
|
||||
(close-port output-port)))))
|
||||
|
||||
(define (install-remote-file conn src dest owner group mode backup?)
|
||||
;; If owner/group/mode is unspecified and the destination file already exists,
|
||||
;; preserve the current ownership and mode.
|
||||
(unless (and owner group mode)
|
||||
(let ((st (file-info conn #:path dest)))
|
||||
(when st
|
||||
(set! owner (or owner (assoc-ref st 'owner)))
|
||||
(set! group (or group (assoc-ref st 'group)))
|
||||
(set! mode (or mode (assoc-ref st 'mode))))))
|
||||
(when (integer? mode)
|
||||
(set! mode (number->string mode 8)))
|
||||
(remote-cmd conn "install"
|
||||
"--compare"
|
||||
(when owner `("--owner" ,owner))
|
||||
(when group `("--group" ,group))
|
||||
(when mode `("--mode" ,mode))
|
||||
(when backup? "--backup=numbered")
|
||||
src
|
||||
dest
|
||||
#:check? #t))
|
||||
|
||||
(define* (install-file conn #:key path owner group (mode #o644) content local-src remote-src backup?)
|
||||
(when (not (= 1 (length (filter identity (list content local-src remote-src)))))
|
||||
(error "exactly one of #:content, #:local-src, or #:remote-src is required"))
|
||||
(changed-if-stat-changed
|
||||
conn path
|
||||
(if remote-src
|
||||
(install-remote-file conn remote-src path owner group mode backup?)
|
||||
;; Because we might need sudo to install the remote file, we first
|
||||
;; upload the source to a temporary file, then call @code{install-remote-file} to
|
||||
;; install the temporary file to the target path.
|
||||
(let ((tmp-file (remote-cmd conn "mktemp" #:check? #t #:return car)))
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
(cond
|
||||
(local-src (call-with-input-file local-src (upload-tmp-file conn tmp-file)))
|
||||
((string? content) (call-with-input-string content (upload-tmp-file conn tmp-file)))
|
||||
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn tmp-file)))
|
||||
(else (error "unsupported type for #:content")))
|
||||
(install-remote-file conn tmp-file path owner group mode backup?))
|
||||
(lambda ()
|
||||
(remote-cmd conn "rm" "-f" tmp-file)))))))
|
||||
75
ordo/action/quadlet.scm
Normal file
75
ordo/action/quadlet.scm
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo action quadlet)
|
||||
#:use-module (ice-9 filesystem)
|
||||
#:use-module (ini)
|
||||
#:use-module (logging logger)
|
||||
#:use-module (ordo connection)
|
||||
#:use-module ((ordo action filesystem) #:prefix fs:)
|
||||
#:use-module ((srfi srfi-1) #:select (remove))
|
||||
#:export (create-network
|
||||
create-pod
|
||||
create-container
|
||||
create-volume
|
||||
create-image
|
||||
create-build))
|
||||
|
||||
(define system-quadlet-dir "/etc/containers/systemd")
|
||||
|
||||
(define default-install-options '(("WantedBy" . "multi-user.target default.target")))
|
||||
|
||||
(define (scm->ini-string data)
|
||||
(with-output-to-string (lambda () (scm->ini data))))
|
||||
|
||||
(define (quadlet quadlet-type name description unit-options quadlet-options service-options install-options)
|
||||
(let* ((description (or description (string-append "Podman " (string-downcase quadlet-type) " " name)))
|
||||
(data `(("Unit" ("Description" . ,description) ,@unit-options)
|
||||
(,(string-titlecase quadlet-type) ,@quadlet-options)
|
||||
,@(if (null? service-options) '() (list (cons "Service" service-options)))
|
||||
,@(if (null? install-options) '() (list (cons "Install" install-options))))))
|
||||
(scm->ini-string data)))
|
||||
|
||||
(define* (create-network conn #:key name description network (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir))
|
||||
(fs:install-file conn
|
||||
#:path (file-name-join* quadlet-dir (string-append name ".network"))
|
||||
#:content (quadlet "Network" name description unit network service install)))
|
||||
|
||||
(define* (create-pod conn #:key name description pod (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir))
|
||||
(fs:install-file conn
|
||||
#:path (file-name-join* quadlet-dir (string-append name ".pod"))
|
||||
#:content (quadlet "Pod" name description unit pod service install)))
|
||||
|
||||
(define* (create-container conn #:key name description container (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir))
|
||||
(fs:install-file conn
|
||||
#:path (file-name-join* quadlet-dir (string-append name ".container"))
|
||||
#:content (quadlet "Container" name description unit container service install)))
|
||||
|
||||
(define* (create-volume conn #:key name description volume (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir))
|
||||
(fs:install-file conn
|
||||
#:path (file-name-join* quadlet-dir (string-append name ".volume"))
|
||||
#:content (quadlet "Volume" name description unit volume service install)))
|
||||
|
||||
(define* (create-build conn #:key name description build (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir))
|
||||
(fs:install-file conn
|
||||
#:path (file-name-join* quadlet-dir (string-append name ".build"))
|
||||
#:content (quadlet "Build" name description unit build service install)))
|
||||
|
||||
(define* (create-image conn #:key name description image (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir))
|
||||
(fs:install-file conn
|
||||
#:path (file-name-join* quadlet-dir (string-append name ".image"))
|
||||
#:content (quadlet "Image" name description unit image service install)))
|
||||
40
ordo/action/systemctl.scm
Normal file
40
ordo/action/systemctl.scm
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo action systemctl)
|
||||
#:use-module (ordo connection)
|
||||
#:export (daemon-reload stop start restart reload))
|
||||
|
||||
(define* (daemon-reload conn #:key user?)
|
||||
(remote-cmd conn "systemctl" (when user? "--user") "daemon-reload" #:check? #t)
|
||||
#t)
|
||||
|
||||
(define* (stop conn #:key unit user?)
|
||||
(remote-cmd conn "systemctl" (when user? "--user") "stop" unit #:check? #t)
|
||||
#t)
|
||||
|
||||
(define* (start conn #:key unit user?)
|
||||
(remote-cmd conn "systemctl" (when user? "--user") "start" unit #:check? #t)
|
||||
#t)
|
||||
|
||||
(define* (reload conn #:key unit user?)
|
||||
(remote-cmd conn "systemctl" (when user? "--user") "reload" unit #:check? #t)
|
||||
#t)
|
||||
|
||||
(define* (restart conn #:key unit user?)
|
||||
(remote-cmd conn "systemctl" (when user? "--user") "restart" unit #:check? #t)
|
||||
#t)
|
||||
68
ordo/cli/run.scm
Normal file
68
ordo/cli/run.scm
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo cli run)
|
||||
#:use-module (config)
|
||||
#:use-module (config api)
|
||||
#:use-module (ice-9 filesystem)
|
||||
#:use-module (ordo inventory)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo playbook)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:export (config handler))
|
||||
|
||||
(define (valid-tags? x)
|
||||
(or (null? x)
|
||||
(and (list? x) (every keyword? x))))
|
||||
|
||||
(define (parse-tags x)
|
||||
(map (compose symbol->keyword string->symbol)
|
||||
(if (list? x) x (list x))))
|
||||
|
||||
(define config
|
||||
(configuration
|
||||
(name 'run)
|
||||
(wanted '((keywords . (log-level)) directory))
|
||||
(keywords
|
||||
(list
|
||||
(setting
|
||||
(name 'inventory)
|
||||
(default "/dev/null")
|
||||
(example "examples/inventory.scm")
|
||||
(handler (cut expand-file-name <> #f #t))
|
||||
(test file-exists?)
|
||||
(synopsis "Inventory file"))
|
||||
(switch
|
||||
(name 'tag)
|
||||
(default (list))
|
||||
(test valid-tags?)
|
||||
(handler parse-tags)
|
||||
(merge-strategy cons)
|
||||
(synopsis "Limit operations to specified tag(s)"))))
|
||||
(arguments
|
||||
(list
|
||||
(argument
|
||||
(name 'playbook)
|
||||
(handler (cut expand-file-name <> #f #t))
|
||||
(test file-exists?))))
|
||||
(synopsis "Run a playbook")))
|
||||
|
||||
(define (handler options)
|
||||
(let ((inventory (load-inventory (option-ref options 'inventory)))
|
||||
(playbook (load-playbook (option-ref options '(playbook)))))
|
||||
(run-playbook playbook inventory)))
|
||||
80
ordo/connection.scm
Normal file
80
ordo/connection.scm
Normal file
|
|
@ -0,0 +1,80 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo connection)
|
||||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ordo connection base)
|
||||
#:use-module (ordo connection local)
|
||||
#:use-module (ordo connection ssh)
|
||||
#:use-module (ordo connection sudo)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo util flatten)
|
||||
#:use-module (ordo util keyword-args)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-71)
|
||||
#:export (connection?
|
||||
local-connection
|
||||
ssh-connection
|
||||
call-with-connection
|
||||
remote-cmd)
|
||||
#:re-export (remote-exec with-remote-input-file with-remote-output-file))
|
||||
|
||||
(define (connection? c)
|
||||
(is-a? c <connection>))
|
||||
|
||||
(define (local-connection)
|
||||
(make <local-connection>))
|
||||
|
||||
(define* (ssh-connection host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t)
|
||||
(sudo? #f) (sudo-user #f) (sudo-password #f))
|
||||
(make <ssh-connection> #:user user #:host host #:password password
|
||||
#:identity identity #:authenticate-server? authenticate-server?
|
||||
#:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password))
|
||||
|
||||
(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password)
|
||||
(let ((conn (deep-clone conn)))
|
||||
(when sudo?
|
||||
(unless (is-a? conn <sudo-connection>)
|
||||
(raise-exception
|
||||
(make-exception
|
||||
(make-programming-error)
|
||||
(make-exception-with-message (format #f "connection ~a does not support sudo" conn)))))
|
||||
(set! (become? conn) sudo?)
|
||||
(set! (become-user conn) sudo-user)
|
||||
(set! (become-password conn) sudo-password))
|
||||
(dynamic-wind
|
||||
(lambda () (setup conn))
|
||||
(lambda () (proc conn))
|
||||
(lambda () (teardown conn)))))
|
||||
|
||||
(define (remote-cmd conn prog . args)
|
||||
(let* ((args options (break keyword? args))
|
||||
(args (remove unspecified? (flatten args)))
|
||||
(return (keyword-arg options #:return identity))
|
||||
(check? (keyword-arg options #:check?))
|
||||
(command (build-command conn prog args options)))
|
||||
(log-msg 'INFO "Running command: " command)
|
||||
(let ((out rc (remote-exec conn command)))
|
||||
(log-msg 'INFO "Command exit code: " rc)
|
||||
(if check?
|
||||
(if (zero? rc)
|
||||
(return out)
|
||||
(raise-exception (make-exception
|
||||
(make-external-error)
|
||||
(make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog)))))
|
||||
(values (return out) rc)))))
|
||||
57
ordo/connection/base.scm
Normal file
57
ordo/connection/base.scm
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo connection base)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ordo util flatten)
|
||||
#:use-module (ordo util keyword-args)
|
||||
#:use-module (ordo util shell-quote)
|
||||
#:use-module ((srfi srfi-1) #:select (remove))
|
||||
#:export (<connection>
|
||||
setup
|
||||
teardown
|
||||
build-command
|
||||
remote-exec
|
||||
with-remote-input-file
|
||||
with-remote-output-file))
|
||||
|
||||
(define-generic setup)
|
||||
(define-generic teardown)
|
||||
(define-generic build-command)
|
||||
(define-generic remote-exec)
|
||||
(define-generic with-remote-input-file)
|
||||
(define-generic with-remote-output-file)
|
||||
|
||||
(define-class <connection> ())
|
||||
|
||||
(define-method (setup (c <connection>)) #t)
|
||||
|
||||
(define-method (teardown (c <connection>)) #t)
|
||||
|
||||
(define-method (build-command (c <connection>) (prog-name <string>) (prog-args <list>) (options <list>))
|
||||
(let* ((pwd (keyword-arg options #:pwd))
|
||||
(env (keyword-arg options #:env))
|
||||
(redirect-err? (keyword-arg options #:redirect-err? #t))
|
||||
(xs (remove unspecified?
|
||||
(flatten (list "env"
|
||||
(when pwd (list "--chdir" (string-shell-quote pwd)))
|
||||
(when env (map (match-lambda ((k . v) (string-append k "=" (string-shell-quote v)))) env))
|
||||
prog-name
|
||||
(map string-shell-quote prog-args)
|
||||
(when redirect-err? "2>&1"))))))
|
||||
(string-join xs " ")))
|
||||
38
ordo/connection/local.scm
Normal file
38
ordo/connection/local.scm
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo connection local)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ordo connection base)
|
||||
#:use-module (ordo connection sudo)
|
||||
#:use-module (ordo util read-lines)
|
||||
#:export (<local-connection>))
|
||||
|
||||
(define-class <local-connection> (<sudo-connection>))
|
||||
|
||||
(define-method (remote-exec (c <local-connection>) (command <string>))
|
||||
(let* ((port (open-input-pipe command))
|
||||
(output (read-lines port))
|
||||
(exit-status (status:exit-val (close-pipe port))))
|
||||
(values output exit-status)))
|
||||
|
||||
(define-method (with-remote-input-file (c <local-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-input-file filename proc))
|
||||
|
||||
(define-method (with-remote-output-file (c <local-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-output-file filename proc))
|
||||
80
ordo/connection/ssh.scm
Normal file
80
ordo/connection/ssh.scm
Normal file
|
|
@ -0,0 +1,80 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo connection ssh)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ssh session)
|
||||
#:use-module (ssh channel)
|
||||
#:use-module (ssh auth)
|
||||
#:use-module (ssh popen)
|
||||
#:use-module (ssh sftp)
|
||||
#:use-module (ordo connection base)
|
||||
#:use-module (ordo connection sudo)
|
||||
#:use-module (ordo util read-lines)
|
||||
#:export (<ssh-connection>))
|
||||
|
||||
(define-class <ssh-connection> (<sudo-connection>)
|
||||
(user #:getter ssh-connection-user #:init-keyword #:user)
|
||||
(host #:getter ssh-connection-host #:init-keyword #:host)
|
||||
(password #:getter ssh-connection-password #:init-keyword #:password #:init-val #f)
|
||||
(identity #:getter ssh-connection-identity #:init-keyword #:identity #:init-val #f)
|
||||
(authenticate-server? #:getter ssh-connection-authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t)
|
||||
(session)
|
||||
(sftp-session))
|
||||
|
||||
(define-method (setup (c <ssh-connection>))
|
||||
(unless (slot-bound? c 'session)
|
||||
(slot-set! c 'session (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c)))
|
||||
(when (ssh-connection-identity c) (session-set! (slot-ref c 'session) 'identity (ssh-connection-identity c))))
|
||||
(let ((s (slot-ref c 'session)))
|
||||
(unless (connected? s)
|
||||
(connect! s)
|
||||
(when (ssh-connection-authenticate-server? s)
|
||||
(let ((server-auth (authenticate-server s)))
|
||||
(unless (equal? 'ok server-auth)
|
||||
(error (format #f "authenticate-server: ~a" server-auth)))))
|
||||
(let ((user-auth (if (ssh-connection-password c)
|
||||
(userauth-password! s (ssh-connection-password c))
|
||||
(userauth-public-key/auto! s))))
|
||||
(unless (equal? 'success user-auth)
|
||||
(error (format #f "userauth: ~a" user-auth)))))))
|
||||
|
||||
(define-method (remote-exec (c <ssh-connection>) (command <string>))
|
||||
(let* ((channel (open-remote-input-pipe (slot-ref c 'session) command))
|
||||
(output (read-lines channel))
|
||||
(exit-status (channel-get-exit-status channel)))
|
||||
(close channel)
|
||||
(values output exit-status)))
|
||||
|
||||
(define-method (sftp-session (c <ssh-connection>))
|
||||
(unless (slot-bound? c 'sftp-session)
|
||||
(slot-set! c 'sftp-session (make-sftp-session (session c))))
|
||||
(slot-ref c 'sftp-session))
|
||||
|
||||
(define-method (with-remote-input-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-remote-input-file (sftp-session c) filename proc))
|
||||
|
||||
(define-method (with-remote-output-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-remote-output-file (sftp-session c) filename proc))
|
||||
|
||||
(define-method (teardown (c <ssh-connection>))
|
||||
(when (slot-bound? c 'session)
|
||||
(let ((s (slot-ref c session)))
|
||||
(when (connected? s)
|
||||
(disconnect! s)))))
|
||||
66
ordo/connection/sudo.scm
Normal file
66
ordo/connection/sudo.scm
Normal file
|
|
@ -0,0 +1,66 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo connection sudo)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-71)
|
||||
#:use-module (ordo connection base)
|
||||
#:use-module (ordo util shell-quote)
|
||||
#:export (<sudo-connection>
|
||||
become?
|
||||
become-user
|
||||
become-password))
|
||||
|
||||
(define-class <sudo-connection> (<connection>)
|
||||
(become? #:accessor become? #:init-keyword become? #:init-form #f)
|
||||
(become-user #:accessor become-user #:init-keyword #:become-user #:init-form #f)
|
||||
(become-password #:accessor become-password #:init-keyword #:become-password #:init-form #f)
|
||||
(password-tmp-file #:accessor password-tmp-file))
|
||||
|
||||
(define-method (setup (conn <sudo-connection>))
|
||||
(when (become-password conn)
|
||||
(let ((out rc (remote-exec conn "mktemp")))
|
||||
(unless (zero? rc)
|
||||
(raise-exception (make-exception
|
||||
(make-external-error)
|
||||
(make-exception-with-message (format #f "Failed to create temporary directory: ~a" (car out))))))
|
||||
(let ((tmp-file (car out)))
|
||||
(with-remote-output-file conn tmp-file (cut write-line (become-password conn) <>))
|
||||
(set! (password-tmp-file conn) tmp-file)))))
|
||||
|
||||
(define-method (build-command (conn <sudo-connection>) (prog-name <string>) (prog-args <list>) (options <list>))
|
||||
(cond
|
||||
((not (become? conn))
|
||||
(next-method))
|
||||
|
||||
((and (become-user conn) (become-password conn))
|
||||
(format #f "cat ~a - | sudo -k -S -H -u ~a -- ~a" (string-shell-quote (password-tmp-file conn)) (string-shell-quote (become-user conn)) (next-method)))
|
||||
|
||||
((become-password conn)
|
||||
(format #f "cat ~a - | sudo -k -S -H -- ~a" (string-shell-quote (password-tmp-file conn)) (next-method)))
|
||||
|
||||
((become-user conn)
|
||||
(format #f "sudo -k -n -H -u ~a -- ~a" (string-shell-quote (become-user conn)) (next-method)))
|
||||
|
||||
(else (format #f "sudo -k -n -H -- ~a" (next-method)))))
|
||||
|
||||
(define-method (teardown (conn <sudo-connection>))
|
||||
(when (slot-bound? conn 'password-tmp-file)
|
||||
(remote-exec conn (format #f "rm -f ~a" (string-shell-quote (password-tmp-file conn))))))
|
||||
24
ordo/context.scm
Normal file
24
ordo/context.scm
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo context))
|
||||
|
||||
(define-public *inventory* (make-parameter #f))
|
||||
(define-public *playbook* (make-parameter #f))
|
||||
(define-public *play* (make-parameter #f))
|
||||
(define-public *host* (make-parameter #f))
|
||||
(define-public *triggered-handlers* (make-parameter #f))
|
||||
69
ordo/core.scm
Normal file
69
ordo/core.scm
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
(define-module (ordo core)
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo context)
|
||||
#:use-module (ordo handler)
|
||||
#:use-module (ordo inventory)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo playbook)
|
||||
#:use-module (ordo play)
|
||||
#:use-module (ordo task)
|
||||
#:use-module ((srfi srfi-26) #:select (cut)))
|
||||
|
||||
(define (run-playbook ctx pb)
|
||||
(log-msg 'NOTICE "Running playbook: " (playbook-name pb))
|
||||
(set-ctx-playbook! ctx pb)
|
||||
(for-each (cut run-play ctx <>) (playbook-plays pb)))
|
||||
|
||||
(define (run-play ctx p)
|
||||
(log-msg 'NOTICE "Running play: " (play-name p))
|
||||
(set-ctx-play! ctx p)
|
||||
(let ((hosts (resolve-hosts (ctx-inventory ctx) (play-host p))))
|
||||
(if (null? hosts)
|
||||
(log-msg 'WARN "No hosts matched: " (play-host p))
|
||||
(for-each (cut run-host-play ctx p <>) hosts))))
|
||||
|
||||
(define (run-host-play ctx p h)
|
||||
(log-msg 'NOTICE "Running play on host: " (host-name h))
|
||||
(set-ctx-host! ctx h)
|
||||
(call-with-connection
|
||||
(host-connection h)
|
||||
(lambda (conn)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set-ctx-connection! ctx conn))
|
||||
(lambda ()
|
||||
(for-each (cut run-task ctx <>) (play-tasks p))
|
||||
(for-each (cut run-handler ctx <>) (play-handlers p)))
|
||||
(lambda ()
|
||||
(set-ctx-connection! ctx #f))))
|
||||
#:sudo? (play-sudo? p)
|
||||
#:sudo-user (play-sudo-user p)
|
||||
#:sudo-password (play-sudo-password p)))
|
||||
|
||||
(define (run-task ctx t)
|
||||
(if ((task-pre-condition t) ctx)
|
||||
(begin
|
||||
(log-msg 'NOTICE "Running task " (task-name t))
|
||||
((task-action t) ctx))
|
||||
(log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met")))
|
||||
|
||||
(define (run-handler ctx h)
|
||||
(when (member (ctx-triggers ctx) (handler-name h))
|
||||
(log-msg 'NOTICE "Running handler: " (handler-name h))
|
||||
((handler-action h) ctx)))
|
||||
39
ordo/handler.scm
Normal file
39
ordo/handler.scm
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo handler)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (ordo logger)
|
||||
#:export (make-handler
|
||||
handler?
|
||||
handler-name
|
||||
handler-action
|
||||
handler
|
||||
run-handler))
|
||||
|
||||
(define-record-type <handler>
|
||||
(make-handler name action)
|
||||
handler?
|
||||
(name handler-name)
|
||||
(action handler-action))
|
||||
|
||||
(define* (handler #:key name action)
|
||||
(make-handler name action))
|
||||
|
||||
(define (run-handler h conn)
|
||||
(log-msg 'NOTICE "Running handler: " (handler-name h))
|
||||
((handler-action h) conn))
|
||||
78
ordo/inventory.scm
Normal file
78
ordo/inventory.scm
Normal file
|
|
@ -0,0 +1,78 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo inventory)
|
||||
#:use-module (ice-9 eval-string)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (oop goops)
|
||||
#:use-module ((ordo connection) #:select (local-connection))
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-69)
|
||||
#:export (host
|
||||
host?
|
||||
host-name
|
||||
host-connection
|
||||
host-tags
|
||||
host-vars
|
||||
resolve-hosts
|
||||
load-inventory))
|
||||
|
||||
(define-record-type <host>
|
||||
(make-host name connection tags vars)
|
||||
host?
|
||||
(name host-name)
|
||||
(connection host-connection)
|
||||
(tags host-tags)
|
||||
(vars host-vars))
|
||||
|
||||
(define* (host #:key name connection (tags '()) (vars '()))
|
||||
(make-host name connection tags (alist->hash-table vars)))
|
||||
|
||||
(define (tagged-every? wanted-tags)
|
||||
(lambda (h)
|
||||
(lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags))))
|
||||
|
||||
(define (tagged-any? wanted-tags)
|
||||
(lambda (h)
|
||||
(not (null? (lset-intersection equal? (host-tags h) wanted-tags)))))
|
||||
|
||||
(define (named? hostname)
|
||||
(lambda (h)
|
||||
(string=? (host-name h) hostname)))
|
||||
|
||||
(define (resolve-hosts inventory expr)
|
||||
(match expr
|
||||
("localhost" (list (or (find (named? "localhost") inventory)
|
||||
(host #:name "localhost" #:connection (local-connection)))))
|
||||
((? string? hostname) (filter (named? hostname) inventory))
|
||||
('all inventory)
|
||||
(('tagged tag) (filter (tagged-every? (list tag)) inventory))
|
||||
(('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) inventory))
|
||||
(('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) inventory))
|
||||
((. hostnames) (filter (lambda (h) (member (host-name h) hostnames string=?)) inventory))))
|
||||
|
||||
(define (load-inventory filename)
|
||||
(log-msg 'INFO "Loading inventory " filename)
|
||||
(let* ((inventory (eval-string (call-with-input-file filename get-string-all)
|
||||
#:file filename))
|
||||
(inventory (if (list? inventory) inventory '())))
|
||||
(when (null? inventory)
|
||||
(log-msg 'NOTICE "Inventory is empty, only localhost will be available"))
|
||||
inventory))
|
||||
46
ordo/logger.scm
Normal file
46
ordo/logger.scm
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo logger)
|
||||
#:use-module (oop goops)
|
||||
#:use-module ((srfi srfi-1) #:select (take-while member))
|
||||
#:use-module ((srfi srfi-26) #:select (cut))
|
||||
#:use-module (logging logger)
|
||||
#:use-module (logging port-log)
|
||||
#:export (setup-logging!
|
||||
shutdown-logging!
|
||||
valid-log-level?)
|
||||
#:re-export (log-msg))
|
||||
|
||||
(define log-levels '(DEBUG INFO NOTICE WARN ERROR))
|
||||
|
||||
(define (valid-log-level? level)
|
||||
(member level log-levels eq?))
|
||||
|
||||
(define* (setup-logging! #:key (level 'INFO))
|
||||
(let ((logger (make <logger>))
|
||||
(handler (make <port-log> #:port (current-error-port))))
|
||||
(for-each (cut disable-log-level! handler <>)
|
||||
(take-while (negate (cut equal? level <>)) log-levels))
|
||||
(add-handler! logger handler)
|
||||
(set-default-logger! logger)
|
||||
(open-log! logger)))
|
||||
|
||||
(define (shutdown-logging!)
|
||||
(flush-log) ; since no args, it uses the default
|
||||
(close-log!) ; ditto
|
||||
(set-default-logger! #f))
|
||||
92
ordo/play.scm
Normal file
92
ordo/play.scm
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo play)
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo context)
|
||||
#:use-module (ordo handler)
|
||||
#:use-module (ordo inventory)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo task)
|
||||
#:use-module (ordo util flatten)
|
||||
#:use-module (ordo util keyword-args)
|
||||
#:use-module (srfi srfi-1) ; lists
|
||||
#:use-module (srfi srfi-9) ; records
|
||||
#:use-module (srfi srfi-26) ; cut/cute
|
||||
#:use-module (srfi srfi-69) ; hash tables
|
||||
#:use-module (srfi srfi-71) ; extended let
|
||||
#:export (play
|
||||
play?
|
||||
play-host
|
||||
play-sudo?
|
||||
play-sudo-user
|
||||
play-sudo-password
|
||||
play-vars
|
||||
play-tasks
|
||||
play-handlers
|
||||
run-play
|
||||
trigger-handler!))
|
||||
|
||||
(define-record-type <play>
|
||||
(make-play name host sudo? sudo-user sudo-password vars tasks handlers)
|
||||
play?
|
||||
(name play-name)
|
||||
(host play-host)
|
||||
(sudo? play-sudo?)
|
||||
(sudo-user play-sudo-user)
|
||||
(sudo-password play-sudo-password)
|
||||
(vars play-vars)
|
||||
(tasks play-tasks)
|
||||
(handlers play-handlers))
|
||||
|
||||
(define (play name . args)
|
||||
(let* ((tasks args (partition task? args))
|
||||
(handlers kwargs (partition handler? args)))
|
||||
(make-play name
|
||||
(keyword-arg #:host kwargs)
|
||||
(keyword-arg #:sudo? kwargs)
|
||||
(keyword-arg #:sudo-user kwargs)
|
||||
(keyword-arg #:sudo-password kwargs)
|
||||
(and=> (keyword-arg #:vars kwargs) alist->hash-table)
|
||||
tasks
|
||||
handlers)))
|
||||
|
||||
(define (run-play p)
|
||||
(log-msg 'NOTICE "Running play: " (play-name p))
|
||||
(parameterize ((*play* p))
|
||||
(let ((hosts (resolve-hosts (*inventory*) (play-host p))))
|
||||
(if (null? hosts)
|
||||
(log-msg 'WARN "No hosts matched: " (play-host p))
|
||||
(for-each (cut run-host-play p <>) hosts)))))
|
||||
|
||||
(define (run-host-play p h)
|
||||
(log-msg 'NOTICE "Running play on host: " (host-name h))
|
||||
(parameterize ((*host* h)
|
||||
(*triggered-handlers* (make-hash-table)))
|
||||
(call-with-connection
|
||||
(host-connection h)
|
||||
(lambda (conn)
|
||||
(for-each (cut run-task <> conn) (play-tasks p))
|
||||
(for-each (cut run-handler <> conn)
|
||||
(filter (compose (cut hash-table-ref/default *triggered-handlers* <> #f) handler-name)
|
||||
(play-handlers p))))
|
||||
#:sudo? (play-sudo? p)
|
||||
#:sudo-user (play-sudo-user p)
|
||||
#:sudo-password (play-sudo-password p))))
|
||||
|
||||
(define (trigger-handler! handler-name)
|
||||
(hash-table-set! *triggered-handlers* handler-name #t))
|
||||
61
ordo/playbook.scm
Normal file
61
ordo/playbook.scm
Normal file
|
|
@ -0,0 +1,61 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo playbook)
|
||||
#:use-module (ice-9 eval-string)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (ordo context)
|
||||
#:use-module (ordo handler)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo play)
|
||||
#:use-module (ordo task)
|
||||
#:use-module (ordo util keyword-args)
|
||||
#:use-module (srfi srfi-1) ; lists
|
||||
#:use-module (srfi srfi-9) ; records
|
||||
#:use-module (srfi srfi-26) ; cut/cute
|
||||
#:use-module (srfi srfi-69) ; hash tables
|
||||
#:use-module (srfi srfi-71) ; extended let
|
||||
#:export (<playbook>
|
||||
playbook
|
||||
playbook?
|
||||
playbook-name
|
||||
playbook-vars
|
||||
playbook-plays
|
||||
load-playbook
|
||||
run-playbook))
|
||||
|
||||
(define-record-type <playbook>
|
||||
(make-playbook name vars plays)
|
||||
playbook?
|
||||
(name playbook-name)
|
||||
(vars playbook-vars)
|
||||
(plays playbook-plays))
|
||||
|
||||
(define (playbook name . args)
|
||||
(let ((plays kwargs (partition play? args)))
|
||||
(make-playbook name (alist->hash-table (keyword-arg #:vars kwargs '())) plays)))
|
||||
|
||||
(define (load-playbook filename)
|
||||
(log-msg 'INFO "Loading playbook " filename)
|
||||
(eval-string (call-with-input-file filename get-string-all)
|
||||
#:file filename))
|
||||
|
||||
(define (run-playbook pb inventory)
|
||||
(log-msg 'NOTICE "Running playbook: " (playbook-name pb))
|
||||
(parameterize ((*inventory* inventory)
|
||||
(*playbook* pb))
|
||||
(for-each run-play (playbook-plays pb))))
|
||||
43
ordo/task.scm
Normal file
43
ordo/task.scm
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo task)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:export (task
|
||||
task?
|
||||
task-name
|
||||
task-pre-condition
|
||||
task-action
|
||||
run-task))
|
||||
|
||||
(define-record-type <task>
|
||||
(make-task name action pre-condition)
|
||||
task?
|
||||
(name task-name)
|
||||
(pre-condition task-pre-condition)
|
||||
(action task-action))
|
||||
|
||||
(define* (task #:key name action (pre-condition (const #t)))
|
||||
(make-task name action pre-condition))
|
||||
|
||||
(define (run-task t conn)
|
||||
(if ((task-pre-condition t) conn)
|
||||
(begin
|
||||
(log-msg 'NOTICE "Running task " (task-name t))
|
||||
((task-action t) conn))
|
||||
(log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met")))
|
||||
27
ordo/util/flatten.scm
Normal file
27
ordo/util/flatten.scm
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo util flatten)
|
||||
#:export (flatten))
|
||||
|
||||
(define (flatten lst)
|
||||
(cond
|
||||
((null? lst) '())
|
||||
((list? (car lst))
|
||||
(append (flatten (car lst)) (flatten (cdr lst))))
|
||||
(else
|
||||
(cons (car lst) (flatten (cdr lst))))))
|
||||
23
ordo/util/keyword-args.scm
Normal file
23
ordo/util/keyword-args.scm
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo util keyword-args)
|
||||
#:use-module ((srfi srfi-1) #:select (member))
|
||||
#:export (keyword-arg))
|
||||
|
||||
(define* (keyword-arg args kw #:optional (default #f))
|
||||
(or (and=> (member kw args) cadr) default))
|
||||
28
ordo/util/read-lines.scm
Normal file
28
ordo/util/read-lines.scm
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
#|
|
||||
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) '()))
|
||||
|
|
@ -1,21 +1,23 @@
|
|||
;; This file is part of Ordo.
|
||||
;;
|
||||
;; Shell quoting implementation is based on Perl's String::ShellQuote
|
||||
;; Copyright (c) 1997 Roderick Schertler.
|
||||
;;
|
||||
;; Guile implementation Copyright (c) 2025 Ray Miller.
|
||||
;;
|
||||
;; Ordo is free software: you can redistribute it and/or modify it under
|
||||
;; the terms of the GNU General Public License as published by the Free
|
||||
;; Software Foundation, either version 3 of the License, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; Ordo 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
|
||||
;; Ordo. If not, see <https://www.gnu.org/licenses/>.
|
||||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Shell quoting implementation is based on Perl's String::ShellQuote
|
||||
Copyright (c) 1997 Roderick Schertler.
|
||||
|
||||
Guile implementation Copyright (c) 2025 Ray Miller.
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free
|
||||
Software Foundation, either version 3 of the License, or (at your option)
|
||||
any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
|
||||
A PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo util shell-quote)
|
||||
#:use-module (rx irregex)
|
||||
Loading…
Add table
Add a link
Reference in a new issue