Refactor, implement inventory, add examples
This commit is contained in:
parent
d16df7616f
commit
54b6fd0377
GPG key ID:
043F786C4CD681B8
17 changed files with 373 additions and 483 deletions
|
|
@ -1,8 +1,6 @@
|
|||
(use-modules
|
||||
(ice-9 filesystem)
|
||||
(ordo)
|
||||
(ordo connection)
|
||||
(ordo logger))
|
||||
(ordo))
|
||||
|
||||
(define* (install-aws-cli conn #:key (url "https://awscli.amazonaws.com/awscli-exe-linux-x86_64.zip") update? install-dir bin-dir)
|
||||
(let ((tmp-dir (run conn "mktemp" "-d" #:return car #:check? #t)))
|
||||
|
|
@ -20,16 +18,12 @@
|
|||
(lambda ()
|
||||
(run conn "rm" "-rf" tmp-dir #:check? #t)))))
|
||||
|
||||
(define test-playbook
|
||||
(playbook "Test Playbook"
|
||||
(play "Test play"
|
||||
#:connection (local-connection)
|
||||
(task "Install AWS CLI"
|
||||
(lambda (c)
|
||||
(install-aws-cli c
|
||||
#:update? #t
|
||||
#:install-dir (file-name-join* ($$ #:pwent #:home-dir) ".local" "aws-cli")
|
||||
#:bin-dir (file-name-join* ($$ #:pwent #:home-dir) ".local" "bin")))))))
|
||||
|
||||
(setup-logging)
|
||||
(run-playbook test-playbook)
|
||||
(playbook "Test Playbook"
|
||||
(play "Test play"
|
||||
#:host "localhost"
|
||||
(task "Install AWS CLI"
|
||||
(lambda (c)
|
||||
(install-aws-cli c
|
||||
#:update? #t
|
||||
#:install-dir (file-name-join* ($ #:fact.home-dir) ".local" "aws-cli")
|
||||
#:bin-dir (file-name-join* ($ #:fact.home-dir) ".local" "bin"))))))
|
||||
14
examples/inventory.scm
Normal file
14
examples/inventory.scm
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
(use-modules (ordo inventory)
|
||||
(ordo connection))
|
||||
|
||||
(add-host! "little-rascal"
|
||||
(local-connection)
|
||||
#:linux #:guix)
|
||||
|
||||
(add-host! "screw-loose"
|
||||
(ssh-connection "core" "screw-loose")
|
||||
#:linux #:coreos)
|
||||
|
||||
(add-host! "limiting-factor"
|
||||
(ssh-connection "core" "limiting-factor")
|
||||
#:linux #:coreos)
|
||||
187
modules/ordo.scm
187
modules/ordo.scm
|
|
@ -1,171 +1,22 @@
|
|||
(define-module (ordo)
|
||||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (logging logger)
|
||||
#:declarative? #f
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ordo playbook)
|
||||
#:use-module (ordo play)
|
||||
#:use-module (ordo task)
|
||||
#:use-module (ordo handler)
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo facts)
|
||||
#: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
|
||||
#:export (task
|
||||
task-name
|
||||
task-tags
|
||||
task-action
|
||||
task-condition
|
||||
task-register
|
||||
task-triggers
|
||||
run-task
|
||||
play
|
||||
play-name
|
||||
play-vars
|
||||
play-tasks
|
||||
play-connection
|
||||
play-handlers
|
||||
run-play
|
||||
playbook
|
||||
playbook-name
|
||||
playbook-vars
|
||||
playbook-plays
|
||||
run-playbook
|
||||
$
|
||||
$$
|
||||
register-play-var
|
||||
register-playbook-var))
|
||||
#:use-module (ordo inventory)
|
||||
#:use-module (ordo vars)
|
||||
#:use-module (ordo logger)
|
||||
#:export (main)
|
||||
#:re-export (add-host! local-connection ssh-connection run playbook play task handler $))
|
||||
|
||||
(define +filter-tags+ '())
|
||||
|
||||
(define (check-tags tags)
|
||||
(or (null? +filter-tags+)
|
||||
(not (null? (lset-intersection eqv? +filter-tags+ tags)))))
|
||||
|
||||
(define +play-vars+ #f)
|
||||
|
||||
(define (register-play-var var-name)
|
||||
(lambda (v)
|
||||
(log-msg 'DEBUG "Registering play variable " var-name)
|
||||
(hash-table-set! +play-vars+ var-name v)))
|
||||
|
||||
(define +playbook-vars+ #f)
|
||||
|
||||
(define (register-playbook-var var-name)
|
||||
(lambda (v)
|
||||
(log-msg 'DEBUG "Registering playbook variable " var-name)
|
||||
(hash-table-set! +playbook-vars+ var-name v)))
|
||||
|
||||
(define ($ var-name)
|
||||
"Try to resolve var-name as a play variable or a playbook
|
||||
variable (in that order). Raise an exception if the variable is not found."
|
||||
(define not-found (cons 'not-found '()))
|
||||
(define (lookup-var var-name vars)
|
||||
(cond
|
||||
((null? vars)
|
||||
(raise-exception (make-exception
|
||||
(make-undefined-variable-error)
|
||||
(make-exception-with-irritants var-name))))
|
||||
((not (car vars)) (lookup-var var-name (cdr vars)))
|
||||
(else (let ((v (hash-table-ref/default (car vars) var-name not-found)))
|
||||
(if (eqv? v not-found)
|
||||
(lookup-var var-name (cdr vars))
|
||||
v)))))
|
||||
(lookup-var var-name (list +play-vars+ +playbook-vars+)))
|
||||
|
||||
(define ($$ . keys)
|
||||
"Look up nested keys in gathered facts."
|
||||
(apply get-fact (hash-table-ref +play-vars+ #:ordo-facts) keys))
|
||||
|
||||
(define +triggers+ #f)
|
||||
|
||||
(define (add-triggers triggers)
|
||||
(set! +triggers+ (apply lset-adjoin equal? (or +triggers+ '())
|
||||
triggers)))
|
||||
|
||||
(define-record-type <task>
|
||||
(make-task name tags action condition register triggers)
|
||||
task?
|
||||
(name task-name)
|
||||
(tags task-tags)
|
||||
(action task-action)
|
||||
(condition task-condition)
|
||||
(register task-register)
|
||||
(triggers task-triggers))
|
||||
|
||||
(define* (task name action #:key (tags '()) (condition (const #t)) (register (const #f)) (triggers '()))
|
||||
(make-task name tags action condition register triggers))
|
||||
|
||||
(define (run-task t c)
|
||||
(when (check-tags (task-tags t))
|
||||
(if (not ((task-condition t) c))
|
||||
(log-msg 'NOTICE "Skipping task " (task-name t) " (precondition not met)")
|
||||
(begin
|
||||
(log-msg 'NOTICE "Running task " (task-name t))
|
||||
(let ((result ((task-action t) c)))
|
||||
((task-register t) result)
|
||||
(add-triggers (task-triggers t)))))))
|
||||
|
||||
(define-record-type <handler>
|
||||
(make-handler name action)
|
||||
handler?
|
||||
(name handler-name)
|
||||
(action handler-action))
|
||||
|
||||
(define (handler name action)
|
||||
(make-handler name action))
|
||||
|
||||
(define-record-type <play>
|
||||
(make-play name connection vars gather-facts tasks handlers)
|
||||
play?
|
||||
(name play-name)
|
||||
(connection play-connection)
|
||||
(vars play-vars)
|
||||
(tasks play-tasks)
|
||||
(handlers play-handlers)
|
||||
(gather-facts play-gather-facts))
|
||||
|
||||
(define* (play name #:key connection (vars '()) (gather-facts #t) . more)
|
||||
(let ((tasks (filter task? more))
|
||||
(handlers (filter handler? more)))
|
||||
(make-play name connection vars gather-facts tasks handlers)))
|
||||
|
||||
(define (run-play p)
|
||||
(log-msg 'NOTICE "Running play " (play-name p))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! +play-vars+ (alist->hash-table (play-vars p) equal?))
|
||||
(init-connection! (play-connection p)))
|
||||
(lambda ()
|
||||
(when (play-gather-facts p)
|
||||
(hash-table-set! +play-vars+ #:ordo-facts (gather-facts (play-connection p))))
|
||||
(for-each (cut run-task <> (play-connection p)) (play-tasks p))
|
||||
(for-each (lambda (h)
|
||||
(when (member (handler-name h) +triggers+)
|
||||
(log-msg 'INFO "Running handler " (handler-name h))
|
||||
((handler-action h) (play-connection p))))
|
||||
(play-handlers p)))
|
||||
(lambda ()
|
||||
(set! +play-vars+ #f)
|
||||
(set! +triggers+ #f)
|
||||
(close-connection! (play-connection p)))))
|
||||
|
||||
(define-record-type <playbook>
|
||||
(make-playbook name vars plays)
|
||||
playbook?
|
||||
(name playbook-name)
|
||||
(vars playbook-vars)
|
||||
(plays playbook-plays))
|
||||
|
||||
(define* (playbook name #:key (vars '()) . plays)
|
||||
(make-playbook name vars plays))
|
||||
|
||||
(define* (run-playbook pb #:optional (filter-tags '()))
|
||||
(log-msg 'NOTICE "Running playbook " (playbook-name pb))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! +filter-tags+ filter-tags)
|
||||
(set! +playbook-vars+ (alist->hash-table (playbook-vars pb) equal?)))
|
||||
(lambda ()
|
||||
(for-each run-play (playbook-plays pb)))
|
||||
(lambda ()
|
||||
(set! +filter-tags+ '())
|
||||
(set! +playbook-vars+ #f))))
|
||||
|
||||
;; TODO: add validate methods for <task>, <play>, and <playbook>
|
||||
(define (main args)
|
||||
(match-let (((_ inventory-path playbook-path) args))
|
||||
(setup-logging #:level 'DEBUG)
|
||||
(init-command-line-vars! '())
|
||||
(load inventory-path)
|
||||
(let ((playbook (load playbook-path)))
|
||||
(run-playbook playbook)))
|
||||
(quit))
|
||||
|
|
|
|||
|
|
@ -2,8 +2,6 @@
|
|||
#:use-module (oop goops)
|
||||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (logging logger)
|
||||
#:use-module (srfi srfi-1) ; list operations
|
||||
#:use-module (srfi srfi-71) ; extended let
|
||||
|
|
@ -14,36 +12,39 @@
|
|||
#:use-module (ordo util flatten)
|
||||
#:use-module (ordo util shell-quote)
|
||||
#:use-module (ordo util keyword-args)
|
||||
#:export (connection
|
||||
#:export (connection?
|
||||
local-connection
|
||||
ssh-connection
|
||||
call-with-connection
|
||||
run))
|
||||
|
||||
(define (connection type . kwargs)
|
||||
(validate-keyword-args kwargs)
|
||||
(let* ((c (case type
|
||||
((#:local) (make <local-connection>))
|
||||
((#:ssh) (apply make <ssh-connection>
|
||||
(select-keyword-args kwargs '(#:user #:host #:password #:identity #:authenticate-server?))))))
|
||||
(c (if (keyword-arg kwargs #:sudo?)
|
||||
(apply make <sudo-connection> #:connection c (select-keyword-args kwargs '(#:become-user #:become-password)))
|
||||
c)))
|
||||
(conn:validate c)
|
||||
c))
|
||||
(define (connection? c)
|
||||
(is-a? c <connection>))
|
||||
|
||||
(define (call-with-connection c proc)
|
||||
(dynamic-wind
|
||||
(lambda () (conn:setup c))
|
||||
(lambda () (proc c))
|
||||
(lambda () (conn:teardown c))))
|
||||
(define (local-connection)
|
||||
(make <local-connection>))
|
||||
|
||||
(define (build-command prog args pwd env)
|
||||
(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 proc #:key (sudo? #f) (sudo-user #f) (sudo-password #f))
|
||||
(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)
|
||||
"2>&1")))))
|
||||
(when redirect-err? "2>&1"))))))
|
||||
(string-join xs " ")))
|
||||
|
||||
(define (run conn prog . args)
|
||||
|
|
@ -54,13 +55,14 @@
|
|||
(env (keyword-arg kwargs #:env))
|
||||
(return (keyword-arg kwargs #:return identity))
|
||||
(check? (keyword-arg kwargs #:check?))
|
||||
(command (build-command prog args pwd env))
|
||||
(out rc (conn:run conn command)))
|
||||
(log-msg 'INFO "Command " command " exited " 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))))
|
||||
(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,7 +1,6 @@
|
|||
(define-module (ordo connection base)
|
||||
#:use-module (oop goops)
|
||||
#:export (<connection>
|
||||
conn:validate
|
||||
conn:setup
|
||||
conn:teardown
|
||||
conn:run
|
||||
|
|
@ -10,8 +9,6 @@
|
|||
|
||||
(define-class <connection> ())
|
||||
|
||||
(define-method (conn:validate (c <connection>)) #t)
|
||||
|
||||
(define-method (conn:setup (c <connection>)) #t)
|
||||
|
||||
(define-method (conn:teardown (c <connection>)) #t)
|
||||
|
|
|
|||
|
|
@ -20,18 +20,6 @@
|
|||
(session #:accessor session)
|
||||
(sftp-session #:accessor sftp-session))
|
||||
|
||||
(define-method (conn:validate (c <ssh-connection>))
|
||||
(unless (slot-bound? c 'user)
|
||||
(raise-exception
|
||||
(make-exception
|
||||
(make-programming-error)
|
||||
(make-exception-with-message "#:user is required"))))
|
||||
(unless (slot-bound? c 'host)
|
||||
(raise-exception
|
||||
(make-exception
|
||||
(make-programming-error)
|
||||
(make-exception-with-message "#:host is required")))))
|
||||
|
||||
(define-method (conn:setup (c <ssh-connection>))
|
||||
(unless (slot-bound? c 'session)
|
||||
(set! (session c) (make-session #:user (user c) #:host (host c)))
|
||||
|
|
|
|||
|
|
@ -1,59 +0,0 @@
|
|||
(define-module (ordo context)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-71)
|
||||
#:use-module (ordo connection)
|
||||
#:export (make-context
|
||||
context?
|
||||
context-connection
|
||||
add-context-triggers!
|
||||
get-context-triggers
|
||||
context-triggered?
|
||||
register-context-var!
|
||||
context-ref
|
||||
bind-context-vars
|
||||
run
|
||||
must))
|
||||
|
||||
(define-record-type <context>
|
||||
(make-context connection vars)
|
||||
context?
|
||||
(connection context-connection)
|
||||
(vars context-vars set-context-vars!)
|
||||
(triggers context-triggers set-context-triggers!))
|
||||
|
||||
(define (context-ref ctx var-name)
|
||||
(let ((kv (assoc var-name (context-vars ctx))))
|
||||
(if kv
|
||||
(cdr kv)
|
||||
(error (format #f "failed to resolve context reference: ~a" var-name)))))
|
||||
|
||||
(define (add-context-triggers! ctx triggers)
|
||||
(when triggers
|
||||
(set-context-triggers! ctx
|
||||
(apply lset-adjoin equal? (or (context-triggers ctx) '()) triggers))))
|
||||
|
||||
(define (context-triggered? ctx trigger)
|
||||
(find (lambda (t) (equal? t trigger)) (context-triggers ctx)))
|
||||
|
||||
(define (register-context-var! ctx var-name val)
|
||||
(set-context-vars! ctx (assoc-set! (context-vars ctx) var-name val)))
|
||||
|
||||
(define-syntax bind-context-vars
|
||||
(syntax-rules ()
|
||||
((bind-context-vars (var-name ...) proc)
|
||||
(lambda (ctx)
|
||||
(let ((var-name (context-ref ctx (quote var-name))) ...)
|
||||
(proc ctx))))))
|
||||
|
||||
(define* (run ctx prog args #:key (env #f) (pwd #f))
|
||||
(connection-run (context-connection ctx) pwd env prog args))
|
||||
|
||||
(define* (must ctx prog args #:key (env #f) (pwd #f) (error-msg #f))
|
||||
(let ((out rc (run ctx prog args #:env env #:pwd pwd)))
|
||||
(if (zero? rc)
|
||||
out
|
||||
(error (if error-msg
|
||||
(format #f "~a: ~a" error-msg out)
|
||||
(format #f "~a error: ~a" prog out))))))
|
||||
|
|
@ -1,18 +1,18 @@
|
|||
(define-module (ordo facts)
|
||||
#:use-module ((srfi srfi-88) #:select (string->keyword))
|
||||
#:use-module (ordo vars)
|
||||
#:use-module (ordo facts user)
|
||||
#:export (gather-facts
|
||||
get-fact))
|
||||
#:export (gather-facts))
|
||||
|
||||
(define (get-fact facts . keys)
|
||||
(cond
|
||||
((null? keys) facts)
|
||||
((list? facts) (let ((facts (assoc-ref facts (car keys))))
|
||||
(apply get-fact facts (cdr keys))))
|
||||
(else #f)))
|
||||
(define (set-facts! src keys)
|
||||
(for-each (lambda (k)
|
||||
(set-play-var! (string->keyword (string-append "fact." k))
|
||||
(assoc-ref src (string->keyword k))))
|
||||
keys))
|
||||
|
||||
(define (gather-facts conn)
|
||||
(let* ((id (fact:id conn))
|
||||
(user-name (get-fact id #:user #:name))
|
||||
(user-name (assoc-ref id #:user-name))
|
||||
(pwent (fact:pwent conn user-name)))
|
||||
`((#:id . ,id)
|
||||
(#:pwent . ,pwent))))
|
||||
(set-facts! id '("user-name" "user-id" "group-name" "group-id" "groups"))
|
||||
(set-facts! pwent '("gecos" "home-dir" "shell"))))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
(define-module (ordo facts user)
|
||||
#:use-module (rx irregex)
|
||||
#:use-module (srfi srfi-1) ; list utils
|
||||
#:use-module (srfi srfi-2) ; and-let*
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ordo connection)
|
||||
#:export (fact:id
|
||||
fact:pwent))
|
||||
|
|
@ -14,8 +13,10 @@
|
|||
accum))
|
||||
'()
|
||||
s))))
|
||||
`((#:user . ,(first data))
|
||||
(#:group . ,(second data))
|
||||
`((#: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 (fact:id conn)
|
||||
|
|
|
|||
|
|
@ -1,26 +1,24 @@
|
|||
(define-module (ordo handler)
|
||||
#:use-module (ice-9 match)
|
||||
#: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 (ordo context)
|
||||
#:use-module (logging logger)
|
||||
#:export (handler
|
||||
handler?
|
||||
handler-description
|
||||
handler-name
|
||||
handler-action
|
||||
run-handler))
|
||||
|
||||
(define-record-type <handler>
|
||||
(make-handler description action)
|
||||
(make-handler name action)
|
||||
handler?
|
||||
(description handler-description)
|
||||
(name handler-name)
|
||||
(action handler-action))
|
||||
|
||||
(define handler make-handler)
|
||||
(define (handler name action)
|
||||
(make-handler name action))
|
||||
|
||||
(define (run-handler ctx h)
|
||||
(define (run-handler c h)
|
||||
(match h
|
||||
(($ <handler> description action)
|
||||
(log-msg 'NOTICE "Running handler: " description)
|
||||
(action ctx))))
|
||||
(($ <handler> name action)
|
||||
(log-msg 'NOTICE "Running handler: " name)
|
||||
(action c))))
|
||||
|
|
|
|||
|
|
@ -14,9 +14,7 @@
|
|||
terminate-when
|
||||
execute
|
||||
bind
|
||||
unbind
|
||||
run
|
||||
must))
|
||||
unbind))
|
||||
|
||||
(define-record-type <interceptor>
|
||||
(make-interceptor name enter leave error)
|
||||
|
|
@ -187,21 +185,3 @@
|
|||
((< (length args) 2) #f)
|
||||
((equal? (first args) kw) (second args))
|
||||
(else (keyword-arg kw (cddr args)))))
|
||||
|
||||
(define (run ctx prog . args)
|
||||
(let* ((args kwargs (break keyword? args))
|
||||
(pwd (keyword-arg #:pwd kwargs))
|
||||
(env (keyword-arg #:env kwargs)))
|
||||
(connection-run (context-connection ctx) pwd env prog args)))
|
||||
|
||||
(define (must ctx prog . args)
|
||||
(let* ((args kwargs (break keyword? args))
|
||||
(pwd (keyword-arg #:pwd kwargs))
|
||||
(env (keyword-arg #:env kwargs))
|
||||
(error-msg (keyword-arg #:error-msg kwargs))
|
||||
(out rc (connection-run (context-connection ctx) pwd env prog args)))
|
||||
(if (zero? rc)
|
||||
out
|
||||
(error (if error-msg
|
||||
(format #f "~a: ~a" error-msg out)
|
||||
(format #f "~a error: ~a" prog out))))))
|
||||
|
|
|
|||
54
modules/ordo/inventory.scm
Normal file
54
modules/ordo/inventory.scm
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
(define-module (ordo inventory)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-69)
|
||||
#:use-module (logging logger)
|
||||
#:use-module (ordo connection)
|
||||
#:export (make-host
|
||||
host?
|
||||
host-name
|
||||
host-connection
|
||||
host-tags
|
||||
add-host!
|
||||
resolve-hosts))
|
||||
|
||||
(define *hosts* (make-hash-table equal?))
|
||||
|
||||
(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)
|
||||
(log-msg 'DEBUG "Adding host to inventory: " name)
|
||||
(hash-table-set! *hosts* name (make-host name connection tags)))
|
||||
|
||||
(define (tagged-all? 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 resolve-hosts
|
||||
(match-lambda
|
||||
("localhost" (list (or (hash-table-ref/default *hosts* "localhost" #f)
|
||||
(make-host "localhost" (local-connection) '()))))
|
||||
((? string? name) (list (hash-table-ref *hosts* name)))
|
||||
('all (hash-table-values *hosts*))
|
||||
(('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) (hash-table-values *hosts*)))
|
||||
(('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) (hash-table-values *hosts*)))))
|
||||
|
||||
#!
|
||||
(define (setup-test-data)
|
||||
(add-host! "little-rascal" (ssh-connection "ray" "little-rascal") #:linux #:guix)
|
||||
(add-host! "linux-1" (ssh-connection "root" "linux-1") #:linux)
|
||||
(add-host! "linux-2" (ssh-connection "root" "linux-2") #:linux)
|
||||
(add-host! "debian-1" (ssh-connection "root" "debian-1") #:linux #:debian)
|
||||
(add-host! "debian-2" (ssh-connection "root" "debian-2") #:linux #:debian)
|
||||
(add-host! "debian-3" (ssh-connection "root" "debian-3") #:linux #:debian #:eu-west-1))
|
||||
!#
|
||||
|
|
@ -1,76 +1,67 @@
|
|||
(define-module (ordo play)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-26)
|
||||
#: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 (ordo connection)
|
||||
#:use-module (ordo context)
|
||||
#:use-module (ordo task)
|
||||
#:use-module (ordo handler)
|
||||
#:use-module (ordo logger)
|
||||
#:export (play run-play))
|
||||
#:use-module (ordo vars)
|
||||
#:use-module (ordo inventory)
|
||||
#:use-module (ordo facts)
|
||||
#:export (play
|
||||
play?
|
||||
play-host
|
||||
play-sudo?
|
||||
play-sudo-user
|
||||
play-sudo-password
|
||||
play-vars
|
||||
play-tasks
|
||||
play-handlers
|
||||
play-gather-facts
|
||||
run-play))
|
||||
|
||||
(define-record-type <play>
|
||||
(make-play description connection vars tasks handlers)
|
||||
(make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers)
|
||||
play?
|
||||
(connection play-connection)
|
||||
(name play-name)
|
||||
(host play-host)
|
||||
(sudo? play-sudo?)
|
||||
(sudo-user play-sudo-user)
|
||||
(sudo-password play-sudo-password)
|
||||
(vars play-vars)
|
||||
(description play-description)
|
||||
(tasks play-tasks)
|
||||
(handlers play-handlers))
|
||||
(handlers play-handlers)
|
||||
(gather-facts play-gather-facts))
|
||||
|
||||
(define (validate-connection connection)
|
||||
(unless (and connection (is-a? connection <connection>))
|
||||
(error (format #f "invalid connection: ~a" connection))))
|
||||
(define* (play name #:key host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (gather-facts #t) . more)
|
||||
(let ((tasks (filter task? more))
|
||||
(handlers (filter handler? more)))
|
||||
(make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers)))
|
||||
|
||||
(define (validate-tasks tasks)
|
||||
(unless (and tasks (not (null? tasks)) (every task? tasks))
|
||||
(error (format #f "invalid tasks: ~a" tasks))))
|
||||
(define (run-play p)
|
||||
(log-msg 'NOTICE "Running play: " (play-name p))
|
||||
(for-each (lambda (h) (run-host-play p h))
|
||||
(resolve-hosts (play-host p))))
|
||||
|
||||
(define (validate-handlers handlers)
|
||||
(unless (every (lambda (h) (and (pair? h) (handler? (cdr h)))) handlers)
|
||||
(error (format #f "invalid handlers: ~a" handlers))))
|
||||
|
||||
(define (validate-vars vars)
|
||||
(unless (every pair? vars)
|
||||
(error (format #f "invalid vars: ~a" vars))))
|
||||
|
||||
(define (validate-triggers tasks handlers)
|
||||
(for-each (lambda (task)
|
||||
(for-each (lambda (trigger)
|
||||
(unless (assoc-ref handlers trigger)
|
||||
(error (format #f "task \"~a\" references an undefined trigger: ~a"
|
||||
(task-description task)
|
||||
trigger))))
|
||||
(task-triggers task)))
|
||||
tasks))
|
||||
|
||||
(define* (play description #:key connection tasks (vars '()) (handlers '()))
|
||||
(validate-connection connection)
|
||||
(validate-tasks tasks)
|
||||
(validate-handlers handlers)
|
||||
(validate-triggers tasks handlers)
|
||||
(validate-vars vars)
|
||||
;; Reconstruct the vars here because, when a quoted list is passed in the
|
||||
;; play, it can result in an error (expected mutable pair) from assoc-set!
|
||||
;; from register-context-var!.
|
||||
(make-play description connection (fold (match-lambda* (((k . v) accum) (alist-cons k v accum))) '() vars) tasks handlers))
|
||||
|
||||
(define (run-play play)
|
||||
;; TODO move logging setup and shutdown to a higher level when we implement playbook etc.
|
||||
(setup-logging)
|
||||
(log-msg 'NOTICE "Running play: " (play-description play))
|
||||
(call-with-connection
|
||||
(play-connection play)
|
||||
(lambda (c)
|
||||
(let* ((ctx (make-context c (play-vars play))))
|
||||
(for-each (cut run-task ctx <>) (play-tasks play))
|
||||
(for-each (match-lambda
|
||||
((name . handler)
|
||||
(when (context-triggered? ctx name)
|
||||
(run-handler ctx handler))))
|
||||
(play-handlers play)))))
|
||||
(log-msg 'NOTICE "Completed play: " (play-description play))
|
||||
(shutdown-logging))
|
||||
(define (run-host-play p h)
|
||||
(log-msg 'NOTICE "Running play: " (play-name p) " on host: " (host-name h))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(init-play-vars! (play-vars p)))
|
||||
(lambda ()
|
||||
(call-with-connection
|
||||
(host-connection h)
|
||||
(lambda (c)
|
||||
(when (play-gather-facts p)
|
||||
(gather-facts c))
|
||||
(for-each (cut run-task <> c)
|
||||
(play-tasks p))
|
||||
(for-each (cut run-handler <> c)
|
||||
(filter (compose play-triggered? handler-name)
|
||||
(play-handlers p))))
|
||||
#:sudo? (play-sudo? p)
|
||||
#:sudo-user (play-sudo-user p)
|
||||
#:sudo-password (play-sudo-password p)))
|
||||
(lambda ()
|
||||
(reset-play-vars!)
|
||||
(reset-play-triggers!))))
|
||||
|
|
|
|||
31
modules/ordo/playbook.scm
Normal file
31
modules/ordo/playbook.scm
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
(define-module (ordo playbook)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (logging logger)
|
||||
#:use-module (ordo play)
|
||||
#:use-module (ordo vars)
|
||||
#: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 name #:key (vars '()) . plays)
|
||||
(make-playbook name vars plays))
|
||||
|
||||
(define (run-playbook pb)
|
||||
(log-msg 'NOTICE "Running playbook: " (playbook-name pb))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(init-playbook-vars! (playbook-vars pb)))
|
||||
(lambda ()
|
||||
(for-each run-play (playbook-plays pb)))
|
||||
(lambda ()
|
||||
(reset-playbook-vars!))))
|
||||
|
|
@ -1,42 +1,41 @@
|
|||
(define-module (ordo task)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-9)
|
||||
#: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 (ordo context)
|
||||
#:use-module (ordo vars)
|
||||
#:export (task
|
||||
task?
|
||||
task-description
|
||||
task-condition
|
||||
task-name
|
||||
task-tags
|
||||
task-action
|
||||
task-register
|
||||
task-condition
|
||||
task-register-play-var
|
||||
task-register-playbook-var
|
||||
task-triggers
|
||||
run-task))
|
||||
|
||||
(define-record-type <task>
|
||||
(make-task description condition action register triggers)
|
||||
(make-task name tags action condition register-play-var register-playbook-var triggers)
|
||||
task?
|
||||
(description task-description)
|
||||
(condition task-condition)
|
||||
(name task-name)
|
||||
(tags task-tags)
|
||||
(action task-action)
|
||||
(register task-register)
|
||||
(condition task-condition)
|
||||
(register-play-var task-register-play-var)
|
||||
(register-playbook-var task-register-playbook-var)
|
||||
(triggers task-triggers))
|
||||
|
||||
(define* (task description action #:key (condition (const #t)) (register #f) (triggers '()))
|
||||
(make-task description condition action register triggers))
|
||||
(define* (task name action #:key (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '()))
|
||||
(make-task name tags action condition register-play-var register-playbook-var triggers))
|
||||
|
||||
(define (run-task ctx t)
|
||||
(match t
|
||||
(($ <task> description condition action register triggers)
|
||||
(if (not (condition ctx))
|
||||
(log-msg 'NOTICE "Skipping task: " description " (precondition not met)")
|
||||
(begin
|
||||
(log-msg 'NOTICE "Running task: " description)
|
||||
(let ((result (action ctx)))
|
||||
(when register
|
||||
(log-msg 'INFO "Registering result " register)
|
||||
(register-context-var! ctx register result))
|
||||
(when (and triggers (not (null? triggers)))
|
||||
(log-msg 'INFO "Scheduling triggers " triggers)
|
||||
(add-context-triggers! ctx triggers))))))))
|
||||
(define (run-task t c)
|
||||
(when (check-filter-tags (task-tags t))
|
||||
(if (not ((task-condition t) c))
|
||||
(log-msg 'NOTICE "Skipping task: " (task-name t) " (precondition not met)")
|
||||
(begin
|
||||
(log-msg 'NOTICE "Running task: " (task-name t))
|
||||
(let ((result ((task-action t) c)))
|
||||
(when (task-register-play-var t)
|
||||
(set-play-var! (task-register-play-var t) result))
|
||||
(when (task-register-playbook-var t)
|
||||
(set-playbook-var! (task-register-playbook-var t) result))
|
||||
(add-play-triggers! (task-triggers t)))))))
|
||||
|
|
|
|||
104
modules/ordo/vars.scm
Normal file
104
modules/ordo/vars.scm
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
(define-module (ordo vars)
|
||||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-69)
|
||||
#:export (init-playbook-vars!
|
||||
get-playbook-var
|
||||
set-playbook-var!
|
||||
reset-playbook-vars!
|
||||
init-play-vars!
|
||||
get-play-var
|
||||
set-play-var!
|
||||
reset-play-vars!
|
||||
init-command-line-vars!
|
||||
get-command-line-var
|
||||
set-command-line-var!
|
||||
$
|
||||
reset-play-triggers!
|
||||
add-play-triggers!
|
||||
play-triggered?
|
||||
set-filter-tag!
|
||||
reset-filter-tags!
|
||||
check-filter-tags))
|
||||
|
||||
(define not-found (cons 'not-found '()))
|
||||
|
||||
(define (not-found? x) (eq? x not-found))
|
||||
|
||||
(define *playbook-vars* #f)
|
||||
|
||||
(define (init-playbook-vars! alist)
|
||||
(set! *playbook-vars* (alist->hash-table alist equal?)))
|
||||
|
||||
(define (get-playbook-var var-name)
|
||||
(hash-table-ref/default *playbook-vars* var-name not-found))
|
||||
|
||||
(define (set-playbook-var! var-name val)
|
||||
(hash-table-set! *playbook-vars* var-name val))
|
||||
|
||||
(define (reset-playbook-vars!)
|
||||
(set! *playbook-vars* #f))
|
||||
|
||||
(define *play-vars* #f)
|
||||
|
||||
(define (init-play-vars! alist)
|
||||
(set! *play-vars* (alist->hash-table alist equal?)))
|
||||
|
||||
(define (get-play-var var-name)
|
||||
(hash-table-ref/default *play-vars* var-name not-found))
|
||||
|
||||
(define (set-play-var! var-name val)
|
||||
(hash-table-set! *play-vars* var-name val))
|
||||
|
||||
(define (reset-play-vars!)
|
||||
(set! *play-vars* #f))
|
||||
|
||||
(define *command-line-vars* #f)
|
||||
|
||||
(define (init-command-line-vars! alist)
|
||||
(set! *command-line-vars* (alist->hash-table alist equal?)))
|
||||
|
||||
(define (get-command-line-var var-name)
|
||||
(hash-table-ref/default *command-line-vars* var-name not-found))
|
||||
|
||||
(define (set-command-line-var var-name val)
|
||||
(hash-table-set! *command-line-vars* var-name val))
|
||||
|
||||
(define ($ var-name)
|
||||
"Try to resolve var-name as a command-line variable, a play variable or a
|
||||
playbook variable (in that order). Raise an exception if the variable is not
|
||||
found."
|
||||
(define (lookup-var procs)
|
||||
(if (null? procs)
|
||||
(raise-exception (make-exception
|
||||
(make-undefined-variable-error)
|
||||
(make-exception-with-irritants var-name)))
|
||||
(let ((v ((car procs) var-name)))
|
||||
(if (not-found? v)
|
||||
(lookup-var (cdr procs))
|
||||
v))))
|
||||
(lookup-var (list get-command-line-var get-play-var get-playbook-var)))
|
||||
|
||||
(define *play-triggers* '())
|
||||
|
||||
(define (reset-play-triggers!)
|
||||
(set! *play-triggers* '()))
|
||||
|
||||
(define (add-play-triggers! triggers)
|
||||
(set! *play-triggers* (apply lset-adjoin equal? (or *play-triggers* '())
|
||||
triggers)))
|
||||
|
||||
(define (play-triggered? trigger)
|
||||
(member trigger *play-triggers*))
|
||||
|
||||
(define *filter-tags* '())
|
||||
|
||||
(define (set-filter-tag! tag)
|
||||
(set! *filter-tags* (lset-adjoin equal? *filter-tags* tag)))
|
||||
|
||||
(define (reset-filter-tags!)
|
||||
(set! *filter-tags* '()))
|
||||
|
||||
(define (check-filter-tags tags)
|
||||
(or (null? *filter-tags*)
|
||||
(not (null? (lset-intersection eqv? *filter-tags* tags)))))
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
(use-modules
|
||||
(ice-9 filesystem)
|
||||
(logging logger)
|
||||
(srfi srfi-9)
|
||||
(ordo connection)
|
||||
(ordo interceptor)
|
||||
(ordo logger))
|
||||
|
||||
(define-record-type <play>
|
||||
(make-play name connection vars interceptors)
|
||||
play?
|
||||
(connection play-connection)
|
||||
(vars play-vars)
|
||||
(name play-name)
|
||||
(interceptors play-interceptors))
|
||||
|
||||
(define* (play #:key name connection (interceptors '()) (vars '()))
|
||||
(make-play name connection vars interceptors))
|
||||
|
||||
(define (run-play play)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(log-msg 'NOTICE "Running play: " (play-name play))
|
||||
(init-connection! (play-connection play)))
|
||||
(lambda ()
|
||||
(let ((ctx (init-context (play-connection play) #:vars (play-vars play))))
|
||||
(execute ctx (play-interceptors play))
|
||||
(if (context-error ctx)
|
||||
(log-msg 'ERROR "Play " (play-name play) " terminated with error: " (context-error ctx))
|
||||
(log-msg 'NOTICE "Completed play: " (play-name play)))))
|
||||
(lambda ()
|
||||
(close-connection! (play-connection play)))))
|
||||
|
||||
(define test-play
|
||||
(play
|
||||
#:name "Test play"
|
||||
#:connection (local-connection)
|
||||
#:vars '((base-dir . "/home/ray/ordo-test"))
|
||||
#:interceptors (list
|
||||
(interceptor
|
||||
"Handle errors"
|
||||
#:error (lambda (ctx err)
|
||||
(log-msg 'WARN "Handling error " err)
|
||||
(set-context-error! ctx #f)))
|
||||
(interceptor
|
||||
"Create base directory"
|
||||
#:enter (lambda (ctx)
|
||||
(must ctx "mkdir" "-p" (unbind ctx base-dir))))
|
||||
(interceptor
|
||||
"Create test file"
|
||||
#:enter (lambda (ctx)
|
||||
(must ctx "touch" (file-name-join* (unbind ctx base-dir) "test-file"))))
|
||||
(interceptor
|
||||
"Throw an error"
|
||||
#:enter (lambda (ctx) (error "badness"))))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue