ordo/modules/ordo.scm

(define-module (ordo)
  #:use-module (ice-9 exceptions)
  #:use-module (logging logger)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)  ; list utils
  #:use-module (srfi srfi-26) ; cut
  #:use-module (srfi srfi-69) ; hash-tables
  #:use-module (ordo connection)
  #:export (task
            act
            play
            playbook
            $
            register-act-var
            register-play-var
            register-playbook-var
            perform))

(define +filter-tags+ '())

(define (check-tags tags)
  (or (null? +filter-tags+)
      (not (null? (lset-intersection eqv? +filter-tags+ tags)))))

(define +playbook-vars+ #f)

(define +play-vars+ #f)

(define +act-vars+ #f)

(define (register-act-var var-name)
  (lambda (v)
    (log-msg 'DEBUG "Registering act variable " var-name)
    (hash-table-set! +act-vars+ var-name v)))

(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 (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 an act variable, 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 +act-vars+ +play-vars+ +playbook-vars+)))

(define-class <task> ()
  (name #:init-keyword #:name #:getter task-name)
  (tags #:init-keyword #:tags #:getter task-tags #:init-form '())
  (action #:init-keyword #:action #:getter task-action)
  (condition #:init-keyword #:condition #:getter task-condition)
  (register #:init-keyword #:register #:getter task-register)
  (triggers #:init-keyword #:triggers #:getter task-triggers))

(define (task . args) (apply make <task> args))

(define-method (check-condition (t <task>) (c <connection>))
  (if (slot-bound? t 'condition)
      ((task-condition t) c)
      #t))

(define-method (perform (t <task>) (c <connection>))
  (when (check-tags (task-tags t))
    (if (not (check-condition t c))
        (log-msg 'NOTICE "Skipping task " (task-name t) " (precondition not met)")
        (begin
          (log-msg 'NOTICE "Performing task " (task-name t))
          (let ((result ((task-action t) c)))
            (when (slot-bound? t 'register)
              ((task-register t) result))
            (when (slot-bound? t 'triggers)
              (for-each (lambda (f) (f)) (task-triggers t))))))))

(define-class <act> ()
  (name #:init-keyword #:name #:getter act-name)
  (tags #:init-keyword #:tags #:getter act-tags #:init-form '())
  (vars #:init-keyword #:vars #:getter act-vars)
  (condition #:init-keyword #:condition #:getter act-condition)
  (tasks #:init-keyword #:tasks #:getter act-tasks)
  (handlers #:init-keyword #:handlers #:getter act-handlers))

(define (act . args) (apply make <act> args))

(define-method (check-condition (a <act>) (c <connection>))
  (if (slot-bound? a 'condition)
      ((act-condition a) c)
      #t))

(define-method (perform (a <act>) (c <connection>))
  (when (check-tags (act-tags a))
    (if (not (check-condition a c))
        (log-msg 'NOTICE "Skipping act " (act-name a) " (precondition not met")
        (begin
          (log-msg 'NOTICE "Performing act " (act-name a))
          (dynamic-wind
            (lambda ()
              (when (slot-bound? a 'vars)
                (set! +act-vars+ (alist->hash-table (act-vars a) equal?))))
            (lambda ()
              (for-each (cut perform <> c) (act-tasks a))
              ;; TODO: run any triggered handlers
              )
            (lambda ()
              (set! +act-vars+ #f)))))))

(define-class <play> ()
  (name #:init-keyword #:name #:getter play-name)
  (tags #:init-keyword #:tags #:getter play-tags #:init-form '())
  (vars #:init-keyword #:vars #:getter play-vars)
  (connection #:init-keyword #:connection #:getter play-connection)
  (acts #:init-keyword #:acts #:getter play-acts))

(define (play . args) (apply make <play> args))

(define-method (perform (p <play>))
  (when (check-tags (play-tags p))
    (log-msg 'NOTICE "Performing play " (play-name p))
    (dynamic-wind
      (lambda ()
        (when (slot-bound? p 'vars)
          (set! +play-vars+ (alist->hash-table (play-vars p) equal?)))
        (init-connection! (play-connection p)))
      (lambda ()
        (for-each (cut perform <> (play-connection p)) (play-acts p))
        ;; TODO: run any triggered handlers
        )
      (lambda ()
        (set! +play-vars+ #f)
        (close-connection! (play-connection p))))))

(define-class <playbook> ()
  (name #:init-keyword #:name #:getter playbook-name)
  (vars #:init-keyword #:vars #:getter playbook-vars)
  (plays #:init-keyword #:plays #:getter playbook-plays))

(define (playbook . args) (apply make <playbook> args))

(define-method (perform (pb <playbook>) (filter-tags <list>))
  (log-msg 'NOTICE "Performing playbook " (playbook-name pb))
  (dynamic-wind
    (lambda ()
      (set! +filter-tags+ filter-tags)
      (when (slot-bound? pb 'vars)
        (set! +playbook-vars+ (alist->hash-table (playbook-vars pb) equal?))))
    (lambda ()
      (for-each perform (playbook-plays pb)))
    (lambda ()
      (set! +filter-tags+ '())
      (set! +playbook-vars+ #f))))

;; TODO: add validate methods for <task>, <act>, <play>, and <playbook>