ordo/modules/ordo.scm

(define-module (ordo)
  #:use-module (ice-9 exceptions)
  #:use-module (logging logger)
  #:use-module (ordo connection)
  #: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))

(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 +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 tasks handlers)
  play?
  (name play-name)
  (connection play-connection)
  (vars play-vars)
  (tasks play-tasks)
  (handlers play-handlers))

(define* (play name #:key connection (vars '()) . more)
  (let ((tasks (filter task? more))
        (handlers (filter handler? more)))
    (make-play name connection vars 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 ()
      (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>