thodg/cl-unix-cybernetics/unix/freebsd.lisp

• Show log

  Commit

• Hash : c1256c2e
  Author : Thomas de Grivel
  Date : 2018-07-26T14:28:21
  

  update license and copyright

Download

• unix/freebsd.lisp

• ;;
  ;;  adams - system administrator written in Common Lisp
  ;;
  ;;  Copyright 2013,2014,2018 Thomas de Grivel <thoxdg@gmail.com>
  ;;
  ;;  Permission to use, copy, modify, and distribute this software for any
  ;;  purpose with or without fee is hereby granted, provided that the above
  ;;  copyright notice and this permission notice appear in all copies.
  ;;
  ;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  ;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  ;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  ;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  ;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  ;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  ;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  ;;
  
  (in-package :adams)
  
  (in-re-readtable)
  
  (defun get-sh-var (name file)
    (let (value)
      (with-sh-var (var val) (egrep (str "^" name "=") file)
        (when (string= name var)
          (setq value val)))
      value))
  
  (defsetf get-sh-var (name file) (value)
    `(let ((name (re-quote ,name))
           (value (re-quote ,value))
           (file (sh-quote ,file)))
       (run "perl -pi -e " (sh-quote (str "s/^" name "=.*$/" name "=" value "/"))
            file)))
      
  (defmethod probe-hostname ((host host) (os os-freebsd))
    (let ((hostname (first (run "hostname")))
          (rc-conf (get-sh-var "hostname" "/etc/rc.conf")))
      (list :hostname (if (equal hostname rc-conf)
                          hostname
                          (list hostname :rc-conf rc-conf)))))
  
  (defmethod op-hostname ((host host) (os os-freebsd) &key hostname)
    (let* ((probed (get-probed host :hostname))
           (probed-rc probed))
      (when (consp probed)
        (setq probed (first probed)
              probed-rc (getf (rest probed-rc) :rc-conf probed)))
      (unless (equal hostname probed)
        (call-next-method))
      (unless (equal hostname probed-rc)
        (setf (get-sh-var "hostname" "/etc/rc.conf") hostname)))) 
  
  (defmethod op-update-group ((group group) (os os-freebsd) &key ensure gid)
    (run-as-root
     (join-str " "
               (ecase ensure
                 ((:absent)  "pw groupdel")
                 ((:present) "pw groupadd")
                 ((nil)      "pw groupmod"))
               (when gid `("-g" ,(sh-quote gid)))
               "-n" (sh-quote (resource-id group)))))
  
  (defmethod op-update-user ((user user) (os os-freebsd) &key ensure uid gid
                                                           realname home shell
                                                           login-class
                                                           groups)
    (run-as-root
     (join-str " "
               (ecase ensure
                 ((:absent)  "pw userdel")
                 ((:present) "pw useradd")
                 ((nil)      "pw usermod"))
               (when realname `("-c" ,(sh-quote realname)))
               (when home `("-d" ,(sh-quote home)))
               (when gid `("-g" ,(sh-quote gid)))
               (when login-class `("-L" ,(sh-quote login-class)))
               (when groups `("-G" ,(join-str "," (mapcar #'sh-quote groups))))
               (when shell `("-s" ,(sh-quote shell)))
               (when uid `("-u" ,(sh-quote uid)))
               "-n" (sh-quote (resource-id user)))))
  
  ;;  Pkg
  
  (defun freebsd-pkg-version<8>-status (str)
    (cond ((equal "=" str) :latest)
          ((equal "<" str) :update-available)
          ((equal ">" str) :newer)
          ((equal "?" str) :not-in-index)
          ((equal "!" str) :error)
          (:otherwise nil)))
  
  (define-syntax freebsd-pkg-version<8> (name version
                                         (#'freebsd-pkg-version<8>-status status))
      #~|^([-_0-9A-Za-z]+)-([_.,0-9A-Za-z]+)\s+([=<>?!])$|)
  
  (defmethod probe-host-packages ((host host) (os os-freebsd))
    (let ((packages))
      (with-freebsd-pkg-version<8> (name version ensure)
          (run "pkg version")
        (when (and name version ensure)
          (let ((pkg (resource 'freebsd-pkg name))
                (versions (list version)))
            (add-probed-properties pkg (properties* versions ensure))
            (push pkg packages))))
      (properties :packages (nreverse packages))))
  
  (define-resource-class freebsd-pkg (pkg)
    ()
    ((probe-freebsd-pkg :properties (:ensure :versions)))
    ((op-freebsd-pkg :properties (:ensure :versions))))
  
  (defmethod probe-freebsd-pkg ((pkg freebsd-pkg) (os os-freebsd))
    (let ((id (resource-id pkg))
          (ensure :absent)
          versions)
      (with-freebsd-pkg-version<8> (name ver status)
          (run "pkg version | egrep ^" (sh-quote id) "-")
        (when (equal id name)
          (setq ensure status)
          (push ver versions)))
      (properties* ensure versions)))
  
  (defmethod op-freebsd-pkg ((pkg freebsd-pkg) (os os-freebsd)
                             &key ensure versions)
    (let ((id (resource-id pkg))
          (cmd (ecase ensure
                 ((:absent) "pkg delete -y ")
                 ((:present :latest) "pkg install -y "))))
      (if versions
          (dolist (ver versions)
            (run-as-root cmd (sh-quote id "-" ver)))
          (run-as-root cmd (sh-quote id)))))
  

Download