thodg/cl-unix-cybernetics/core/host.lisp

• Show log

  Commit

• Hash : 442de453
  Author : Thomas de Grivel
  Date : 2023-11-01T22:06:14
  

  fix build on OpenBSD, add run! and run-as-root!

Download

• core/host.lisp

• ;; cl-unix-cybernetics
  ;; Copyright 2013-2022 Thomas de Grivel <thodg@kmx.io>
  ;;
  ;; Permission is hereby granted to use this software granted
  ;; the above copyright notice and this permission paragraph
  ;; are included in all copies and substantial portions of this
  ;; software.
  ;;
  ;; THIS SOFTWARE IS PROVIDED "AS-IS" WITHOUT ANY GUARANTEE OF
  ;; PURPOSE AND PERFORMANCE. IN NO EVENT WHATSOEVER SHALL THE
  ;; AUTHOR BE CONSIDERED LIABLE FOR THE USE AND PERFORMANCE OF
  ;; THIS SOFTWARE.
  
  (in-package :cl-unix-cybernetics)
  
  (defun strip-last-newline (string)
    (when (stringp string)
      (let* ((len (length string))
             (len-1 (1- len)))
        (if (< len 1)
            string
            (when (char= #\Newline (char string len-1))
              (subseq string 0 len-1))))))
  
  (defun run-1 (&rest command)
    (strip-last-newline (first (apply #'run command))))
  
  ;;  localhost
  
  (defun local-hostname ()
    (machine-instance))
  
  (defun localhost ()
    (let ((id (local-hostname)))
      (or #1=(get-resource 'host id)
          (setf #1# (make-instance 'host :id id)))))
  
  (unless (boundp '*host*)
    (setf *host* (localhost)))
  
  (defun host-user (host)
    (get-specified host :user))
  
  (defun host-connect (host)
    (let* ((id (resource-id host))
           (locale (get-specified host :locale))
           (shell (cond ((string-equal (local-hostname) id)
                         (make-shell "/bin/sh"))
                        (:otherwise
                         (let ((user (host-user host)))
                           (apply #'make-shell
                                  `("/usr/bin/ssh"
                                    ,@(when user `("-l" ,user))
                                    ,id "/bin/sh")))))))
      (when locale
        (shell-run shell "export LANG=" locale))
      (setf (host-shell host) shell)
      shell))
  
  (defun current-host ()
    (or *host* (localhost)))
  
  ;;  Host
  
  (defun hostname (&optional (host (current-host)))
    (resource-id (the host host)))
  
  (defun homedir (user &optional (host (current-host)))
    (str (etypecase (host-os host)
           (os-darwin "/Users")
           (os "/home"))
         "/"
         (etypecase user
           (user (resource-id user))
           (string user))))
  
  (defgeneric probe-host-homedir (host os))
  
  (defmethod probe-host-homedir (host (os os-unix))
    '(:homedir "/home"))
  
  (defmethod probe-host-homedir (host (os os-darwin))
    '(:homedir "/Users"))
  
  ;;  Host shell
  
  (defmethod host-shell ((host host))
    (if (slot-boundp host 'shell)
        (slot-value host 'shell)
        (setf (slot-value host 'shell) (host-connect host))))
  
  (defmethod (setf host-shell) ((shell shell) (host host))
    (setf (slot-value host 'shell) shell))
  
  (defmethod host-disconnect ((host host))
    (when (slot-boundp host 'shell)
      (shell-close (host-shell host))
      (slot-makunbound host 'shell)))
  
  (defun host (&optional host)
    (etypecase host
      (null (localhost))
      (host host)
      (string (if (or (string-equal (local-hostname) host)
                      (string-equal "localhost" host)
                      (string= "127.0.0.1" host))
                  (localhost)
                  (resource 'host host)))))
  
  (defmethod host-run ((host host) &rest command)
    (let ((shell (host-shell host)))
      (loop
         (if (shell-closed-p shell)
             (setq shell (host-connect host))
             (return)))
      (apply #'shell-run shell command)))
  
  (defmethod host-run ((hostname string) &rest command)
    (let ((host (host hostname)))
      (apply #'host-run host command)))
  
  ;;  With host
  
  (defmacro with-host (host &body body)
    `(let ((*host* (host ,host)))
       (with-parent-resource *host*
         ,@body)))
  
  ;;  OS
  
  (defmethod host-os ((host host))
    (get-probed host :os))
  
  ;;  Host probes
  
  (defmethod describe-probed% ((host host) (out (eql :form)))
    (with-host host
      (call-next-method)))
  
  (defun linux-name (name)
    (when (string-equal (symbol-name 'linux) name)
      'linux))
  
  (defun debian-version (version)
    (when (search (symbol-name 'debian) version :test #'char-equal)
      'debian))
  
  (defun gentoo-release (release)
    (when (search (symbol-name 'gentoo) release :test #'char-equal)
      'gentoo))
  
  (defmethod probe-os-using-uname ((host host) (os t))
    (multiple-value-bind (name hostname release version machine) (uname)
      (declare (ignore hostname))
      (let* ((name (or (linux-name name)
                       name))
             (distrib (or (debian-version version)
                          (gentoo-release release)))
             (class (flet ((try (&rest parts)
                             (when-let ((s (find-symbol (string-upcase (str 'os- parts))
                                                        *package*)))
                               (ignore-errors (find-class s)))))
                      (or (try name '- release '- machine '- distrib)
                          (try name '- release '- machine '- version)
                          (try name '- release '- machine)
                          (try name '- release '- distrib)
                          (try name '- release '- version)
                          (try name '- release)
                          (try name '- machine '- distrib)
                          (try name '- machine '- version)
                          (try name '- machine)
                          (try name '- distrib)
                          (try name '- version)
                          (try name)
                          (warn "Unknown OS : ~A" name)))))
        (when class
          (let ((plist (list :machine machine
                             :name name
                             :release release
                             :version version)))
            (when distrib
              (setf plist (list* :distrib distrib plist)))
            (let ((os (apply #'make-instance class plist)))
              (list :os os)))))))
  
  (defmethod probe-hostname ((host host) (os os-unix))
    (list :hostname (run-1 "hostname")))
  
  (defmethod probe-boot-time ((host host) (os os-unix))
    (with-uptime<1> (time uptime users load1 load5 load15) (run "uptime")
      (return (list :boot-time (chronicity:parse
                                (str uptime " seconds ago"))))))
  
  (defmethod probe-host-user ((host host) (os os-unix))
    (list :user (run-1 "whoami")))
  
  (defmethod compare-property-values ((host host)
                                      (property (eql :os))
                                      (a os)
                                      (b os))
    (string= (prin1-to-string a)
             (prin1-to-string b)))
  
  (defmethod match-specified-value ((res host)
                                    (property (eql :packages))
                                    (specified list)
                                    (probed list)
                                    os)
    (format t "~&match-specified-value specified ~S~%" specified)
    (format t "~&match-specified-value probed ~S~%" probed)
    (force-output)
    (loop (when (endp specified)
            (return t))
       (let ((pkg (pop specified)))
         (unless (find pkg probed :test #'string=)
           (return nil)))))
  

Download