ordo/ordo/core.scm

#|
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 (ice-9 exceptions)
  #:use-module (ice-9 format)
  #:use-module (ice-9 optargs)
  #:use-module (oop goops)
  #:use-module (ordo connection)
  #:use-module (ordo connection base)
  #:use-module (ordo inventory)
  #:use-module (ordo logger)
  #:use-module (ordo util flatten)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-69)
  #:export (<task>
            task
            task?
            task-name
            task-pre-condition
            task-action
            task-args
            task-trigger

            <handler>
            handler
            handler?
            handler-name
            handler-action
            handler-args

            <blueprint>
            blueprint
            blueprint?
            blueprint-name
            blueprint-tasks
            blueprint-handlers

            execute))

(define-generic execute%)

(define-class <task> ()
  (name #:init-keyword #:name #:getter task-name)
  (pre-condition #:init-keyword #:pre-condition #:init-value (const #t) #:getter task-pre-condition)
  (action #:init-keyword #:action #:getter task-action)
  (args #:init-keyword #:args #:init-form (list) #:getter task-args)
  (trigger #:init-keyword #:trigger #:init-form (list) #:getter task-trigger))

(define (task name . args) (apply make <task> #:name name args))
(define (task? x) (is-a? x <task>))

(define-method (execute% (task <task>) (conn <connection>))
  (log-msg 'DEBUG "execute task " (task-name task) " on connection")
  (if ((task-pre-condition task) conn)
      (let ((result (apply (task-action task) conn (map (lambda (a) (if (promise? a) (force a) a)) (task-args task)))))
        (cond
         ((equal? result #f)
          (log-msg 'NOTICE (task-name task) " - OK"))
         ((equal? result #t)
          (log-msg 'NOTICE (task-name task) " - CHANGED")
          (for-each schedule-handler! (task-trigger task)))
         (else
          (log-msg 'NOTICE (task-name task) " - " result)))
        result)
      (log-msg 'NOTICE (task-name task) " - SKIPPED")))

(define-method (execute% (task <task>) (host <host>) (options <list>))
  (log-msg 'NOTICE "Executing task " (task-name task) " on host " (host-name host))
  (let-keywords
   options #t
   ((sudo? #f)
    (sudo-user #f)
    (sudo-password #f))
   (call-with-connection
    (host-connection host)
    (cut execute% task <>)
    #:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password)))

(define-method (execute% (task <task>) target (options <list>))
  (let-keywords
   options #t
   ((continue-on-error? #f))
   (for-each
    (if continue-on-error?
        (lambda (host)
          (with-exception-handler
              (lambda (e) (log-msg 'ERROR "Failed to execute " (task-name task) " on host " (host-name host) ": " e))
            (lambda ()
              (execute% task host options))
            #:unwind? #t))
        (lambda (host)
          (execute% task host options)))
    (resolve-hosts target))))

(define-class <handler> ()
  (name #:init-keyword #:name #:getter handler-name)
  (action #:init-keyword #:action #:getter handler-action)
  (args #:init-keyword #:args #:init-form (list) #:getter handler-args))

(define (handler . args) (apply make <handler> args))
(define (handler? x) (is-a? x <handler>))

(define-method (execute% (handler <handler>) (conn <connection>))
  (log-msg 'NOTICE "Executing handler " (handler-name handler))
  ((handler-action handler) conn))

(define-class <blueprint> ()
  (name #:init-keyword #:name #:getter blueprint-name)
  (tasks #:init-keyword #:tasks #:getter blueprint-tasks)
  (handlers #:init-keyword #:handlers #:getter blueprint-handlers))

(define (blueprint? x) (is-a? x <blueprint>))

(define (validate-triggers blueprint-name tasks handlers)
  (let ((handler-names (map handler-name handlers)))
    (for-each (lambda (task)
                (for-each (lambda (trigger)
                            (unless (member trigger handler-names)
                              (raise-exception
                               (make-exception
                                (make-programming-error)
                                (make-exception-with-message (format #f "Task ~a in blueprint ~a references unknown trigger: ~a"
                                                                     blueprint-name (task-name task) trigger))))))
                          (task-trigger task)))
              tasks)))

(define (blueprint name . args)
  (let* ((args (flatten args))
         (tasks (filter task? args))
         (handlers (filter handler? args)))
    (validate-triggers name (filter task? tasks) handlers)
    (make <blueprint> #:name name #:tasks tasks #:handlers handlers)))

(define *triggered-handlers* (make-parameter #f))

(define (schedule-handler! handler-name)
  "Schedule a handler to be run after all tasks in a blueprint. This function
may also be called outside of a blueprint (e.g. when a stand-alone task is run),
in which case it is a no-op."
  (let ((triggered (*triggered-handlers*)))
    (when triggered
      (log-msg 'DEBUG "Scheduling handler: " handler-name)
      (hash-table-set! triggered handler-name #t))))

(define-method (execute% (blueprint <blueprint>) (conn <connection>))
  (parameterize ((*triggered-handlers* (make-hash-table)))
    (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint))
    (for-each (cut execute% <> conn)
              (blueprint-tasks blueprint))
    (for-each (lambda (handler)
                (when (hash-table-ref/default (*triggered-handlers*) (handler-name handler) #f)
                  (execute% handler conn)))
              (blueprint-handlers blueprint))))

(define-method (execute% (blueprint <blueprint>) (host <host>) (options <list>))
  (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint) " on host " (host-name host))
  (let-keywords
   options #t
   ((sudo? #f)
    (sudo-user #f)
    (sudo-password #f))
   (call-with-connection
    (host-connection host)
    (cut execute% blueprint <>)
    #:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password)))

(define-method (execute% (blueprint <blueprint>) target (options <list>))
  (let-keywords
   options #t
   ((continue-on-error? #f))
   (for-each
    (if continue-on-error?
        (lambda (host)
          (with-exception-handler
              (cut log-msg 'ERROR "Failed to execute blueprint " (blueprint-name blueprint) " on host " (host-name host) ": " <>)
            (lambda ()
              (execute% blueprint host options))
            #:unwind? #t))
        (lambda (host)
          (execute% blueprint host options)))
    (resolve-hosts target))))

(define (execute task-or-blueprint target . options)
  (execute% task-or-blueprint target options))