pallet

0.7.0-SNAPSHOT


Pallet, DevOps for the JVM

Pallet is a platform for agile and programmatic automation of infrastructure
in the cloud, on server racks or directly on virtual machines. Pallet
provides cloud provider and operating system independence, and allows for an
unprecedented level of customization.

dependencies

org.clojure/clojure
1.2.1
org.clojure/core.incubator
0.1.0
org.clojure/tools.logging
0.1.2
org.cloudhoist/chiba
0.1.0-SNAPSHOT
org.cloudhoist/thread-expr
1.0.0
org.cloudhoist/pallet-common
0.2.2-SNAPSHOT
org.cloudhoist/stevedore
0.7.1-SNAPSHOT
commons-codec
1.4
clj-ssh
0.3.1-20120210.004410-3
org.slf4j/slf4j-api
1.6.1
enlive
1.0.0

dev dependencies

ch.qos.logback/logback-core
1.0.0
ch.qos.logback/logback-classic
1.0.0



(this space intentionally left almost blank)

namespaces

 

Conditional action execution.

(ns pallet.action.conditional
  (:refer-clojure :exclude [when when-not])
  (:require
   [pallet.action :as action]
   [pallet.action.exec-script :as exec-script])
  (:use
   clojure.tools.logging))
(defmacro when
  "A when statement that takes a script condtion."
  [session condition & crate-fns-or-actions]
  `(->
    ~session
    (action/enter-scope)
    (exec-script/exec-script ("if [" ~condition "]; then"))
    ~@crate-fns-or-actions
    (exec-script/exec-script "fi")
    (action/leave-scope)))
(defmacro when-not
  "A when statement that takes a script condtion."
  [session condition & crate-fns-or-actions]
  `(->
    ~session
    (action/enter-scope)
    (exec-script/exec-script ("if [ !" ~condition "]; then"))
    ~@crate-fns-or-actions
    (exec-script/exec-script "fi")
    (action/leave-scope)))
 

A directory manipulation action, to create and remove directories with given ownership and mode.

(ns pallet.action.directory
  (:require
   [pallet.action :as action]
   [pallet.action.file :as file]
   [pallet.script.lib :as lib]
   [pallet.stevedore :as stevedore]))
(defn adjust-directory
  "Script to set the ownership and mode of a directory."
  [path {:keys [owner group mode recursive] :as opts}]
  (stevedore/chain-commands*
   (filter
    identity
    [(when owner
       (stevedore/script
        (~lib/chown ~owner ~path :recursive ~recursive)))
     (when group
       (stevedore/script
        (~lib/chgrp ~group ~path :recursive ~recursive)))
     (when mode
       (stevedore/script
        (~lib/chmod ~mode ~path)))])))
(defn make-directory
  "Script to create a directory."
  [dir-path & {:keys [path verbose mode recursive] :as opts}]
  (stevedore/checked-commands
   (str "Directory " dir-path)
   (stevedore/script
    (~lib/mkdir ~dir-path :path ~path :verbose ~verbose :mode ~mode))
   (adjust-directory dir-path opts)))
(action/def-bash-action directory
  "Directory management.
   For :create and :touch, all components of path are effected.
   Options are:
    - :action     One of :create, :touch, :delete
    - :recursive  Flag for recursive delete
    - :force      Flag for forced delete
    - :path       flag to create all path elements
    - :owner      set owner
    - :group      set group
    - :mode       set mode"
  [session dir-path & {:keys [action recursive force path mode verbose owner
                              group]
                       :or {action :create recursive true force true path true}
                       :as options}]
  (case action
    :delete (stevedore/checked-script
             (str "Delete directory " dir-path)
             (~lib/rm ~dir-path :recursive ~recursive :force ~force))
    :create (make-directory
             dir-path
             :path path :mode mode :verbose verbose
             :owner owner :group group :recursive recursive)
    :touch (make-directory
            dir-path
            :path path :mode mode :verbose verbose
            :owner owner :group group :recursive recursive)))
(action/def-bash-action directories
  "Directory management of multiple directories with the same
   owner/group/permissions.
   `options` are as for `directory` and are applied to each directory in
   `paths`"
  [session paths & options]
  (stevedore/chain-commands*
   (map #(apply (action/action-fn directory) session % options) paths)))
 

Set up the system environment.

(ns pallet.action.environment
  (:require
   [clojure.string :as string]
   [pallet.action.exec-script :as exec-script]
   [pallet.action.remote-file :as remote-file]
   [pallet.session :as session]
   [pallet.stevedore :as stevedore]))
(defn system-environment
  "Define system wide default environment.
   On redhat based systems, this is set in /etc/profile.d, so is only
   valid within a login shell. On debian based systems, /etc/environment
   is used."
  [session env-name key-value-pairs & {:keys [path shared] :as options}]
  (let [os-family (session/os-family session)
        [path shared] (if (and path shared)
                        [path shared]
                        (if (#{:rhel :centos :fedora} os-family)
                          ["/etc/profile.d/java.sh" false]
                          ["/etc/environment" true]))]
    (if shared
      (exec-script/exec-script*
       session
       (stevedore/checked-commands*
        (format "Add %s environment to %s" env-name path)
        (conj
         (for [[k v] key-value-pairs]
           (stevedore/script
            (pallet_set_env
             ~k ~v
             ~(str (name k) "=" (pr-str v)))))
         (stevedore/script
          (defn pallet_set_env [k v s]
            (if (not @(grep (quoted @s) ~path))
              (sed -i
                   -e (quoted "/${k}/ d")
                   -e (quoted "$ a \\\\\n${s}")
                   ~path)))))))
      (remote-file/remote-file
       session
       path
       :owner "root"
       :group "root"
       :mode 644
       :content (string/join
                 \newline
                 (for [[k v] key-value-pairs]
                   (str (name k) "=" (pr-str v))))))))
 

Script execution. Script generation occurs with the correct script context.

(ns pallet.action.exec-script
  (:require
   [pallet.action :as action]
   [pallet.stevedore :as stevedore]))
(def exec-script* (action/bash-action [session script] script))
(defmacro exec-script
  "Execute a bash script remotely"
  [session & script]
  `(exec-script* ~session (stevedore/script ~@script)))
(defmacro exec-checked-script
  "Execute a bash script remotely, throwing if any element of the
   script fails."
  [session name & script]
  `(exec-script* ~session (stevedore/checked-script ~name ~@script)))
 

File manipulation.

(ns pallet.action.file
  (:require
   [pallet.action :as action]
   [pallet.script.lib :as lib]
   [pallet.stevedore :as stevedore]
   [pallet.utils :as utils]
   [clojure.string :as string]))
(defn adjust-file [path options]
  (stevedore/chain-commands*
   (filter
    identity
    [(when (:owner options)
       (stevedore/script (~lib/chown ~(options :owner) ~path)))
     (when (:group options)
       (stevedore/script (~lib/chgrp ~(options :group) ~path)))
     (when (:mode options)
       (stevedore/script (chmod ~(options :mode) ~path)))])))
(defn write-md5-for-file
  "Create a .md5 file for the specified input file"
  [path md5-path]
  (stevedore/script
   ((~lib/md5sum ~path) > ~md5-path)))
(defn touch-file [path {:keys [force] :as options}]
  (stevedore/chain-commands
   (stevedore/script
    (~lib/touch ~path :force ~force))
   (adjust-file path options)))
(action/def-bash-action file
  "File management."
  [session path & {:keys [action owner group mode force]
                   :or {action :create force true}
                   :as options}]
  (case action
    :delete (stevedore/checked-script
             (str "delete file " path)
             (~lib/rm ~path :force ~force))
    :create (stevedore/checked-commands
             (str "file " path)
             (touch-file path options))
    :touch (stevedore/checked-commands
             (str "file " path)
             (touch-file path options))))
(action/def-bash-action symbolic-link
  "Symbolic link management."
  [session from name & {:keys [action owner group mode force]
                        :or {action :create force true}}]
  (case action
    :delete (stevedore/checked-script
             (str "Link %s " name)
             (~lib/rm ~name :force ~force))
    :create (stevedore/checked-script
             (format "Link %s as %s" from name)
             (~lib/ln ~from ~name :force ~force :symbolic ~true))))
(action/def-bash-action fifo
  "FIFO pipe management."
  [session path & {:keys [action] :or {action :create} :as options}]
  (case action
    :delete (stevedore/checked-script
             (str "fifo " path)
             (~lib/rm ~path :force ~force))
    :create (stevedore/checked-commands
             (str "fifo " path)
             (stevedore/script
              (if-not (file-exists? ~path)
                (mkfifo ~path)))
             (adjust-file path options))))
(action/def-bash-action sed
  "Execute sed on a file.  Takes a path and a map for expr to replacement."
  [session path exprs-map & {:keys [seperator no-md5 restriction] :as options}]
  (stevedore/checked-script
   (format "sed file %s" path)
   (~lib/sed-file ~path ~exprs-map ~options)
   ~(when-not no-md5
      (write-md5-for-file path (str path ".md5")))))
 

Filesystem action

(ns pallet.action.filesystem
  (:require
   [pallet.action.directory :as directory]
   [pallet.action.exec-script :as exec-script]
   [clojure.string :as string])
  (:use
   pallet.thread-expr))
(defn make-xfs-filesytem
  "Format a device as an XFS filesystem."
  [session device]
  (-> session
      (exec-script/exec-checked-script
       (format "Format %s as XFS" device)
       (mkfs.xfs -f ~device))))
(defmulti format-mount-option
  (fn [[key value]] (class value)))
(defmethod format-mount-option :default
  [[key value]]
  (format "%s=%s" (name key) value))
(defmethod format-mount-option java.lang.Boolean
  [[key value]]
  (when value
    (format "%s" (name key))))
(defn- mount-cmd-options [options]
  (let [option-string (string/join ","
                       (filter identity (map format-mount-option options)))]
    (if (string/blank? option-string)
      (str "-o " option-string))))
(defn mount
  "Mount a device."
  [session device mount-point
   & {:keys [fs-type device-type automount no-automount dump-frequency
             boot-check-pass]
      :or {dump-frequency 0 boot-check-pass 0}
      :as options}]
  (->
   session
   (directory/directory mount-point)
   (exec-script/exec-checked-script
    (format "Mount %s at %s" device mount-point)
    (if-not @(mountpoint -q ~mount-point)
      (mount ~(if fs-type (str "-t " fs-type) )
             ~(mount-cmd-options
               (dissoc options :device-type :dump-frequency :boot-check-pass
                       :fs-type))
             ~device (quoted ~mount-point))))))
 

Actions for working with the centos repositories

(ns pallet.action.package.centos
  (:require
   [pallet.action.package :as package]
   [pallet.parameter :as parameter]
   [pallet.session :as session]))
(def ^{:private true} centos-repo
  "http://mirror.centos.org/centos/%s/%s/%s/repodata/repomd.xml")
(def ^{:private true} centos-repo-key
  "http://mirror.centos.org/centos/RPM-GPG-KEY-CentOS-%s")
(defn arch
  "Return the centos package architecture for the target node."
  [session]
  (if (session/is-64bit? session) "x86_64" "i386"))
(defn add-repository
  "Add a centos repository. By default, ensure that it has a lower than default
  priority."
  [session & {:keys [version repository enabled priority]
              :or {version "5.5" repository "os" enabled 0 priority 50}}]
  (->
   session
   (package/package "yum-priorities")
   (package/package-source
    (format "Centos %s %s %s" version repository (arch session))
    :yum {:url (format centos-repo version repository (arch session))
          :gpgkey (format centos-repo-key (str (first version)))
          :priority priority
          :enabled enabled})))
 

Actions for working with the debian backports repository

(ns pallet.action.package.debian-backports
  (:require
   [pallet.action.package :as package]
   [pallet.parameter :as parameter]
   [pallet.script.lib :as lib]
   [pallet.session :as session]
   [pallet.stevedore :as stevedore]))
(defn add-debian-backports
  "Add debian backport package repository"
  [session]
  (package/package-source
   session
   "debian-backports"
   :aptitude {:url "http://backports.debian.org/debian-backports"
              :release (str
                        (stevedore/script (~lib/os-version-name)) "-backports")
              :scopes ["main"]}))
 

Actions for working with the epel repository

(ns pallet.action.package.epel
  (:require
   [pallet.action :as action]
   [pallet.action.package :as package]
   [pallet.parameter :as parameter]
   [pallet.session :as session]
   [pallet.stevedore :as stevedore]))

this is an aggregate so that it can come before the aggragate package-manager

(action/def-aggregated-action add-epel
  "Add the EPEL repository"
  [session args]
  {:arglists '([session & {:keys [version] :or {version "5-4"}}])
   :always-before #{`package/package-manager `package/package}}
  (let [{:keys [version] :or {version "5-4"}} (apply
                                               merge {}
                                               (map #(apply hash-map %) args))]
    (stevedore/script
     ;; "Add EPEL package repository"
     ("rpm"
      -U --quiet
      ~(format
        "http://download.fedora.redhat.com/pub/epel/5/%s/epel-release-%s.noarch.rpm"
        "$(uname -i)"
        version)))))
 

Actions for working with the jpackage repository

(ns pallet.action.package.jpackage
  (:require
   [pallet.action :as action]
   [pallet.action.package :as package]
   [pallet.parameter :as parameter]
   [pallet.session :as session]
   [pallet.thread-expr :as thread-expr]))

The source for this rpm is available here: http://plone.lucidsolutions.co.nz/linux/centos/ jpackage-rpm-repository-for-centos-rhel-5.x http://plone.lucidsolutions.co.nz/linux/centos/images/ jpackage-utils-compat-el5-0.0.1-1.noarch.rpm/at_download/file

(def jpackage-utils-compat-rpm
  (str "https://github.com/downloads/pallet/pallet/"
       "jpackage-utils-compat-el5-0.0.1-1.noarch.rpm"))
(defn jpackage-utils
  "Add jpackge-utils. Due to incompatibilities on RHEL derived distributions,
   a compatability package is required.
   https://bugzilla.redhat.com/show_bug.cgi?id=260161
   https://bugzilla.redhat.com/show_bug.cgi?id=497213"
  [session]
  (->
   session
   (thread-expr/when->
    (or
     (= :fedora (session/os-family session))
     (and
      (#{:rhel :centos} (session/os-family session))
      (re-matches #"5\.[0-5]" (session/os-version session))))
    (action/with-precedence {:action-id ::install-jpackage-compat}
      (package/add-rpm
       "jpackage-utils-compat-el5-0.0.1-1"
       :url jpackage-utils-compat-rpm
       :insecure true))) ;; github's ssl doesn't validate
   (package/package "jpackage-utils")))
(def jpackage-mirror-fmt
  "http://www.jpackage.org/mirrorlist.php?dist=%s&type=%s&release=%s")
(defn mirrorlist
  [dist type release]
  (format jpackage-mirror-fmt dist type release))
(defn add-jpackage
  "Add the jpackage repository.  component should be one of:
     fedora
     redhat-el
   Installs the jpackage-utils package from the base repos at a
   pritority of 25."
  [session & {:keys [version component releasever enabled]
              :or {component "redhat-el"
                   releasever "$releasever"
                   version "5.0"
                   enabled 0}}]
  (let [no-updates (and                 ; missing updates for fedora 13, 14
                    (= version "5.0")
                    (= :fedora (session/os-family session))
                    (try
                      (< 12 (Integer/decode
                             (str (session/os-version session))))
                      (catch NumberFormatException _)))
        jpackage-repos (vec
                        (filter
                         identity
                         ["jpackage-generic"
                          "jpackage-generic-updates"
                          "jpackage-generic-non-free"
                          "jpackage-generic-updates-non-free"
                          (format "jpackage-%s" component)
                          (when-not no-updates
                            (format "jpackage-%s-updates" component))]))]
    (->
     session
     (package/package-source
      "jpackage-generic"
      :yum {:mirrorlist (mirrorlist "generic" "free" version)
            :failovermethod "priority"
            ;;gpgkey "http://www.jpackage.org/jpackage.asc"
            :enabled enabled})
     (package/package-source
      "jpackage-generic-non-free"
      :yum {:mirrorlist (mirrorlist "generic" "non-free" version)
            :failovermethod "priority"
            ;;gpgkey "http://www.jpackage.org/jpackage.asc"
            :enabled enabled})
     (package/package-source
      (format "jpackage-%s" component)
      :yum {:mirrorlist (mirrorlist
                         (str component "-" releasever) "free" version)
            :failovermethod "priority"
            ;;:gpgkey "http://www.jpackage.org/jpackage.asc"
            :enabled enabled})
     (package/package-source
      "jpackage-generic-updates"
      :yum {:mirrorlist (mirrorlist "generic" "free" (str version "-updates"))
            :failovermethod "priority"
            ;;:gpgkey "http://www.jpackage.org/jpackage.asc"
            :enabled enabled})
     (package/package-source
      "jpackage-generic-updates-non-free"
      :yum {:mirrorlist (mirrorlist
                         "generic" "non-free" (str version "-updates"))
            :failovermethod "priority"
            ;;:gpgkey "http://www.jpackage.org/jpackage.asc"
            :enabled enabled})
     (thread-expr/when-not->
      no-updates
      (package/package-source
       (format "jpackage-%s-updates" component)
       :yum {:mirrorlist (mirrorlist
                          (str component "-" releasever)
                          "free"
                          (str version "-updates"))
             :failovermethod "priority"
             ;;:gpgkey "http://www.jpackage.org/jpackage.asc"
             :enabled enabled}))
     (parameter/assoc-for-target [:jpackage-repos] jpackage-repos))))
(defn package-manager-update-jpackage
  "Update the package lists for the jpackage repositories"
  [request]
  (package/package-manager
   request :update
   :disable ["*"]
   :enable (parameter/get-for-target request [:jpackage-repos])))
 

Actions for working with the rpmforge repository

(ns pallet.action.package.rpmforge
  (:require
   [pallet.action :as action]
   [pallet.action.package :as package]
   [pallet.action.remote-file :as remote-file]
   [pallet.parameter :as parameter]
   [pallet.session :as session]
   [pallet.stevedore :as stevedore]))
(def ^{:private true}
  remote-file* (action/action-fn remote-file/remote-file-action))
(def ^{:private true}
  rpmforge-url-pattern
  "http://packages.sw.be/rpmforge-release/rpmforge-release-%s.%s.rf.%s.rpm")

this is an aggregate so that it can come before the aggragate package-manager

(action/def-aggregated-action add-rpmforge
  "Add the rpmforge repository"
  [session args]
  {:always-before #{`package/package-manager `package/package}
   :arglists '([session & {:keys [version distro arch]
                           :or {version "0.5.2-2" distro "el5" arch "i386"}}])}
  (let [{:keys [version distro arch]
         :or {version "0.5.2-2"
              distro "el5"
              arch "i386"}} (apply hash-map (first args))]
    (stevedore/checked-script
     "Add rpmforge repositories"
     (chain-or
      (if (= "0" @(pipe (rpm -qa) (grep rpmforge) (wc -l)))
        (do
          ~(remote-file*
            session
            "rpmforge.rpm"
            :url (format rpmforge-url-pattern version distro arch))
          ("rpm" -U --quiet "rpmforge.rpm")))))))
 

Package management action.

package is used to install or remove a package.

package-source is used to specify a non-standard source for packages.

(ns pallet.action.package
  "Package management action.
   `package` is used to install or remove a package.
   `package-source` is used to specify a non-standard source for packages."
  (:require
   [pallet.action :as action]
   [pallet.action.file :as file]
   [pallet.action.remote-file :as remote-file]
   [pallet.action.exec-script :as exec-script]
   [pallet.action.exec-script :as exec-script]
   [pallet.parameter :as parameter]
   [pallet.script.lib :as lib]
   [pallet.session :as session]
   [pallet.stevedore :as stevedore]
   [pallet.script :as script]
   [pallet.utils :as utils]
   [clojure.string :as string])
  (:use
   pallet.thread-expr))
(def ^{:private true}
  remote-file* (action/action-fn remote-file/remote-file-action))
(def ^{:private true}
  sed* (action/action-fn file/sed))
(defmulti adjust-packages
  (fn [session & _]
    (session/packager session)))

aptitude can install, remove and purge all in one command, so we just need to split by enable/disable options.

(defmethod adjust-packages :aptitude
  [session packages]
  (stevedore/checked-commands
   "Packages"
   (stevedore/script (~lib/package-manager-non-interactive))
   (stevedore/chain-commands*
    (for [[opts packages] (->>
                           packages
                           (group-by #(select-keys % [:enable]))
                           (sort-by #(apply min (map :priority (second %)))))]
      (stevedore/script
       (aptitude
        install -q -y
        ~(string/join " " (map #(str "-t " %) (:enable opts)))
        ~(string/join
          " "
          (for [[action packages] (group-by :action packages)
                {:keys [package force purge]} packages]
            (case action
              :install (format "%s+" package)
              :remove (if purge
                        (format "%s_" package)
                        (format "%s-" package))
              :upgrade (format "%s+" package)
              (throw
               (IllegalArgumentException.
                (str
                 action " is not a valid action for package action"))))))))))
   (stevedore/script (~lib/list-installed-packages))))
(def ^{:private true :doc "Define the order of actions"}
  action-order {:install 10 :remove 20 :upgrade 30})

yum has separate install, remove and purge commands, so we just need to split by enable/disable options and by command. We install before removing.

(defmethod adjust-packages :yum
  [session packages]
  (stevedore/checked-commands
   "Packages"
   (stevedore/chain-commands*
    (conj
     (vec
      (for [[action packages] (->> packages
                                   (sort-by #(action-order (:action %)))
                                   (group-by :action))
            [opts packages] (->>
                             packages
                             (group-by
                              #(select-keys % [:enable :disable :exclude]))
                             (sort-by #(apply min (map :priority (second %)))))]
        (stevedore/script
         (yum
          ~(name action) -q -y
          ~(string/join " " (map #(str "--disablerepo=" %) (:disable opts)))
          ~(string/join " " (map #(str "--enablerepo=" %) (:enable opts)))
          ~(string/join " " (map #(str "--exclude=" %) (:exclude opts)))
          ~(string/join
            " "
            (distinct (map :package packages)))))))
     (stevedore/script (~lib/list-installed-packages))))))
(defmethod adjust-packages :default
  [session packages]
  (stevedore/checked-commands
   "Packages"
   (stevedore/chain-commands*
    (list*
     (stevedore/script (~lib/package-manager-non-interactive))
     (for [[action packages] (group-by :action packages)
           {:keys [package force purge]} packages]
       (case action
         :install (stevedore/script
                   (~lib/install-package ~package :force ~force))
         :remove (if purge
                   (stevedore/script (~lib/purge-package ~package))
                   (stevedore/script (~lib/remove-package ~package)))
         :upgrade (stevedore/script (~lib/upgrade-package ~package))
         (throw
          (IllegalArgumentException.
           (str action " is not a valid action for package action")))))))))
(defn- package-map
  "Convert the args into a single map"
  [session package-name
   & {:keys [action y force purge priority enable disable] :as options}]
  (letfn [(as-seq [x] (if (or (string? x) (symbol? x) (keyword? x))
                        [(name x)] x))]
    (->
     {:action :install :y true :priority 50}
     (merge options)
     (assoc :package package-name)
     (update-in [:enable] as-seq)
     (update-in [:disable] as-seq))))
(action/def-aggregated-action package
  "Install or remove a package.
   Options
    - :action [:install | :remove | :upgrade]
    - :purge [true|false]         when removing, whether to remove all config
    - :enable [repo|(seq repo)]   enable specific repository
    - :disable [repo|(seq repo)]  disable specific repository
    - :priority n                 priority (0-100, default 50)
   Package management occurs in one shot, so that the package manager can
   maintain a consistent view."
  [session args]
  {:arglists '([session package-name
                & {:keys [action y force purge enable disable priority]
                   :or {action :install
                        y true
                        priority 50}
                   :as options}])}
  (adjust-packages session (map #(apply package-map session %) args)))
(defn packages
  "Install a list of packages keyed on packager.
       (packages session
         :yum [\"git\" \"git-email\"]
         :aptitude [\"git-core\" \"git-email\"])"
  [session & {:keys [yum aptitude pacman brew] :as options}]
  (->
   session
   (for->
    [package-name (options (session/packager session))]
    (package package-name))))
(def source-location
  {:aptitude "/etc/apt/sources.list.d/%s.list"
   :yum "/etc/yum.repos.d/%s.repo"})
(defmulti format-source
  "Format a package source definition"
  (fn [packager & _] packager))
(defmethod format-source :aptitude
  [_ name options]
  (format
   "%s %s %s %s\n"
   (:source-type options "deb")
   (:url options)
   (:release options (stevedore/script (~lib/os-version-name)))
   (string/join " " (:scopes options ["main"]))))
(defmethod format-source :yum
  [_ name {:keys [url mirrorlist gpgcheck gpgkey priority failovermethod
                  enabled]
           :or {enabled 1}
           :as options}]
  (string/join
   "\n"
   (filter
    identity
    [(format "[%s]\nname=%s" name name)
     (when url (format "baseurl=%s" url))
     (when mirrorlist (format "mirrorlist=%s" mirrorlist))
     (format "gpgcheck=%s" (or (and gpgkey 1) 0))
     (when gpgkey (format "gpgkey=%s" gpgkey))
     (when priority (format "priority=%s" priority))
     (when failovermethod (format "failovermethod=%s" failovermethod))
     (format "enabled=%s" enabled)
     ""])))
(defn package-source*
  "Add a packager source."
  [session name & {:as options}]
  (let [packager (session/packager session)]
    (stevedore/checked-commands
     "Package source"
     (let [key-url (-> options :aptitude :url)]
       (if (and key-url (.startsWith key-url "ppa:"))
         (stevedore/chain-commands
          (stevedore/script (~lib/install-package "python-software-properties"))
          (stevedore/script (add-apt-repository ~key-url)))
         (remote-file*
          session
          (format (source-location packager) name)
          :content (format-source packager name (packager options))
          :literal (= packager :yum))))
     (if (and (-> options :aptitude :key-id)
              (= packager :aptitude))
       (stevedore/script
        (apt-key adv
                 "--keyserver subkeys.pgp.net --recv-keys"
                 ~(-> options :aptitude :key-id))))
     (if (and (-> options :aptitude :key-url)
              (= packager :aptitude))
       (stevedore/chain-commands
        (remote-file*
         session
         "aptkey.tmp"
         :url (-> options :aptitude :key-url))
        (stevedore/script (apt-key add aptkey.tmp))))
     (when-let [key (and (= packager :yum) (-> options :yum :gpgkey))]
       (stevedore/script (rpm "--import" ~key))))))
(declare package-manager)
(action/def-aggregated-action package-source
  "Control package sources.
   Options are the package manager keywords, each specifying a map of
   packager specific options.
   :aptitude
     - :source-type string   - source type (deb)
     - :url url              - repository url
     - :scopes seq           - scopes to enable for repository
     - :key-url url          - url for key
     - :key-id id            - id for key to look it up from keyserver
   :yum
     - :name                 - repository name
     - :url url          - repository base url
     - :gpgkey url           - gpg key url for repository
   Example
       (package-source \"Partner\"
         :aptitude {:url \"http://archive.canonical.com/\"
                    :scopes [\"partner\"]})"
  [session args]
  {:arglists (:arglists (meta pallet.action.package/package-source*))
   :always-before #{`package-manager `package}}
  (stevedore/do-script*
   (map (fn [x] (apply package-source* session x)) args)))
(defn add-scope*
  "Add a scope to all the existing package sources. Aptitude specific."
  [type scope file]
  (stevedore/chained-script
   (var tmpfile @(mktemp -t addscopeXXXX))
   (~lib/cp ~file @tmpfile :preserve true)
   (awk "'{if ($1 ~" ~(str "/^" type "/") "&& !" ~(str "/" scope "/")
        " ) print $0 \" \" \ ~scope  "\" ; else print; }'"
        ~file > @tmpfile)
   (~lib/mv @tmpfile ~file :force ~true)))
(defn add-scope
  "Add a scope to an apt source"
  [opts]
  (add-scope*
   (or (opts :type) "deb.*")
   (:scope opts)
   (or (opts :file) "/etc/apt/sources.list")))
(defmulti configure-package-manager
  "Configure the package manager"
  (fn [session packager options] packager))
(defmulti package-manager-option
  "Provide packager specific options"
  (fn [session packager option value] [packager option]))
(defmethod package-manager-option [:aptitude :proxy]
  [session packager proxy proxy-url]
  (format "ACQUIRE::http::proxy \"%s\";" proxy-url))
(defmethod package-manager-option [:yum :proxy]
  [session packager proxy proxy-url]
  (format "proxy=%s" proxy-url))
(defmethod package-manager-option [:pacman :proxy]
  [session packager proxy proxy-url]
  (format
   (str "XferCommand = /usr/bin/wget "
        "-e \"http_proxy = %s\" -e \"ftp_proxy = %s\" "
        "--passive-ftp --no-verbose -c -O %%o %%u")
   proxy-url proxy-url))
(def default-installonlypkgs
  (str "kernel kernel-smp kernel-bigmem kernel-enterprise kernel-debug "
       "kernel-unsupported"))
(defmethod package-manager-option [:yum :installonlypkgs]
  [session packager installonly packages]
  (format
   "installonlypkgs=%s %s" (string/join " " packages) default-installonlypkgs))
(defmethod configure-package-manager :aptitude
  [session packager {:keys [priority prox] :or {priority 50} :as options}]
  (remote-file*
   session
   (format "/etc/apt/apt.conf.d/%spallet" priority)
   :content (string/join
             \newline
             (map
              #(package-manager-option session packager (key %) (val %))
              (dissoc options :priority)))
   :literal true))
(defmethod configure-package-manager :yum
  [session packager {:keys [proxy] :as options}]
  (stevedore/chain-commands
   (remote-file*
    session
    "/etc/yum.pallet.conf"
    :content (string/join
              \newline
              (map
               #(package-manager-option session packager (key %) (val %))
               (dissoc options :priority)))
    :literal true)
   ;; include yum.pallet.conf from yum.conf
   (stevedore/script
    (if (not @("fgrep" "yum.pallet.conf" "/etc/yum.conf"))
      (do
        ("cat" ">>" "/etc/yum.conf" " <<'EOFpallet'")
        "include=file:///etc/yum.pallet.conf"
        "EOFpallet")))))
(defmethod configure-package-manager :pacman
  [session packager {:keys [proxy] :as options}]
  (stevedore/chain-commands
   (remote-file*
    session
    "/etc/pacman.pallet.conf"
    :content (string/join
              \newline
              (map
               #(package-manager-option session packager (key %) (val %))
               (dissoc options :priority)))
    :literal true)
   ;; include pacman.pallet.conf from pacman.conf
   (stevedore/script
    (if (not @("fgrep" "pacman.pallet.conf" "/etc/pacman.conf"))
      (do
        ~(sed*
          session
          "/etc/pacman.conf"
          "a Include = /etc/pacman.pallet.conf"
          :restriction "/\\[options\\]/"))))))
(defmethod configure-package-manager :default
  [session packager {:as options}]
  (comment "do nothing"))
(defn package-manager*
  "Package management."
  [session action & options]
  (let [packager (session/packager session)]
    (stevedore/checked-commands
     (format "package-manager %s %s" (name action) (string/join " " options))
     (case action
       :update (stevedore/script (apply ~lib/update-package-list ~options))
       :upgrade (stevedore/script (~lib/upgrade-all-packages))
       :list-installed (stevedore/script (~lib/list-installed-packages))
       :add-scope (add-scope (apply hash-map options))
       :multiverse (add-scope (apply hash-map :scope "multiverse" options))
       :universe (add-scope (apply hash-map :scope "universe" options))
       :debconf (if (= :aptitude packager)
                  (stevedore/script
                   (apply ~lib/debconf-set-selections ~options)))
       :configure (configure-package-manager session packager options)
       (throw (IllegalArgumentException.
               (str action
                    " is not a valid action for package-manager action")))))))
(action/def-aggregated-action package-manager
  "Package manager controls.
   `action` is one of the following:
   - :update          - update the list of available packages
   - :list-installed  - output a list of the installed packages
   - :add-scope       - enable a scope (eg. multiverse, non-free)
   To refresh the list of packages known to the pakage manager:
       (package-manager session :update)
   To enable multiverse on ubuntu:
       (package-manager session :add-scope :scope :multiverse)
   To enable non-free on debian:
       (package-manager session :add-scope :scope :non-free)"
  [session package-manager-args]
  {:copy-arglist (:arglists (meta pallet.action.package/package-manager*))
   :always-before `package}
  (stevedore/do-script*
   (map #(apply package-manager* session %) (distinct package-manager-args))))
(action/def-bash-action add-rpm
  "Add an rpm.  Source options are as for remote file."
  [request rpm-name & {:as options}]
  (stevedore/do-script
   (apply remote-file* request rpm-name (apply concat options))
   (stevedore/checked-script
    (format "Install rpm %s" rpm-name)
    (if-not (rpm -q @(rpm -pq ~rpm-name) > "/dev/null" "2>&1")
      (do (rpm -U --quiet ~rpm-name))))))
(action/def-bash-action minimal-packages
  "Add minimal packages for pallet to function"
  [session]
  {:always-before #{`package-manager `package-source `package}}
  (let [os-family (session/os-family session)]
    (cond
     (#{:ubuntu :debian} os-family) (stevedore/checked-script
                                     "Add minimal packages"
                                     (~lib/update-package-list)
                                     (~lib/install-package "coreutils")
                                     (~lib/install-package "sudo"))
     (= :arch os-family) (stevedore/checked-script
                          "Add minimal packages"
                          ("{" pacman-db-upgrade "||" true "; } "
                           "2> /dev/null")
                          (~lib/update-package-list)
                          (~lib/upgrade-package "pacman")
                          (println "  checking for pacman-db-upgrade")
                          ("{" pacman-db-upgrade
                           "&&" (~lib/update-package-list)
                           "||" true "; } "
                           "2> /dev/null")
                          (~lib/install-package "sudo")))))
 

Action to specify the content of a remote directory. At present the content can come from a downloaded tar or zip file.

(ns pallet.action.remote-directory
  (:require
   [pallet.action :as action]
   [pallet.action.directory :as directory]
   [pallet.action.file :as file]
   [pallet.action.remote-file :as remote-file]
   [pallet.script.lib :as lib]
   [pallet.stevedore :as stevedore]
   [pallet.thread-expr :as thread-expr]
   [clojure.java.io :as io]))
(def ^{:private true}
  directory* (action/action-fn directory/directory))
(def ^{:private true}
  remote-file* (action/action-fn remote-file/remote-file-action))
(defn- source-to-cmd-and-path
  [session path url local-file remote-file md5 md5-url]
  (cond
   url (let [tarpath (str
                      (stevedore/script (~lib/tmp-dir)) "/"
                      (.getName
                       (java.io.File. (.getFile (java.net.URL. url)))))]
         [(remote-file* session tarpath :url url :md5 md5 :md5-url md5-url)
          tarpath])
   local-file [ (str path "-content")]
   remote-file [ remote-file]))
(action/def-bash-action remote-directory-action
  [session path & {:keys [action url local-file remote-file
                          unpack tar-options unzip-options jar-options
                          strip-components md5 md5-url owner group recursive]
                   :or {action :create
                        tar-options "xz"
                        unzip-options "-o"
                        jar-options "xf"
                        strip-components 1
                        recursive true}
                   :as options}]
  (case action
    :create (let [url (options :url)
                  unpack (options :unpack :tar)]
              (when (and (or url local-file remote-file) unpack)
                (let [[cmd tarpath] (source-to-cmd-and-path
                                     session path
                                     url local-file remote-file md5 md5-url)]
                  (stevedore/checked-commands
                   "remote-directory"
                   (directory*
                    session path :owner owner :group group :recursive false)
                   cmd
                   (condp = unpack
                       :tar (stevedore/checked-script
                             (format "Untar %s" tarpath)
                             (var rdf @(readlink -f ~tarpath))
                             (cd ~path)
                             (tar ~tar-options
                                  ~(str "--strip-components=" strip-components)
                                  -f @rdf)
                             (cd -))
                       :unzip (stevedore/checked-script
                               (format "Unzip %s" tarpath)
                               (var rdf @(readlink -f ~tarpath))
                               (cd ~path)
                               (unzip ~unzip-options @rdf)
                               (cd -))
                       :jar (stevedore/checked-script
                             (format "Unjar %s" tarpath)
                             (var rdf @(readlink -f ~tarpath))
                             (cd ~path)
                             (jar ~jar-options @rdf)
                             (cd -)))
                   (if recursive
                     (directory*
                      session path
                      :owner owner
                      :group group
                      :recursive recursive))))))))
(defn remote-directory
  "Specify the contents of remote directory.
   Options:
    - :url              - a url to download content from
    - :unpack           - how download should be extracts (default :tar)
    - :tar-options      - options to pass to tar (default \"xz\")
    - :unzip-options    - options to pass to unzip (default \"-o\")
    - :jar-options      - options to pass to unzip (default \"xf\")
                          jar does not support stripping path components
    - :strip-components - number of path compnents to remove when unpacking
    - :md5              - md5 of file to unpack
    - :md5-url          - url of md5 file for file to unpack
   Ownership options:
    - :owner            - owner of files
    - :group            - group of files
    - :recursive        - flag to recursively set owner and group
   To install the content of an url pointing at a tar file, specify the :url
   option.
       (remote-directory session path
          :url \"http://a.com/path/file.tgz\")
   If there is an md5 url with the tar file's md5, you can specify that as well,
   to prevent unecessary downloads and verify the content.
       (remote-directory session path
          :url \"http://a.com/path/file.tgz\"
          :md5-url \"http://a.com/path/file.md5\")
   To install the content of an url pointing at a zip file, specify the :url
   option and :unpack :unzip.
       (remote-directory session path
          :url \"http://a.com/path/file.\"
          :unpack :unzip)"
  [session path & {:keys [action url local-file remote-file
                          unpack tar-options unzip-options jar-options
                          strip-components md5 md5-url owner group recursive
                          force-overwrite
                          local-file-options]
                   :or {action :create
                        tar-options "xz"
                        unzip-options "-o"
                        jar-options "xf"
                        strip-components 1
                        recursive true}
                   :as options}]
  (when-let [f (and local-file (io/file local-file))]
    (when (not (and (.exists f) (.isFile f) (.canRead f)))
      (throw (IllegalArgumentException.
              (format
               (str "'%s' does not exist, is a directory, or is unreadable; "
                    "cannot register it for transfer.")
               local-file)))))
  (->
   session
   (thread-expr/when-> local-file
           ;; transfer local file to remote system if required
           (remote-file/transfer-file
            local-file
            (str path "-content")
            local-file-options))
   (action/with-precedence local-file-options
     (thread-expr/apply-map->
      remote-directory-action path
      (merge
       {:overwrite-changes force-overwrite} ;; capture the value of the flag
       options)))))
 

Action to specify remote file content.

remote-file has many options for the content of remote files. Ownership and mode can of course be specified. By default the remote file is versioned, and multiple versions are kept.

Modification of remote files outside of pallet cause an error to be raised by default.

(ns pallet.action.remote-file
  "Action to specify remote file content.
   `remote-file` has many options for the content of remote files.  Ownership
   and mode can of course be specified. By default the remote file is versioned,
   and multiple versions are kept.
   Modification of remote files outside of pallet cause an error to be raised
   by default."
  (:require
   [pallet.action :as action]
   [pallet.action.directory :as directory]
   [pallet.action.file :as file]
   [pallet.blobstore :as blobstore]
   [pallet.environment :as environment]
   [pallet.script.lib :as lib]
   [pallet.stevedore :as stevedore]
   [pallet.template :as templates]
   [pallet.utils :as utils]
   [clojure.java.io :as io])
  (:use
   pallet.thread-expr))
(def ^{:dynamic true} *install-new-files* true)
(def ^{:dynamic true} *force-overwrite* false)
(defn set-install-new-files
  "Set boolean flag to control installation of new files"
  [flag]
  (alter-var-root #'*install-new-files* (fn [_] flag)))
(defn set-force-overwrite
  "Globally force installation of new files, even if content on node has
  changed."
  [flag]
  (alter-var-root #'*force-overwrite* (fn [_] flag)))
(def
  ^{:doc "A vector of the options accepted by remote-file.  Can be used for
          option forwarding when calling remote-file from other crates."}
  content-options
  [:local-file :remote-file :url :md5 :content :literal :template :values
   :action :blob :blobstore :insecure])
(def
  ^{:doc "A vector of options for controlling versions. Can be used for option
          forwarding when calling remote-file from other crates."}
  version-options
  [:overwrite-changes :no-versioning :max-versions :flag-on-changed])
(def
  ^{:doc "A vector of options for controlling ownership. Can be used for option
          forwarding when calling remote-file from other crates."}
  ownership-options
  [:owner :group :mode])
(def
  ^{:doc "A vector of the options accepted by remote-file.  Can be used for
          option forwarding when calling remote-file from other crates."}
  all-options
  (concat content-options version-options ownership-options))
(defn- get-session
  "Build a curl or wget command from the specified session object."
  [session]
  (stevedore/script
   (if (test @(~lib/which curl))
     (curl -s "--retry" 20
           ~(apply str (map
                        #(format "-H \"%s: %s\" " (first %) (second %))
                        (.. session getHeaders entries)))
           ~(.. session getEndpoint toASCIIString))
     (if (test @(~lib/which wget))
       (wget -nv "--tries" 20
             ~(apply str (map
                          #(format "--header \"%s: %s\" " (first %) (second %))
                          (.. session getHeaders entries)))
             ~(.. session getEndpoint toASCIIString))
       (do
         (println "No download utility available")
         (~lib/exit 1))))))
(defn- arg-vector
  "Return the non-session arguments."
  [_ & args]
  args)
(defn- delete-local-path
  [session local-path]
  (.delete local-path)
  session)
(defn with-remote-file
  "Function to call f with a local copy of the sessioned remote path.
   f should be a function taking [session local-path & _], where local-path will
   be a File with a copy of the remote file (which will be unlinked after
   calling f."
  [session f path & args]
  (let [local-path (utils/tmpfile)]
    (->
     session
     (action/schedule-action
      arg-vector
      {}
      [path (.getPath local-path)]
      :in-sequence :transfer/to-local :origin)
     (apply-> f local-path args)
     (action/schedule-action
      delete-local-path
      {}
      [local-path]
      :in-sequence :fn/clojure :origin))))
(defn transfer-file
  "Function to transfer a local file."
  [session local-path remote-path {:as options}]
  (action/schedule-action
   session
   arg-vector
   options
   [local-path remote-path]
   :in-sequence :transfer/from-local :origin))
(action/def-bash-action remote-file-action
  [session path & {:keys [action url local-file remote-file link
                          content literal
                          template values
                          md5 md5-url
                          owner group mode force
                          blob blobstore
                          overwrite-changes no-versioning max-versions
                          flag-on-changed
                          force
                          insecure]
                   :or {action :create max-versions 5}
                   :as options}]
  (let [new-path (str path ".new")
        md5-path (str path ".md5")
        versioning (if no-versioning nil :numbered)
        proxy (environment/get-for session [:proxy] nil)]
    (case action
      :create
      (stevedore/checked-commands
       (str "remote-file " path)
       (cond
        (and url md5) (stevedore/chained-script
                       (if (|| (not (file-exists? ~path))
                               (!= ~md5 @((pipe
                                           (~lib/md5sum ~path)
                                           (~lib/cut
                                             :fields 1 :delimiter " ")))))
                         ~(stevedore/chained-script
                           (~lib/download-file
                            ~url ~new-path :proxy ~proxy :insecure ~insecure))))
        ;; Download md5 to temporary directory.
        (and url md5-url) (stevedore/chained-script
                           (var tmpdir (quoted (~lib/make-temp-dir "rf")))
                           (var basefile
                                (quoted
                                 (str @tmpdir "/" @(~lib/basename ~path))))
                           (var newmd5path (quoted (str @basefile ".md5")))
                           (~lib/download-file
                            ~md5-url @newmd5path :proxy ~proxy
                            :insecure ~insecure)
                           (~lib/normalise-md5 @newmd5path)
                           (if (|| (not (file-exists? ~md5-path))
                                   (~lib/diff @newmd5path ~md5-path))
                             (do
                               (~lib/download-file
                                ~url ~new-path :proxy ~proxy
                                :insecure ~insecure)
                               (~lib/ln ~new-path @basefile)
                               (if-not (~lib/md5sum-verify @newmd5path)
                                 (do
                                   (println ~(str "Download of " url
                                                  " failed to match md5"))
                                   (~lib/exit 1)))))
                           (~lib/rm @tmpdir :force ~true :recursive ~true))
        url (stevedore/chained-script
             (~lib/download-file
              ~url ~new-path :proxy ~proxy :insecure ~insecure))
        content (stevedore/script
                 (~lib/heredoc
                  ~new-path ~content ~(select-keys options [:literal])))
        local-file nil
        ;; (let [temp-path (action/register-file-transfer!
        ;;                   local-file)]
        ;;    (stevedore/script
        ;;     (mv -f (str "~/" ~temp-path) ~new-path)))
        remote-file (stevedore/script
                     (~lib/cp ~remote-file ~new-path :force ~true))
        template (stevedore/script
                  (~lib/heredoc
                   ~new-path
                   ~(templates/interpolate-template
                     template (or values {}) session)
                   ~(select-keys options [:literal])))
        link (stevedore/script
              (~lib/ln ~link ~path :force ~true :symbolic ~true))
        blob (stevedore/checked-script
              "Download blob"
              (~lib/download-request
               ~new-path
               ~(blobstore/sign-blob-request
                 (or blobstore (environment/get-for session [:blobstore] nil)
                     (throw (IllegalArgumentException.
                             "No :blobstore given for blob content.") ))
                 (:container blob) (:path blob)
                 {:method :get})))
        :else (throw
               (IllegalArgumentException.
                (str "remote-file " path " specified without content."))))
       ;; process the new file accordingly
       (when *install-new-files*
         (stevedore/chain-commands
          (if (or overwrite-changes no-versioning *force-overwrite*)
            (stevedore/script
             (if (file-exists? ~new-path)
               (do
                 ~(stevedore/chain-commands
                   (stevedore/script
                    (~lib/mv ~new-path ~path :backup ~versioning :force ~true))
                   (if flag-on-changed
                     (stevedore/script (~lib/set-flag ~flag-on-changed)))))))
            (stevedore/script
             (var md5diff )
             (if (&& (file-exists? ~path) (file-exists? ~md5-path))
               (do
                 (~lib/md5sum-verify ~md5-path)
                 (set! md5diff "$?")))
             (var contentdiff )
             (if (&& (file-exists? ~path) (file-exists? ~new-path))
               (do
                 (~lib/diff ~path ~new-path :unified true)
                 (set! contentdiff "$?")))
             (if (== @md5diff 1)
               (do
                 (println "Existing content did not match md5:")
                 (~lib/exit 1)))
             (if (!= @contentdiff "0")
               (do
                 ~(stevedore/chain-commands
                   (stevedore/script
                    (~lib/mv ~new-path ~path :force ~true :backup ~versioning))
                   (if flag-on-changed
                     (stevedore/script (~lib/set-flag ~flag-on-changed))))))
             (if-not (file-exists? ~path)
               (do
                 ~(stevedore/chain-commands
                   (stevedore/script (~lib/mv ~new-path ~path))
                   (if flag-on-changed
                     (stevedore/script (~lib/set-flag ~flag-on-changed))))))))
          (file/adjust-file path options)
          (when-not no-versioning
            (stevedore/chain-commands
             (file/write-md5-for-file path md5-path)
             (stevedore/script
              (println "MD5 sum is" @(~lib/cat ~md5-path)))))))
       ;; cleanup
       (if (and (not no-versioning) (pos? max-versions))
         (stevedore/script
          (pipe
           ((~lib/ls (str ~path ".~[0-9]*~") :sort-by-time ~true)
            "2>" "/dev/null")
           (~lib/tail  :max-lines ~(str "+" (inc max-versions)))
           (~lib/xargs (~lib/rm  :force ~true))))))
      :delete (stevedore/checked-script
               (str "delete remote-file " path)
               (~lib/rm ~path :force ~force)))))
(defn remote-file
  "Remote file content management.
The `remote-file` action can specify the content of a remote file in a number
different ways.
By default, the remote-file is versioned, and 5 versions are kept.
The remote content is also verified against it's md5 hash.  If the contents
of the remote file have changed (e.g. have been edited on the remote machine)
then by default the file will not be overwritten, and an error will be raised.
To force overwrite, call `set-force-overwrite` before running `converge` or
`lift`.
Options for specifying the file's content are:
  :url url          - download the specified url to the given filepath
  :content string   - use the specified content directly
  :local-file path  - use the file on the local machine at the given path
  :remote-file path - use the file on the remote machine at the given path
  :link             - file to link to
  :literal          - prevent shell expansion on content
  :md5              - md5 for file
  :md5-url          - a url containing file's md5
  :template         - specify a template to be interpolated
  :values           - values for interpolation
  :blob             - map of :container, :path
  :blobstore        - a jclouds blobstore object (override blobstore in session)
  :insecure         - boolean to specify ignoring of SLL certs
Options for version control are:
  :overwrite-changes - flag to force overwriting of locally modified content
  :no-versioning    - do not version the file
  :max-versions     - specfy the number of versions to keep (default 5)
  :flag-on-changed  - flag to set if file is changed
Options for specifying the file's permissions are:
  :owner user-name
  :group group-name
  :mode  file-mode
To copy the content of a local file to a remote file:
    (remote-file session \"remote/path\" :local-file \"local/path\")
To copy the content of one remote file to another remote file:
    (remote-file session \"remote/path\" :remote-file \"remote/source/path\")
To link one remote file to another remote file:
    (remote-file session \"remote/path\" :link \"remote/source/path\")
To download a url to a remote file:
    (remote-file session \"remote/path\" :url \"http://a.com/path\")
If a url to a md5 file is also available, then it can be specified to prevent
unnecessary downloads and to verify the download.
    (remote-file session \"remote/path\"
      :url \"http://a.com/path\"
      :md5-url \"http://a.com/path.md5\")
If the md5 of the file to download, it can be specified to prevent unnecessary
downloads and to verify the download.
    (remote-file session \"remote/path\"
      :url \"http://a.com/path\"
      :md5 \"6de9439834c9147569741d3c9c9fc010\")
Content can also be copied from a blobstore.
    (remote-file session \"remote/path\"
      :blob {:container \"container\" :path \"blob\"})"
  [session path & {:keys [action url local-file remote-file link
                          content literal
                          template values
                          md5 md5-url
                          owner group mode force
                          blob blobstore
                          overwrite-changes no-versioning max-versions
                          flag-on-changed
                          local-file-options]
                   :as options}]
  (when-let [f (and local-file (io/file local-file))]
    (when (not (and (.exists f) (.isFile f) (.canRead f)))
      (throw (IllegalArgumentException.
              (format
               (str "'%s' does not exist, is a directory, or is unreadable; "
                    "cannot register it for transfer.")
               local-file)))))
  (->
   session
   (when-> local-file
           ;; transfer local file to remote system if required
           (transfer-file local-file (str path ".new") local-file-options))
   (action/with-precedence local-file-options
     (apply-map->
      remote-file-action path
      (merge
       {:overwrite-changes *force-overwrite*} ;; capture the value of the flag
       options)))))
 

Provides an action that can be repeated if it fails

(ns pallet.action.retry
  (:require
   [pallet.action :as action]
   [pallet.action.exec-script :as exec-script]
   [pallet.script.lib :as lib]))
(defn loop-until
  [session service-name condition max-retries standoff]
  (exec-script/exec-checked-script
   session
   (format "Wait for %s" service-name)
   (group (chain-or (let x 0) true))
   (while (not ~condition)
     (do
       (let x (+ x 1))
       (if (= ~max-retries @x)
         (do
           (println
            ~(format "Timed out waiting for %s" service-name)
            >&2)
           (~lib/exit 1)))
       (println ~(format "Waiting for %s" service-name))
       (sleep ~standoff)))))
(defmacro retry-until
  [session {:keys [max-retries standoff service-name]
            :or {max-retries 5 standoff 2}}
   condition]
  (let [service-name (or service-name "retryable")]
    `(->
      ~session
      (loop-until ~service-name ~condition ~max-retries ~standoff))))
 
(ns pallet.action.rsync
  (:require
   [pallet.action :as action]
   [pallet.action.directory :as directory]
   [pallet.action.package :as package]
   [pallet.execute :as execute]
   [pallet.node :as node]
   [pallet.session :as session]
   [pallet.utils :as utils]
   [clojure.tools.logging :as logging]))
(def cmd "/usr/bin/rsync -e '%s' -rP --delete --copy-links -F -F %s %s@%s:%s")
(action/def-clj-action rsync
  [session from to {:keys [port]}]
  (logging/infof "rsync %s to %s" from to)
  (let [ssh (str "/usr/bin/ssh -o \"StrictHostKeyChecking no\" "
                 (if port (format "-p %s" port)))
        cmd (format
             cmd ssh from (:username (session/admin-user session))
             (node/primary-ip (session/target-node session)) to)]
    (execute/sh-script cmd)
    session))
(defn rsync-directory
  "Rsync from a local directory to a remote directory."
  [session from to & {:keys [owner group mode port] :as options}]
  (->
   session
   (package/package "rsync")
   (directory/directory to :owner owner :group group :mode mode)
   (rsync from to options)))
 

Service control.

(ns pallet.action.service
  (:use clojure.tools.logging)
  (:require
   [pallet.action :as action]
   [pallet.action.remote-file :as remote-file]
   [pallet.script :as script]
   [pallet.script.lib :as lib]
   [pallet.stevedore :as stevedore]
   [clojure.string :as string]))
(defn init-script-path
  "Path to the specified init script"
  [service-name]
  (str (stevedore/script (~lib/etc-init)) "/" service-name))
(action/def-bash-action service
  "Control services.
   - :action  accepts either startstop, restart, enable or disable keywords.
   - :if-flag  makes start, stop, and restart confitional on the specified flag
               as set, for example, by remote-file :flag-on-changed
   - :sequence-start  a sequence of [sequence-number level level ...], where
                      sequence number determines the order in which services
                      are started within a level."
  [session service-name & {:keys [action if-flag if-stopped]
                           :or {action :start}
                           :as options}]
  (if (#{:enable :disable :start-stop} action)
    (stevedore/checked-script
     (format "Configure service %s" service-name)
     (~lib/configure-service ~service-name ~action ~options))
    (if if-flag
      (stevedore/script
       (println ~(name action) ~service-name "if config changed")
       (if (== "1" (~lib/flag? ~if-flag))
         (~(init-script-path service-name) ~(name action))))
      (if if-stopped
        (stevedore/script
         (println ~(name action) ~service-name "if stopped")
         (if-not (~(init-script-path service-name) status)
           (~(init-script-path service-name) ~(name action))))
        (stevedore/script
         (println ~(name action) ~service-name)
         (~(init-script-path service-name) ~(name action)))))))
(defmacro with-restart
  "Stop the given service, execute the body, and then restart."
  [session service-name & body]
  `(let [service# ~service-name]
     (-> ~session
         (service service# :action :stop)
         ~@body
         (service service# :action :start))))
(defn init-script
  "Install an init script.  Sources as for remote-file."
  [session service-name & {:keys [action url local-file remote-file link
                                  content literal template values md5 md5-url
                                  force]
                           :or {action :create}
                           :as options}]
  (apply
   remote-file/remote-file
   session
   (init-script-path service-name)
   :action action :owner "root" :group "root" :mode "0755"
   (apply concat options)))
 

User management action.

(ns pallet.action.user
  (:use
   [pallet.script :only [defscript]])
  (:require
   [pallet.action :as action]
   [pallet.script.lib :as lib]
   [pallet.stevedore :as stevedore]
   [clojure.string :as string]))
(def
  ^{:doc "Map for looking up shell path based on keyword." :private true}
  shell-names
  {:bash "/bin/bash" :csh "/bin/csh" :ksh "/bin/ksh" :rsh "/bin/rsh"
   :sh "/bin/sh" :tcsh "/bin/tcsh" :zsh "/bin/zsh" :false "/bin/false"})
(defn user*
  "Require a user"
  [session username & {:keys [action shell base-dir home system create-home
                              password shell comment groups remove force append]
                       :or {action :manage}
                       :as options}]
  (let [opts (merge options {:shell (get shell-names shell shell)})]
    (case action
      :create
      (stevedore/script
       (if-not (~lib/user-exists? ~username)
         (~lib/create-user
          ~username ~(select-keys opts [:base-dir :home :system :comment
                                        :create-home :password :shell
                                        :group :groups]))))
      :manage
      (stevedore/script
       (if (~lib/user-exists? ~username)
         (~lib/modify-user
          ~username ~(select-keys
                      opts [:home :shell :comment :group :groups :password
                            :append]))
         (~lib/create-user
          ~username ~(select-keys opts [:base-dir :home :system :comment
                                        :create-home :password :shell
                                        :group :groups]))))
      :lock
      (stevedore/script
       (if (~lib/user-exists? ~username)
         (~lib/lock-user ~username)))
      :unlock
      (stevedore/script
       (if (~lib/user-exists? ~username)
         (~lib/unlock-user ~username)))
      :remove
      (stevedore/script
       (if (~lib/user-exists? ~username)
         (~lib/remove-user ~username ~(select-keys opts [:remove :force]))))
      (throw (IllegalArgumentException.
              (str action " is not a valid action for user action"))))))
(action/def-aggregated-action user
  "User management."
  [session user-args]
  {:arglists (:arglists (meta pallet.action.user/user*))
   :always-after #{`group}}
  (string/join \newline (map #(apply user* session %) user-args)))
(action/def-bash-action group
  "User Group Management."
  [session groupname & {:keys [action system gid password]
                        :or {action :manage}
                        :as options}]
  (case action
    :create
    (stevedore/script
     (if-not (~lib/group-exists? ~groupname)
       (~lib/create-group
        ~groupname ~(select-keys options [:system :gid :password]))))
    :manage
    (stevedore/script
     (if (~lib/group-exists? ~groupname)
       (~lib/modify-group
        ~groupname ~(select-keys options [:gid :password]))
       (~lib/create-group
        ~groupname ~(select-keys options [:system :gid :password]))))
    :remove
    (stevedore/script
     (if (~lib/group-exists? ~groupname)
       (~lib/remove-group ~groupname {})))
    (throw (IllegalArgumentException.
            (str action " is not a valid action for group action")))))
 

Actions implement the conversion of phase functions to script and other execution code.

An action has an :action-type. Known types include :script/bash and :fn/clojure.

An action has a :location, with a value of :origin for execution on the node running pallet, and :target for the target node.

An action has an :execution, which is one of :aggregated, :in-sequence or :collected. Calls to :aggregated actions will be grouped, and run before :in-sequence actions. Calls to :collected actions will be grouped, and run after :in-sequence actions.

(ns pallet.action
  "Actions implement the conversion of phase functions to script and other
   execution code.
   An action has an `:action-type`. Known types include `:script/bash`
   and `:fn/clojure`.
   An action has a `:location`, with a value of `:origin` for execution on the
   node running pallet, and `:target` for the target node.
   An action has an `:execution`, which is one of `:aggregated`, `:in-sequence`
   or `:collected`. Calls to `:aggregated` actions will be grouped, and run
   before `:in-sequence` actions. Calls to `:collected` actions will be grouped,
   and run after `:in-sequence` actions."
  {:author "Hugo Duncan"}
  (:require
   [pallet.action-plan :as action-plan]
   [pallet.argument :as argument]
   [pallet.common.def :as ccdef]
   [clojure.tools.logging :as logging]
   [clojure.set :as set]
   [clojure.string :as string]))

action defining functions

(defn schedule-action
  "Registers an action in the action plan. The action is generated by the
   specified action function and arguments that will be applied to the function
   when the action plan is executed.
   The action can be scheduled within one of three 'executions'
   (conceptually, sub-phases):
   `:in-sequence`
   : The generated action will be applied to the node \"in order\", as it is
        defined lexically in the source crate.  This is the default.
   `:aggregated`
   : All aggregated actions are applied to the node in the order they are
        defined, but before all :in-sequence actions. Note that all of the
        arguments to any given action function are gathered such that there is
        only ever one invocation of each fn within each phase.
   `:collected`
   : All collected actions are applied to the node in the order they are
        defined, but after all :in-sequence action. Note that all of the
        arguments to any given action function are gathered such that there is
        only ever one invocation of each fn within each phase.
   The action-type determines how the action should be handled:
   `:script/bash`
   : action produces bash script for execution on remote machine
   `:fn/clojure`
   : action is a function for local execution
   `:transfer/to-local`
   : action is a function specifying remote source and local destination.
   `:transfer/from-local`
   : action is a function specifying local source and remote destination."
                          [session action-fn metadata args execution action-type
                          location] {:pre [session
         (keyword? (:phase session))
         (keyword? (:target-id session))]}
  (update-in
   session
   (action-plan/target-path session)
   action-plan/add-action
   (action-plan/action-map
    action-fn metadata args execution action-type location)))
(def precedence-key :action-precedence)
(defmacro with-precedence
  "Set up local precedence relations between actions"
  [request m & body]
  `(let [request# ~request]
     (->
      request#
      (update-in [precedence-key] merge ~m)
      ~@body
      (assoc-in [precedence-key] (get-in request# [precedence-key])))))
(defn- force-set [x] (if (or (set? x) (nil? x)) x #{x}))
(defn action-metadata
  "Compute action metadata from precedence specification in session"
  [session f]
  (merge-with
   #(set/union
     (force-set %1)
     (force-set %2))
   (:meta f)
   (precedence-key session)))
(defmacro action
  "Define an anonymous action"
  [execution action-type location [session & args] & body]
  (let [meta-map (when (and (map? (first body)) (> (count body) 1))
                   (first body))
        body (if meta-map (rest body) body)]
    `(let [f# (vary-meta
               (fn ~@(when-let [an (:action-name meta-map)]
                       [(symbol (str an "-action-fn"))])
                 [~session ~@args] ~@body) merge ~meta-map)]
       (vary-meta
        (fn [& [session# ~@args :as argv#]]
          (schedule-action
           session#
           f#
           (action-metadata session# f#)
           (rest argv#) ~execution ~action-type ~location))
        merge
        ~meta-map
        {::action-fn f#}))))
(defn action-fn
  "Retrieve the action-fn that is used to execute the specified action."
  [action]
  (::action-fn (meta action)))

Convenience action definers for common cases

(defmacro bash-action
  "Define a remotely executed bash action function."
  [[session & args] & body]
  `(action :in-sequence :script/bash :target [~session ~@args] ~@body))
(defmacro clj-action
  "Define a clojure action to be executed on the origin machine."
  [[session & args] & body]
  `(action :in-sequence :fn/clojure :origin [~session ~@args] ~@body))
(defmacro aggregated-action
  "Define a remotely executed aggregated action function, which will
   be executed before :in-sequence actions."
  [[session & args] & body]
  `(action :aggregated :script/bash :target [~session ~@args] ~@body))
(defmacro collected-action
  "Define a remotely executed collected action function, which will
   be executed after :in-sequence actions."
  [[session & args] & body]
  `(action :collected :script/bash :target [~session ~@args] ~@body))
(defmacro as-clj-action
  "An adaptor for using a normal function as a local action function"
  ([f [session & args]]
     `(clj-action
       [~session ~@(map (comp symbol name) args)]
       (~f ~session ~@(map (comp symbol name) args))))
  ([f]
     `(as-clj-action
       ~f [~@(first (:arglists (meta (var-get (resolve f)))))])))
(defmacro def-action-def
  "Define a macro for definining action defining vars"
  [name actionfn1]
  `(defmacro ~name
     {:arglists '(~'[name [session & args] & body]
                  ~'[name [session & args] meta? & body])}
     [name# ~'& args#]
     (let [[name# args#] (ccdef/name-with-attributes name# args#)
           arglist# (first args#)
           body# (rest args#)
           [meta-map# body#] (if (and (map? (first body#))
                                        (> (count body#) 1))
                               [(merge
                                 {:action-name (name name#)} (first body#))
                                (rest body#)]
                               [{:action-name (name name#)} body#])
           name# (vary-meta
                  name#
                  #(merge
                    {:arglists (list 'quote (list arglist#))}
                    meta-map#
                    %))]
       `(def ~name# (~'~actionfn1 [~@arglist#] ~meta-map# ~@body#)))))
(def-action-def def-bash-action pallet.action/bash-action)
(def-action-def def-clj-action pallet.action/clj-action)
(def-action-def def-aggregated-action pallet.action/aggregated-action)
(def-action-def def-collected-action pallet.action/collected-action)
(defn enter-scope
  "Enter a new action scope."
  [session]
  (update-in session (action-plan/target-path session) action-plan/push-block))
(defn leave-scope
  "Leave the current action scope."
  [session]
  (update-in session (action-plan/target-path session) action-plan/pop-block))
 

An action plan contains actions for execution.

The action plan is built by executing a phase function. Each phase function calls actions which insert themselves into the action plan.

The action plan is transformed to provide aggregated operations, and to resolve precedence relations between actions.

A translated plan is executed by passing an executor, which is a map from action type to function. The executor functions are called with the result of evaluating the action with it's arguments.

(ns pallet.action-plan
  "An action plan contains actions for execution.
   The action plan is built by executing a phase function. Each phase function
   calls actions which insert themselves into the action plan.
   The action plan is transformed to provide aggregated operations, and to
   resolve precedence relations between actions.
   A translated plan is executed by passing an executor, which is a map
   from action type to function.  The executor functions are called with the
   result of evaluating the action with it's arguments."
  {:author "Hugo Duncan"}
  (:require
   [pallet.argument :as argument]
   [pallet.phase :as phase]
   [pallet.script :as script]
   [pallet.stevedore :as stevedore]
   [clojure.tools.logging :as logging]
   [clojure.set :as set]
   [clojure.string :as string]))

slingshot version compatibility

(try
  (use '[slingshot.slingshot :only [throw+]])
  (catch Exception _
    (use '[slingshot.core :only [throw+]])))

The action plan is a stack of actions, where the action could itself be a stack of actions (ie a tree of stacks)

(defn push-block
  "Push a block onto the action-plan"
  [action-plan]
  (conj (or action-plan '(nil nil)) nil))
(defn pop-block
  "Take the last block and add it to the scope below it in the stack.
   The block is reversed to put it into the order in which elements
   were added. Once pop'd, nothing should be added to the block."
  [action-plan]
  (let [block (peek action-plan)
        stack (pop action-plan)]
    (if-let [stem (next stack)]
      (conj stem (conj (first stack) (reverse block)))
      (if-let [stem (seq (first stack))]
        (conj stem (reverse block))
        (reverse block)))))
(defn add-action
  "Add an action to the plan"
  [action-plan action]
  (let [action-plan (or action-plan '(nil nil))
        block (peek action-plan)
        stack (pop action-plan)]
    (conj stack (conj block action))))

pallet specific action

(defn action-map
  "Return an action map for the given args. The action plan is a tree of
   action maps.
   precedence specifies naming and dependencies, with :action-id, :always-before
   and :always-after. If a precedence is supplied, an action-id is generated
   if none present, to ensure that the standard action precedence is not
   altered.
   - :f            the action function
   - :args         the arguments to pass to the action function
   - :location     where to execute the action - :orgin or :target
   - :action-type  the type of action - :script/bash, :fn/clojure, etc
   - :execution    the execution type - :in-sequence, :aggregated, :collected
   - :value        the result of calling the action function, :f, with :args
   - :session      the session map after calling the action function."
  [action-fn precedence args execution action-type location]
  (let [precedence (and precedence (seq precedence)
                        (update-in precedence [:action-id]
                                   #(or % (gensym "action-id"))))]
    (merge
     (select-keys (meta action-fn) [:action-id :always-after :always-before])
     precedence
     {:f action-fn
      :args args
      :location location
      :action-type action-type
      :execution execution})))

utilities

(defn- script-join
  "Concatenate multiple scripts, removing blank lines"
  [scripts]
  (str
   (->>
    scripts
    (map #(when % (string/trim %)))
    (filter (complement string/blank?))
    (string/join \newline))
   \newline))

transform functions for working with an action-plan containing action-maps with :nested-scope types

(defn- walk-action-plan
  "Traverses an action-plan structure.  leaf-fn is applied to leaf
   action, list-fn to sequences of actions, and nested-fn to
   a nested scope. nested-fn takes the existing nested scope and a transformed
   arg list"
  [leaf-fn list-fn nested-fn action-plan]
  (cond
   (sequential? action-plan) (list-fn
                              (map
                               #(walk-action-plan leaf-fn list-fn nested-fn %)
                               action-plan))
   (= :nested-scope (:action-type action-plan)) (nested-fn
                                                 action-plan
                                                 (walk-action-plan
                                                  leaf-fn list-fn nested-fn
                                                  (:args action-plan)))
   :else (leaf-fn action-plan)))

transform input nested scopes into action maps with :action-type of :nested-scope

(defn- scope-action
  "A scope combining action."
  [session & args]
  (script-join (map #((:f %) session) args)))
(defn- nested-scope-transform
  "Transform a nested scope into an action-map with :action-type :nested-scope"
  [x]
  {:pre [(sequential? x)]}
  {:f scope-action
   :args x
   :action-type :nested-scope
   :execution :in-sequence
   :location :target})
(defn transform-nested-scopes
  "Traverses an action-plan structure. Converting nested scopes into
   action-map's."
  [action-plan]
  (cond
   (sequential? action-plan) (nested-scope-transform
                              (vec (map transform-nested-scopes action-plan)))
   :else action-plan))
(defn- transform-scopes
  "Transforms nexted scopes into an action map."
  [action-plan]
  (map transform-nested-scopes action-plan))

transform executions

(defn- group-by-function
  "Transforms a seq of actions, generally some with identical :f values into a
   sequence of actions where the :args are the concatenation of all of the :args
   of associated with each :f in the original seq.  Sequence order from the
   original seq is retained. Keys over than :f and :args are assumed identical
   for a given :f value.
   e.g. (group-by-function
           [{:f :a :args [1 2]}
            {:f :b :args [3 4]}
            {:f :a :args [5 6]}
            {:f :c :args [7 8]]])
        => ({:f :a :args ([1 2] [5 6])}
            {:f :c :args ([7 8])}
            {:f :b :args ([3 4])})"
  [action-plan]
  (->>
   action-plan
   (group-by (juxt :f :action-id))
   (map (fn [[_ action-calls]]
          (reduce
           #(update-in %1 [:args] conj (:args %2))
           (assoc (first action-calls) :args [])
           action-calls)))))
(def ^{:doc "Execution specifc transforms" :private true}
  execution-transforms
  {:aggregated [group-by-function]
   :collected [group-by-function]})
(def ^{:private true} execution-ordering [:aggregated :in-sequence :collected])
(defn- transform-execution
  "Transform an execution by applying execution-transforms."
  [execution action-plan]
  (if-let [transforms (execution-transforms execution)]
    (reduce #(%2 %1) action-plan transforms)
    action-plan))
(defn- transform-scope-executions
  "Sort an action plan scope into different executions, applying execution
   specific transforms."
  [action-plan]
  (let [executions (group-by :execution action-plan)]
    (mapcat
     #(transform-execution % (% executions))
     execution-ordering)))
(defn- transform-executions
  "Sort an action plan into different executions, applying execution specific
   transforms."
  [action-plan]
  (walk-action-plan
   identity
   transform-scope-executions
   #(assoc %1 :args %2)
   action-plan))

enforce declared precedence rules

(defn- symbol-action-fn
  "Lookup the action-fn from a symbol"
  [sym]
  (if-let [v (find-var sym)]
    (-> v var-get meta :pallet.action/action-fn)))
(defn collect-action-id
  "Extract an action's id to function mapping"
  [m action]
  (if-let [id (:action-id action)]
    (assoc m id (:f action))
    m))
(defn merge-union
  "Merge-with clojure.set/union"
  [& m]
  (apply merge-with set/union m))
(defn action-dependencies
  "Extract an action's dependencies.  Actions are id'd with keywords,
   and dependencies are declared on an action's id or function."
  [action-id-map action]
  (let [as-set (fn [x] (if (or (nil? x) (set? x)) x #{x}))
        before (as-set (:always-before action))
        after (as-set (:always-after action))
        self-id (select-keys action [:action-id :f])]
    (reduce
     (fn [m [id deps]] (update-in m [id] #(conj (or % #{}) deps)))
     {}
     (concat
      ;; before symbol
      (map
       #(vector {:f %} self-id)
       (map symbol-action-fn (filter symbol? before)))
      ;; before id
      (map
       #(vector {:action-id % :f (action-id-map %)} self-id)
       (filter keyword? before))
      ;; after symbol
      (map
       #(vector self-id {:f %})
       (map symbol-action-fn (filter symbol? after)))
      ;; after id
      (map
       #(vector self-id {:action-id % :f (action-id-map %)})
       (filter keyword? after))))))
(defn action-instances
  "Given a map of dependencies, each with an :f and maybe a :action-id,
   returns a map where the values are all matching action instances"
  [actions dependencies]
  (let [action-id-maps (reduce set/union (vals dependencies))]
    (reduce
     (fn [instances instance]
       (let [id (select-keys instance [:f :action-id])]
         (if (action-id-maps id)
           (update-in instances [id] #(conj (or % #{}) instance))
           instances)))
     {}
     actions)))
(defn action-scope-dependencies
  [actions]
  (let [action-id-map (reduce collect-action-id {} actions)
        dependencies (reduce
                      #(merge-union %1 (action-dependencies action-id-map %2))
                      {} actions)
        instances (action-instances actions dependencies)
        dependents (zipmap (keys dependencies)
                           (map
                            (fn [d] (set (mapcat instances d)))
                            (vals dependencies)))]
    [action-id-map dependencies instances dependents]))
(defn action-with-dependents
  [actions dependents seen action]
  {:pre [(vector? actions) (set? seen) (map? action)]}
  (if (seen action)
    [actions dependents seen]
    (let [ids (distinct [(select-keys action [:f :action-id])
                         (select-keys action [:f])])
          action-deps (mapcat dependents ids)]
      (let [[add-actions dependents seen]
            (reduce
             (fn add-a-w-d [[actions dependents seen] action]
               {:pre [(vector? actions) (set? seen) (map? action)]}
               (if (seen action)
                 [actions dependents seen]
                 (action-with-dependents actions dependents seen action)))
             [actions (reduce dissoc dependents ids) seen]
             action-deps)]
        [(conj add-actions action) dependents (conj seen action)]))))
(defn enforce-scope-dependencies
  [actions]
  (let [[action-id-map dependencies instances dependents]
        (action-scope-dependencies actions)]
    (first (reduce
            (fn add-as-w-d [[actions dependents seen] action]
              {:pre [(vector? actions) (set? seen) (map? action)]}
              (if (seen action)
                [actions dependents seen]
                (action-with-dependents actions dependents seen action)))
            [[] dependents #{}]
            actions))))
(defn- enforce-precedence
  "Enforce precedence relations between actions."
  [action-plan]
  (walk-action-plan
   identity
   enforce-scope-dependencies
   #(assoc %1 :args %2)
   action-plan))

convert nested-scopes to script functions

(defn- script-type-scope
  "Convert a scope to a single script function"
  [action-map]
  (if (= :nested-scope (:action-type action-map))
    (assoc action-map :action-type :script/bash :target)
    action-map))
(defn- script-type-scopes-in-scope
  "Reduce a nested scopes of a single scope to a compound action"
  [action-plan]
  (map script-type-scope action-plan))
(defn- script-type-scopes
  "Reduce nested scopes to a compound action"
  [action-plan]
  (walk-action-plan
   identity
   script-type-scopes-in-scope
   (fn [action _] action)
   action-plan))

Bind arguments

(defn- evaluate-args
  "Evaluate an argument sequence"
  [session args]
  (map (fn [arg] (when arg (argument/evaluate arg session))) args))
(defn- apply-action
  "Returns a function that applies args to the function f,
   evaluating the arguments."
  [f args]
  (fn [session]
    (apply f session (evaluate-args session args))))
(defn- apply-aggregated-action
  "Apply args-seq to the function f, evaluating each argument list in args-seq."
  [f args-seq]
  (fn [session]
    (f session (map #(evaluate-args session %) args-seq))))
(defmulti bind-action-arguments
  "Bind an action's arguments."
  (fn [{:keys [execution]}] execution))
(defmethod bind-action-arguments :in-sequence
  [{:keys [f args] :as action-map}]
  (->
   action-map
   (update-in [:f] apply-action args)
   (dissoc :args)))
(defmethod bind-action-arguments :aggregated
  [{:keys [f args] :as action-map}]
  (->
   action-map
   (update-in [:f] apply-aggregated-action args)
   (dissoc :args)))
(defmethod bind-action-arguments :collected
  [{:keys [f args] :as action-map}]
  (->
   action-map
   (update-in [:f] apply-aggregated-action args)
   (dissoc :args)))
(defn- bind-scope-arguments
  "Takes an action plan scope and binds each actions arguments"
  [action-plan]
  (map bind-action-arguments action-plan))
(defn- bind-arguments
  "Takes an action plan and binds each actions arguments"
  [action-plan]
  (walk-action-plan
   identity
   bind-scope-arguments
   #(assoc %1 :args %2)
   action-plan))

combine by location and action-type

(defmulti combine-actions
  "Combine actions by action-type"
  (fn [actions] (:action-type (first actions))))
(defmethod combine-actions :default
  [actions]
  (reduce
   (fn combine-actions-compose [combined action]
     (update-in combined [:f] #(comp (:f action) %)))
   actions))
(defmethod combine-actions :script/bash
  [actions]
  (assoc (first actions)
    :f (fn [session] (script-join (map #((:f %) session) actions)))))
(defmethod combine-actions :nested-scope
  [actions]
  (assoc (first actions)
    :f (fn [session] (script-join (map #((:f %) session) actions)))))
(defmethod combine-actions :transfer/to-local
  [actions]
  (assoc (first actions)
    :f (fn [session] (map #((:f %) session) actions))))
(defmethod combine-actions :transfer/from-local
  [actions]
  (assoc (first actions)
    :f (fn [session] (map #((:f %) session) actions))))
(defn- combine-scope-by-location-and-action-type
  "Combines the bound actions of a scope by location and action-type, producing
  compound actions"
  [action-plan]
  (->>
   action-plan
   (partition-by (juxt :location :action-type))
   (map combine-actions)))
(defn- combine-by-location-and-action-type
  "Combines bound actions by location and action-type, producing compound
  actions"
  [action-plan]
  (walk-action-plan
   identity
   combine-scope-by-location-and-action-type
   #(assoc %1 :args %2)
   action-plan))

augment return

(defmulti augment-return
  "Change the return type of an action, to be an action map with
   :value and :session keys that are the value of the action, and the updated
   session map for the next action.  This creates a consistent return value for
   all action types (effectively creating a monadic value which is a map)."
  (fn [{:keys [action-type] :as action}] action-type))
(defmethod augment-return :default
  [{:keys [f] :as action}]
  (assoc action
    :f (fn [session]
         (assoc action
           :session session
           :value (f session)))))
(defmethod augment-return :fn/clojure
  [{:keys [f] :as action}]
  (assoc action
    :f (fn [session]
         (let [session (f session)]
           (assoc action
             :session session
             :value session)))))
(defn- augment-scope-return-values
  "Augment the return values of each action in a scope."
  [action-plan]
  (map augment-return action-plan))
(defn- augment-return-values
  "Augment the return values of each action."
  [action-plan]
  (walk-action-plan
   identity
   augment-scope-return-values
   #(assoc %1 :args %2)
   action-plan))

translate action plan

(defn translate
  "Process the action-plan, applying groupings and precedence, producing
   an action plan with fully bound functions, ready for execution.
   This is equivalent to using an identity monad with a monadic value
   that is a tree of action maps."
  [action-plan]
  (->
   action-plan
   pop-block ;; pop the default block
   transform-scopes
   transform-executions
   enforce-precedence
   bind-arguments
   combine-by-location-and-action-type
   script-type-scopes
   augment-return-values))

execute action plan

(defn translated?
  "Predicate to test if an action plan has been translated"
  [action-plan]
  (not (and (= 2 (count action-plan))
            (list? (first action-plan))
            (nil? (second action-plan)))))
(defn execute-action
  "Execute a single action"
  [executor session {:keys [f action-type location] :as action}]
  (try
    (executor session f action-type location)
    (catch Exception e
      [{:error {:message (format "Unexpected exception: %s" (.getMessage e))
                :type :pallet/action-execution-error
                :cause e}}
       session])))
(defn execute
  "Execute actions by passing the un-evaluated actions to the `executor`
   function (a function with an arglist of [session f action-type location])."
  [action-plan session executor execute-status-fn]
  (logging/tracef "execute %s actions" (count action-plan))
  (when-not (translated? action-plan)
    (throw+
     {:type :pallet/execute-called-on-untranslated-action-plan
      :message "Attempt to execute an untranslated action plan"}))
  (reduce
   (fn [[results session flag] action]
     (case flag
       :continue (let [[result session] (execute-action
                                         executor session action)]
                   [(conj results result)
                    session
                    (execute-status-fn result flag)])
       [results session flag]))
   [[] session :continue]
   action-plan))

Target specific functions

(defn- target-path*
  "Return the vector path of the action plan for the specified phase an
  target-id."
  [phase target-id]
  [:action-plan phase target-id])
(defn target-path
  "Return the vector path of the action plan for the current session target
   node, or target group."
  [session]
  {:pre [(keyword? (:phase session))
         (keyword? (:target-id session))]}
  (target-path* (:phase session) (-> session :target-id)))
(defn script-template-for-server
  "Return the script template for the specified server."
  [server]
  (let [family (-> server :image :os-family)]
    (filter identity
            [family
             (:packager server)
             (when-let [version (-> server :image :os-version)]
               (keyword (format "%s-%s" (name family) version)))])))
(defn script-template
  "Return the script template for the current group node."
  [session]
  (when-let [server (:server session)]
    (script-template-for-server server)))

action plan functions based on session

(defn reset-for-target
  "Reset the action plan for the current phase and target."
  [session]
  {:pre [(:phase session) (:target-id session)]}
  (reduce
   #(assoc-in %1 (target-path* %2 (-> session :target-id)) nil)
   session
   (phase/all-phases-for-phase (:phase session))))
(defn phase-for-target
  "Return the phase for the target"
  [session]
  (let [phase (:phase session)]
    (or
     (phase (-> session :server :phases))
     (phase (:inline-phases session))
     (phase (-> session :group :phases)))))
(defn build-for-target
  "Create the action plan by calling the current phase for the target group."
  [session]
  {:pre [(:phase session)]}
  (if-let [f (phase-for-target session)]
    (script/with-script-context (script-template session)
      (stevedore/with-script-language :pallet.stevedore.bash/bash
        (logging/tracef "build-for-target building phase")
        (f (reset-for-target session))))
    session))
(defn get-for-target
  "Get the action plan for the current phase and target node."
  [session]
  (get-in session (target-path session)))
(defn translate-for-target
  "Build the action plan and translate for the current phase and target node."
  [session]
  {:pre [(:phase session)]}
  (update-in session (target-path session) translate))
(defn execute-for-target
  "Execute the translated action plan for the current target."
  [session executor execute-status-fn]
  {:pre [(:phase session)]}
  (logging/tracef "execute-for-target")
  (script/with-script-context (script-template session)
    (stevedore/with-script-language :pallet.stevedore.bash/bash
      (execute
       (get-in session (target-path session))
       session executor execute-status-fn))))
 

Arguments to actions. Adds capability of evaluating arguments at action application

(ns pallet.argument)
(defprotocol DelayedArgument
  "A protocol for passing arguments, with delayed evaluation."
  (evaluate [x session]))

By default, arguments should evaluate to themeselves

(extend-type
 Object
 DelayedArgument
 (evaluate [x session] x))
(deftype DelayedFunction
  [f]
  DelayedArgument
  (evaluate [_ session] (f session)))
(defn delayed-fn
  "Pass a function with a single argument, to be used to compute an argument at
   action application time."
  [f]
  (DelayedFunction. f))
(defmacro delayed
  "Pass an argument to be evaluated at action application time."
  [[session-sym] & body]
  `(DelayedFunction. (fn [~session-sym] ~@body)))
 

Implementation details

(ns pallet.blobstore.implementation
  (:require
   [pallet.utils :as utils])
  (:use
   [chiba.plugin :only [plugins]]))
(defmulti service
  "Instantiate a blobstore. Providers should implement a method for this.
   See pallet.blobstore/blobstore-service."
  (fn [provider-name & _] (keyword provider-name)))
(def blobstore-prefix "pallet.blobstore.")
(def exclude-blobstore-ns
  #{'pallet.blobstore.implementation})
(def exclude-regex #".*test.*")
(def provider-list (atom nil))
(defn- providers
  "Find the available providers."
  []
  (->> (plugins blobstore-prefix exclude-regex)
       (remove exclude-blobstore-ns)))
(defn load-providers
  "Require all providers, ensuring no errors if individual providers can not be
   loaded"
  []
  (when-not @provider-list
    (reset! provider-list (providers))
    (let [loaded (filter
                  identity
                  (doall
                   (for [provider @provider-list]
                     (try
                       (require provider)
                       provider
                       (catch Throwable _)))))]
      (reset! provider-list loaded)))
  @provider-list)
(defn supported-providers
  "Create a list of supported providers"
  []
  (->>
   (doall
    (for [provider (load-providers)]
      (when-let [providers (ns-resolve provider 'supported-providers)]
        (@providers))))
   (filter identity)
   (apply concat)))
 

A url based blobstore implementation.

(ns pallet.blobstore.url-blobstore
  (:require
   [pallet.blobstore :as blobstore]
   [pallet.blobstore.implementation :as implementation]))
(defrecord UrlBlobstore
    [base-url]
  pallet.blobstore/Blobstore
  (sign-blob-request
   [blobstore container path request-map]
   {:endpoint (format "%s/%s/%s" base-url container path)
    :headers nil})
  (close
   [blobstore]))
(defmethod implementation/service :url-blobstore
  [provider {:keys [base-url]
             :or {base-url "http://localhost"}}]
  (UrlBlobstore. base-url))
 

Blobstore abstraction

(ns pallet.blobstore
  (:require
   [pallet.blobstore.implementation :as implementation]
   [pallet.utils :as utils]))

Blobstore service instantiation

(defn service
  "Instantiate a blobstore service based on the given arguments"
  [provider-name
   & {:keys [identity credential extensions] :as options}]
  (implementation/load-providers)
  (implementation/service provider-name options))
(defprotocol Blobstore
  (sign-blob-request
   [blobstore container path request-map]
   "Create a signed request")
  (put
   [blobstore container path payload]
   "Upload a file, string, input stream, etc")
  (put-file
   [blobstore container path file]
   "Upload a file")
  (containers
   [blobstore]
   "List containers")
  (close
   [blobstore]
   "Close the blobstore"))

Add deprecated forwarding functions blobstore-from-map blobstore-from-config blobstore-from-config-file

(utils/fwd-to-configure blobstore-from-map)
(utils/fwd-to-configure blobstore-from-config)
(utils/fwd-to-configure blobstore-from-config-file)
 

Taken from clojure.contrib

Process command-line arguments according to a given cmdspec

(ns #^{:author "Chris Houser"}
    pallet.command-line
  (:refer-clojure :exclude [group-by]))
(defn #^String join
  "Returns a string of all elements in coll, separated by
  separator.  Like Perl's join."
  [#^String separator coll]
  (apply str (interpose separator coll)))
(defn group-by ;; in clojure 1.2 core
  "Returns a sorted map of the elements of coll keyed by the result of
  f on each element. The value at each key will be a vector of the
  corresponding elements, in the order they appeared in coll."
  [f coll]
  (reduce
   (fn [ret x]
     (let [k (f x)]
       (assoc ret k (conj (get ret k []) x))))
   (sorted-map) coll))
(defn make-map [args cmdspec]
  (let [{spec true [rest-sym] false} (group-by vector? cmdspec)
        rest-str (str rest-sym)
        key-data (into {} (for [[syms [_ default]] (map #(split-with symbol? %)
                                                        (conj spec '[help? h?]))
                                sym syms]
                            [(re-find #"^.*[^?]" (str sym))
                             {:sym (str (first syms)) :default default}]))
        defaults (into {} (for [[_ {:keys [default sym]}] key-data
                                :when default]
                            [sym default]))]
    (loop [[argkey & [argval :as r]] args
           cmdmap (assoc defaults :cmdspec cmdspec rest-str [])]
      (if argkey
        (let [[_ & [keybase]] (re-find #"^--?(.*)" argkey)]
          (cond
            (= keybase nil) (recur r (update-in cmdmap [rest-str] conj argkey))
            (= keybase )  (update-in cmdmap [rest-str] #(apply conj % r))
            :else (if-let [found (key-data keybase)]
                    (if (= \? (last (:sym found)))
                      (recur r (assoc cmdmap (:sym found) true))
                      (recur (next r) (assoc cmdmap (:sym found)
                                             (if (or (nil? r) (= \- (ffirst r)))
                                               (:default found)
                                               (first r)))))
                    (throw (Exception. (str "Unknown option " argkey))))))
        cmdmap))))
(defn- align
   "Align strings given as vectors of columns, with first vector
   specifying right or left alignment (:r or :l) for each column."
   [spec & rows]
   (let [maxes (vec (for [n (range (count (first rows)))]
                      (apply max (map (comp count #(nth % n)) rows))))
         fmt (join " "
                   (for [n (range (count maxes))]
                     (str "%"
                          (when-not (zero? (maxes n))
                            (str (when (= (spec n) :l) "-") (maxes n)))
                          "s")))]
     (join "\n"
           (for [row rows]
             (apply format fmt row)))))
(defn- rmv-q
   "Remove ?"
   [#^String s]
   (if (.endsWith s "?")
      (.substring s 0 (dec (count s)))
      s))
(defn print-help [desc cmdmap]
  (println desc)
  (println "Options")
  (println
     (apply align [:l :l :l]
        (for [spec (:cmdspec cmdmap) :when (vector? spec)]
            (let [[argnames [text default]] (split-with symbol? spec)
                  [_ opt q] (re-find #"^(.*[^?])(\??)$"
                                 (str (first argnames)))
                  argnames  (map (comp rmv-q str) argnames)
                  argnames
                        (join ", "
                          (for [arg argnames]
                            (if (= 1 (count arg))
                              (str "-" arg)
                              (str "--" arg))))]
               [(str "  " argnames (when (=  q) " <arg>") " ")
                text
                (if-not default
                  (str " [default " default "]"))])))))
(defmacro with-command-line
  "Bind locals to command-line args."
  [args desc cmdspec & body]
  (let [locals (vec (for [spec cmdspec]
                      (if (vector? spec)
                        (first spec)
                        spec)))]
    `(let [{:strs ~locals :as cmdmap#} (make-map ~args '~cmdspec)]
       (if (cmdmap# "help?")
         (print-help ~desc cmdmap#)
         (do ~@body)))))
(comment

; example of usage:

(with-command-line *command-line-args*
  "tojs -- Compile ClojureScript to JavaScript"
  [[simple? s? "Runs some simple built-in tests"]
   [serve      "Starts a repl server on the given port" 8081]
   [mkboot?    "Generates a boot.js file"]
   [verbose? v? "Includes extra fn names and comments in js"]
   filenames]
  (binding [*debug-fn-names* verbose? *debug-comments* verbose?]
    (cond
      simple? (simple-tests)
      serve   (start-server (Integer/parseInt serve))
      mkboot? (mkboot)
      :else   (doseq [filename filenames]
                 (filetojs filename)))))

)
 

Produce a shell script for launching Pallet, possibly customised for extra jars

(ns pallet.command-script
  (:require
   [pallet.stevedore :as stevedore]
   [pallet.action.user :as user]))
(defn path
  [components]
  (apply str (interpose "/" components)))
(defn normalize-scriptname
  "normalize $0 on certain BSDs"
  []
  (stevedore/script
   (if (= @(dirname $0) ".")
     (defvar SCRIPT "$(which $(basename $0))")
     (defvar SCRIPT "$0"))))
(defn resolve-symlinks
  "resolve symlinks to the script itself portably"
  []
  (stevedore/script
   (while (symlink? @SCRIPT)
          (defvar ls @(ls -ld (quoted @SCRIPT)))
          (defvar link @(expr (quoted @ls) ":" "'.*-> \\(.*\\)$'"))
          (if (expr (quoted @link) ":" "'/.*'" > "/dev/null")
            (defvar SCRIPT (quoted @link))
            (defvar SCRIPT (quoted (str @(dirname @SCRIPT) "/" @link)))))
   (defvar BIN_DIR (quoted @(dirname (quoted @SCRIPT))))))
(defn http-client
  "Script to set HTTP client options."
  []
  (stevedore/script
   (defvar HTTP_CLIENT (quoted "wget "))
   (defvar HTTP_OUTFILE (quoted "-O "))
   (defvar HTTP_STDOUT (quoted "-q -O - "))
   (if (type -p curl ">/dev/null 2>&1")
     (do
       (defvar HTTP_CLIENT (quoted "curl -L "))
       (defvar HTTP_OUTFILE (quoted "-o "))
       (defvar HTTP_STDOUT (quoted ))))))
(defn defn-snapshot-path
  [artifacts]
  (stevedore/script
   (defn snapshot-path [version metafile base_path]
     (defvar METADATA
       @(@HTTP_CLIENT @HTTP_STDOUT @metafile))
     (defvar JARDATE
       @(pipe
         (echo @META)
         (egrep (quoted "[0-9]{8}\\.[0-9]{6}") -o)))
     (defvar JARBUILD
       @(pipe
         (echo @META)
         (fgrep "buildNumber")
         (egrep (quoted "[0-9]+") -o)))
     (defvar JARVERSION
       ~(.replace (:version (first artifacts)) "-SNAPSHOT" ))
     (println (str @base_path @JARVERSION "-" @JARDATE "-" @JARBUILD ".jar")))))
(defprotocol Artifact
  (local-path [x] "Local path for installing the artifact")
  (remote-path [x] "Remote path for downloading the artifact")
  (jar-name [x] "jar name for the artifact"))
(defrecord MavenArtifact
  [group-id artifact-id version repository]
  Artifact
  (local-path
   [artifact]
   (path [(stevedore/script @repo) (.replace group-id "." "/") artifact-id version
          (jar-name artifact)]))
  (remote-path
   [artifact]
   (if (.contains version "SNAPSHOT")
     (let [metafile (path [repository (.replace group-id "." "/") artifact-id version
                           "maven-metadata.xml"])]
       (stevedore/script
        @(snapshot-path
          ~version
          ~metafile
          ~(path [repository group-id (.replace group-id "." "/") version
                  (str artifact-id "-")]))))
     (path [repository (.replace group-id "." "/") artifact-id version
            (jar-name artifact)])))
  (jar-name
   [_]
   (str artifact-id "-" version ".jar")))
(defn m2-repository-path
  "Return a script fragment setting $repo to the local maven repository path"
  []
  (stevedore/script
   (defvar settings (str @HOME "/.m2/settings.xml"))
   (defvar default_repo (str @HOME "/.m2/repository"))
   (if (file-exists? @settings)
     (do
       (defvar repo
         @(chain-or
           (group
            (pipe
             (cat @settings)
             (tr -d "'\n\t '")
             (egrep -o (quoted "<localRepository>(.*)</localRepository>"))
             (sed -e (quoted "s%\\${user.home}%${HOME}%")
                  -e (quoted "s%<localRepository>%%")
                  -e (quoted "s%</localRepository>%%"))))
           (println @default_repo)))
       (if (= @repo )
         (defvar repo @default_repo)))
     (defvar repo (str @user-home "/.m2/repository")))))
(defn download-artifact
  [artifact]
  (stevedore/script
   (@HTTP_CLIENT $HTTP_OUTFILE
                 (quoted ~(local-path artifact))
                 (quoted ~(remote-path artifact)))))
(defn defn-download
  "Produces a function to unconditionaly download artifacts"
  [artifacts]
  (stevedore/script
   (defn do-download []
     ~(apply stevedore/checked-commands
       "Downloading dependencies"
       (map download-artifact artifacts)))))
(defn defn-install
  []
  (stevedore/script
   (defn do-install []
     (do-download)
     (exit 0))))
(defn defn-upgrade
  [artifacts]
  (stevedore/script
   (defn do-upgrade []
     (if-not (writeable? $SCRIPT)
       (do
         (println "You do not have permission to upgrade the installation in "
                  @SCRIPT)
         (exit 1)))
     (echo
      "The script at " @SCRIPT " will be upgraded to the latest stable version.")
     (echo -n "Do you want to continue [Y/n]? ")
     (read RESPONSE)
     (case @RESPONSE
         "y|Y|\"\ (do
                      (println)
                      (println "Upgrading...")
                      (defvar BRANCH
                        ~(if (.contains (:version (first artifacts)) "SNAPSHOT")
                           "master"
                           "stable"))
                      (defvar PALLET_SCRIPT_URL
                        (quoted
                         (str "http://github.com/hugoduncan/pallet/raw/"
                              @BRANCH
                              "/bin/pallet")))
                      (chain-and
                       (@HTTP_CLIENT
                        $HTTP_OUTFILE
                        (quoted @SCRIPT) (quoted @PALLET_SCRIPT_URL))
                       ("chmod" +x (quoted @SCRIPT))
                       (println)
                       (@SCRIPT self-install)
                       (println)
                       (println "Now running" @(@SCRIPT version)))
                      (exit "$?"))
         * (do
             (println "Aborted")
             (exit 1))))))
(defn run-from-checkout
  []
  (stevedore/script
   (defvar PALLET_DIR
     (quoted @(dirname (quoted @BIN_DIR))))
   (defvar PALLET_LIBS
     (quoted
      @(pipe
        (find -H (str @PALLET_DIR "/lib") -mindepth 1 -maxdepth 1 -print0
              "2> /dev/null")
        (tr "\\\\0" "\\:"))))
   (defvar CLASSPATH
     (quoted (str (str @PALLET_DIR "/src") ":" (str @PALLET_DIR "/pallet/src") ":" @PALLET_LIBS ":" @CLASSPATH)))
   (defvar BOOTPATH (quoted ))
   (if (&& (= @PALLET_LIBS ) (!= "$1" "self-install" ))
     (do
       (println "Your Pallet development checkout is missing its dependencies.")
       (println "Please use you maven or lein to download the dependencies.")
       (println (quoted "   cd " @PALLET_DIR))
       (println (quoted " and either:"))
       (println (quoted "   lein deps"))
       (println (quoted "   mvn -Dmaven.test.skip=true assembly:directory"))
       (exit 1)))))

We want to run from the first of: nested pallet project current project mvn repo

(defn run-from-jar
  [artifacts]
  (stevedore/script
   (if (readable? (str "./pallet/lib/" ~(jar-name (first artifacts)) ))
     (do
       (defvar PALLET_LIBS
         (quoted
          @(pipe
            (find -H "./pallet/lib/" -mindepth 1 -maxdepth 1 -print0
                  "2> /dev/null")
            (tr "\\\\0" "\\:"))))
       (defvar CLASSPATH
         (quoted (str @PALLET_LIBS ":./pallet/src/:" @CLASSPATH)))
       (defvar BOOTPATH (quoted )))
     (if (readable? (str "./lib/" ~(jar-name (first artifacts)) ))
       (do
         (defvar PALLET_LIBS
         (quoted
          @(pipe
            (find -H "./lib/" -mindepth 1 -maxdepth 1 -print0 "2> /dev/null")
            (tr "\\\\0" "\\:"))))
         (defvar CLASSPATH
           (quoted (str @PALLET_LIBS ":./pallet/src/:" @CLASSPATH)))
         (defvar BOOTPATH (quoted )))
       (do
         (defvar CLASSPATH
           (quoted
            (str
             ~(apply
               str (interpose ":" (map local-path artifacts)))
             ":" @CLASSPATH))))))
   (defvar BOOTPATH (quoted ))))
(defn paths-for-cygwin
  []
  (stevedore/script
   (when (type -p cygpath ">/dev/null 2>&1")
     (defvar CLOJURE_JAR
       @(cygpath -w (quoted @CLOJURE_JAR)))
     (defvar CLASSPATH
       @(cygpath -w (quoted @CLASSPATH))))))
(defn process-commands
  [artifacts]
  (stevedore/script
   (if (= "$1" "self-install")
     (do-install))
   (if (= "$1" "upgrade")
     (do-upgrade))
   (if (readable? (str @BIN_DIR "/../src/pallet/core.clj"))
     (do ~(run-from-checkout))
     (do ~(run-from-jar artifacts)))
   ~(paths-for-cygwin)
   (if "[ $DEBUG ]"
     (println @CLASSPATH))
   (exec
    @RLWRAP
    java -client @JAVA_OPTS -cp (quoted @CLASSPATH)
    (str "-Dpallet.version=" ~(:version (first artifacts)))
    @JLINE
    clojure.main -e (quoted "(use 'pallet.main)(-main)")
    "/dev/null"
    "$@")))
(defn command-script
  [pallet-version artifacts]
  (stevedore/do-script
   "#!/usr/bin/env bash"
   (normalize-scriptname)
   (resolve-symlinks)
   (http-client)
   (m2-repository-path)
   (defn-snapshot-path artifacts)
   (defn-download artifacts)
   (defn-upgrade artifacts)
   (defn-install)
   (process-commands artifacts)))
(def clojars-repo "http://clojars.org/repo")
(def clojure-release-repo "http://build.clojure.org/releases/")
(def clojure-snapshot-repo "http://build.clojure.org/snapshots")
(defn write-script
  []
  (println
   (command-script
    "0.0.1-SNAPSHOT"
    [(MavenArtifact. "pallet" "pallet" "0.0.1-SNAPSHOT" clojars-repo)
     (MavenArtifact. "org.clojure" "clojure" "1.2.0-master-SNAPSHOT"
                     clojure-snapshot-repo)])))
 

Hybrid provider service implementation.

(ns pallet.compute.hybrid
  (:require
   [pallet.compute.implementation :as implementation]
   [pallet.configure :as configure]
   [pallet.node :as node]
   [pallet.environment :as environment]
   [clojure.tools.logging :as logging]))
(defn supported-providers []
  ["hybrid"])
(defn- services
  "Return the service objects from the service map"
  [service-map]
  (vals service-map))
(deftype HybridService
    [service-map dispatch environment]
  pallet.compute/ComputeService
  (nodes [compute]
    (mapcat pallet.compute/nodes (services service-map)))
  (run-nodes [compute group-spec node-count user init-script options]
    (pallet.compute/run-nodes
     (dispatch service-map group-spec)
     group-spec node-count user init-script options))
  (reboot [compute nodes]
    (doseq [node nodes]
      (pallet.compute/reboot (node/compute-service node) node)))
  (boot-if-down [compute nodes]
    (doseq [node nodes]
      (pallet.compute/boot-if-down (node/compute-service node) node)))
  (shutdown-node [compute node user]
    (pallet.compute/shutdown-node (node/compute-service node) node user))
  (shutdown [compute nodes user]
    (doseq [node nodes]
      (pallet.compute/shutdown-node (node/compute-service node) node user)))
  (ensure-os-family [compute group-spec]
    (pallet.compute/ensure-os-family
     (dispatch service-map group-spec)
     group-spec))
  (destroy-nodes-in-group [compute group-name]
    (pallet.compute/destroy-nodes-in-group
     (dispatch service-map (name group-name))
     group-name))
  (destroy-node [compute node]
    (pallet.compute/destroy-node (node/compute-service node) node))
  (images [compute] (mapcat pallet.compute/images (services service-map)))
  (close [compute] (mapcat pallet.compute/close (services service-map)))
  pallet.environment.Environment
  (environment [_]
    (apply merge (conj (map pallet.environment/environment
                                     (vals service-map))
                                environment))))
(defn ensure-service-dispatch
  [f]
  (fn [service-map group-spec]
    (service-map
     (or
      (f group-spec)
      (throw
       (RuntimeException.
        (str "No dispatch for group " group-spec)))))))
(defn group-dispatcher
  "Return a dispatch function based on a map from service to groups."
  [groups-for-services]
  (let [g->s (into {} (apply concat
                             (for [[service groups] groups-for-services]
                               (map #(vector % service) groups))))]
    (logging/infof "Hybrid dispatch function: %s" g->s)
    (fn group-dispatch-fn
      [spec-or-name]
      (if (string? spec-or-name)
        (g->s (keyword spec-or-name))
        (g->s (:group-name spec-or-name))))))

service factory implementation for hybrid provider

(defn compute-provider-from-definition [definition]
  (if (map? definition)
    (configure/compute-service-from-map definition)
    definition))
(defmethod implementation/service :hybrid
  [provider {:keys [sub-services
                    groups-for-services
                    service-dispatcher
                    environment]
             :as options}]
  (let [service-map
        (if (map? sub-services)
          (zipmap (keys sub-services)
                  (map compute-provider-from-definition (vals sub-services)))
          (into {} (map #(vector % (configure/compute-service %)) sub-services)))]
    (logging/infof "sub-services for hybrid provider: %s" service-map)
    (logging/debugf "groups-for-services map: %s" groups-for-services)
    (HybridService.
     service-map
     (or (and
          service-dispatcher
          (ensure-service-dispatch service-dispatcher))
         (and
          groups-for-services
          (ensure-service-dispatch (group-dispatcher groups-for-services))))
     environment)))
 

Implementation details

(ns pallet.compute.implementation
  (:require
   [pallet.utils :as utils]
   [clojure.tools.logging :as logging])
  (:use
   [chiba.plugin :only [plugins]]))
(defmulti service
  "Instantiate a compute service. Providers should implement a method for this.
   See pallet.compute/compute-service."
  (fn [provider-name & _] (keyword provider-name)))
(def compute-prefix "pallet.compute")
(def exclude-compute-ns
  #{'pallet.compute.jvm
    'pallet.compute.implementation})
(def exclude-regex #".*test.*")
(def provider-list (atom nil))
(defn- providers
  "Find the available providers."
  []
  (->> (plugins compute-prefix exclude-regex)
       (remove exclude-compute-ns)))
(defn load-providers
  "Require all providers, ensuring no errors if individual providers can not be
   loaded"
  []
  (when-not @provider-list
    (reset! provider-list (providers))
    (let [loaded (filter
                  identity
                  (doall
                   (for [provider @provider-list]
                     (try
                       (require provider)
                       provider
                       (catch Throwable e
                         (logging/warnf
                          "%s provider failed to load: %s"
                          provider
                          (.getMessage e)))))))]
      (reset! provider-list loaded)))
  @provider-list)
(defn supported-providers
  "Create a list of supported providers"
  []
  (->>
   (doall
    (for [provider (load-providers)]
      (when-let [providers (ns-resolve provider 'supported-providers)]
        (@providers))))
   (filter identity)
   (apply concat)))
 

Information from local jvm

(ns pallet.compute.jvm)
(def jvm-os-map
  {"Mac OS X" :os-x})
(defn os-name []
  (System/getProperty "os.name"))
(defn os-family []
  (or (jvm-os-map (os-name)) :ubuntu))
(defn log4j?
 "Predicate to test for log4j on the classpath."
  []
  (try
    (import org.apache.log4j.Logger)
    true
    (catch java.lang.ClassNotFoundException _
      false)))
(defn slf4j?
 "Predicate to test for slf4j on the classpath."
  []
  (try
    (import org.slf4j.LoggerFactory)
    true
    (catch java.lang.ClassNotFoundException _
      false)))
 

A simple node list provider.

The node-list provider enables pallet to work with a server rack or existing virtual machines. It works by maintaining a list of nodes. Each node minimally provides an IP address, a host name, a group name and an operating system. Nodes are constructed using make-node.

An instance of the node-list provider can be built using node-list-service.

   (node-list-service
     [["host1" "fullstack" "192.168.1.101" :ubuntu]
      ["host2" "fullstack" "192.168.1.102" :ubuntu]])
(ns pallet.compute.node-list
  "A simple node list provider.
   The node-list provider enables pallet to work with a server rack or existing
   virtual machines. It works by maintaining a list of nodes. Each node
   minimally provides an IP address, a host name, a group name and an operating
   system. Nodes are constructed using `make-node`.
   An instance of the node-list provider can be built using
   `node-list-service`.
       (node-list-service
         [[\"host1\" \"fullstack\" \"192.168.1.101\" :ubuntu]
          [\"host2\" \"fullstack\" \"192.168.1.102\" :ubuntu]])"
  (:require
   [pallet.compute :as compute]
   [pallet.compute.jvm :as jvm]
   [pallet.compute.implementation :as implementation]
   [pallet.environment :as environment]
   [pallet.node :as node]
   [clojure.string :as string])
  (:use
   [pallet.utils :only [apply-map]]))

slingshot version compatibility

(try
  (use '[slingshot.slingshot :only [throw+]])
  (catch Exception _
    (use '[slingshot.core :only [throw+]])))
(defrecord Node
    [name group-name ip os-family os-version id ssh-port private-ip is-64bit
     running service]
  pallet.node.Node
  (ssh-port [node] ssh-port)
  (primary-ip [node] ip)
  (private-ip [node] private-ip)
  (is-64bit? [node] (:is-64bit node))
  (group-name [node] group-name)
  (running? [node] running)
  (terminated? [node] (not running))
  (os-family [node] os-family)
  (os-version [node] os-version)
  (hostname [node] name)
  (id [node] id)
  (compute-service [node] service))

Node utilities

(defn make-node
  "Returns a node, suitable for use in a node-list."
  [name group-name ip os-family
   & {:keys [id ssh-port private-ip is-64bit running os-version service]
      :or {ssh-port 22 is-64bit true running true service (atom nil)}}]
  (Node.
   name
   group-name
   ip
   os-family
   os-version
   (or id (str name "-" (string/replace ip #"\." "-")))
   ssh-port
   private-ip
   is-64bit
   running
   service))
(deftype NodeList
    [node-list environment]
  pallet.compute.ComputeService
  (nodes [compute-service] @node-list)
  (ensure-os-family
    [compute-service group-spec]
    (when (not (-> group-spec :image :os-family))
      (throw+
       {:type :no-os-family-specified
        :message "Node list contains a node without os-family"})))
  ;; Not implemented
  ;; (run-nodes [node-type node-count request init-script options])
  ;; (reboot "Reboot the specified nodes")
  (boot-if-down [compute nodes] nil)
  ;; (shutdown-node "Shutdown a node.")
  ;; (shutdown "Shutdown specified nodes")
  ;; this forgets about the nodes
  (destroy-nodes-in-group [_ group]
    (swap! node-list (fn [nl] (remove #(= (node/group-name %) group) nl))))
  (close [compute])
  pallet.environment.Environment
  (environment [_] environment))
(defmethod clojure.core/print-method Node
  [^Node node writer]
  (.write
   writer
   (format
    "%14s\t %s %s public: %s  private: %s  %s"
    (:group-name node)
    (:os-family node)
    (:running node)
    (:ip node)
    (:private-ip node)
    (:id node))))
(defn make-localhost-node
  "Make a node representing the local host. This calls `make-node` with values
   inferred for the local host. Takes options as for `make-node`.
       :name \"localhost\"
       :group-name \"local\"
       :ip \"127.0.0.1\"
       :os-family (pallet.compute.jvm/os-family)"
  [& {:keys [name group-name ip os-family id]
      :or {name "localhost"
           group-name "local"
           ip "127.0.0.1"
           os-family (jvm/os-family)}
      :as options}]
  (apply
   make-node name group-name ip os-family
   (apply concat (merge {:id "localhost"} options))))

Compute Service SPI

(defn supported-providers
  {:no-doc true
   :doc "Returns a sequence of providers that are supported"}
  [] ["node-list"])
(defmethod implementation/service :node-list
  [_ {:keys [node-list environment]}]
  (let [nodes (atom (vec
                     (map
                      #(if (vector? %)
                         (apply make-node %)
                         %)
                      node-list)))
        nodelist (NodeList. nodes environment)]
    (swap! nodes
           #(map
             (fn [node]
               (reset! (node/compute-service node) nodelist)
               node)
             %))
    nodelist))

Compute service constructor

(defn node-list-service
  "Create a node-list compute service, based on a sequence of nodes. Each
   node is passed as either a node object constructed with `make-node`,
   or as a vector of arguments for `make-node`.
   Optionally, an environment map can be passed using the :environment keyword.
   See `pallet.environment`."
  {:added "0.6.8"}
  [node-list & {:keys [environment] :as options}]
  (apply-map
   compute/compute-service :node-list (assoc options :node-list node-list)))
 

Abstraction of the compute interface

(ns pallet.compute
  (:require
   [pallet.common.deprecate :as deprecate]
   [pallet.compute.implementation :as implementation]
   [pallet.node :as node]
   [pallet.utils :as utils]))

slingshot version compatibility

(try
  (use '[slingshot.slingshot :only [throw+]])
  (catch Exception _
    (use '[slingshot.core :only [throw+]])))

Meta

(defn supported-providers
  "A list of supported provider names.  Each name is suitable to be passed
   to compute-service."
  []
  (implementation/supported-providers))

Compute Service instantiation

(defn compute-service
  "Instantiate a compute service. The provider name should be a recognised
   jclouds provider, or \"node-list\". The other arguments are keyword value
   pairs.
   - :identity     username or key
   - :credential   password or secret
   - :extensions   extension modules for jclouds
   - :node-list    a list of nodes for the \"node-list\" provider.
   - :environment  an environment map with service specific values."
  [provider-name
   & {:keys [identity credential extensions node-list endpoint environment sub-services]
      :as options}]
  (implementation/load-providers)
  (implementation/service provider-name options))
(deprecate/forward-fns
 pallet.node
 ssh-port primary-ip private-ip is-64bit? group-name hostname os-family
 os-version running? terminated? id node-in-group? node-address node?)
(defn tag [node]
  (deprecate/warn
   "pallet.compute/tag is deprecated, use pallet.node/group-name")
  (group-name node))

Actions

(defprotocol ComputeService
  (nodes [compute] "List nodes")
  (run-nodes [compute group-spec node-count user init-script options])
  (reboot [compute nodes] "Reboot the specified nodes")
  (boot-if-down
   [compute nodes]
   "Boot the specified nodes, if they are not running.")
  (shutdown-node [compute node user] "Shutdown a node.")
  (shutdown [compute nodes user] "Shutdown specified nodes")
  (ensure-os-family
   [compute group-spec]
   "Called on startup of a new node to ensure group-spec has an os-family
   attached to it.")
  (destroy-nodes-in-group [compute group-name])
  (destroy-node [compute node])
  (images [compute])
  (close [compute]))
(defn nodes-by-tag [nodes]
  (reduce #(assoc %1
             (keyword (tag %2))
             (conj (get %1 (keyword (tag %2)) []) %2)) {} nodes))
(defn node-counts-by-tag [nodes]
  (reduce #(assoc %1
             (keyword (tag %2))
             (inc (get %1 (keyword (tag %2)) 0))) {} nodes))

target mapping

(defn packager
  "Package manager"
  [target]
  (or
   (:packager target)
   (let [os-family (:os-family target)]
     (cond
       (#{:ubuntu :debian :jeos} os-family) :aptitude
       (#{:centos :rhel :amzn-linux :fedora} os-family) :yum
       (#{:arch} os-family) :pacman
       (#{:suse} os-family) :zypper
       (#{:gentoo} os-family) :portage
       (#{:darwin :os-x} os-family) :brew
       :else (throw+
              {:type :unknown-packager
               :message (format
                         "Unknown packager for %s - :image %s"
                         os-family target)})))))
(defn base-distribution
  "Base distribution for the target."
  [target]
  (or
   (:base-distribution target)
   (let [os-family (:os-family target)]
     (cond
       (#{:ubuntu :debian :jeos} os-family) :debian
       (#{:centos :rhel :amzn-linux :fedora} os-family) :rh
       (#{:arch} os-family) :arch
       (#{:suse} os-family) :suse
       (#{:gentoo} os-family) :gentoo
       (#{:darwin :os-x} os-family) :os-x
       :else (throw+
              {:type :unknown-packager
               :message (format
                         "Unknown base-distribution for %s - target is %s"
                         os-family target)})))))
(defn admin-group
  "User that remote commands are run under"
  [target]
  (case (-> target :image :os-family)
    :centos "wheel"
    :rhel "wheel"
    "adm"))

forward moved functions compute-service-from-map compute-service-from-config-var compute-service-from-property compute-service-from-config compute-service-from-config-file service -> configure/compute-service

(utils/fwd-to-configure compute-service-from-map)
(utils/fwd-to-configure compute-service-from-config-var)
(utils/fwd-to-configure compute-service-from-property)
(utils/fwd-to-configure compute-service-from-config)
(utils/fwd-to-configure compute-service-from-config-file)
(utils/fwd-to-configure service compute-service)
 

Some standard file formating.

(ns pallet.config-file.format
  (:require
   [clojure.string :as string]))
(defn sectioned-properties
  "A sectioned property file.
   This is modeled as vector of maps. The keys of the outer map are the section
   names.  The inner maps are keyword value maps."
  [m]
  (letfn [(format-kv
           [[key-name value]]
           (format "%s = %s\n" (name key-name) value))
          (format-section
           [[section-name kv-map]]
           (format
            "[%s]\n%s\n" (name section-name)
            (string/join (map format-kv kv-map))))]
    (string/join (map format-section m))))
(defn name-values
  "A property file.
   The properties are written \"key value\", one per line.
     m                   a key-value map
     :seperator chars    seperator to use between key and value
                         (default is a single space)"
  [m & {:keys [separator] :or {separator " "}}]
  (string/join
   (map
    (fn [[key-name value]] (format "%s%s%s\n" (name key-name) separator value))
    m)))
 

Pallet configuration using ~/.pallet/config.clj, the pallet.config namespace or from settings.xml.

config.clj should be in ~/.pallet or a directory specified by the PALLET_HOME environment variable.

service definitions can also be specified as clojure maps in ~/.pallet/services/*.clj

(ns pallet.configure
  "Pallet configuration using ~/.pallet/config.clj, the pallet.config namespace
   or from settings.xml.
   config.clj should be in ~/.pallet or a directory specified by the PALLET_HOME
   environment variable.
   service definitions can also be specified as clojure maps in
   ~/.pallet/services/*.clj"
  (:require
   [pallet.blobstore :as blobstore]
   [pallet.common.deprecate :as deprecate]
   [pallet.compute :as compute]
   [pallet.environment :as environment]
   [pallet.utils :as utils]
   [clojure.java.io :as java-io]
   [clojure.string :as string]
   [clojure.tools.logging :as logging]
   [clojure.walk :as walk])
  (:use
   [clojure.core.incubator :only [-?>]]))
(def ^{:private true
       :doc "A var to be set by defpallet, so that it may be loaded from any
             namespace"}
  config nil)
(defn- unquote-vals [args]
  (walk/walk
   (fn [item]
     (cond (and (seq? item) (= `unquote (first item))) (second item)
           ;; needed if we want fn literals to be usable by eval-in-project
           (and (seq? item) (= 'fn (first item))) (list 'quote item)
           (symbol? item) (list 'quote item)
           :else (unquote-vals item)))
   identity
   args))
(defmacro defpallet
  "Top level macro for the pallet config.clj file."
  [& {:keys [provider identity credential providers admin-user]
      :as config-options}]
  `(let [m# (zipmap
             ~(cons 'list (keys config-options))
             ~(cons 'list (unquote-vals (vals config-options))))]
    (alter-var-root #'config (fn [_#] m#))))
(defn- read-config
  [file]
  (try
    (use '[pallet.configure :only [defpallet]])
    (load-file file)
    config
    (catch java.io.FileNotFoundException _)))
(defn- home-dir
  "Returns full path to Pallet home dir ($PALLET_HOME or $HOME/.pallet)"
  []
  (.getAbsolutePath
   (doto (if-let [pallet-home (System/getenv "PALLET_HOME")]
           (java.io.File. pallet-home)
           (java.io.File. (System/getProperty "user.home") ".pallet"))
     .mkdirs)))
(defn pallet-config
  "Read pallet configuration from config.clj and services/*.clj files. The
   files are taken from ~/.pallet or $PALLET_HOME if set."
  []
  (reduce
   (fn [config service]
     (assoc-in config [:services (key (first service))] (val (first service))))
   (read-config (.getAbsolutePath (java-io/file (home-dir) "config.clj")))
   (for [file (filter
               #(and (.isFile %) (.endsWith (.getName %) ".clj"))
               (file-seq (java-io/file (home-dir) "services")))]
     (read-string (slurp file)))))
(defn- check-deprecations
  "Provide deprecation warnings."
  [config]
  (when (:providers config)
    (deprecate/warn
     (str
      "Use of :providers key in ~/.pallet/config.clj is "
      "deprecated. Please change to use :services."))))
(defn- cake-project-environment
  "Read an environment from the cake-project if it exists"
  []
  (-?> 'cake/*project* resolve var-get :environment))

Compute service

(defn compute-service-properties
  "Helper to read compute service properties. Given a config file return the
   selected service definition as a map."
  [config profiles]
  (when config
    (let [service (first profiles)
          default-service (map config [:provider :identity :credential])
          services (:services config (:providers config))
          environment (when-let [env (:environment config)]
                        (environment/eval-environment env))]
      (cond
       ;; no specific service requested, and default service specified by
       ;; top level keys in defppallet
       (and
        (not service)
        (every? identity default-service)) (->
                                            (select-keys
                                             config
                                             [:provider :identity :credential
                                              :blobstore :endpoint
                                              :environment])
                                            (utils/maybe-update-in
                                             [:environment]
                                             (fn [env] environment)))
        ;; pick from specified services
       (map? services) (->
                        (or
                         (and service
                              ;; ensure that if services is specified as a
                              ;; vector of keyword value vectors, that
                              ;; it is converted into a map first.
                              (let [services (into {} services)]
                                (or
                                 (services (keyword service))
                                 (services service))))
                         (and (not service) ; use default if service unspecified
                              (when-let [service (first services)]
                                (-> service second))))
                        ;; merge any top level environment with the service
                        ;; specific environment
                        (utils/maybe-update-in
                         [:environment]
                         #(environment/merge-environments
                           environment
                           (environment/eval-environment
                            (cake-project-environment))
                           (environment/eval-environment %))))
       :else nil))))
(defn compute-service-from-map
  "Create a compute service from a credentials map.
   Uses the :provider, :identity, :credential, :extensions and :node-list keys.
   The :extensions and :node-list keys will be read with read-string if they
   are strings."
  [credentials]
  (let [options (->
                 credentials
                 (update-in [:extensions]
                            #(if (string? %)
                               (map read-string (string/split % #" "))
                               %))
                 (update-in [:node-list] #(if (string? %) (read-string %) %))
                 (update-in [:environment] #(environment/eval-environment %)))]
    (when-let [provider (:provider options)]
      (apply
       compute/compute-service
       provider
       (apply concat (filter second (dissoc options :provider)))))))
(defn compute-service-from-config
  "Compute service from a defpallet configuration map and a list of active
   profiles (provider keys)."
  [config profiles]
  (check-deprecations config)
  (compute-service-from-map
   (compute-service-properties config profiles)))
(defn compute-service-from-config-var
  "Checks to see if pallet.config/service is a var, and if so returns its
  value."
  []
  (utils/find-var-with-require 'pallet.config 'service))
(defn compute-service-from-property
  "If the pallet.config.service property is defined, and refers to a var, then
   return its value."
  []
  (when-let [property (System/getProperty "pallet.config.service")]
    (when-let [sym-names (and (re-find #"/" property)
                              (string/split property #"/"))]
      (utils/find-var-with-require
       (symbol (first sym-names)) (symbol (second sym-names))))))
(defn compute-service-from-config-file
  "Compute service from ~/.pallet/config.clj. Profiles is a sequence of service
   keys to use from the :services map."
  [& profiles]
  (compute-service-from-config (pallet-config) profiles))
(defn compute-service
  "Instantiate a compute service.
   If passed no arguments, then the compute service is looked up in the
   following order:
   - from a var referenced by the pallet.config.service system property
   - from pallet.config/service if defined
   - the first service in config.clj
   - the service from the first active profile in settings.xml
   If passed a service name, it is looked up in external
   configuration (~/.pallet/config.clj or ~/.m2/settings.xml). A service name is
   one of the keys in the :services map in config.clj, or a profile id in
   settings.xml.
   When passed a provider name and credentials, the service is instantiated
   based on the credentials.  The provider name should be a recognised provider
   name (see `pallet.compute/supported-providers` to obtain a list of these).
   The other arguments are keyword value pairs.
   - :identity     username or key
   - :credential   password or secret
   - :extensions   extension modules for jclouds
   - :node-list    a list of nodes for the \"node-list\" provider.
   - :environment  an environment map with service specific values."
  ([]
     (or
      (compute-service-from-property)
      (compute-service-from-config-var)
      (compute-service-from-config-file)))
  ([service-name]
     (or
      (compute-service-from-config-file service-name)))
  ([provider-name
    & {:keys [identity credential extensions node-list endpoint environment]
       :as options}]
     (apply compute/compute-service provider-name (apply concat options))))

Blobstore

(def ^{:doc "Translate compute provider to associated blobstore provider"}
  blobstore-lookup
  {"cloudservers" "cloudfiles"
   "cloudservers-us" "cloudfiles-us"
   "cloudservers-eu" "cloudfiles-eu"
   "ec2" "s3"
   "aws-ec2" "aws-s3"})
(defn blobstore-from-map
  "Create a blobstore service from a credentials map.
   Uses :provider, :identity, :credential and
   :blobstore-provider, :blobstore-identity and :blobstore-credential.
   Blobstore keys fall back to the compute keys"
  [credentials]
  (when-let [provider (or (:blobstore-provider credentials)
                          (blobstore-lookup (:provider credentials)))]
    (blobstore/service
     provider
     :identity (or (:blobstore-identity credentials)
                   (:identity credentials))
     :credential (or (:blobstore-credential credentials)
                     (:credential credentials)))))
(defn blobstore-from-config
  "Create a blobstore service form a configuration map."
  [config profiles]
  (let [config (compute-service-properties config profiles)
        {:keys [provider identity credential]} (merge
                                                (update-in
                                                 config [:provider]
                                                 (fn [p]
                                                   (blobstore-lookup p)))
                                                (:blobstore config))]
    (when provider
      (blobstore/service provider :identity identity :credential credential))))
(defn blobstore-service-from-config-var
  "Checks to see if pallet.config/service is a var, and if so returns its
  value."
  []
  (utils/find-var-with-require 'pallet.config 'blobstore-service))
(defn blobstore-service-from-property
  "If the pallet.config.service property is defined, and refers to a var, then
   return its value."
  []
  (when-let [property (System/getProperty "pallet.config.blobstore-service")]
    (when-let [sym-names (and (re-find #"/" property)
                              (string/split property #"/"))]
      (utils/find-var-with-require
       (symbol (first sym-names)) (symbol (second sym-names))))))
(defn blobstore-service-from-config-file
  "Create a blobstore service form a configuration map."
  [& profiles]
  (blobstore-from-config (pallet-config) profiles))
(defn blobstore-service
  "Instantiate a blobstore service.
   If passed no arguments, then the blobstore service is looked up in the
   following order:
   - from a var referenced by pallet.config.blobstore-service system property
   - from pallet.config/blobstore-service if defined
   - the first service in config.clj
   - the service from the first active profile in settings.xml
   If passed a service name, it is looked up in external
   configuration (~/.pallet/config.clj or ~/.m2/settings.xml). A service name is
   one of the keys in the :services map in config.clj, or a profile id in
   settings.xml.
   When passed a provider name and credentials, the service is instantiated
   based on the credentials.  The provider name should be a recognised provider
   name (see `pallet.blobstore/supported-providers` to obtain a list of these).
   The other arguments are keyword value pairs.
   - :identity     username or key
   - :credential   password or secret
   - :extensions   extension modules for jclouds
   - :node-list    a list of nodes for the \"node-list\" provider.
   - :environment  an environment map with service specific values."
  ([]
     (or
      (blobstore-service-from-property)
      (blobstore-service-from-config-var)
      (blobstore-service-from-config-file)))
  ([service-name]
     (or
      (blobstore-service-from-config-file service-name)))
  ([provider-name
    & {:keys [identity credential extensions node-list endpoint environment]
       :as options}]
     (apply blobstore/service provider-name (apply concat options))))

Admin user

(defn admin-user-from-property
  "If the pallet.config.admin-user property is defined, and refers to a var
   then return its value."
  []
  (when-let [property (System/getProperty "pallet.config.admin-user")]
    (when-let [sym-names (and (re-find #"/" property)
                              (string/split property #"/"))]
      (utils/find-var-with-require
       (symbol (first sym-names)) (symbol (second sym-names))))))
(defn admin-user-from-config-var
  "Set the admin user based on pallet.config setup."
  []
  (utils/find-var-with-require 'pallet.config 'admin-user))
(defn admin-user-from-config
  "Set the admin user based on a config map"
  [config]
  (when-let [admin-user (:admin-user config)]
    (apply utils/make-user (:username admin-user) (apply concat admin-user))))
(defn admin-user-from-config-file
  "Create an admin user form a configuration map."
  []
  (admin-user-from-config (pallet-config)))
(defn admin-user
  "Instantiate an admin-user.
   If passed no arguments, then the blobstore service is looked up in the
   following order:
   - from a var referenced by pallet.config.admin-user system property
   - from pallet.config/admin-user if defined
   - the :admin-user top level key in config.clj
   Service specific admin-user values should be specified through a :user
   key on the :environment for the service.
   The other arguments are keyword value pairs.
   - :identity     username or key
   - :credential   password or secret
   - :extensions   extension modules for jclouds
   - :node-list    a list of nodes for the \"node-list\" provider.
   - :environment  an environment map with service specific values."
  ([]
     (or
      (admin-user-from-property)
      (admin-user-from-config-var)
      (admin-user-from-config-file))))

Service map

(defn service-map
  "Instantiate service objects. The service objects are returned in a map
   with keys as expected by `configure` or `lift`."
  ([]
     {:compute (compute-service)
      :blobstore (blobstore-service)
      :user (admin-user)})
  ([service-name]
     {:compute (compute-service service-name)
      :blobstore (blobstore-service service-name)
      :user (admin-user)}))
 

Core functionality is provided in lift and converge.

  • node :: A node in the compute service
  • node-spec :: A specification for a node. The node-spec provides an image hardware, location and network template for starting new nodes.
  • server-spec :: A specification for a server. This is a map of phases and a default node-spec. A server-spec has the following keys :phase, :packager and node-spec keys.
  • group-spec :: A group of identically configured nodes, represented as a map with :group-name, :count and server-spec keys. The group-name is used to link running nodes to their configuration (via pallet.node.Node/group-name)
  • group :: A group of identically configured nodes, represented as a group-spec, together with the servers that are running for that group-spec.
  • group name :: The name used to identify a group.
  • server :: A map used to descibe the node, image, etc of a single node running as part of a group. A server has the following keys :group-name, :node, :node-id and server-spec keys.
  • phase list :: A list of phases to be used
  • action plan :: A list of actions that should be run.
(ns pallet.core
"Core functionality is provided in `lift` and `converge`.
- node           :: A node in the compute service
- node-spec      :: A specification for a node. The node-spec provides an image
                    hardware, location and network template for starting new
                    nodes.
- server-spec    :: A specification for a server. This is a map of phases and
                    a default node-spec. A server-spec has the following keys
                    :phase, :packager and node-spec keys.
- group-spec     :: A group of identically configured nodes, represented as a
                    map with :group-name, :count and server-spec keys.
                    The group-name is used to link running nodes to their
                    configuration (via pallet.node.Node/group-name)
- group          :: A group of identically configured nodes, represented as a
                    group-spec, together with the servers that are running
                    for that group-spec.
- group name     :: The name used to identify a group.
- server         :: A map used to descibe the node, image, etc of a single
                    node running as part of a group. A server has the
                    following keys :group-name, :node, :node-id and server-spec
                    keys.
- phase list     :: A list of phases to be used
- action plan    :: A list of actions that should be run."
  {:author "Hugo Duncan"}
  (:require
   [pallet.action :as action]
   [pallet.action-plan :as action-plan]
   [pallet.blobstore :as blobstore]
   [pallet.common.deprecate :as deprecate]
   [pallet.common.logging.logutils :as logutils]
   [pallet.common.map-utils :as map-utils]
   [pallet.common.resource :as resource]
   [pallet.compute :as compute]
   [pallet.environment :as environment]
   [pallet.execute :as execute]
   [pallet.futures :as futures]
   [pallet.map-merge :as map-merge]
   [pallet.node :as node]
   [pallet.parameter :as parameter]
   [pallet.phase :as phase]
   [pallet.script :as script]
   [pallet.thread-expr :as thread-expr]
   [pallet.utils :as utils]
   [clojure.tools.logging :as logging]
   [clojure.set :as set]
   [clojure.string :as string])
  (:use
   [clojure.core.incubator :only [-?>]]))

slingshot version compatibility

(try
  (use '[slingshot.slingshot :only [throw+]])
  (catch Exception _
    (use '[slingshot.core :only [throw+]])))
(let [v (atom nil)]
  (defn version
    "Returns the pallet version."
    []
    (or
     @v
     (reset! v (System/getProperty "pallet.version"))
     (reset! v (if-let [version (resource/slurp "pallet-version")]
                       (string/trim version))))))

Set the agent string for http requests.

(. System setProperty "http.agent"
   (str "Pallet " (version)))
(defmacro with-admin-user
  "Specify the admin user for running remote commands.  The user is specified
   either as pallet.utils.User record (see the pallet.utils/make-user
   convenience fn) or as an argument list that will be passed to make-user.
   This is mainly for use at the repl, since the admin user can be specified
   functionally using the :user key in a lift or converge call, or in the
   environment."
  {:arglists
   '([user & body]
     [[username & {:keys [public-key-path private-key-path passphrase password
                          sudo-password no-sudo] :as options}] & body])}
  [user & exprs]
  `(let [user# ~user]
     (binding [utils/*admin-user* (if (utils/user? user#)
                                    user#
                                    (apply utils/make-user user#))]
       ~@exprs)))
(defn admin-user
  "Set the root binding for the admin user.
   The user arg is a map as returned by make-user, or a username.  When passing
   a username the options can be specified as in `pallet.utils/make-user`.
   This is mainly for use at the repl, since the admin user can be specified
   functionally using the :user key in a lift or converge call, or in the
   environment."
  {:arglists
   '([user]
     [username & {:keys [public-key-path private-key-path passphrase
                         password sudo-password no-sudo] :as options}])}
  [user & options]
  (alter-var-root
   #'utils/*admin-user*
   #(identity %2)
   (if (string? user)
     (apply utils/make-user user options)
     user)))
(def ^{:doc "Vector of keywords recognised by node-spec"
       :private true}
  node-spec-keys [:image :hardware :location :network])
(defn node-spec
  "Create a node-spec.
   Defines the compute image and hardware selector template.
   This is used to filter a cloud provider's image and hardware list to select
   an image and hardware for nodes created for this node-spec.
   :image     a map descirbing a predicate for matching an image:
              os-family os-name-matches os-version-matches
              os-description-matches os-64-bit
              image-version-matches image-name-matches
              image-description-matches image-id
   :location  a map describing a predicate for matching location:
              location-id
   :hardware  a map describing a predicate for matching harware:
              min-cores min-ram smallest fastest biggest architecture
              hardware-id
   :network   a map for network connectivity options:
              inbound-ports
   :qos       a map for quality of service options:
              spot-price enable-monitoring"
  [& {:keys [image hardware location network qos] :as options}]
  {:pre [(or (nil? image) (map? image))]}
  options)
(def
  ^{:doc
    "Map from key to merge algorithm. Specifies how specs are merged."}
  merge-spec-algorithm
  {:phases :merge-comp
   :roles :merge-union})
(defn- merge-specs
  "Merge specs, using comp for :phases"
  [a b]
  (map-merge/merge-keys merge-spec-algorithm a b))
(defn- extend-specs
  "Merge in the inherited specs"
  [spec inherits]
  (if inherits
    (merge-specs
     (if (map? inherits) inherits (reduce merge-specs inherits))
     spec)
    spec))
(defn server-spec
  "Create a server-spec.
   - :phases a hash-map used to define phases. Standard phases are:
     - :bootstrap    run on first boot of a new node
     - :configure    defines the configuration of the node
   - :extends        takes a server-spec, or sequence thereof, and is used to
                     inherit phases, etc.
   - :roles          defines a sequence of roles for the server-spec
   - :node-spec      default node-spec for this server-spec
   - :packager       override the choice of packager to use"
  [& {:keys [phases packager node-spec extends roles]
      :as options}]
  (->
   node-spec
   (merge options)
   (thread-expr/when-> roles
           (update-in [:roles] #(if (keyword? %) #{%} (into #{} %))))
   (extend-specs extends)
   (dissoc :extends :node-spec)))
(defn group-spec
  "Create a group-spec.
   `name` is used for the group name, which is set on each node and links a node
   to it's node-spec
   - :extends  specify a server-spec, a group-spec, or sequence thereof,
               and is used to inherit phases, etc.
   - :phases used to define phases. Standard phases are:
     - :bootstrap    run on first boot of a new node
     - :configure    defines the configuration of the node.
   - :count    specify the target number of nodes for this node-spec
   - :packager override the choice of packager to use
   - :node-spec      default node-spec for this server-spec"
  [name
   & {:keys [extends count image phases packager node-spec roles] :as options}]
  {:pre [(or (nil? image) (map? image))]}
  (->
   node-spec
   (merge options)
   (thread-expr/when-> roles
           (update-in [:roles] #(if (keyword? %) #{%} (into #{} %))))
   (extend-specs extends)
   (dissoc :extends :node-spec)
   (assoc :group-name (keyword name))))
(defn expand-cluster-groups
  "Expand a node-set into its groups"
  [node-set]
  (cond
   (sequential? node-set) (mapcat expand-cluster-groups node-set)
   (map? node-set) (if-let [groups (:groups node-set)]
                     (mapcat expand-cluster-groups groups)
                     [node-set])
   :else [node-set]))
(defn expand-group-spec-with-counts
  "Expand a converge node spec into its groups"
  ([node-set spec-count]
     (letfn [(*1 [x y] (* (or x 1) y))
             (scale-spec [spec factor]
               (update-in spec [:count] *1 factor))
             (set-spec [node-spec]
               (mapcat
                (fn [[node-spec spec-count]]
                  (if-let [groups (:groups node-spec)]
                    (expand-group-spec-with-counts groups spec-count)
                    [(assoc node-spec :count spec-count)]))
                node-set))]
       (cond
        (sequential? node-set) (mapcat
                                #(expand-group-spec-with-counts % spec-count)
                                node-set)
        (map? node-set) (if-let [groups (:groups node-set)]
                          (let [spec (scale-spec node-set spec-count)]
                            (mapcat
                             #(expand-group-spec-with-counts % (:count spec))
                             groups))
                          (if (:group-name node-set)
                            [(scale-spec node-set spec-count)]
                            (set-spec node-spec)))
        :else [(scale-spec node-set spec-count)])))
  ([node-set] (expand-group-spec-with-counts node-set 1)))
(defn cluster-spec
  "Create a cluster-spec.
   `name` is used as a prefix for all groups in the cluster.
   - :groups    specify a sequence of groups that define the cluster
   - :extends   specify a server-spec, a group-spec, or sequence thereof
                for all groups in the cluster
   - :phases    define phases on all groups.
   - :node-spec default node-spec for the nodes in the cluster
   - :roles     roles for the group-spec"
  [cluster-name
   & {:keys [extends groups phases node-spec environment] :as options}]
  (->
   options
   (update-in [:groups]
              (fn [group-specs]
                (map
                 (fn [group-spec]
                   (->
                    node-spec
                    (merge (dissoc group-spec :phases))
                    (update-in
                     [:group-name]
                     #(keyword (str (name cluster-name) "-" (name %))))
                    (update-in
                     [:environment]
                     environment/merge-environments environment)
                    (extend-specs extends)
                    (extend-specs [{:phases phases}])
                    (extend-specs [(select-keys group-spec [:phases])])))
                 (expand-group-spec-with-counts group-specs 1))))
   (dissoc :extends :node-spec)
   (assoc :cluster-cluster-name (keyword cluster-name))))
(defn make-node
  "Create a node definition.  See defnode."
  {:deprecated "0.5.0"}
  [name image & {:as phase-map}]
  (deprecate/deprecated
   (str
    "pallet.core/make-node is deprecated. "
    "See group-spec, server-spec and node-spec in pallet.core."))
  {:pre [(or (nil? image) (map? image))]}
  (->
   {:group-name (keyword name)
    :image image}
   (thread-expr/when-not->
    (empty? phase-map)
    (assoc :phases phase-map))))
(defn name-with-attributes
  "Modified version, of that found in contrib, to handle the image map."
  [name macro-args]
  (let [[docstring macro-args] (if (string? (first macro-args))
                                 [(first macro-args) (next macro-args)]
                                 [nil macro-args])
        [attr macro-args] (if (and (map? (first macro-args))
                                   (map? (first (next macro-args))))
                            [(first macro-args) (next macro-args)]
                            [{} macro-args])
        attr (if docstring
               (assoc attr :doc docstring)
               attr)
        attr (if (meta name)
               (conj (meta name) attr)
               attr)]
    [(with-meta name attr) macro-args]))
(defmacro defnode
  "Define a node type.  The name is used for the group name.
   image defines the image selector template.  This is a vector of keyword or
          keyword value pairs that are used to filter the image list to select
          an image.
   Options are used to define phases. Standard phases are:
     :bootstrap    run on first boot
     :configure    defines the configuration of the node."
  {:arglists ['(tag doc-str? attr-map? image & phasekw-phasefn-pairs)]
   :deprecated "0.5.0"}
  [group-name & options]
  (let [[group-name options] (name-with-attributes group-name options)]
    `(do
       (deprecate/deprecated-macro
        ~&form
        (str
         "pallet.core/defnode is deprecated. See group-spec, server-spec and "
         "node-spec in pallet.core"))
       (def ~group-name (make-node '~(name group-name) ~@options)))))
(defn- add-session-keys-for-0-4-compatibility
  "Add target keys for compatibility.
   This function adds back deprecated keys"
  [session]
  (-> session
      (assoc :node-type (:group session))
      (assoc :target-packager (-> session :server :packager))
      (assoc :target-node (-> session :server :node))))
(defn show-target-keys
  "Middleware that is useful in debugging."
  [handler]
  (fn [session]
    (logging/infof
     "TARGET KEYS :phase %s :node-id %s :group-name %s :packager %s"
     (:phase session)
     (-> session :server :node-id)
     (-> session :server :group-name)
     (-> session :server :packager))
    (handler session)))

executor

(defn- executor [session f action-type location]
  (let [exec-fn (get-in session [:executor action-type location])]
    (when-not exec-fn
      (throw+
       {:type :missing-executor-fn
        :fn-for [action-type location]
        :message (format
                  "Missing executor function for %s %s"
                  action-type location)}))
    (exec-fn session f)))
(let [raise (fn [message]
              (fn [_ _]
                (throw+ {:type :executor-error :message message})))]
  (def ^{:doc "Default executor map"}
    default-executors
    {:script/bash
     {:origin execute/bash-on-origin
      :target (raise
               (str ":script/bash on :target not implemented.\n"
                    "Add middleware to enable remote execution."))}
     :fn/clojure
     {:origin execute/clojure-on-origin
      :target (raise ":fn/clojure on :target not supported")}
     :transfer/to-local
     {:origin (raise
               (str ":transfer/to-local on :origin not implemented.\n"
                    "Add middleware to enable transfers."))
      :target (raise ":transfer/to-local on :target not supported")}
     :transfer/from-local
     {:origin (raise
               (str ":transfer/to-local on :origin not implemented.\n"
                    "Add middleware to enable transfers."))
      :target (raise ":transfer/from-local on :target not supported")}}))

bootstrap functions

(defn- bootstrap-script
  [session]
  {:pre [(get-in session [:group :image :os-family])
         (get-in session [:group :packager])]}
  (let [error-fn (fn [message]
                   (fn [_ _]
                     (throw+
                      {:type :booststrap-contains-non-remote-actions
                       :message message})))
        [result session] (->
                          session
                          (assoc
                              :phase :bootstrap
                              :target-type :node
                              :target-id :bootstrap-id
                              :server (assoc (:group session)
                                        :node-id :bootstrap-id))
                          (assoc-in
                           [:executor :script/bash :target]
                           execute/echo-bash)
                          (assoc-in
                           [:executor :transfer/to-local :origin]
                           (error-fn "Bootstrap can not contain transfers"))
                          (assoc-in
                           [:executor :transfer/from-local :origin]
                           (error-fn "Bootstrap can not contain transfers"))
                          (assoc-in
                           [:executor :fn/clojure :origin]
                           (error-fn "Bootstrap can not contain local actions"))
                          add-session-keys-for-0-4-compatibility
                          action-plan/build-for-target
                          action-plan/translate-for-target
                          (action-plan/execute-for-target
                           executor
                           (environment/get-for
                            session [:algorithms :execute-status-fn])))]
    (when-let [error (some :error result)]
      (throw+ error))
    (string/join \newline result)))
(defn log-session
  "Log the session state"
  [msg]
  (fn [session]
    (logging/infof "%s Session is %s" msg session)
    session))
(defn log-message
  "Log the message"
  [msg]
  (fn [session]
    (logging/infof "%s" msg)
    session))
(defn- log-nodes
  "Log the node lists in the session state"
  [msg]
  (fn [session]
    (logging/infof
     "%s nodes  %s with %s old nodes"
     msg
     (pr-str
      (select-keys
       session [:all-nodes :selected-nodes :new-nodes]))
     (count (:old-nodes session)))
    session))
(defn- apply-environment
  "Apply the effective environment"
  [session]
  (environment/session-with-environment
    session
    (environment/merge-environments
     (:environment session)
     (environment/eval-environment (-> session :server :environment)))))
(defn translate-action-plan
  [handler]
  (fn [session]
    (handler (action-plan/translate-for-target session))))
(defn middleware-handler
  "Build a middleware processing pipeline from the specified middleware.
   The result is a middleware."
  [handler]
  (fn [session]
    ((reduce #(%2 %1) handler (:middleware session)) session)))
(defn- execute
  "Execute the action plan"
  [session]
  (action-plan/execute-for-target
   session executor
   (environment/get-for session [:algorithms :execute-status-fn])))

middleware

(defn stop-execution-on-error
  ":execute-status-fn algorithm to stop execution on an error"
  [result flag]
  (if (= flag :continue)
    (if (:error result)
      :stop
      flag)
    flag))
(defn raise-on-error
  "Middleware that raises a condition on an error."
  [handler]
  (fn [session]
    (let [[results session] (handler session)
          errors (seq (filter :error results))]
      (if errors
        (do
          (logging/errorf "errors found %s" (vec (map :error errors)))
          (throw+ (assoc (:error (first errors)) :all-errors errors)))
        [results session]))))
(def ^{:dynamic true} *middleware*
  [translate-action-plan
   execute/ssh-user-credentials
   execute/execute-with-ssh
   raise-on-error])
(defmacro with-middleware
  "Wrap node execution in the given middleware. A middleware is a function of
   one argument (a handler function, that is the next middleware to call) and
   returns a dunction of one argument (the session map).  Middleware can be
   composed with the pipe macro."
  [f & body]
  `(binding [*middleware* ~f]
     ~@body))

results

(defn- reduce-phase-results
  "Combine the phase execution results."
  [session results]
  (reduce
   (fn reduce-phase-results-fn [session [result req :as arg]]
     (let [target-id (-> req :target-id)
           param-keys [:parameters]]
       (->
        session
        (assoc-in [:results target-id (:phase req)] result)
        (update-in
         param-keys
         (fn merge-params [p]
           (map-utils/deep-merge-with
            (fn merge-params-fn [x y] (or y x)) p (get-in req param-keys)))))))
   session
   results))

action plan

(defn- plan-for-server
  "Build an action plan for the specified server."
  [session server]
  {:pre [(:node server) (:node-id server)]}
  (logutils/with-context [:target (node/primary-ip (:node server))]
    (logging/debugf "p-f-s server environment %s" (:environment server))
    (action-plan/build-for-target
     (->
      session
      (assoc :server server)
      add-session-keys-for-0-4-compatibility
      (assoc :target-id (:node-id server))
      (environment/session-with-environment
        (environment/merge-environments
         (:environment session)
         (:environment server)))))))
(defn- plan-for-servers
  "Build an action plan for the specified servers."
  [session servers]
  (reduce plan-for-server session servers))
(defn- plan-for-groups
  "Build an invocation map for specified node-type map."
  [session groups]
  (reduce
   (fn [session group]
     (logutils/with-context [:group (:group-name group)]
       (plan-for-servers (assoc session :group group) (:servers group))))
   session groups))
(defn- plan-for-phases
  "Build an invocation map for specified phases and nodes.
   This allows configuration to be accumulated in the session parameters."
  [session]
  (reduce
   (fn [session phase]
     (logutils/with-context [:phase phase]
       (plan-for-groups (assoc session :phase phase) (:groups session))))
   session (:phase-list session)))
(defn- plan-for-group-phase
  "Build an invocation map for specified groups map."
  [session groups]
  (reduce
   (fn [session group]
     (logutils/with-context [:group (:group-name group)]
       (action-plan/build-for-target
        (->
         session
         (assoc :target-id (:group-name group) :group group)
         (environment/session-with-environment
           (environment/merge-environments
            (:environment session)
            (:environment group)))))))
   session groups))
(defmulti plan-for-target :target-type)
(defmethod plan-for-target :node
  [session]
  (plan-for-groups session (:groups session)))
(defmethod plan-for-target :group
  [session]
  (plan-for-group-phase session (:groups session)))

Phase application

(defn has-phase?
  [session]
  (let [phase (:phase session)]
    (action-plan/phase-for-target
     (assoc session :phase (or (phase/subphase-for phase) phase)))))
(defn- apply-phase-to-node
  "Apply a phase to a node session"
  [session]
  {:pre [(:server session) (:phase session)]}
  (logging/infof
   "apply-phase-to-node: phase %s group %s target %s session %s"
   (:phase session)
   (-> session :group :group-name)
   (node/primary-ip (-> session :server :node))
   session)
  (logutils/with-context [:target (node/primary-ip
                                   (-> session :server :node))
                          :phase (:phase session)
                          :group (-> session :group :group-name)]
    ((middleware-handler execute)
     (->
      session
      apply-environment
      add-session-keys-for-0-4-compatibility))))
(defn- apply-phase-to-group
  "Apply a phase to a group"
  [session]
  {:pre [(:group session) (:phase session)]}
  (logging/infof
   "apply-phase-to-group: phase %s group %s"
   (:phase session)
   (-> session :group :group-name))
  (logutils/with-context [:phase (:phase session)
                          :group (-> session :group :group-name)]
    ((middleware-handler execute)
     session)))
(defmulti sequential-apply-phase-to-target :target-type)
(defmethod sequential-apply-phase-to-target :node
  [session]
  (logging/infof
   "sequential-apply-phase-to-target :node  %s for %s with %d nodes"
   (:phase session)
   (-> session :group :group-name)
   (count (-> session :group :servers)))
  (for [server (-> session :group :servers)
        :let [session (assoc session
                        :server server :target-id (:node-id server))]
        :when (has-phase? session)]
    (apply-phase-to-node session)))
(defmethod sequential-apply-phase-to-target :group
  [session]
  (logging/infof
   "sequential-apply-phase-to-target :group  %s for %s"
   (:phase session) (-> session :group :group-name))
  (let [session (assoc session :target-id (-> session :group :group-name))]
    (when (has-phase? session)
      [(apply-phase-to-group session)])))
(defn sequential-apply-phase
  "Apply a phase to a sequence of nodes"
  [session]
  (logging/infof
   "sequential-apply-phase %s for %s"
   (:phase session) (-> session :group :group-name))
  (sequential-apply-phase-to-target session))
(defmulti parallel-apply-phase-to-target :target-type)
(defmethod parallel-apply-phase-to-target :node
  [session]
  (logging/infof
   "parallel-apply-phase-to-target :node  %s for %s with %d nodes"
   (:phase session)
   (-> session :group :group-name)
   (count (-> session :group :servers)))
  (for [server (-> session :group :servers)
        :let [session (assoc session
                        :server server :target-id (:node-id server))]
        :when (has-phase? session)]
    (future (apply-phase-to-node session))))
(defmethod parallel-apply-phase-to-target :group
  [session]
  (logging/infof
   "parallel-apply-phase-to-target :group  %s for %s"
   (:phase session) (-> session :group :group-name))
  (let [session (assoc session :target-id (-> session :group :group-name))]
    (when (has-phase? session)
      [(future (apply-phase-to-group session))])))
(defn parallel-apply-phase
  "Apply a phase to a sequence of nodes"
  [session]
  (logging/infof
   "parallel-apply-phase %s for %s"
   (:phase session) (-> session :group :group-name))
  (futures/add (parallel-apply-phase-to-target session)))
(defn- ensure-phase [phases phase-kw]
  (if (some #{phase-kw} phases)
    phases
    (concat [phase-kw] phases)))
(defn sequential-lift
  "Sequential apply the phases."
  [session]
  (apply
   concat
   (for [group (:groups session)]
     (sequential-apply-phase (assoc session :group group)))))
(defn parallel-lift
  "Apply the phases in sequence, to nodes in parallel."
  [session]
  (->>
   (for [group (:groups session)]
     (parallel-apply-phase (assoc session :group group)))
   (reduce concat [])
   doall                        ; make sure we start all futures before deref
   (map deref)                  ; make sure all nodes complete before next phase
   doall))                      ; make sure we force the deref
(defn lift-phase
  "Lift nodes in target-node-map for the specified phases.
   Builds the commands for the phase, then executes pre-phase, phase, and
   after-phase"
  [session]
  (let [lift-fn (environment/get-for session [:algorithms :lift-fn])
        phase (:phase session)]
    (reduce
     (fn [session sub-phase]
       (let [session (->
                      session
                      (assoc :phase phase)
                      plan-for-target
                      (assoc :phase sub-phase))]
         (reduce-phase-results session (lift-fn session))))
     session
     (phase/all-phases-for-phase phase))))
(defn lift-nodes
  "Lift nodes in target-node-map for the specified phases."
  [session]
  (logging/infof
   "lift-nodes phases %s, groups %s"
   (vec (:phase-list session))
   (vec (map :group-name (:groups session))))
  (reduce
   (fn [session phase]
     (->
      session
      (assoc :phase phase)
      plan-for-target
      lift-phase))
   (assoc session :target-type :node)
   (:phase-list session)))
(defn- lift-group-phase
  [session]
  (logging/infof
   "lift-group-phase phases %s, groups %s"
   (vec (:phase-list session))
   (vec (map :group-name (:groups session))))
  (reduce
   (fn [session phase]
     (->
      session
      (assoc :phase phase)
      plan-for-target
      lift-phase))
   (assoc session :target-type :group)
   (:phase-list session)))

node create/destroy

(defn- create-nodes
  "Create count nodes based on the template for the group.
   Returns a map with updated server node lists."
  [session]
  {:pre [(map? (:group session))]}
  (let [group (:group session)]
    (logging/infof
     "Starting %s nodes for %s, os-family %s"
     (:delta-count group) (:group-name group) (-> group :image :os-family)))
  (let [compute (:compute session)
        count (-> session :group :delta-count)
        session (update-in session [:group]
                           #(compute/ensure-os-family compute %))
        session (assoc-in session [:group :packager]
                          (compute/packager (-> session :group :image)))
        init-script (bootstrap-script session)
        _ (logging/tracef "Bootstrap script:\n%s" init-script)
        new-nodes (compute/run-nodes
                   compute (:group session) count (:user session) init-script
                   (-> session :environment :provider-options))]
    (when-not (seq new-nodes)
      (throw+
       {:message "No additional nodes could be started"
        :group (:group session)
        :type :pallet/could-not-start-new-nodes}))
    (->
     session
     (assoc-in [:groups-new-nodes (-> session :group :group-name)] new-nodes)
     (update-in [:new-nodes] concat new-nodes))))
(defn- servers-to-remove
  "Finds the specified number of nodes to be removed from the given group.
   Nodes are selected at random. Update the :groups-with-servers-to-remove key
   of the session."
  [group]
  (let [destroy-count (- (:delta-count group 0))]
    (if (pos? destroy-count)
      (do
        (logging/infof
         "Select %s nodes for destruction in group %s"
         destroy-count (:group-name group))
        (assoc group
          :servers-to-remove (take destroy-count (:servers group))))
      group)))
(defn- remove-nodes
  "Destroys the specified number of nodes with the given group.  Nodes are
   selected at random. Returns a map containing removed nodes."
  [session]
  (let [compute (:compute session)
        group (:group session)
        servers (:servers-to-remove group)
        nodes (map :node servers)]
    (logging/infof
     "destroying %s nodes for %s, remove-group %s"
     (count servers) (:group-name group) (:remove-group group))
    (if (:remove-group group)
      (compute/destroy-nodes-in-group compute (name (:group-name group)))
      (doseq [node nodes] (compute/destroy-node compute node)))
    (->
     session
     (assoc-in [:groups-old-nodes (:group-name group)] nodes)
     (update-in [:old-nodes] concat nodes))))

deltas-fn's, for calculating node counts to add or remove

(defn- deltas-for-converge-to-count
  "Find the difference between the required and actual node counts by group."
  [group]
  (assoc group :delta-count (- (:count group) (count (:servers group)))))
(defn- deltas-for-delta-count
  "Find the difference between the required and actual node counts by group."
  [group]
  (assoc group :delta-count (:count group)))
(defn- adjust-node-count
  "Adjust the server count by :delta-count nodes."
  [session op group]
  (let [session (->
                 session
                 (assoc :group group)
                 (environment/session-with-environment
                   (environment/merge-environments
                    (:environment session)
                    (:environment group))))]
    (logging/infof "adjust-server-count %s" (:group-name group))
    (op session)))
(defn- server-with-packager
  "Add the target packager to the session"
  [server]
  (update-in server [:packager]
             (fn [p] (or p
                         (-> server :image :packager)
                         (compute/packager (:image server))))))
(defn server
  "Take a `group` and a `node`, an `options` map and combine them to produce
   a server.
   The group os-family, os-version, are replaced with the details form the
   node. The :node key is set to `node`, and the :node-id and :packager keys
   are set.
   `options` allows adding extra keys on the server."
  [group node options]
  (->
   group
   (update-in [:image :os-family] (fn [f] (or (node/os-family node) f)))
   (update-in [:image :os-version] (fn [f] (or (node/os-version node) f)))
   (update-in [:node-id] (fn [id] (or (keyword (node/id node)) id)))
   (assoc :node node)
   server-with-packager
   (merge options)))
(defn update-group-servers
  [groups old-nodes new-nodes]
  (map
   (fn [{:keys [group-name] :as group}]
     (->
      group
      (update-in [:servers] (fn [servers]
                              (remove
                               (comp (set (get old-nodes group-name)) :node)
                               servers)))
      (update-in [:servers] concat
                 (map #(server group % nil) (get new-nodes group-name)))))
   groups))
(defn reduce-adjust-nodes
  "reduce the result of an adjust-node onto a session"
  [session session-adjust]
  (->
   session
   (update-in [:new-nodes] concat (:new-nodes session-adjust))
   (update-in [:old-nodes] concat (:old-nodes session-adjust))
   (update-in [:groups-old-nodes] merge (:groups-old-nodes session-adjust))
   (update-in [:groups-new-nodes] merge (:groups-new-nodes session-adjust))))
(defn adjust-session-for-nodes
  "Take :new-nodes and :old-nodes, and adjust :original-nodes and :all-nodes"
  [session]
  (->
   session
   (assoc :original-nodes (:all-nodes session))
   (update-in [:all-nodes]
              #(vec (->>
                     %
                     (concat (:new-nodes session))
                     (remove
                      (fn [node] (some
                                  (fn [n] (identical? n node))
                                  (:old-nodes session)))))))
   (update-in [:groups]
              update-group-servers
              (:groups-old-nodes session)
              (:groups-new-nodes session))))
(defn serial-adjust-node-counts
  "Start or stop the specified number of nodes."
  [session op groups]
  (logging/tracef "serial-adjust-node-counts")
  (adjust-session-for-nodes
   (reduce
    (fn [session group] (adjust-node-count session op group))
    session
    groups)))
(defn parallel-adjust-node-counts
  "Start or stop the specified number of nodes."
  [session op groups]
  (logging/tracef "parallel-adjust-node-counts")
  (->>
   groups
   (map
    (fn p-a-n-c-future [group]
      (future (adjust-node-count session op group))))
   futures/add
   doall ;; force generation of all futures
   (map
    (fn p-a-n-c-deref [f]
      (futures/deref-with-logging f "Adjust node count")))
   (reduce reduce-adjust-nodes session)
   adjust-session-for-nodes))
(defn lift-with-alternative-groups-and-phases
  [session f]
  (assoc (f session)
    :groups (:groups session)
    :phase-list (:phase-list session)))
(defn lift-destroy-server
  [session]
  (lift-with-alternative-groups-and-phases
    session
    (fn [session]
      (lift-nodes
       (-> session
           (update-in [:groups]
                      #(->>
                        (filter :servers-to-remove %)
                        (map (fn [group]
                               (assoc group
                                 :servers (:servers-to-remove group))))))
           (assoc :phase-list [:destroy-server]))))))
(defn destroy-servers
  [session]
  ((environment/get-for session [:algorithms :converge-fn])
   session
   remove-nodes
   (filter :servers-to-remove (:groups session))))
(defn lift-destroy-group
  [session]
  (lift-with-alternative-groups-and-phases
    session
    (fn [session]
      (lift-group-phase
       (-> session
           (update-in [:groups]
                      #(->> %
                            (filter (comp neg? (fn [g] (:delta-count g 0))))
                            (filter (comp empty? :servers))))
           (assoc :phase-list [:destroy-group]))))))
(defn lift-create-group
  [session]
  (lift-with-alternative-groups-and-phases
    session
    (fn [session]
      (lift-group-phase
       (-> session
           (update-in [:groups]
                      #(->> %
                            (filter (comp pos? (fn [g] (:delta-count g 0))))
                            (filter (comp empty? :servers))))
           (assoc :phase-list [:create-group]))))))
(defn create-servers
  [session]
  ((environment/get-for session [:algorithms :converge-fn])
   session
   create-nodes
   (filter (comp pos? :delta-count) (:groups session))))
(defn- adjust-server-counts
  "Adjust the server counts, given a compute facility and a map of ops and
   number of instances. Returns a session object with :original-nodes
   :all-nodes, :new-nodes and :old-nodes keys.
   - for nodes to be removed, select the nodes to be removed.
   - for nodes to be removed, run :destroy-server phase on each.
   - destroy any nodes required
   - for groups with no nodes left, run :destroy-group on each.
   - for groups with no nodes, that should have nodes started, run :create-group
   - create any nodes required"
  [session]
  (-> session
      (update-in [:groups] (partial map servers-to-remove))
      lift-destroy-server
      destroy-servers
      lift-destroy-group
      lift-create-group
      create-servers))
(def
  ^{:doc
    "Flag to control output of warnings about undefined phases in calls to lift
     and converge."
    :dynamic true}
  *warn-on-undefined-phase* true)
(defn- warn-on-undefined-phase
  "Generate a warning for the elements of the session's :phase-list that are not
   defined in the session's :groups.
   No warnings are generated for the settings or configure phases."
  [session]
  (when *warn-on-undefined-phase*
    (when-let [undefined (seq
                          (set/difference
                           (set (filter keyword? (:phase-list session)))
                           #{:settings :configure}
                           (set
                            (concat
                             (->>
                              (:groups session)
                              (map (comp keys :phases))
                              (reduce concat))
                             (keys (:inline-phases session))))))]
      (logging/warnf
       "Undefined phases: %s"
       (string/join ", " (map name undefined)))))
  session)
(defn- group-with-prefix
  [prefix node-spec]
  (update-in node-spec [:group-name]
             (fn [group-name] (keyword (str prefix (name group-name))))))
(defn- node-map-with-prefix [prefix node-map]
  (zipmap
   (map #(group-with-prefix prefix %) (keys node-map))
   (vals node-map)))
(defn- phase-list-with-configure
  "Ensure that the `phase-list` contains the :configure phase, prepending it if
  not."
  [phase-list]
  (->
   phase-list
   (ensure-phase :configure)
   (ensure-phase :settings)))
(defn- phase-list-with-default
  "Add the default configure phase if the `phase-list` is empty"
  [phase-list]
  (if (seq phase-list) phase-list [:settings :configure]))
(defn- session-with-configure-phase
  "Add the configure phase to the session's :phase-list if not present."
  [session]
  (update-in session [:phase-list] phase-list-with-configure))
(defn- session-with-default-phase
  "Add the default phase to the session's :phase-list if none supplied."
  [session]
  (update-in session [:phase-list]
             (fn [phase-list]
               (-> phase-list
                   phase-list-with-default
                   (ensure-phase :settings)))))
(defn- node-in-types?
  "Predicate for matching a node belonging to a set of node types"
  [node-types node]
  (some #(= (node/group-name node) (name (% :group-name))) node-types))
(defn- nodes-for-group
  "Return the nodes that have a group-name that matches one of the node types"
  [nodes group]
  (let [group-name (name (:group-name group))]
    (filter #(node/node-in-group? group-name %) nodes)))
(defn- group-spec?
  "Predicate for testing if argument is a node-spec.
   This is not exhaustive, and not intended for general use."
  [x]
  (and (map? x) (:group-name x) (keyword? (:group-name x))))
(defn nodes-in-set
  "Build a map of node-spec to nodes for the given `node-set`.
   A node set can be a node spec, a map from node-spec to a sequence of nodes,
   or a sequence of these.
   The prefix is applied to the group-name of each node-spec in the result.
   This allows you to build seperate clusters based on the same node-spec's.
   The return value is a map of node-spec to node sequence.
   Example node sets:
       node-spec-1
       [node-spec1 node-spec-2]
       {node-spec #{node1 node2}}
       [node-spec1 node-spec-2 {node-spec #{node1 node2}}]"
  [node-set prefix nodes]
  (letfn [(ensure-set [x] (if (set? x) x #{x}))
          (ensure-set-values
           [m]
           (zipmap (keys m) (map ensure-set (vals m))))]
    (cond
     (and (map? node-set) (not (group-spec? node-set)))
     (ensure-set-values (node-map-with-prefix prefix node-set))
     (group-spec? node-set)
     (let [group (group-with-prefix prefix node-set)]
       {group (set (nodes-for-group nodes group))})
     :else (reduce
            #(merge-with concat %1 %2) {}
            (map #(nodes-in-set % prefix nodes) node-set)))))
(defn groups-with-servers
  "Takes a map from node-spec to sequence of nodes, and converts it to a
   sequence of group definitions, containing a server for each node in then
   :servers key of each group.  The server will contain the node-spec,
   updated with any information that was available from the node.
       (groups-with-servers {(node-spec \"spec\" {}) [a b c]})
         => [{:group-name \"spec\"
              :servers [{:group-name \"spec\" :node a}
                        {:group-name \"spec\" :node b}
                        {:group-name \"spec\" :node c}]}]
   `options` allows adding extra keys to the servers."
  [node-map execute-node?]
  (for [[group nodes] node-map]
    (assoc group
      :servers (map
                (fn [node]
                  (server group node {:invoke-only (not (execute-node? node))}))
                (filter node/running? nodes)))))
(defn session-with-all-nodes
  "If the :all-nodes key is not set, then the nodes are retrieved from the
   compute service if possible."
  [session]
  (let [nodes (filter
               node/running?
               (or (:all-nodes session) ; empty list is ok
                   (if-let [compute (environment/get-for
                                     session [:compute] nil)]
                     (do
                       (logging/info "retrieving nodes")
                       (compute/nodes compute))
                     (->>
                      (:node-set session)
                      (filter #(and (map? %) (every? map? (keys %))))
                      (mapcat vals)
                      (mapcat #(if (seq? %) % [%]))
                      (filter node/node?)
                      (distinct)))))]
    (assoc session :all-nodes nodes :selected-nodes nodes)))
(defn session-with-groups
  "Takes the :selected-nodes, :all-nodes. :node-set and :prefix keys and compute
   the groups for the session, updating the :selected-nodes, :all-nodes
   and :groups keys of the session.
   The :groups key is set to a sequence of groups, each containing its
   list of servers on the :servers key."
  [session]
  (let [nodes (:selected-nodes session)
        all-nodes (:all-nodes session)
        all-targets (nodes-in-set
                     (:node-set session) (:prefix session) all-nodes)
        targets (nodes-in-set (:node-set session) (:prefix session) nodes)
        plan-targets (if-let [all-node-set (:all-node-set session)]
                       (-> (nodes-in-set all-node-set nil all-nodes)
                           (utils/dissoc-keys (keys targets))))]
    (->
     session
     (assoc :all-nodes (or (seq all-nodes)
                           (filter
                            node/running?
                            (reduce
                             concat
                             (concat
                              (vals all-targets) (vals plan-targets))))))
     (assoc :selected-nodes (or (seq nodes)
                                (filter
                                 node/running?
                                 (reduce concat (vals targets)))))
     (assoc :groups (concat
                     (groups-with-servers targets (set nodes))
                     (groups-with-servers plan-targets (constantly false)))))))
(defn all-node-set-selector
  "Select all nodes for groups in the node-set for processing"
  [session]
  (assoc session :selected-nodes (:all-nodes session)))
(defn new-node-set-selector
  "Select all new nodes for groups in the node-set for processing"
  [session]
  (assoc session :selected-nodes (:new-nodes session)))
(defn select-node-set
  "Select a node-set of nodes to be passed to lift"
  [session]
  ((:node-set-selector session all-node-set-selector) session))
(defn lift*
  "Lift the nodes specified in the session :node-set key.
   - :node-set     - a specification of nodes to lift
   - :all-nodes    - a sequence of all known nodes
   - :all-node-set - a specification of nodes to invoke (but not lift)"
  [session]
  (logging/debugf "pallet version: %s" (version))
  (logging/tracef "lift* phases %s" (vec (:phase-list session)))
  (->
   session
   session-with-all-nodes
   select-node-set
   session-with-groups
   session-with-default-phase
   warn-on-undefined-phase
   lift-nodes))
(defn converge*
  "Converge the node counts of each node-spec in `:node-set`, executing each of
   the configuration phases on all the group-names in `:node-set`. The
   phase-functions are also executed, but not applied, for any other nodes in
   `:all-node-set`"
  [session]
  {:pre [(:node-set session)]}
  (logging/debugf "pallet version: %s" (version))
  (logging/tracef "converge* phases %s" (vec (:phase-list session)))
  (logging/tracef "converge* node-set %s" (vec (:node-set session)))
  (->
   session
   session-with-all-nodes
   session-with-groups
   session-with-configure-phase
   (update-in [:groups] (partial map deltas-for-converge-to-count))
   adjust-server-counts
   lift*))
(defmacro or-fn [& args]
  `(fn or-args [current#]
     (or current# ~@args)))
(defn- compute-from-options
  [current-value {:keys [compute compute-service]}]
  (or current-value
      compute
      (and compute-service
           (compute/compute-service
            (:provider compute-service)
            :identity (:identity compute-service)
            :credential (:credential compute-service)
            :extensions (:extensions compute-service)
            :node-list (:node-list compute-service)))))
(defn- blobstore-from-options
  [current-value {:keys [blobstore blobstore-service]}]
  (or current-value
      blobstore
      (and blobstore-service
           (blobstore/service
            (:provider blobstore-service)
            :identity (:identity blobstore-service)
            :credential (:credential blobstore-service)
            :extensions (:extensions blobstore-service)))))
(def
  ^{:doc "Algorithms to use when none specified"}
  default-algorithms
  {:lift-fn parallel-lift
   :converge-fn parallel-adjust-node-counts
   :execute-status-fn stop-execution-on-error})
(defn default-environment
  "Specify the built-in default environment"
  []
  {:blobstore nil
   :compute nil
   :user utils/*admin-user*
   :middleware *middleware*
   :algorithms default-algorithms})
(defn- effective-environment
  "Build the effective environment for the session map.
   This merges the explicitly passed :environment, with that
   defined on the :compute service."
  [session]
  (assoc
   session
   :environment
   (environment/merge-environments
    (default-environment)                                     ; global default
    (utils/find-var-with-require 'pallet.config 'environment) ; project default
    (-?> session :environment :compute environment/environment) ;service default
    (:environment session))))                                 ; session default
(def ^{:doc "args that are really part of the environment"}
  environment-args [:compute :blobstore :user :middleware :provider-options])
(defn- session-with-environment
  "Build a session map from the given options, combining the service specific
   options with those given in the converge or lift invocation."
  [{:as options}]
  (->
   options
   (update-in                           ; ensure backwards compatable
    [:environment]
    merge (select-keys options environment-args))
   (assoc :executor default-executors)
   (utils/dissoc-keys environment-args)
   (effective-environment)))
(def ^{:doc "A set of recognised argument keywords, used for input checking."
       :private true}
  argument-keywords
  #{:compute :blobstore :phase :user :prefix :middleware :all-node-set
    :all-nodes :parameters :environment :node-set :phase-list
    :node-set-selector :provider-options})
(defn- check-arguments-map
  "Check an arguments map for errors."
  [{:as options}]
  (let [unknown (remove argument-keywords (keys options))]
    (when (and (:phases options) (not (:phase options)))
      (throw+
       {:type :invalid-argument
        :message (str
                  "Please pass :phase and not :phases. :phase takes a single "
                  "phase or a sequence of phases.")
        :invalid-keys unknown}))
    (when (seq unknown)
      (throw+
       {:type :invalid-argument
        :message (format "Invalid argument keywords %s" (vec unknown))
        :invalid-keys unknown})))
  options)
(defn- identify-anonymous-phases
  "For all inline phase defintions in the session's :phase-list,
   generate a keyword for the phase, adding an entry to the session's
   :inline-phases map containing the phase definition, and replacing the
   phase defintion in the :phase-list with the keyword."
  [session]
  (reduce
   (fn [session phase]
     (if (keyword? phase)
       (update-in session [:phase-list] #(conj (or % []) phase))
       (let [phase-kw (keyword (name (gensym "phase")))]
         (->
          session
          (assoc-in [:inline-phases phase-kw] phase)
          (update-in [:phase-list] conj phase-kw)))))
   (dissoc session :phase-list)
   (:phase-list session)))
(defn- group-spec-with-count
  "Take the given group-spec, and set the :count key to the value specified
   by `count`"
  [[group-spec count]]
  (assoc group-spec :count count))
(defn- node-set-for-converge
  "Takes the input, and translates it into a sequence of group-spec's.
   The input can be a single group-spec, a map from group-spec to node count,
   or a sequence of group-spec's"
  [group-spec->count]
  (cond
   ;; a single group-spec
   (and
    (map? group-spec->count)
    (:group-name group-spec->count)) [group-spec->count]
   ;; a map from group-spec to count
   (map? group-spec->count) (map group-spec-with-count group-spec->count)
   :else group-spec->count))
(defn converge
  "Converge the existing compute resources with the counts specified in
   `group-spec->count`. New nodes are started, or nodes are destroyed,
   to obtain the specified node counts.
   `group-spec->count` can be a map from group-spec to node count, or can be a
   sequence of group-specs containing a :count key.
   The compute service may be supplied as an option, otherwise the bound
   compute-service is used.
   This applies the bootstrap phase to all new nodes and the configure phase to
   all running nodes whose group-name matches a key in the node map.  Additional
   phases can also be specified in the options, and will be applied to all
   matching nodes.  The :configure phase is always applied, by default as the
   first (post bootstrap) phase.  You can change the order in which
   the :configure phase is applied by explicitly listing it.
   An optional group-name prefix may be specified. This will be used to modify
   the group-name for each group-spec, allowing you to build multiple discrete
   clusters from a single set of group-specs."
  [group-spec->count & {:keys [compute blobstore user phase prefix middleware
                               all-nodes all-node-set environment]
                        :as options}]
  (converge*
   (->
    options
    (assoc :node-set (expand-group-spec-with-counts group-spec->count)
           :phase-list (if (sequential? phase)
                         phase
                         (if phase [phase] [:configure])))
    check-arguments-map
    session-with-environment
    identify-anonymous-phases)))
(defn lift
  "Lift the running nodes in the specified node-set by applying the specified
   phases.  The compute service may be supplied as an option, otherwise the
   bound compute-service is used.  The configure phase is applied by default
   unless other phases are specified.
   node-set can be a node type, a sequence of node types, or a map
   of node type to nodes. Examples:
              [node-type1 node-type2 {node-type #{node1 node2}}]
              node-type
              {node-type #{node1 node2}}
   options can also be keywords specifying the phases to apply, or an immediate
   phase specified with the phase macro, or a function that will be called with
   each matching node.
   Options:
    :compute         a jclouds compute service
    :compute-service a map of :provider, :identity, :credential, and
                     optionally :extensions for constructing a jclouds compute
                     service.
    :phase           a phase keyword, phase function, or sequence of these
    :middleware      the middleware to apply to the configuration pipeline
    :prefix          a prefix for the group-name names
    :user            the admin-user on the nodes"
  [node-set & {:keys [compute phase prefix middleware all-node-set environment]
               :as options}]
  (lift*
   (->
    options
    (assoc :node-set (expand-cluster-groups node-set)
           :phase-list (if (sequential? phase)
                         phase
                         (if phase [phase] [:configure])))
    check-arguments-map
    (dissoc :phase)
    session-with-environment
    identify-anonymous-phases)))

Cluster operations

(defn cluster-groups
  "Return the groups in the passed cluster or sequence of clusters."
  [cluster]
  (if (seq? cluster)
    (mapcat :groups cluster)
    (:groups cluster)))
(defn converge-cluster
  "Converge the specified cluster. As for `converge`, but takes a cluster-spec
   or sequence of cluster-specs."
  [cluster & options]
  (apply converge (cluster-groups cluster) options))
(defn lift-cluster
  "Lift the specified cluster.  As for `lift`, but takes a cluster-spec
   or sequence of cluster-specs."
  [cluster & options]
  (apply lift (cluster-groups cluster) options))
(defn destroy-cluster
  "Destroy the specified cluster. As for `converge`, but takes a cluster-spec
   or sequence of cluster-specs."
  [cluster & options]
  (apply converge (map #(assoc % :count 0) (cluster-groups cluster)) options))
 

Crate for working with network services

(ns pallet.crate.network-service
  (:require
   [pallet.action.exec-script :as exec-script]
   [pallet.script.lib :as lib]))
(defn wait-for-port-listen
  "Wait for the network port `port` to be in a listening state.
   Options:
   - :standoff      time between checking port state (seconds)
   - :max-retries   number of times to test port state before erroring
   - :service-name  name of service to use in messages (defaults to port)"
  [session port & {:keys [max-retries standoff service-name]
                   :or {max-retries 5 standoff 2
                        service-name (str "port " port)}}]
  (->
   session
   (exec-script/exec-checked-script
    (format "Wait for %s to be in a listen state" service-name)
    (group (chain-or (let x 0) true))
    (while
        (pipe (netstat -lnt) (awk ~(format "'$4 ~ /:%s$/ {exit 1}'" port)))
      (let x (+ x 1))
      (if (= ~max-retries @x)
        (do
          (println
           ~(format "Timed out waiting for listen state for %s" service-name)
           >&2)
          (~lib/exit 1)))
      (println ~(format "Waiting for %s to be in a listen state" service-name))
      (sleep ~standoff))
    (sleep ~standoff))))
(defn wait-for-http-status
  "Wait for a url to respond with the given HTTP status code.
   Options:
   - :standoff      time between checking HTTP status (seconds)
   - :max-retries   number of times to test HTTP status before erroring
   - :url-name      name of url to use in messages (defaults to url)"
  [session url status & {:keys [max-retries standoff url-name cookie]
                         :or {max-retries 5 standoff 2
                              url-name url}}]
  (->
   session
   (exec-script/exec-checked-script
    (format "Wait for %s to return a %s status" url-name status)
    (if (~lib/has-command? wget)
      (defn httpresponse []
        (pipe
         ("wget" -q -S -O "/dev/null"
          ~(if cookie (str "--header " (format "'Cookie: %s'" cookie)) )
          (quoted ~url) "2>&1")
         ("grep" "HTTP/1.1")
         ("tail" -1)
         ("grep" -o -e (quoted "[0-9][0-9][0-9]"))))
      (if (~lib/has-command? curl)
        (defn httpresponse []
          ("curl" -sL -w (quoted "%{http_code}")
           ~(if cookie (str "-b '" cookie "'") )
           (quoted ~url)
           -o "/dev/null"))
        (do
          (println "No httpresponse utility available")
          (~lib/exit 1))))
    (group (chain-or (let x 0) true))
    (while
        (!= ~status @(httpresponse))
      (let x (+ x 1))
      (if (= ~max-retries @x)
        (do
          (println
           ~(format
             "Timed out waiting for %s to return a %s status" url-name status)
           >&2)
          (~lib/exit 1)))
      (println ~(format "Waiting for %s to return a %s status" url-name status))
      (sleep ~standoff))
    (sleep ~standoff))))
(defn wait-for-port-response
  "Wait for a port to respond to a message with a given response regex.
   Options:
   - :host          host to check (defaults to localhost)
   - :timeout       time to wait for a response (default 2 secs)
   - :standoff      time between checking HTTP status (seconds)
   - :max-retries   number of times to test HTTP status before erroring
   - :service-name  name of service to use in messages (defaults to port)"
  [session port message response-regex
   & {:keys [host timeout max-retries standoff service-name]
      :or {host "localhost" max-retries 5 standoff 2 timeout 2
           service-name (str "port " port)}}]
  (->
   session
   (exec-script/exec-checked-script
    (format
     "Wait for %s to return a response %s to message %s"
     service-name response-regex message)
    (group (chain-or (let x 0) true))
    (while
        (! (pipe (println (quoted ~message))
                 ("nc" -q ~timeout ~host ~port)
                 ("grep" -E (quoted ~response-regex))))
      (let x (+ x 1))
      (if (= ~max-retries @x)
        (do
          (println
           ~(format
             "Timed out waiting for %s to return response %s"
             service-name response-regex)
           >&2)
          (~lib/exit 1)))
      (println
       ~(format
         "Waiting for %s to return response %s" service-name response-regex))
      (sleep ~standoff))
    (sleep ~standoff))))
 

Helpers for debugging.

(ns pallet.debug
  (:require
   [clojure.tools.logging :as logging]))
(defn log-session
  "A crate function that will log the session map at the debug level, using
   the supplied format string.
       (log-session session \"The session is %s\")"
  ([session]
     (log-session session "%s"))
  ([session format-string]
     (logging/debug (format format-string (pr-str session)))
     session))
(defn print-session
  "A crate function that will print the session map to *out*, using the supplied
   format string.
       (print-session session \"The session is %s\")"
  ([session]
     (print-session session "%s"))
  ([session format-string]
     (println (format format-string (pr-str session)))
     session))
 

Wrappers for enlive to enable template specialisation and use xml.

(ns pallet.enlive
  (:use
   [pallet.template :only [find-template]]
   clojure.tools.logging)
  (:require
   [net.cgrand.enlive-html :as enlive]))
(defn elt
 ([tag] (elt tag nil))
 ([tag attrs & content]
   {:tag tag
    :attrs attrs
    :content content}))
(defmacro transform-nodes
  [[nodes] & forms]
  `(enlive/flatmap (enlive/transformation ~@forms) ~nodes))
(defmacro deffragment
  [name args & forms]
  `(defn ~name ~args
     (fn [nodes#] (enlive/at nodes# ~@forms))))
(def memo-xml-resource
     (memoize
      (fn [source session]
        (if-let [source (find-template source session)]
          (enlive/xml-resource source)
          (error
           (format
            "No template found for %s %s"
            source (-> session :server :tag)))))))
(defmacro defsnippet
  "A snippet returns a collection of nodes."
  [name source session args & forms]
  `(defn ~name ~args
    (if-let [nodes# (memo-xml-resource ~source ~session)]
      (enlive/at nodes# ~@forms))))
(defmacro xml-template
  "A template returns a seq of string:
   Overridden from enlive to defer evaluation of the source until runtime, and
   to enable specialisation on node-type"
  [source session args & forms]
  `(comp enlive/emit*
         (fn ~args
           (if-let [nodes# (memo-xml-resource ~source ~session)]
             (enlive/flatmap (enlive/transformation ~@forms) nodes#)))))
(defn xml-emit
  "Emit a template, adding an XML Declaration."
  [f & args]
  (str "<?xml version='1.0' encoding='utf-8'?>\n"
       (apply str (apply f args))))
(defmacro transform-if [expr transform]
  `(if ~expr ~transform identity))
(defmacro transform-if-let [binding transform]
  `(if-let ~binding ~transform identity))
 

The environment provide a mechanism for customising pallet and pallet crates according to some externally determined criteria.

An environment can be specified at the global, service, invocation and tag scopes.

To provide a global default, specify an :environment key at the top level of defpallet in ~/.pallet/config.clj.

To provide a service spevific default, specify an :environment key at the service level of defpallet in ~/.pallet/config.clj.

To provide a project specific default, define pallet.config/environment.

To provide a specific environment when invoking lift or converge, pass an environment map using the :environment key.

The merging of values between scopes is key specific, and is determined by merge-key-algorithm.

(ns pallet.environment
  "The environment provide a mechanism for customising pallet and
   pallet crates according to some externally determined criteria.
   An environment can be specified at the global, service, invocation and tag
   scopes.
   To provide a global default, specify an :environment key at the top level
   of `defpallet` in `~/.pallet/config.clj`.
   To provide a service spevific default, specify an :environment key at the
   service level of `defpallet` in `~/.pallet/config.clj`.
   To provide a project specific default, define `pallet.config/environment`.
   To provide a specific environment when invoking lift or converge, pass an
   environment map using the `:environment` key.
   The merging of values between scopes is key specific, and is determined by
   `merge-key-algorithm`."
  (:require
   [pallet.common.deprecate :as deprecate]
   [pallet.execute :as execute]
   [pallet.map-merge :as map-merge]
   [pallet.utils :as utils]
   [clojure.tools.logging :as logging]
   [clojure.walk :as walk])
  (:use
   [clojure.core.incubator :only [-?>]]))

slingshot version compatibility

(try
  (use '[slingshot.slingshot :only [throw+]])
  (catch Exception _
    (use '[slingshot.core :only [throw+]])))
(defprotocol Environment
  "A protocol for accessing an environment."
  (environment [_] "Returns an environment map"))
(def
  ^{:doc
    "Map from key to merge algorithm. Specifies how environments are merged."}
  merge-key-algorithm
  {:phases :merge-comp
   :user :merge
   :image :merge
   :compute :replace
   :blobstore :replace
   :count :merge
   :algorithms :merge
   :executor :merge
   :middleware :replace
   :groups :merge-environments
   :tags :merge-environments})
(def ^{:doc "node specific environment keys"}
  node-keys [:image :phases])
(def standard-pallet-keys (keys merge-key-algorithm))
(def user-keys-to-shell-expand [:public-key-path :private-key-path])
(defn merge-environments
  "Returns a map that consists of the rest of the maps conj-ed onto
  the first.  If a key occurs in more than one map, the mapping(s)
  from the latter (left-to-right) will be combined with the mapping in
  the result by calling (merge-key key val-in-result val-in-latter)."
  [& maps]
  (apply map-merge/merge-keys merge-key-algorithm maps))
(defmethod map-merge/merge-key :merge-environments
  [key val-in-result val-in-latter]
  (merge-environments val-in-result val-in-latter))
(defn- eval-phase
  "Evaluate a phase definition."
  [phase]
  (if (or (list? phase) (instance? clojure.lang.Cons phase))
    (eval phase)
    phase))
(defn- eval-phases
  "Evaluate a phase map.  This will attempt to require any namespaces mentioned
   and will then read each phase definition."
  [phases]
  (walk/postwalk
   #(do
      (when (symbol? %)
        (when-let [n (namespace %)]
          (utils/find-var-with-require %)))
      %)
   phases)
  (zipmap (keys phases) (map eval-phase (vals phases))))
(defn- eval-algorithms
  "Evaluate an algorithm map.  This will attempt to require any namespaces
   mentioned and will then lookup each symbol to retrieve the specified
   var."
  [algorithms]
  (walk/postwalk
   #(or
     (when (and (symbol? %) (namespace %))
       (utils/find-var-with-require %))
      %)
   algorithms))
(defn shell-expand-keys
  "Shell expand the values matching the specified keys"
  [user-map keys]
  (reduce
   (fn [m kwd]
     (if (kwd m)
       (update-in m [kwd] execute/local-script-expand)
       m))
   user-map keys))
(defn eval-environment
  "Evaluate an environment literal.  This is used to replace certain keys with
   objects constructed from the map of values provided.  The keys that are
   evaluated are:
   - :user
   - :phases
   - :algorithms"
  [env-map]
  (let [env-map (if-let [user (shell-expand-keys
                               (:user env-map) user-keys-to-shell-expand)]
                  (if-let [username (:username user)]
                    (assoc
                        env-map :user
                        (apply
                         utils/make-user username (mapcat identity user)))
                    env-map)
                  env-map)
        env-map (if-let [phases (:phases env-map)]
                  (if (every? fn? (vals phases))
                    env-map
                    (assoc env-map :phases (eval-phases phases)))
                  env-map)
        env-map (if-let [algorithms (:algorithms env-map)]
                  (if (every? fn? (vals algorithms))
                    env-map
                    (assoc env-map :algorithms (eval-algorithms algorithms)))
                  env-map)]
    env-map))
(defn get-for
  "Retrieve the environment value at the path specified by keys.
   When no default value is specified, then raise a :environment-not-found if no
   environment value is set.
       (get-for {:p {:a {:b 1} {:d 2}}} [:p :a :d])
         => 2"
  ([session keys]
     (let [result (get-in (:environment session) keys ::not-set)]
       (when (= ::not-set result)
         (throw+
          {:type :environment-not-found
           :message (format
                     "Could not find keys %s in session :environment"
                     (if (sequential? keys) (vec keys) keys))
           :key-not-set keys}))
       result))
  ([session keys default]
     (get-in (:environment session) keys default)))
(defn session-with-environment
  "Returns an updated `session` map, containing the keys for the specified
   `environment` map.
   When session includes a :server value, then the :server value is
   treated as an environment, and merge with any environment in the
   `environment`'s :groups key.
   The node-specific environment keys are :images and :phases."
  [session environment]
  (when (:tags environment)
    (deprecate/warn
     (str "Use of :tags key in the environment is deprecated. "
          "Please change to use :groups.")))
  (let [group (or (-> session :server :group-name)
                  (-> session :group :group-name))
        session (merge
                 session
                 (merge-environments
                  (->
                   environment
                   (select-keys standard-pallet-keys)
                   (utils/dissoc-keys (conj node-keys :groups :tags)))
                  (when group
                    (->
                     (-> environment :groups group)
                     (select-keys standard-pallet-keys)
                     (utils/dissoc-keys (conj node-keys :groups :tags))))))
        session (assoc-in session [:environment]
                          (utils/dissoc-keys environment node-keys))
        session (if (:server session)
                  (let [group (-> session :server :group-name)]
                    (assoc session
                      :server (merge-environments
                               (:server session)
                               (select-keys environment node-keys)
                               (-?> environment :tags group) ; deprecated
                               (-?> environment :groups group))))
                  session)
        session (if (:group session)
                  (let [group (-> session :group :group-name)]
                    (assoc session
                      :group (merge-environments
                              (:group session)
                              (select-keys environment node-keys)
                              (-?> environment :tags group) ; deprecated
                              (-?> environment :groups group))))
                  session)]
    session))
 

Exectute commands. At the moment the only available transport is ssh.

(ns pallet.execute
  (:require
   [pallet.common.filesystem :as filesystem]
   [pallet.common.shell :as shell]
   [pallet.compute :as compute]
   [pallet.compute.jvm :as jvm]
   [pallet.script :as script]
   [pallet.script.lib :as lib]
   [pallet.stevedore :as stevedore]
   [pallet.stevedore.bash :as bash]
   [pallet.utils :as utils]
   [clj-ssh.ssh :as ssh]
   [clojure.string :as string]
   [clojure.java.io :as io]
   [pallet.shell :as ccshell]
   [clojure.tools.logging :as logging]))

slingshot version compatibility

(try
  (use '[slingshot.slingshot :only [throw+]])
  (catch Exception _
    (use '[slingshot.core :only [throw+]])))
(def prolog
  (str "#!/usr/bin/env bash\n" bash/hashlib))
(defn- normalise-eol
  "Convert eol into platform specific value"
  [#^String s]
  (string/replace s #"[\r\n]+" (str \newline)))
(defn- strip-sudo-password
  "Elides the user's password or sudo-password from the given ssh output."
  [#^String s user]
  (string/replace
   s (format "\"%s\ (or (:password user) (:sudo-password user))) "XXXXXXX"))
(script/defscript sudo-no-password [])
(script/defimpl sudo-no-password :default []
  ("/usr/bin/sudo" -n))
(script/defimpl sudo-no-password
  [#{:centos-5.3 :os-x :darwin :debian :fedora}]
  []
  ("/usr/bin/sudo"))
(defn sudo-cmd-for
  "Construct a sudo command prefix for the specified user."
  [user]
  (if (or (= (:username user) "root") (:no-sudo user))
    "/bin/bash "
    (if-let [pw (:sudo-password user)]
      (str "echo \ (or (:password user) pw) "\" | /usr/bin/sudo -S ")
      (str (stevedore/script (~sudo-no-password)) " "))))
(def
  ^{:doc "Specifies the buffer size used to read the ssh output stream.
    Defaults to 10K, to match clj-ssh.ssh/*piped-stream-buffer-size*"}
  ssh-output-buffer-size (atom (* 1024 10)))
(def
  ^{:doc "Specifies the polling period for retrieving ssh command output.
    Defaults to 1000ms."}
  output-poll-period (atom 1000))

local script execution

(defn local-cmds
  "Run local cmds on a target."
  [#^String commands]
  (let [execute (fn [cmd] ((second cmd)))
        rv (doall (map execute (filter #(= :origin (first %)) commands)))]
    rv))
(defn read-buffer [stream]
  (let [buffer-size @ssh-output-buffer-size
        bytes (byte-array buffer-size)
        sb (StringBuilder.)]
    {:sb sb
     :reader (fn []
               (when (pos? (.available stream))
                 (let [num-read (.read stream bytes 0 buffer-size)
                       s (normalise-eol (String. bytes 0 num-read "UTF-8"))]
                   (logging/infof "Output:\n%s" s)
                   (.append sb s)
                   s)))}))
(defn sh-script
  "Run a script on local machine."
  [command]
  (logging/tracef "sh-script %s" command)
  (let [tmp (java.io.File/createTempFile "pallet" "script")]
    (try
      (io/copy (str prolog command) tmp)
      (ccshell/sh "chmod" "+x" (.getPath tmp))
      (let [{:keys [out err proc]} (ccshell/sh
                                    "bash" (.getPath tmp) :async true)
            out-reader (read-buffer out)
            err-reader (read-buffer err)
            period @output-poll-period
            read-out #(let [out ((:reader out-reader))]
                        (when (not (string/blank? out))
                          (logging/spy out))
                        out)
            read-err #(let [err ((:reader err-reader))]
                        (when (not (string/blank? err))
                          (logging/spy err))
                        err)]
        (with-open [out out err err]
          (while (not (try (.exitValue proc)
                           (catch IllegalThreadStateException _)))
            (Thread/sleep period)
            (read-out)
            (read-err))
          (while (read-out))
          (while (read-err))
          (let [exit (.exitValue proc)]
            (when-not (zero? exit)
              (logging/errorf
               "Command failed: %s\n%s"
               command (str (:sb err-reader))))
            {:exit exit
             :out (str (:sb out-reader))
             :err (str (:sb err-reader))})))
      (finally  (.delete tmp)))))
(defmacro local-script
  "Run a script on the local machine, setting up stevedore to produce the
   correct target specific code"
  [& body]
  `(script/with-script-context
     [(jvm/os-family)]
     (stevedore/with-script-language :pallet.stevedore.bash/bash
       (sh-script
        (stevedore/script
         ~@body)))))
(defn local-script-expand
  "Expand a script expression."
  [expr]
  (string/trim (:out (local-script (echo ~expr)))))
(defn verify-sh-return
  "Verify the return code of a sh execution"
  [msg cmd result]
  (if (zero? (:exit result))
    result
    (assoc result
      :error {:message (format
                        "Error executing script %s\n :cmd %s :out %s\n :err %s"
                        msg cmd (:out result) (:err result))
              :type :pallet-script-excution-error
              :script-exit (:exit result)
              :script-out  (:out result)
              :script-err (:err result)
              :server "localhost"})))
(defmacro local-checked-script
  "Run a script on the local machine, setting up stevedore to produce the
   correct target specific code.  The return code is checked."
  [msg & body]
  `(script/with-template
     [(jvm/os-family)]
     (let [cmd# (stevedore/checked-script ~msg ~@body)]
       (verify-sh-return ~msg cmd# (sh-script cmd#)))))

(defn local-sh-cmds "Execute cmds for the session. Runs locally as the current user, so useful for testing." [{:keys [root-path] :or {root-path "/tmp/"} :as session}] (if (seq (action-plan/get-for-target session)) (letfn [(execute-bash [cmdstring] (logging/infof "Cmd %s" cmdstring) (sh-script cmdstring)) (transfer [transfers] (logging/infof "Local transfer") (doseq [[from to] transfers] (logging/infof "Copying %s to %s" from to) (io/copy (io/file from) (io/file to))))] (action-plan/execute-for-target session {:script/bash execute-bash :fn/clojure (fn [& _]) :transfer/to-local transfer :transfer/from-local transfer})) [nil session]))

ssh

(defonce default-agent-atom (atom nil))
(defn default-agent
  []
  (or @default-agent-atom
      (swap! default-agent-atom
             (fn [agent]
               (if agent
                 agent
                 (ssh/create-ssh-agent false))))))
(defn possibly-add-identity
  [agent private-key-path passphrase]
  (if passphrase
    (ssh/add-identity agent private-key-path passphrase)
    (ssh/add-identity-with-keychain agent private-key-path)))
(defn- ssh-mktemp
  "Create a temporary remote file using the `ssh-session` and the filename
  `prefix`"
  [ssh-session prefix]
  (let [result (ssh/ssh
                ssh-session
                (stevedore/script (println (~lib/make-temp-file ~prefix)))
                :return-map true)]
    (if (zero? (:exit result))
      (string/trim (result :out))
      (throw+
       {:type :remote-execution-failure
        :message (format
                  "Failed to generate remote temporary file %s" (:err result))
        :exit (:exit result)
        :err (:err result)
        :out (:out result)}))))
(defn remote-sudo-cmd
  "Execute remote command.
   Copies `command` to `tmpfile` on the remote node using the `sftp-channel`
   and executes the `tmpfile` as the specified `user`."
  [server ssh-session sftp-channel user tmpfile command
   {:keys [pty] :or {pty true} :as options}]
  (when (not (ssh/connected? ssh-session))
    (throw+ {:type :no-ssh-session
             :message (format"No ssh session for %s" server)}))
  (let [response (ssh/sftp sftp-channel
                           :put (java.io.ByteArrayInputStream.
                                 (.getBytes
                                  (str prolog command \newline)))
                           tmpfile
                           :return-map true)
        response2 (ssh/sftp sftp-channel :ls)]
    (logging/infof
     "Transfering commands to %s:%s : %s" server tmpfile response))
  (let [chmod-result (ssh/ssh
                      ssh-session (str "chmod 755 " tmpfile) :return-map true)]
    (if (pos? (chmod-result :exit))
      (logging/error (str "Couldn't chmod script : "  (chmod-result :err)))))
  (let [cmd (str (sudo-cmd-for user) "./" tmpfile)
        _ (logging/infof "Running %s" cmd)
        [shell stream] (ssh/ssh
                        ssh-session
                        ;; using :in forces a shell ssh-session, rather than
                        ;; exec; some services check for a shell ssh-session
                        ;; before detaching (couchdb being one prime
                        ;; example)
                        :in cmd
                        :out :stream
                        :return-map true
                        :pty pty)
        sb (StringBuilder.)
        buffer-size @ssh-output-buffer-size
        period @output-poll-period
        bytes (byte-array buffer-size)
        read-ouput (fn []
                     (when (pos? (.available stream))
                       (let [num-read (.read stream bytes 0 buffer-size)
                             s (normalise-eol
                                (strip-sudo-password
                                 (String. bytes 0 num-read "UTF-8") user))]
                         (logging/infof "Output: %s\n%s" server s)
                         (.append sb s)
                         s)))]
    (while (ssh/connected? shell)
      (Thread/sleep period)
      (read-ouput))
    (while (read-ouput))
    (.close stream)
    (ssh/ssh ssh-session (str "rm " tmpfile))
    (let [exit (.getExitStatus shell)
          stdout (str sb)]
      (if (zero? exit)
        {:out stdout :exit exit}
        (do
          (logging/errorf "Exit status  : %s" exit)
          {:out stdout :exit exit
           :error {:message (format
                             "Error executing script :\n :cmd %s\n :out %s\n"
                             command stdout)
                   :type :pallet-script-excution-error
                   :script-exit exit
                   :script-out stdout
                   :server server}})))))
(defn remote-sudo
  "Run a sudo command on a server."
  [#^String server #^String command user {:keys [pty] :as options}]
  (ssh/with-ssh-agent [(default-agent)]
    (possibly-add-identity
     ssh/*ssh-agent* (:private-key-path user) (:passphrase user))
    (let [ssh-session (ssh/session server
                               :username (:username user)
                               :password (:password user)
                               :strict-host-key-checking :no)]
      (ssh/with-connection ssh-session
        (let [tmpfile (ssh-mktemp ssh-session "remotesudo")
              sftp-channel (ssh/ssh-sftp ssh-session)]
          (logging/infof "Cmd %s" command)
          (ssh/with-connection sftp-channel
            (remote-sudo-cmd
             server ssh-session sftp-channel user tmpfile command options)))))))
(defn remote-exec
  "Run an ssh exec command on a server."
  [#^String server #^String command user]
  (ssh/with-ssh-agent [(default-agent)]
    (possibly-add-identity
     ssh/*ssh-agent* (:private-key-path user) (:passphrase user))
    (let [ssh-session (ssh/session server
                               :username (:username user)
                               :password (:password user)
                               :strict-host-key-checking :no)]
      (ssh/with-connection ssh-session
        (logging/infof "Exec %s" command)
        (ssh/ssh-exec ssh-session command nil "UTF-8" nil)))))
(defn- ensure-ssh-connection
  "Try ensuring an ssh connection to the server specified in the session."
  [session]
  (let [{:keys [server port user ssh-session sftp-channel tmpfile tmpcpy]
         :as ssh} (:ssh session)]
    (when-not
        (and server
             (if (string? server) (not (string/blank? server)) true)
             user)
      (throw+
       {:type :session-missing-middleware
        :message (str
                  "The session is missing server ssh connection details.\n"
                  "Add middleware to enable ssh.")}))
    (let [ssh-session (or ssh-session
                          (ssh/session
                           server
                           :username (:username user)
                           :strict-host-key-checking :no
                           :port port
                           :password (:password user)))
          _ (.setDaemonThread ssh-session true)
          _ (when-not (ssh/connected? ssh-session)
              (try
                (ssh/connect ssh-session)
                (catch Exception e
                  (throw+
                   {:type :pallet/ssh-connection-failure
                    :message (format
                              "ssh-fail: server %s, port %s, user %s, group %s"
                              server (or port 22) (:username user)
                              (-> session :server :group-name))
                    :cause e}))))
          tmpfile (or tmpfile (ssh-mktemp ssh-session "sudocmd"))
          tmpcpy (or tmpcpy (ssh-mktemp ssh-session "tfer"))
          sftp-channel (or sftp-channel (ssh/ssh-sftp ssh-session))
          _ (when-not (ssh/connected? sftp-channel) (ssh/connect sftp-channel))]
      (update-in session [:ssh] merge
                 {:ssh-session ssh-session
                  :tmpfile tmpfile
                  :tmpcpy tmpcpy
                  :sftp-channel sftp-channel}))))
(defn- close-ssh-connection
  "Close any ssh connection to the server specified in the session."
  [[results session flag]]
  (let [{:keys [ssh-session sftp-channel tmpfile tmpcpy]
         :as ssh} (:ssh session)]
    (if ssh
      (do
        (when sftp-channel
          ;; remove tmpfile, tmpcpy
          (ssh/disconnect sftp-channel))
        (when ssh-session
          (ssh/disconnect ssh-session))
        [results (dissoc session :ssh) flag])
      [results session flag])))
(defmacro with-ssh-tunnel
  "Execute the body with an ssh-tunnel available for the ports given in the
   tunnels map. Automatically closes port forwards on completion.
   Tunnels should be a map from local ports (integers) to either
     1) An integer remote port. Remote host is assumed to be \"localhost\".
     2) A vector of remote host and remote port. eg, [\"yahoo.com\" 80].
   e.g.
        (with-ssh-tunnel session {2222 22}
           ;; do something on local port 2222
           session)"
  [session tunnels & body]
  `(let [~session (#'ensure-ssh-connection ~session)
         ssh-session# (-> ~session :ssh :ssh-session)
         tunnels# ~tunnels
         unforward# (fn []
                      (doseq [[lport# _#] tunnels#]
                        (try
                          (.delPortForwardingL ssh-session# lport#)
                          (catch com.jcraft.jsch.JSchException e#
                            (logging/warnf
                             "Removing Port forward to %s failed: %s"
                             lport# (.getMessage e#))))))]
     (try
       ;; Set up the port forwards
       (doseq [[lport# rspec#] tunnels#
               :let [[rhost# rport#] (if (sequential? rspec#)
                                       rspec#
                                       ["localhost" rspec#])]]
         (.setPortForwardingL ssh-session# lport# rhost# rport#))
       ~@body
       (finally (unforward#)))))

executor functions

(defn bash-on-origin
  "Execute a bash action on the origin"
  [session f]
  (let [{:keys [value session]} (f session)
        result (sh-script value)]
    (logging/infof "Origin cmd\n%s" value)
    (verify-sh-return "for origin cmd" value result)
    [result session]))
(defn transfer-on-origin
  "Transfer files on origin by copying"
  [session f]
  (let [{:keys [value session]} (f session)]
    (logging/info "Local transfer")
    (doseq [[from to] value]
      (logging/infof "Copying %s to %s" from to)
      (io/copy (io/file from) (io/file to)))
    [value session]))
(defn clojure-on-origin
  "Execute a clojure function on the origin"
  [session f]
  (let [{:keys [value session]} (f session)]
    [value session]))
(defn ssh-bash-on-target
  "Execute a bash action on the target via ssh."
  [session f]
  (let [{:keys [ssh] :as session} (ensure-ssh-connection session)
        {:keys [server ssh-session sftp-channel tmpfile tmpcpy user]} ssh
        {:keys [value session]} (f session)]
    (logging/infof "Target %s cmd\n%s" server value)
    [(remote-sudo-cmd server ssh-session sftp-channel user tmpfile value {})
     session]))
(defn- ssh-upload
  "Upload a file to a remote location via sftp"
  [tmpcpy file server ssh-session sftp-channel user tmpfile remote-name]
  (logging/infof
   "Transferring %s to %s:%s via %s" file server remote-name tmpcpy)
  (ssh/sftp
   sftp-channel
   :put (-> file java.io.FileInputStream. java.io.BufferedInputStream.)
   tmpcpy)
  (remote-sudo-cmd
   server ssh-session sftp-channel user tmpfile
   (stevedore/script
    (chmod "0600" ~tmpcpy)
    (mv -f ~tmpcpy ~remote-name))
   {}))
(defn ssh-from-local
  "Transfer a file from the origin machine to the target via ssh."
  [session f]
  (let [{:keys [ssh] :as session} (ensure-ssh-connection session)
        {:keys [server ssh-session sftp-channel tmpfile tmpcpy user]} ssh
        {:keys [value session]} (f session)]
    (doseq [[file remote-name] value
            :let [remote-md5-name (-> remote-name
                                      (string/replace #"\.new$" ".md5")
                                      (string/replace #"-content$" ".md5"))]]
      (logging/debugf "Remote file %s:%s from" server remote-md5-name file)
      (let [md5 (try
                  (filesystem/with-temp-file [md5-copy]
                    (ssh/sftp
                     sftp-channel
                     :get
                     remote-md5-name
                     (.getPath md5-copy))
                    (slurp md5-copy))
                  (catch Exception _ nil))]
        (if md5
          (filesystem/with-temp-file [local-md5-file]
            (logging/debugf "Calculating md5 for %s" file)
            (local-script
             ((~lib/md5sum ~file) ">" ~(.getPath local-md5-file))
             (~lib/normalise-md5 ~(.getPath local-md5-file)))
            (let [local-md5 (slurp local-md5-file)]
              (logging/debugf "md5 check - remote: %s local: %s" md5 local-md5)
              (if (not=
                   (first (string/split md5 #" "))
                   (first (string/split local-md5 #" ")) )
                (ssh-upload
                 tmpcpy file server ssh-session sftp-channel user tmpfile
                 remote-name)
                (logging/infof "%s:%s is already up to date" server remote-name))))
          (ssh-upload
           tmpcpy file server ssh-session sftp-channel user tmpfile
           remote-name))))
    [value session]))
(defn ssh-to-local
  "Transfer a file from the origin machine to the target via ssh."
  [session f]
  (let [{:keys [ssh] :as session} (ensure-ssh-connection session)
        {:keys [server ssh-session sftp-channel tmpfile tmpcpy user]} ssh
        {:keys [value session]} (f session)]
    (doseq [[remote-file local-file] value]
      (logging/infof
       "Transferring file %s from node to %s" remote-file local-file)
      (remote-sudo-cmd
       server ssh-session sftp-channel user tmpfile
       (stevedore/script
        (cp -f ~remote-file ~tmpcpy))
       {})
      (ssh/sftp sftp-channel
                :get tmpcpy
                (-> local-file java.io.FileOutputStream.
                    java.io.BufferedOutputStream.)))
    [value session]))
(defn echo-bash
  "Echo a bash action. Do not execute."
  [session f]
  [(:value (f session)) session])
(defn echo-clojure
  "Echo a clojure action (which returns nil)"
  [session f]
  (let [{:keys [value session]} (f session)]
    [ session]))
(defn echo-transfer
  "echo transfer of files"
  [session f]
  (let [{:keys [value session]} (f session)]
    (logging/info "Local transfer")
    (doseq [[from to] value]
      (logging/infof "Copying %s to %s" from to))
    [value session]))

executor middleware

(defn execute-with-ssh
  "Execute cmds for the session. Also accepts an IP or hostname as address."
  [handler]
  (fn execute-with-ssh-fn [{:keys [target-type user] :as session}]
    (if (= :node target-type)
      (let [target-node (-> session :server :node)]
        (logging/infof
         "execute-with-ssh on %s %s"
         (compute/group-name target-node)
         (pr-str (compute/node-address target-node)))
        (ssh/with-ssh-agent [(default-agent)]
          (try
            (->
             session
             (assoc :ssh {:port (compute/ssh-port target-node)
                          :server (compute/node-address target-node)
                          :user user})
             (assoc-in [:executor :script/bash :target] ssh-bash-on-target)
             (assoc-in [:executor :transfer/to-local :origin] ssh-to-local)
             (assoc-in [:executor :transfer/from-local :origin] ssh-from-local)
             handler
             close-ssh-connection)
            (catch Exception e
              (logging/error
               e
               "Unexpected exception in execute-with-ssh: probable connection leak")
              (close-ssh-connection session)
              (throw e)))))
      (do
        (logging/infof "execute-with-ssh no-ssh for target-type %s" target-type)
        (handler session)))))
(defn execute-target-on-localhost
  "Execute cmds for target on the local machine"
  [handler]
  (fn execute-target-on-localhost-fn [{:keys [target-node user] :as session}]
    (->
     session
     (assoc-in [:executor :script/bash :target] bash-on-origin)
     (assoc-in [:executor :transfer/from-local :origin] transfer-on-origin)
     (assoc-in [:executor :transfer/to-local :origin] transfer-on-origin)
     handler)))
(defn execute-echo
  "Execute cmds for target on the local machine"
  [handler]
  (fn execute-target-on-localhost-fn [{:keys [target-node user] :as session}]
    (->
     session
     (assoc-in [:executor :script/bash :target] echo-bash)
     (assoc-in [:executor :script/bash :origin] echo-bash)
     (assoc-in [:executor :fn/clojure :target] echo-clojure)
     (assoc-in [:executor :fn/clojure :origin] echo-clojure)
     (assoc-in [:executor :transfer/from-local :origin] echo-transfer)
     (assoc-in [:executor :transfer/to-local :origin] echo-transfer)
     handler)))

other middleware

(defn ssh-user-credentials
  "Middleware to user the session :user credentials for SSH authentication."
  [handler]
  (fn [session]
    (let [user (:user session)]
      (logging/infof
       "Admin user %s %s" (:username user) (:private-key-path user))
      (possibly-add-identity
       (default-agent) (:private-key-path user) (:passphrase user)))
    (handler session)))
 

Pallet feature recognition.

A feature is implemented as a function within the pallet.feature namespace

(ns pallet.feature
  "Pallet feature recognition.
   A feature is implemented as a function within the pallet.feature namespace")
(defmacro has-feature?
  "Predicate to test for feature availability"
  [feature]
  (when-let [f (ns-resolve 'pallet.feature feature)]
    (f)))
 

Keep track of operations started by pallet

(ns pallet.futures
  (:require
   [clojure.stacktrace :as stacktrace]
   [clojure.tools.logging :as logging])
  (:import
   java.util.concurrent.CancellationException
   java.util.concurrent.ExecutionException
   java.util.concurrent.Future))
(def
  ^{:doc "Keep track of pending operations, so they can be cancelled."
    :private true}
  pending-futures (atom (list)))
(defn- remove-done
  "Remove all completed futures"
  [futures]
  (remove #(.isDone ^Future %1) futures))
(defn add
  "Add a sequence of futures to the list of pending operations. Returns
   its argument."
  [futures]
  (do
    (swap! pending-futures #(concat (remove-done %1) %2) futures)
    futures))
(defn cancel-all
  "Cancel all pending parallel operations"
  []
  (swap! pending-futures #(do (doseq [^Future f %] (.cancel f true)) '()))
  nil)
(defn deref-with-logging
  "Deref a future with logging, returning nil if exception thrown.
   `operation-label` appears in each log message generated."
  [f operation-label]
  (try
    @f
    (catch CancellationException e
      (logging/warnf "%s cancelled : %s" operation-label (.getMessage e)))
    (catch InterruptedException e
      (logging/warnf "%s interrupted" operation-label))
    (catch ExecutionException e
      (let [cause (stacktrace/root-cause e)]
        (logging/errorf
         cause "%s exception: %s" operation-label (.getMessage cause)))
      (logging/debugf (.getCause e) "%s exception" operation-label))))
 
(ns pallet.main
  (:gen-class)
  (:require
   [pallet.command-line :as command-line]
   [clojure.tools.logging :as logging]
   [clojure.stacktrace :as stacktrace]
   [clojure.walk :as walk]
   [clojure.string :as string]))
(def
  ^{:doc "An exception instance to use for terminating the task, without
          a stack trace"}
  exit-task-exception (Exception.))
(defn report-error
  "Report a message to *err*."
  [msg]
  (binding [*out* *err*]
    (println msg)))
(defn abort
  "Abort a task, with the specified error message, and no stack trace."
  [msg]
  (report-error msg)
  (throw exit-task-exception))
(defn read-targets
  ([dir]
     (try
      (doseq [file (file-seq dir)]
        (load (.getPath file)))
      (catch java.io.FileNotFoundException _
        (abort "No pallet directory found in the current directory."))))
  ([] (read-targets "pallet")))
(def aliases {"--help" "help" "-h" "help" "-?" "help" "-v" "version"
              "--version" "version"})
(defn resolve-task [task]
  (let [task-ns (symbol (str "pallet.task." task))
        task (symbol task)
        error-fn (with-meta
                   (fn [& _]
                     (abort
                      (format
                       "%s is not a task. Use \"help\" to list all tasks."
                       task)))
                   {:no-service-required true})]
    (try
      (when-not (find-ns task-ns)
        (require task-ns))
      (or (ns-resolve task-ns task)
          error-fn)
      (catch java.io.FileNotFoundException e
        error-fn))))
(defn parse-as-qualified-symbol
  "Convert the given string into a namespace qualified symbol.
   Returns a vector of ns and symbol"
  [arg]
  {:pre [(string? arg)]}
  (if (.contains arg "/")
    (if-let [sym (symbol arg)]
      [(symbol (namespace sym)) sym])))
(defn map-and-resolve-symbols
  "Function to build a symbol->value map, requiring namespaces as needed."
  [symbol-map arg]
  (if-let [[ns sym] (parse-as-qualified-symbol arg)]
    (do
      (try
        (require ns)
        (catch java.io.FileNotFoundException e
          (abort
           (format "Could not locate node definition for %s" arg))))
      (if-let [v (find-var sym)]
        (assoc symbol-map sym (var-get v))
        symbol-map))
    symbol-map))
(defn profiles
  [profiles-string]
  (when profiles-string
    (string/split profiles-string #",")))
(defn- report-unexpected-exception
  "Check the exception to see if it is the `exit-task-exception`, and if it is
   not, then report the exception."
  [^Throwable e]
  (when-not (= e exit-task-exception)
    (logging/error e "Exception")
    (report-error (.getMessage e))
    (binding [*out* *err*]
      (stacktrace/print-stack-trace
       (stacktrace/root-cause e)))))
(defn pallet-task
  "A pallet task.
   Returns an integer exit status suitable for System/exit."
  [args & {:keys [environment]}]
  (command-line/with-command-line args
    "Pallet command line"
    [[provider "Cloud provider name."]
     [identity "Cloud user name or key."]
     [credential "Cloud password or secret."]
     [blobstore-provider "Blobstore provider name."]
     [blobstore-identity "Blobstore user name or key."]
     [blobstore-credential "Blobstore password or secret."]
     [P "Profiles to use for key lookup in config.clj or settings.xml"]
     [project-options "Project options (usually picked up from project.clj)."]
     [defaults "Default options (usually picked up from config.clj)."]
     args]
    (try
      (let [[task & args] args
            task (or (aliases task) task "help")
            project-options (when project-options
                              (read-string project-options))
            defaults (when defaults
                       (read-string defaults))
            symbol-map (reduce map-and-resolve-symbols {} args)
            arg-line (str "[ " (apply str (interpose " " args)) " ]")
            params (read-string arg-line)
            params (clojure.walk/prewalk-replace symbol-map params)
            task (resolve-task task)
            return-value (if (:no-service-required (meta task))
                           (apply task params)
                           (let [_ (require 'pallet.main-invoker)
                                 invoker (find-var
                                          'pallet.main-invoker/invoke)]
                             (invoker
                              {:provider provider
                               :identity identity
                               :credential credential
                               :blobstore-provider blobstore-provider
                               :blobstore-identity blobstore-identity
                               :blobstore-credential blobstore-credential
                               :profiles (profiles P)
                               :project project-options
                               :defaults defaults
                               :environment environment}
                              task
                              params)))]
        (flush)
        (if (integer? return-value) return-value 0))
      (catch Exception e
        (report-unexpected-exception e)
        1))))
(defn -main
  "Command line runner."
  ([& args]
     (let [return-value (pallet-task args)]
       (shutdown-agents)
       (System/exit return-value)))
  ([] (apply -main *command-line-args*)))
 

Invoke tasks requiring a compute service. This decouples main from anything pallet, jclouds or maven specific, and ensures compiling main doesn't compile the world.

(ns pallet.main-invoker
  (:require
   [clojure.tools.logging :as logging]
   [pallet.blobstore :as blobstore]
   [pallet.compute :as compute]
   [pallet.configure :as configure]
   [pallet.environment :as environment]
   [pallet.utils :as utils]
   [pallet.main :as main]))
(defn log-info
  [admin-user]
  (logging/debugf "OS              %s %s"
                   (System/getProperty "os.name")
                   (System/getProperty "os.version"))
  (logging/debugf "Arch            %s" (System/getProperty "os.arch"))
  (logging/debugf "Admin user      %s" (:username admin-user))
  (let [private-key-path (:private-key-path admin-user)
        public-key-path (:public-key-path admin-user)]
    (logging/debugf
     "private-key-path %s %s"
     private-key-path (.canRead (java.io.File. private-key-path)))
    (logging/debugf
     "public-key-path %s %s"
     public-key-path (.canRead (java.io.File. public-key-path)))))
(defn find-admin-user
  "Return the admin user"
  [defaults project profiles]
  (or
   (configure/admin-user-from-config (:pallet project))
   (configure/admin-user-from-config defaults)
   (configure/admin-user-from-config-var)
   utils/*admin-user*))
(defn compute-service-from-config-files
  [defaults project profiles]
  (or
   (configure/compute-service-from-config (:pallet project) profiles)
   (configure/compute-service-from-config defaults profiles)))
(defn find-compute-service
  "Look for a compute service in the following sequence:
     Check pallet.config.service property
     check maven settings
     check pallet.config/service var.
   This sequence allows you to specify an overridable default in
   pallet.config/service."
  [options defaults project profiles]
  (or
   (configure/compute-service-from-map options)
   (when (seq profiles)
     (compute-service-from-config-files defaults project profiles))
   (configure/compute-service-from-property)
   (configure/compute-service-from-config-var)
   (compute-service-from-config-files defaults project profiles)))
(defn find-blobstore
  "Look for a compute service in the following sequence:
     Check pallet.config.service property
     check maven settings
     check pallet.config/service var.
   This sequence allows you to specify an overridable default in
   pallet.config/service."
  [options defaults project profiles]
  (or
   (configure/blobstore-from-map options)
   (configure/blobstore-from-config (:pallet project) profiles)
   (configure/blobstore-from-config defaults profiles)))
(defn invoke
  [options task params]
  (let [default-config (or (:defaults options) (configure/pallet-config))
        admin-user (find-admin-user
                    default-config (:project options) (:profiles options))
        compute (try
                  (find-compute-service
                   options default-config
                   (:project options) (:profiles options))
                  (catch IllegalArgumentException e
                    (let [msg (.getMessage e)]
                      (if (and
                           msg
                           (re-find #"provider .* not configured" msg))
                        (binding [*out* *err*]
                          (println msg)
                          (throw pallet.main/exit-task-exception))
                        (throw e)))))]
    (if compute
      (try
        (let [blobstore (find-blobstore
                         options default-config
                         (:project options) (:profiles options))]
          (try
            (log-info admin-user)
            (apply task
                   {:compute compute
                    :blobstore blobstore
                    :project (:project options)
                    :config default-config
                    :user admin-user
                    :environment
                    (pallet.environment/merge-environments
                     (:environment options)
                     (environment/environment compute))}
                   params)
            (finally ;; make sure we don't hang on exceptions
             (when blobstore
               (blobstore/close blobstore)))))
        (finally ;; make sure we don't hang on exceptions
         (compute/close compute)))
      (do
        (println "Error: no credentials supplied\n\n")
        ((main/resolve-task "help"))
        1))))
 

Map merging algorithms. Enables specification of merging function on a per key basis.

(ns pallet.map-merge
  (:require
   [clojure.set :as set]
   [pallet.common.map-utils :as map-utils]))
(defmulti merge-key
  "Merge function that dispatches on the map entry key"
  (fn [algorithms key val-in-result val-in-latter]
    (algorithms key :deep-merge)))
(defn merge-keys
  "Returns a map that consists of the rest of the maps conj-ed onto
  the first.  If a key occurs in more than one map, the mapping(s)
  from the latter (left-to-right) will be combined with the mapping in
  the result by calling:
    (merge-key key-algorithms key val-in-result val-in-latter)."
  [key-algorithms & maps]
  (when (some identity maps)
    (let [merge-entry (fn [m e]
                        (let [k (key e) v (val e)]
                          (if (contains? m k)
                            (assoc m k (merge-key key-algorithms k (get m k) v))
                            (assoc m k v))))
          merge2 (fn [m1 m2]
                   (reduce merge-entry (or m1 {}) (seq m2)))]
      (reduce merge2 maps))))
(defmethod merge-key :replace
  [_ _ val-in-result val-in-latter]
  val-in-latter)
(defmethod merge-key :merge
  [_ _ val-in-result val-in-latter]
  (merge val-in-result val-in-latter))
(defmethod merge-key :deep-merge
  [_ _ val-in-result val-in-latter]
  (let [map-or-nil? (fn [x] (or (nil? x) (map? x)))]
    (map-utils/deep-merge-with
     (fn deep-merge-env-fn [x y]
       (if (and (map-or-nil? x) (map-or-nil? y))
         (merge x y)
         (or y x)))
     val-in-result val-in-latter)))
(defmethod merge-key :merge-comp
  [_ _ val-in-result val-in-latter]
  (merge-with comp val-in-latter val-in-result))
(defmethod merge-key :merge-union
  [_ _ val-in-result val-in-latter]
  (set/union val-in-result val-in-latter))
 
(ns pallet.md5crypt
  (:import [java.security NoSuchAlgorithmException MessageDigest]))
(defonce salt-chars
  "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890")
(defonce itoa64
  "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
(defonce md5-magic "$1$")
(defonce apache-magic "$apr1$")
(defn to64
  "Return value encoded as n base64 chars"
  [#^Integer value #^Integer n]
  (if (pos? n)
    (str (.charAt itoa64 (int (bit-and value 0x3f)))
         (to64 (bit-shift-right value 6) (dec n)))))
(defn salt
  []
  (apply str (take 8 (repeatedly #(rand-nth itoa64)))))
(defn #^String clean-salt
  "Clean up a passed salt value"
  [#^String salt #^String magic]
  (let [salt (if (.startsWith salt magic)
                (.substring salt (.length magic))
                salt)
        salt (if (.contains salt "$")
               (.substring salt 0 (.indexOf salt "$"))
               salt)
        salt (if (> (.length salt) 8)
               (.substring salt 0 8)
               salt)]
    salt))
(defn set-array [#^bytes array #^Byte value]
  (dotimes [i (alength array)]
    (aset array i value))
  array)
(defn #^Integer byte-as-unsigned
  [b]
  (int (bit-and (int (byte b)) 0xff)))
(defn crypt
  "LINUX/BSD MD5Crypt function"
  ([password]
     (crypt password (salt) md5-magic))
  ([password salt]
     (crypt password salt md5-magic))
  ([#^String password #^String salt #^String magic]
     (let [salt (clean-salt salt magic)
           ctx (doto (MessageDigest/getInstance "md5")
                 (.update (.getBytes password))
                 (.update (.getBytes magic))
                 (.update (.getBytes salt)))
           ctx1 (doto (MessageDigest/getInstance "md5")
                  (.update (.getBytes password))
                  (.update (.getBytes salt))
                  (.update (.getBytes password)))
           final-state (.digest ctx1)]
       (loop [l (.length password)]
         (.update ctx final-state 0 (min l 16))
         (if (> l 16)
           (recur (int (- l 16)))))
       (set-array final-state (byte 0))
       (loop [i (.length password)]
         (when (pos? i)
           (if (pos? (bit-and i 1))
             (.update ctx final-state 0 1)
             (.update ctx (.getBytes password) 0 1))
           (recur (bit-shift-right i 1))))
       (let [#^bytes final-state (loop [final-state (.digest ctx)
                                i 0]
                           (if (< i 1000)
                             (let [ctx1 (MessageDigest/getInstance "md5")]
                               (if (pos? (bit-and i 1))
                                 (.update ctx1 (.getBytes password))
                                 (.update ctx1 final-state 0 16))
                               (if (pos? (mod i 3))
                                 (.update ctx1 (.getBytes salt)))
                               (if (pos? (mod i 7))
                                 (.update ctx1 (.getBytes password)))
                               (if (pos? (bit-and i 1))
                                 (.update ctx1 final-state 0 16)
                                 (.update ctx1 (.getBytes password)))
                               (recur (.digest ctx1) (inc i)))
                             final-state))]
         (str
          magic
          salt
          "$"
          (to64 (bit-or
                 (bit-or
                  (bit-shift-left (byte-as-unsigned (aget final-state 0)) 16)
                  (bit-shift-left (byte-as-unsigned (aget final-state 6)) 8))
                 (byte-as-unsigned (aget final-state 12)))
                4)
          (to64 (bit-or
                 (bit-or
                  (bit-shift-left (byte-as-unsigned (aget final-state 1)) 16)
                  (bit-shift-left (byte-as-unsigned (aget final-state 7)) 8))
                 (byte-as-unsigned (aget final-state 13)))
                4)
          (to64 (bit-or
                 (bit-or
                  (bit-shift-left (byte-as-unsigned (aget final-state 2)) 16)
                  (bit-shift-left (byte-as-unsigned (aget final-state 8)) 8))
                 (byte-as-unsigned (aget final-state 14)))
                4)
          (to64 (bit-or
                 (bit-or
                  (bit-shift-left (byte-as-unsigned (aget final-state 3)) 16)
                  (bit-shift-left (byte-as-unsigned (aget final-state 9)) 8))
                 (byte-as-unsigned (aget final-state 15)))
                4)
          (to64 (bit-or
                 (bit-or
                  (bit-shift-left (byte-as-unsigned (aget final-state 4)) 16)
                  (bit-shift-left (byte-as-unsigned (aget final-state 10)) 8))
                 (byte-as-unsigned (aget final-state 5)))
                4)
          (to64 (byte-as-unsigned (aget final-state 11)) 2))))))
 
(ns pallet.node)

Nodes

(defprotocol Node
  (ssh-port [node] "Extract the port from the node's userMetadata")
  (primary-ip [node] "Returns the first public IP for the node.")
  (private-ip [node] "Returns the first private IP for the node.")
  (is-64bit? [node] "64 Bit OS predicate")
  (group-name [node] "Returns the group name for the node.")
  (hostname [node] "TODO make this work on ec2")
  (os-family [node] "Return a node's os-family, or nil if not available.")
  (os-version [node] "Return a node's os-version, or nil if not available.")
  (running? [node] "Predicate to test if node is running.")
  (terminated? [node] "Predicate to test if node is terminated.")
  (id [node])
  (compute-service [node]
    "Return the service provider the node was provided by."))
(defn node?
  "Predicate to test whether an object implements the Node protocol"
  [obj]
  (instance? pallet.node.Node obj))
(defn tag [node] (group-name node))
(defn node-in-group? [group-name node]
  (= (clojure.core/name group-name) (pallet.node/group-name node)))
(defn node-address
  [node]
  (if (string? node)
    node
    (primary-ip node)))
 

Provides functions for working with parameters.

Parameters are data maps that allow propogation of information between the functions of a crate, and between crates. There are two conventions for using parameters in crates that are directly supported here.

Host specific parameters are specified under [:parameters :host (keyword target-id)] These functions are get-for-target, assoc-for-target, and update-for-target.

Service specific paramters, used across hosts, are specified under [:parameters :service (keyword service-name)] These functions are get-for-service, assoc-for-service, and update-for-service.

The get-for functions have slightly different semantics compared with clojure.core/get, in that they throw an exception if the key is undefined and no default value is specified.

Delayed evaluation of parameters specified as arguments to action functions are also implemented here. lookup and lookup-for-target.

(ns pallet.parameter
  "Provides functions for working with parameters.
   Parameters are data maps that allow propogation of information between the
   functions of a crate, and between crates. There are two conventions for using
   parameters in crates that are directly supported here.
   Host specific parameters are specified under
       [:parameters :host (keyword target-id)]
   These functions are `get-for-target`, `assoc-for-target`, and
   `update-for-target`.
   Service specific paramters, used across hosts, are specified under
      [:parameters :service (keyword service-name)]
   These functions are `get-for-service`, `assoc-for-service`, and
   `update-for-service`.
   The `get-for` functions have slightly different semantics compared with
   clojure.core/get, in that they throw an exception if the key is undefined
   and no default value is specified.
   Delayed evaluation of parameters specified as arguments to action functions
   are also implemented here. `lookup` and `lookup-for-target`.
"
  (:require
   [pallet.action :as action]
   [pallet.argument :as argument]
   [pallet.compute :as compute]))

slingshot version compatibility

(try
  (use '[slingshot.slingshot :only [throw+]])
  (catch Exception _
    (use '[slingshot.core :only [throw+]])))
(defn from-map
  "Initialise parameters based on the given keys, which are used to merge maps
   from m."
  [m keys]
  (reduce merge {} (map m keys)))
(defn get-for
  "Retrieve the parameter at the path specified by keys.
   When no default value is specified, then raise a :parameter-not-found if no
   parameter is set.
       (get-for {:p {:a {:b 1} {:d 2}}} [:p :a :d])
         => 2"
  ([session keys]
     {:pre [(map? session)]}
     (let [result (get-in (:parameters session) keys ::not-set)]
       (when (= ::not-set result)
         (let [found-keys (take-while
                           #(not=
                             (get-in (:parameters session) % ::not-set)
                             ::not-set)
                           (rest (reductions conj [] keys)))]
           (throw+
            {:type :parameter-not-found
             :message (format
                       (str
                        "Could not find keys %s in session :parameters. "
                        "Found keys %s with values %s")
                       (if (sequential? keys) (vec keys) keys)
                       (vec found-keys)
                       (if (seq found-keys)
                         (get-in (:parameters session) (vec found-keys))
                         (:parameters session)))
             :key-not-set keys})))
       result))
  ([session keys default]
       (get-in (:parameters session) keys default)))
(defn get-for-target
  "Retrieve the host parameter for the current target at the path specified by
   keys.  When no default value is specified, then raise a :parameter-not-found
   if no parameter is set.
       (get-for-target
         {:parameters {:host {:id1 {:a {:b 1} {:d 2}}}}
          :target-id :id1} [:a :b])
         => 1"
  ([session keys]
     (get-for session (concat [:host (-> session :server :node-id)] keys)))
  ([session keys default]
     (get-for
      session (concat [:host (-> session :server :node-id)] keys) default)))
(defn get-for-service
  "Retrieve the service parameter for the service and path specified by
   keys.  When no default value is specified, then raise a :parameter-not-found
   if no parameter is set.
       (get-for-service
         {:parameters {:service {:proxy {:a {:b 1} {:d 2}}}}} [:proxy :a :b])
         => 1"
  ([session keys]
     (get-for session (concat [:service] keys)))
  ([session keys default]
     (get-for session (concat [:service] keys) default)))
(defn get-node-settings
  "Retrieve the settings for the specified node facility. The instance-id allows
   the specification of specific instance of the facility. If passed a nil
   `instance-id`, then `:default` is used"
  [session node facility instance-id]
  (get-for
   session
   [:host (keyword (compute/id node)) facility (or instance-id :default)]))
(defn get-target-settings
  "Retrieve the settings for the specified host facility. The instance-id allows
   the specification of specific instance of the facility. If passed a nil
   `instance-id`, then `:default` is used"
  ([session facility instance-id]
     (get-for
      session
      [:host (-> session :server :node-id) facility (or instance-id :default)]))
  ([session facility instance-id default]
     (get-for
      session
      [:host (-> session :server :node-id) facility (or instance-id :default)]
      default)))
(defn- assoc-for-prefix
  "Set the values in a map at the paths specified with prefix prepended to each
   path.
       (assoc-for-prefix {} :prefix [:a :b] 1 [:a :d] 2)
         => {:prefix {:a {:b 1} {:d 2}}}"
  [session prefix {:as keys-value-pairs}]
  (reduce
   #(assoc-in %1 (concat prefix (first %2)) (second %2))
   session
   keys-value-pairs))
(defn assoc-for
  "Set the :parameters values at the paths specified.
       (assoc-for {} [:a :b] 1 [:a :d] 2)
         => {:parameters {:a {:b 1} {:d 2}}}"
  [session & {:as keys-value-pairs}]
  (assoc-for-prefix session [:parameters] keys-value-pairs))
(defn assoc-for-target
  "Set the host parameter values at the paths specified.
       (assoc-for-target {:target-id :id1} [:a :b] 1 [:a :d] 2)
         => {:parameters {:host {:id1 {:a {:b 1} {:d 2}}}}}"
  [session & {:as keys-value-pairs}]
  (assoc-for-prefix
   session [:parameters :host (-> session :server :node-id)] keys-value-pairs))
(defn assoc-for-service
  "Set the service parameter values at the paths specified.
       (assoc-for-service {} :proxy [:a :b] 1 [:a :d] 2)
         => {:parameters {:srvice {:proxy {:a {:b 1} {:d 2}}}}}"
  [session service & {:as keys-value-pairs}]
  (assoc-for-prefix
   session [:parameters :service service] keys-value-pairs))
(defn assoc-target-settings
  "Set the settings for the specified host facility. The instance-id allows
   the specification of specific instance of the facility (the default is
   :default)."
  [session facility instance-id values]
  (assoc-for
   session
   [:host (-> session :server :node-id) facility (or instance-id :default)]
   values))
(defn- update-for-prefix
  "Update a map at the path given by the prefix and keys.
   The value is set to the value return by calling f with the current
   value and the given args.
       (update-for-prefix {:p {:a {:b 1}}} [:p] [:a :b] + 2)
         => {:p {:a {:b 3}}}"
  ([session prefix keys f args]
  (apply update-in session (concat prefix keys) f args)))
(defn update-for
  "Update parameters at the path given by keys.
   The value is set to the value return by calling f with the current
   value and the given args.
       (update-for {:parameters {:a {:b 1}}} [:a :b] + 2)
         => {:parameters {:a {:b 3}}}"
  [session keys f & args]
  (update-for-prefix session [:parameters] keys f args))
(defn update-for-target
  "Update host parameters for the current target at the path given by keys.
   The value is set to the value return by calling f with the current
   value and the given args.
       (update-for-target
          {:parameters {:host {:id1 {:a {:b 1}}}}
           :target-id :id1}
          [:a :b] + 2)
         => {:parameters {:host {:id1 {:a {:b 3}}}}}"
  [session keys f & args]
  (update-for-prefix
   session [:parameters :host (-> session :server :node-id)] keys f args))
(defn update-for-service
  "Update serivce parameters for the pecified service at the path given by keys.
   The value is set to the value return by calling f with the current
   value and the given args.
       (update-for-service
          {:parameters {:service {:proxy {:a {:b 1}}}}}
          [:proxy :a :b] + 2)
         => {:parameters {:service {:proxy {:a {:b 3}}}}}"
  [session keys f & args]
  (update-for-prefix session [:parameters :service] keys f args))
(defn update-target-settings
  "Update the settings for the specified host facility. The instance-id allows
   the specification of specific instance of the facility (the default is
   :default)."
  [session facility instance-id f & args]
  (apply
   update-for
   session
   [:host (-> session :server :node-id) facility (or instance-id :default)]
   f args))

Delayed parameter evaluation

(deftype ParameterLookup
  [keys]
  pallet.argument.DelayedArgument
  (evaluate
   [_ session]
   (get-for session keys)))
(deftype ParameterLookupTarget
  [keys]
  pallet.argument.DelayedArgument
  (evaluate
   [_ session]
   (get-for session (concat [:host (-> session :server :node-id)] keys))))
(defn lookup
  "Lookup a parameter in a delayed manner. Use a call to this function as the
   argument of a action.
   This function produces an object, which causes parameter lookup when it's
   toString method is called.
   See also `pallet.argument`."
  [& keys]
  (ParameterLookup. keys))
(defn lookup-for-target
  "Lookup a parameter for the target in a delayed manner. Use a call to this
   function as the argument of a action.  This function produces an object,
   which causes parameter lookup when it's toString method is called.
   See also `pallet.argument`."
  [& keys]
  (ParameterLookupTarget. keys))

Actions

(action/def-clj-action parameters
  "An action to set parameters"
  [session & {:as keyvector-value-pairs}]
  (assoc session
    :parameters (reduce
                 #(apply assoc-in %1 %2)
                 (:parameters session)
                 keyvector-value-pairs)))
 

A phase is a function of a single session argument, that contains calls to crate functions or actions. A phase has an implicitly defined pre and post phase.

(ns pallet.phase)

slingshot version compatibility

(try
  (use '[slingshot.slingshot :only [throw+]])
  (catch Exception _
    (use '[slingshot.core :only [throw+]])))
(defn pre-phase-name
  "Return the name for the pre-phase for the given `phase`."
  [phase]
  (keyword "pallet.phase" (str "pre-" (name phase))))
(defn post-phase-name
  "Return the name for the post-phase for the given `phase`."
  [phase]
  (keyword "pallet.phase" (str "post-" (name phase))))
(defn all-phases-for-phase
  "Return a sequence including the implicit pre and post phases for a phase."
  [phase]
  [(pre-phase-name phase) phase (post-phase-name phase)])
(defn subphase-for
  "Return the phase this is a subphase for, or nil if not a subphase"
  [phase]
  (when (= (namespace phase) "pallet.phase")
    (let [n (name phase)
          [_ pre] (re-matches #"pre-(.*)" n)
          [_ post] (re-matches #"post-(.*)" n)
          p (or pre post)]
      (when p
        (keyword p)))))
(defmacro schedule-in-pre-phase
  "Specify that the body should be executed in the pre-phase."
  [session & body]
  `(let [session# ~session
         phase# (:phase session#)]
     (->
      (assoc session# :phase (pre-phase-name phase#))
      ~@body
      (assoc :phase phase#))))
(defmacro schedule-in-post-phase
  "Specify that the body should be executed in the post-phase."
  [session & body]
  `(let [session# ~session
         phase# (:phase session#)]
     (->
      (assoc session# :phase (post-phase-name phase#))
      ~@body
      (assoc :phase phase#))))
(defn check-session
  "Function that can check a session map to ensure it is a valid part of
   phase definiton. It returns the session map.
   If this fails, then it is likely that you have an incorrect crate function,
   which is failing to return its session map properly, or you have a non crate
   function in the phase defintion."
  ([session]
     ;; we do not use a precondition in order to improve the error message
     (when-not (and session (map? session))
       (throw+
        {:type :invalid-session
         :message
         "Invalid session map in phase. Check for non crate functions,
      improper crate functions, or problems in threading the session map
      in your phase definition.
      A crate function is a function that takes a session map and other
      arguments, and returns a modified session map. Calls to crate functions
      are often wrapped in a threading macro, -> or pallet.phase/phase-fn,
      to simplify chaining of the session map argument."}))
     session)
  ([session form]
     ;; we do not use a precondition in order to improve the error message
     (when-not (and session (map? session))
       (throw+
        {:type :invalid-session
         :message
         (format
          (str
           "Invalid session map in phase session.\n"
           "`session` is %s\n"
           "Problem probably caused in:\n  %s ")
          session form)}))
     session))
(defmacro check-session-thread
  "Add session checking to a sequence of calls which thread a session
   map. e.g.
       (->
         session
         (check-session-thread
           (file \"/some-file\")
           (file \"/other-file\")))
   The example is thus equivalent to:
       (-> session
         (check-session \"The session passed to the pipeline\")
         (check-session (file \"/some-file\"))
         (check-session (file \"/other-file\")))"
  [arg & body]
  `(->
    ~arg
    (check-session "The session passed to the pipeline")
    ~@(mapcat (fn [form] [form `(check-session '~form)]) body)))
(defmacro phase-fn
  "Create a phase function from a sequence of crate invocations with
   an ommited session parameter.
   eg. (phase-fn
         (file \"/some-file\")
         (file \"/other-file\"))
   which generates a function with a session argument, that is thread
   through the function calls. The example is thus equivalent to:
   (fn [session] (-> session
                   (file \"/some-file\")
                   (file \"/other-file\"))) "
  [& body]
  `(fn [session#]
     (->
      session#
      (check-session-thread ~@body))))
 

A namespace that can be used to pull in most of pallet's namespaces. uesful when working at the clojure REPL.

(ns pallet.repl
  (:use
   pallet.utils
   [pallet.compute :exclude [make-node]]
   pallet.core
   pallet.phase
   pallet.action.package
   clj-ssh.ssh))
(defmacro use-pallet
  "Macro that will use pallet's namespaces, to provide an easy to access REPL."
  []
  '(do
     (clojure.core/use
      'pallet.utils
      '[pallet.compute :exclude [make-node]]
      'pallet.core
      'pallet.phase
      'pallet.action.package
      'clj-ssh.ssh)))
 

Compatibility namespace

(ns pallet.request-map
  (:require
   [pallet.common.deprecate :as deprecate]
   [pallet.session :as session]))
(deprecate/forward-fns
 pallet.session
 safe-id phase target-node target-name target-id target-ip os-family
 os-version safe-name packager admin-user group-name)
(defn nodes-in-tag
  "All nodes in the same tag as the target-node, or with the specified tag."
  {:deprecated "0.5.0"}
  ([session]
     (deprecate/deprecated
      (deprecate/rename
       'pallet.request-map/nodes-in-tag 'pallet.session/nodes-in-group))
     (session/nodes-in-group session))
  ([session group-name] (session/nodes-in-group session group-name)))
(defn tag
  "Tag of the target-node."
  {:deprecated "0.5.0"}
  [session]
  (deprecate/deprecated
   (deprecate/rename 'pallet.request-map/tag 'pallet.session/group-name))
  (session/group-name session))
 

Compatability namespace

(ns pallet.resource.directory
  (:require
   [pallet.action :as action]
   [pallet.action.directory :as directory]
   [pallet.common.deprecate :as deprecate]
   pallet.script.lib
   [pallet.utils :as utils]))
(utils/forward-to-script-lib rmdir mkdir make-temp-dir)
(deprecate/forward-fns
 "0.5.0"
 pallet.action.directory
 adjust-directory
 make-directory
 directory
 directories)
(def directory* (action/action-fn directory/directory))
 

Compatability namespace

(ns pallet.resource.exec-script
  (:require
   [pallet.action.exec-script :as exec-script]
   [pallet.common.deprecate :as deprecate]
   [pallet.utils :as utils]))
(defmacro exec-script
  "Execute a bash script remotely"
  {:deprecated "0.5.0"}
  [session & script]
  `(do
     (deprecate/deprecated-macro
      ~&form
      (deprecate/rename
       'pallet.resource.exec-script/exec-script
       'pallet.action.exec-script/exec-script))
     (exec-script/exec-script ~session ~@script)))
(defmacro exec-checked-script
  "Execute a bash script remotely, throwing if any element of the
   script fails."
  {:deprecated "0.5.0"}
  [session name & script]
  `(do
     (deprecate/deprecated-macro
      ~&form
      (deprecate/rename
       'pallet.resource.exec-script/exec-checked-script
       'pallet.action.exec-script/exec-checked-script))
     (exec-script/exec-checked-script ~session ~name ~@script)))
 

Compatability namespace

(ns pallet.resource.file
  (:require
   pallet.action.file
   [pallet.common.deprecate :as deprecate]
   pallet.script.lib
   [pallet.utils :as utils]))
(utils/forward-to-script-lib
 rm mv cp ln backup-option basename ls cat tail diff cut chown chgrp chmod
 touch md5sum md5sum-verify sed-file download-file tmp-dir make-temp-file
 heredoc-in heredoc)
(deprecate/forward-fns
 pallet.action.file
 adjust-file write-md5-for-file touch-file
 file symbolic-link fifo sed)
 

Compatability namespace

(ns pallet.resource.filesystem
  (:require
   pallet.action.filesystem
   [pallet.common.deprecate :as deprecate]))
(deprecate/forward-fns
 pallet.action.filesystem
 make-xfs-filesytem format-mount-option mount)
 

Compatibility namespace

(ns pallet.resource.filesystem-layout
  (:require
   pallet.script.lib
   [pallet.utils :as utils]))
(utils/forward-to-script-lib
 etc-default
 log-root
 pid-root
 config-root
 etc-hosts
 etc-init
 pkg-etc-default
 etc-default
 pkg-log-root
 pkg-pid-root
 pkg-config-root
 pkg-sbin)
 

Compatability namespace

(ns pallet.resource.format
  (:require
   pallet.config-file.format
   [pallet.common.deprecate :as deprecate]))
(deprecate/forward-fns
 pallet.config-file.format sectioned-properties name-values)
 

Compatibility namespace

(ns pallet.resource.hostinfo
  (:require
   pallet.script.lib
   [pallet.common.deprecate :as deprecate]
   [pallet.stevedore :as stevedore]
   [pallet.utils :as utils]))
(utils/forward-to-script-lib
 os-version-name
 hostname
 dnsdomainname
 nameservers
 debian-version
 redhat-version
 ubuntu-version
 arch)
(defn architecture
  "Machine CPU architecture."
  {:deprecated "0.5.0"}
  []
  (deprecate/deprecated "pallet.resource.hostinfo/architecture is deprecated")
  (stevedore/script (~arch)))
 

Compatibility namespace

(ns pallet.resource.lib
  (:require
   pallet.script.lib
   [pallet.utils :as utils]))
(utils/forward-to-script-lib
 file-changed
 set-flag
 flag?)
 

Compatability namespace

(ns pallet.resource.network-service
  (:require
   [pallet.common.deprecate :as deprecate]
   pallet.crate.network-service
   pallet.script.lib))
(deprecate/forward-fns
 pallet.crate.network-service
 wait-for-port-listen wait-for-http-status
 wait-for-port-response)
 
(ns pallet.resource.package
  (:require
   pallet.action.package
   pallet.action.package.centos
   pallet.action.package.debian-backports
   pallet.action.package.epel
   pallet.action.package.jpackage
   pallet.action.package.rpmforge
   [pallet.common.deprecate :as deprecate]
   pallet.script.lib
   [pallet.utils :as utils]))
(utils/forward-to-script-lib
 update-package-list upgrade-all-packages install-package upgrade-package
 remove-package purge-package list-installed-packages debconf-set-selections
 package-manager-non-interactive)
(deprecate/forward-fns
 pallet.action.package
 package packages package-source package-manager add-scope
 minimal-packages format-source)
(deprecate/forward-fns pallet.action.package.jpackage add-jpackage)
(deprecate/forward-fns pallet.action.package.epel add-epel)
(deprecate/forward-fns pallet.action.package.rpmforge add-rpmforge)
(deprecate/forward-fns
 pallet.action.package.debian-backports add-debian-backports)
(defn add-centos55-to-amzn-linux
  {:deprecated "0.5.0"}
  [& args]
  (deprecate/deprecated
   (deprecate/rename
    'pallet.action.package/add-centos55-to-amzn-linux
    'pallet.action.package.centos/add-repository))
  (apply pallet.action.package.centos/add-repository args))
 

Compatability namespace

(ns pallet.resource.remote-directory
  (:require
   pallet.action.remote-directory
   [pallet.common.deprecate :as deprecate]))
(deprecate/forward-fns pallet.action.remote-directory remote-directory)
 

Compatability namespace

(ns pallet.resource.remote-file
  (:require
   [pallet.action :as action]
   [pallet.action.remote-file :as remote-file]
   [pallet.common.deprecate :as deprecate]))
(deprecate/forward-fns
 pallet.action.remote-file
 set-install-new-files set-force-overwrite with-remote-file transfer-file
 remote-file-action remote-file)
(deprecate/forward-vars
 pallet.action.remote-file
 content-options
 version-options
 ownership-options
 all-options)
(def remote-file* (action/action-fn remote-file/remote-file-action))
 

Conditional resource execution.

(ns pallet.resource.resource-when
  (:require
   [pallet.action.conditional :as conditional]
   [pallet.common.deprecate :as deprecate]
   [pallet.utils :as utils]))
(defmacro resource-when
  {:deprecated "0.5.0"}
  [session condition & resources]
  `(do
     (deprecate/deprecated-macro
      ~&form
      (deprecate/rename
       'pallet.resource.resource-when/resource-when
       'pallet.action.conditional/when))
     (conditional/when ~session ~condition ~@resources)))
(defmacro resource-when-not
  {:deprecated "0.5.0"}
  [session condition & resources]
  `(do
     (deprecate/deprecated-macro
      ~&form
      (deprecate/rename
       'pallet.resource.resource-when/resource-when-not
       'pallet.action.conditional/when-not))
     (conditional/when-not ~session ~condition ~@resources)))
 

Compatability namespace

(ns pallet.resource.rsync
  (:require
   pallet.action.rsync
   [pallet.common.deprecate :as deprecate]))
(deprecate/forward-fns
 pallet.action.rsync
 rsync rsync-directory)
 

Compatability namespace

(ns pallet.resource.service
  (:require
   pallet.action.service
   [pallet.common.deprecate :as deprecate]
   pallet.script.lib
   [pallet.utils :as utils]))
(utils/forward-to-script-lib configure-service)
(deprecate/forward-fns pallet.action.service service init-script)
(defmacro with-restart
  [session service-name & body]
  `(do
     (deprecate/deprecated-macro
      ~&form
      (deprecate/rename
       'pallet.resource.service/with-restart
       'pallet.action.service/with-restart))
     (pallet.action.service/with-restart ~session ~service-name ~@body)))
 

Compatibility namespace

(ns pallet.resource.shell
  (:require
   pallet.script.lib
   [pallet.utils :as utils]))
(utils/forward-to-script-lib
 exit
 xargs
 which)
 

Compatability namespace

(ns pallet.resource.user
  (:require
   pallet.action.user
   [pallet.common.deprecate :as deprecate]
   pallet.script.lib
   [pallet.utils :as utils]))
(utils/forward-to-script-lib
 user-exists? modify-user create-user remove-user lock-user unlock-user
 user-home current-user group-exists? modify-group create-group remove-group)
(deprecate/forward-fns pallet.action.user user group)
 

Namespace for backward compatibility

(ns pallet.resource
  (:require
   [pallet.action :as action]
   [pallet.common.deprecate :as deprecate]
   [pallet.phase :as phase]
   [pallet.common.def :as ccdef]))
(defmacro phase [& body]
  `(do
     (deprecate/deprecated-macro
      ~&form
      (deprecate/rename 'pallet.resource/phase 'pallet.phase/phase-fn))
     (phase/phase-fn ~@body)))
(defmacro execute-pre-phase
  [& body]
  `(do
     (deprecate/deprecated-macro
      ~&form
      (deprecate/rename
       'pallet.resource/execute-pre-phase 'pallet.phase/schedule-in-pre-phase))
     (phase/schedule-in-pre-phase ~@body)))
(defmacro execute-after-phase [& body]
  `(do
     (deprecate/deprecated-macro
      ~&form
      (deprecate/rename
       'pallet.resource/execute-after-phase
       'pallet.phase/schedule-in-post-phase))
     (phase/schedule-in-post-phase ~@body)))
(defmacro defresource [n & body]
  (let [[n args] (ccdef/name-with-attributes n body)
        n (vary-meta n dissoc :use-arglist :copy-arglist)
        [[n* arguments & forms]] args]
    `(do
       (deprecate/deprecated-macro
        ~&form
        (deprecate/rename
         'pallet.resource/defresource 'pallet.action/def-bash-action))
       (action/def-bash-action
         ~n [~@arguments] ~@forms))))
(defmacro deflocal [n & body]
  (let [[n args] (ccdef/name-with-attributes n body)
        n (vary-meta n dissoc :use-arglist :copy-arglist)
        [[n* arguments & forms]] args]
    `(do
       (deprecate/deprecated-macro
        ~&form
        (deprecate/rename
         'pallet.resource/deflocal 'pallet.action/def-clj-action))
       (action/def-clj-action
         ~n [~@arguments] ~@forms))))
(defmacro defaggregate [n & body]
  (let [[n args] (ccdef/name-with-attributes n body)
        n (vary-meta n dissoc :use-arglist :copy-arglist)
        [[n* arguments & forms]] args]
    `(do
       (deprecate/deprecated-macro
        ~&form
        (deprecate/rename
         'pallet.resource/defaggregate 'pallet.action/def-aggregated-action))
       (action/def-aggregated-action
         ~n [~@arguments] ~@forms))))
(defmacro defcollect [n & body]
  (let [[n args] (ccdef/name-with-attributes n body)
        n (vary-meta n dissoc :use-arglist :copy-arglist)
        [[n* arguments & forms]] args]
    `(do
       (deprecate/deprecated-macro
        ~&form
        (deprecate/rename
         'pallet.resource/defcollect 'pallet.action/def-collected-action))
       (action/def-collected-action
         ~n [~@arguments] ~@forms))))
(action/def-clj-action as-local-resource
  [session f & args]
  (apply f session args))
 

Script library for abstracting target host script differences

(ns pallet.script.lib
  (:require
   [pallet.script :as script]
   [pallet.stevedore :as stevedore]
   [pallet.thread-expr :as thread-expr]
   [clojure.string :as string]))
(defn- translate-options
  [options translations]
  (reduce
   (fn [options [from to]]
     (-> options
         (assoc to (from options))
         (dissoc from)))
   options
   translations))
(script/defscript exit [value])
(script/defimpl exit :default [value]
  (exit ~value))
(script/defscript xargs [script])
(script/defimpl xargs :default
  [script]
  (xargs ~script))
(script/defscript which [arg])
(script/defimpl which :default
  [arg]
  (which ~arg))
(script/defscript has-command?
  "Check whether the specified command is on the path"
  [arg])
(script/defimpl has-command? :default [arg] (hash ~arg "2>&-"))
(script/defscript canonical-path [path]
  "Return the canonical version of the specified path"
  [arg])
(script/defimpl canonical-path :default [arg] (readlink -f ~arg))
(script/defscript rm [file & {:keys [recursive force]}])
(script/defimpl rm :default [file & {:keys [recursive force] :as options}]
  ("rm" ~(stevedore/map-to-arg-string options) ~file))
(script/defimpl rm [#{:darwin :os-x}] [file & {:keys [recursive force]}]
  ("rm" ~(stevedore/map-to-arg-string {:r recursive :f force}) ~file))
(script/defscript mv [source destination & {:keys [force backup]}])
(script/defimpl mv :default
  [source destination & {:keys [force backup]}]
  (mv
   ~(stevedore/map-to-arg-string
     {:f force :backup (when backup (name backup))}
     :assign true)
   ~source ~destination))
(script/defimpl mv [#{:darwin :os-x}]
  [source destination & {:keys [force backup]}]
  (mv
   ~(stevedore/map-to-arg-string
     {:f force}
     :assign true)
   ~source ~destination))
(script/defscript cp [source destination & {:keys [force backup preserve]}])
(script/defimpl cp :default
  [source destination & {:keys [force backup preserve]}]
  (cp
   ~(stevedore/map-to-arg-string {:f force
                                  :backup (when backup (name backup))
                                  :p preserve})
   ~source ~destination))
(script/defimpl cp [#{:darwin :os-x}]
  [source destination & {:keys [force backup preserve]}]
  (cp
   ~(stevedore/map-to-arg-string {:f force :p preserve})
   ~source ~destination))
(script/defscript ln [source destination & {:keys [force symbolic]}])
(script/defimpl ln :default
  [source destination & {:keys [force symbolic]}]
  (ln
   ~(stevedore/map-to-arg-string {:f force :s symbolic})
   ~source ~destination))
(script/defscript backup-option [])
(script/defimpl backup-option :default []
  "--backup=numbered")
(script/defimpl backup-option [#{:darwin :os-x}] [])
(script/defscript basename [path])
(script/defimpl basename :default
  [path]
  (basename ~path))
(script/defscript dirname [path])
(script/defimpl dirname :default
  [path]
  (dirname ~path))
(script/defscript ls [pattern & {:keys [sort-by-time sort-by-size reverse]}])
(script/defimpl ls :default
  [pattern & {:keys [sort-by-time sort-by-size reverse]}]
  (ls ~(stevedore/map-to-arg-string
          {:t sort-by-time
           :S sort-by-size
           :r reverse})
   ~pattern))
(script/defscript cat [pattern])
(script/defimpl cat :default
  [pattern]
  (cat ~pattern))
(script/defscript tail [pattern & {:keys [max-lines]}])
(script/defimpl tail :default
  [pattern & {:keys [max-lines]}]
  (tail ~(stevedore/map-to-arg-string {:n max-lines}) ~pattern))
(script/defscript diff [file1 file2 & {:keys [unified]}])
(script/defimpl diff :default
  [file1 file2 & {:keys [unified]}]
  (diff ~(stevedore/map-to-arg-string {:u unified}) ~file1 ~file2))
(script/defscript cut [file & {:keys [fields delimiter]}])
(script/defimpl cut :default
  [file & {:keys [fields delimiter]}]
  (cut
   ~(stevedore/map-to-arg-string {:f fields :d delimiter})
   ~file))
(script/defscript chown [owner file & {:as options}])
(script/defimpl chown :default [owner file & {:as options}]
  (chown ~(stevedore/map-to-arg-string options) ~owner ~file))
(script/defscript chgrp [group file & {:as options}])
(script/defimpl chgrp :default [group file & {:as options}]
  (chgrp ~(stevedore/map-to-arg-string options) ~group ~file))
(script/defscript chmod [mode file & {:as options}])
(script/defimpl chmod :default [mode file & {:as options}]
  (chmod ~(stevedore/map-to-arg-string options) ~mode ~file))
(script/defscript touch [file & {:as options}])
(script/defimpl touch :default [file & {:as options}]
  (touch ~(stevedore/map-to-arg-string options) ~file))
(script/defscript md5sum [file & {:as options}])
(script/defimpl md5sum :default [file & {:as options}]
  (md5sum ~(stevedore/map-to-arg-string options) ~file))
(script/defimpl md5sum [#{:darwin :os-x}] [file & {:as options}]
  ("/sbin/md5" -r ~file))
(script/defscript normalise-md5
  "Normalise an md5 sum file to contain the base filename"
  [file])
(script/defimpl normalise-md5 :default
  [file]
  (if (egrep "'^[a-fA-F0-9]+$'" ~file)
    (echo
     (quoted (str "  " @(pipe (basename ~file) (sed -e "s/.md5//"))))
     ">>" ~file)))
(script/defscript md5sum-verify [file & {:as options}])
(script/defimpl md5sum-verify :default
  [file & {:keys [quiet check] :or {quiet true check true} :as options}]
  ("(" (chain-and
        (cd @(dirname ~file))
        (md5sum
         ~(stevedore/map-to-arg-string {:quiet quiet :check check})
         @(basename ~file))) ")"))
(script/defimpl md5sum-verify [#{:centos :debian :amzn-linux :rhel :fedora}]
  [file & {:keys [quiet check] :or {quiet true check true} :as options}]
  ("(" (chain-and
        (cd @(dirname ~file))
        (md5sum
         ~(stevedore/map-to-arg-string {:status quiet :check check})
         @(basename ~file))) ")"))
(script/defimpl md5sum-verify [#{:darwin :os-x}] [file & {:as options}]
  (chain-and
   (var testfile @(~cut ~file :delimiter " " :fields 2))
   (var md5 @(~cut ~file :delimiter " " :fields 1))
   ("test" (quoted @("/sbin/md5" -q @testfile)) == (quoted @md5))))
(script/defscript backup-option [])
(script/defimpl backup-option :default []
  "--backup=numbered")
(script/defimpl backup-option [#{:darwin :os-x}] [])
(script/defscript sed-file [file expr-map options])
(def ^{:doc "Possible sed separators" :private true}
  sed-separators
  (concat [\/ \_ \| \: \% \! \@] (map char (range 42 127))))
(script/defimpl sed-file :default
  [file expr-map {:keys [seperator restriction quote-with]
                  :or {quote-with "\}
                  :as options}]
  (sed "-i"
   ~(if (map? expr-map)
      (string/join
       " "
       (map
        (fn [[key value]]
          (let [used (fn [c]
                       (or (>= (.indexOf key (int c)) 0)
                           (>= (.indexOf value (int c)) 0)))
                seperator (or seperator (first (remove used sed-separators)))]
            (format
             "-e %s%ss%s%s%s%s%s%s"
             quote-with
             (if restriction (str restriction " ") )
             seperator key seperator value seperator quote-with)))
        expr-map))
      (format
       "-e %s%s%s%s"
       quote-with
       (if restriction (str restriction " ") )
       expr-map quote-with))
   ~file))
(script/defscript download-file [url path & {:keys [proxy insecure]}])
(script/defimpl download-file :default [url path & {:keys [proxy insecure]}]
  (if (~has-command? curl)
    (curl "-o" (quoted ~path)
          --retry 5 --silent --show-error --fail --location
          ~(if proxy
             (let [url (java.net.URL. proxy)]
               (format "--proxy %s:%s" (.getHost url) (.getPort url))))
          ~(if insecure "--insecure" )
          (quoted ~url))
    (if (~has-command? wget)
      (wget "-O" (quoted ~path) --tries 5 --no-verbose
            ~(if proxy
               (format
                "-e \"http_proxy = %s\" -e \"ftp_proxy = %s\ proxy proxy))
            ~(if insecure "--no-check-certificate" )
            (quoted ~url))
      (do
        (println "No download utility available")
        (~exit 1)))))
(script/defscript download-request [path request])
(script/defimpl download-request :default [path request]
  (curl "-o" (quoted ~path) --retry 3 --silent --show-error --fail --location
   ~(string/join
     " "
     (map (fn dlr-fmt [e] (format "-H \"%s: %s\ (key e) (val e)))
          (:headers request)))
   (quoted ~(str (:endpoint request)))))
(script/defscript tmp-dir [])
(script/defimpl tmp-dir :default []
  @TMPDIR-/tmp)
(script/defscript make-temp-file [pattern])
(script/defimpl make-temp-file :default [pattern]
  @(mktemp (quoted ~(str pattern "XXXXX"))))
(script/defscript heredoc-in [cmd content {:keys [literal]}])
(script/defimpl heredoc-in :default [cmd content {:keys [literal]}]
  ("{" ~cmd
   ~(str (if literal "<<'EOFpallet'\n" "<<EOFpallet\n")
         content "\nEOFpallet\n }")))
(script/defscript heredoc [path content {:keys [literal]}])
(script/defimpl heredoc :default
  [path content {:keys [literal] :as options}]
  (~heredoc-in ("cat" ">" ~path) ~content ~options))
(script/defscript rmdir
  "Remove the specified directory"
  [directory & {:as options}])
(script/defimpl rmdir :default [directory & {:as options}]
  (rmdir ~(stevedore/map-to-arg-string options) ~directory))
(script/defscript mkdir
  "Create the specified directory"
  [directory & {:keys [path verbose mode]}])
(script/defimpl mkdir :default
  [directory & {:keys [path verbose mode] :as options}]
  (mkdir
   ~(stevedore/map-to-arg-string {:m mode :p path :v verbose})
   ~directory))
(script/defscript make-temp-dir
  "Create a temporary directory"
  [pattern & {:as options}])
(script/defimpl make-temp-dir :default [pattern & {:as options}]
  @(mktemp -d
    ~(stevedore/map-to-arg-string options)
    ~(str pattern "XXXXX")))

Host information.

(script/defscript os-version-name [])
(script/defimpl os-version-name [#{:ubuntu :debian}] []
  @(lsb_release -c -s))
(script/defimpl os-version-name :default [])
(script/defscript hostname [& options])
(script/defimpl hostname :default [& options]
  @(hostname
    ~(if (first options)
       (stevedore/map-to-arg-string (apply hash-map options)))))
(script/defscript dnsdomainname [])
(script/defimpl dnsdomainname :default []
  @(dnsdomainname))
(script/defscript nameservers [])
(script/defimpl nameservers :default []
  @(grep nameserver "/etc/resolv.conf" | cut "-f2"))
(script/defscript debian-version [])
(script/defimpl debian-version :default []
  (if (file-exists? "/etc/debian") (cat "/etc/debian")))
(script/defscript redhat-version [])
(script/defimpl redhat-version :default []
  (if (file-exists? "/etc/redhat-release") (cat "/etc/redhat-release")))
(script/defscript ubuntu-version [])
(script/defimpl ubuntu-version :default []
  (if (file-exists? "/usr/bin/lsb_release") @("/usr/bin/lsb_release" -c -s)))
(script/defscript arch [])
(script/defimpl arch :default []
  @(uname -p))

Users

(script/defscript user-exists? [name])
(script/defscript modify-user [name options])
(script/defscript create-user [name options])
(script/defscript remove-user [name options])
(script/defscript lock-user [name])
(script/defscript unlock-user [name])
(script/defscript user-home [username])
(script/defscript current-user [])
(script/defscript group-exists? [name])
(script/defscript modify-group [name options])
(script/defscript create-group [name options])
(script/defscript remove-group [name options])
(script/defimpl user-exists? :default [username]
  (getent passwd ~username))
(defn group-seq->string
  [groups]
  (if (not (string? groups))
    (string/join "," groups)
    groups))
(script/defimpl create-user :default [username options]
  ("/usr/sbin/useradd"
   ~(-> options
        (thread-expr/when->
         (:groups options)
         (update-in [:groups] group-seq->string))
        (thread-expr/when->
         (:group options)
         (assoc :g (:group options))
         (dissoc :group))
        stevedore/map-to-arg-string)
   ~username))
(script/defimpl create-user [#{:rhel :centos :amzn-linux :fedora}]
  [username options]
  ("/usr/sbin/useradd"
   ~(-> options
        (thread-expr/when->
         (:groups options)
         (update-in [:groups] group-seq->string))
        (translate-options {:system :r :group :g :password :p :groups :G})
        stevedore/map-to-arg-string)
   ~username))
(script/defimpl modify-user :default [username options]
  ("/usr/sbin/usermod"
   ~(stevedore/map-to-arg-string
     (-> options
         (thread-expr/when->
          (:groups options)
          (update-in [:groups] group-seq->string))))
   ~username))
(script/defimpl modify-user [#{:rhel :centos :amzn-linux :fedora}]
  [username options]
  ("/usr/sbin/usermod"
   ~(-> options
        (thread-expr/when->
         (:groups options)
         (update-in [:groups] group-seq->string))
        (translate-options
         {:system :r :group :g :password :p :append :a :groups :G})
        stevedore/map-to-arg-string)
   ~username))
(script/defimpl remove-user :default [username options]
  ("/usr/sbin/userdel" ~(stevedore/map-to-arg-string options) ~username))
(script/defimpl lock-user :default [username]
  ("/usr/sbin/usermod" --lock ~username))
(script/defimpl unlock-user :default [username]
  ("/usr/sbin/usermod" --unlock ~username))
(script/defimpl user-home :default [username]
  @("getent" passwd ~username | "cut" "-d:" "-f6"))
(script/defimpl user-home [#{:darwin :os-x}] [username]
  @(pipe
    ("dscl" localhost -read ~(str "/Local/Default/Users/" username)
          "dsAttrTypeNative:home")
    ("cut" -d "' '" -f 2)))
(script/defimpl current-user :default []
  @("whoami"))
(script/defimpl group-exists? :default [name]
  ("getent" group ~name))
(script/defimpl create-group :default [groupname options]
  ("/usr/sbin/groupadd" ~(stevedore/map-to-arg-string options) ~groupname))
(script/defimpl create-group [#{:rhel :centos :amzn-linux :fedora}]
  [groupname options]
  ("/usr/sbin/groupadd"
   ~(-> options
        (assoc :r (:system options))
        (dissoc :system)
        stevedore/map-to-arg-string)
   ~groupname))
(script/defimpl modify-group :default [groupname options]
  ("/usr/sbin/groupmod" ~(stevedore/map-to-arg-string options) ~groupname))
(script/defimpl remove-group :default [groupname options]
  ("/usr/sbin/groupdel" ~(stevedore/map-to-arg-string options) ~groupname))

Package management

the package management commands vary for each distribution, so we use a script multimethod to describe these

(script/defscript update-package-list
  "Update the list of packages available to the package manager from the
   declared package sources."
  [& options])
(script/defscript upgrade-all-packages
  "Upgrade the all installed package."
  [& options])
(script/defscript install-package
  "Install the specified package."
  [name & options])
(script/defscript upgrade-package
  "Upgrade the specified package."
  [name & options])
(script/defscript remove-package
  "Uninstall the specified package, leaving the configuration files if
   possible."
  [name & options])
(script/defscript purge-package
  "Uninstall the specified package, removing the configuration files if
   possible."
  [name & options])
(script/defscript list-installed-packages
  "List the installed packages"
  [& options])

Implementation to do nothing Repeating the selector makes it more explicit

(script/defimpl update-package-list [#{:no-packages} #{:no-packages}]
  [& options] )
(script/defimpl upgrade-all-packages [#{:no-packages} #{:no-packages}]
  [& options] )
(script/defimpl install-package [#{:no-packages} #{:no-packages}]
  [package & options] )
(script/defimpl upgrade-package [#{:no-packages} #{:no-packages}]
  [package & options] )
(script/defimpl remove-package [#{:no-packages} #{:no-packages}]
  [package & options] )
(script/defimpl purge-package [#{:no-packages} #{:no-packages}]
  [package & options] )
(script/defimpl list-installed-packages [#{:no-packages} #{:no-packages}]
  [& options] )

aptitude

(script/defimpl update-package-list [#{:aptitude}] [& {:keys [] :as options}]
  (chain-or
   (aptitude update ~(stevedore/map-to-arg-string options)) true))
(script/defimpl upgrade-all-packages [#{:aptitude}] [& options]
  (aptitude upgrade -q -y ~(stevedore/option-args options)))
(script/defimpl install-package [#{:aptitude}] [package & options]
  (aptitude install -q -y ~(stevedore/option-args options) ~package
            ;; show returns an error code if no package found, while install
            ;; does not.  There should be a better way than this...
            "&&" aptitude show ~package))
(script/defimpl upgrade-package [#{:aptitude}] [package & options]
  (aptitude install -q -y ~(stevedore/option-args options) ~package
            ;; show returns an error code if no package found, while install
            ;; does not.  There should be a better way than this...
            "&&" aptitude show ~package))
(script/defimpl remove-package [#{:aptitude}] [package & options]
  (aptitude remove -y ~(stevedore/option-args options) ~package))
(script/defimpl purge-package [#{:aptitude}] [package & options]
  (aptitude purge -y  ~(stevedore/option-args options) ~package))
(script/defimpl list-installed-packages [#{:aptitude}] [& options]
  (aptitude search (quoted "~i")))

yum

(script/defimpl update-package-list [#{:yum}] [& {:keys [enable disable]}]
  (yum makecache -q ~(string/join
                      " "
                      (concat
                       (map #(str "--disablerepo=" %) disable)
                       (map #(str "--enablerepo=" %) enable)))))
(script/defimpl upgrade-all-packages [#{:yum}] [& options]
  (yum update -y -q ~(stevedore/option-args options)))
(script/defimpl install-package [#{:yum}] [package & options]
  (yum install -y -q ~(stevedore/option-args options) ~package))
(script/defimpl upgrade-package [#{:yum}] [package & options]
  (yum upgrade -y -q ~(stevedore/option-args options) ~package))
(script/defimpl remove-package [#{:yum}] [package & options]
  (yum remove ~(stevedore/option-args options) ~package))
(script/defimpl purge-package [#{:yum}] [package & options]
  (yum purge ~(stevedore/option-args options) ~package))
(script/defimpl list-installed-packages [#{:yum}] [& options]
  (yum list installed))

zypper

(script/defimpl update-package-list [#{:zypper}] [& options]
  (zypper refresh ~(stevedore/option-args options)))
(script/defimpl upgrade-all-packages [#{:zypper}] [& options]
  (zypper update -y ~(stevedore/option-args options)))
(script/defimpl install-package [#{:zypper}] [package & options]
  (zypper install -y ~(stevedore/option-args options) ~package))
(script/defimpl remove-package [#{:zypper}] [package & options]
  (zypper remove ~(stevedore/option-args options) ~package))
(script/defimpl purge-package [#{:zypper}] [package & options]
  (zypper remove ~(stevedore/option-args options) ~package))

pacman

(script/defimpl update-package-list [#{:pacman}] [& options]
  (pacman -Sy "--noconfirm" "--noprogressbar"
   ~(stevedore/option-args options)))
(script/defimpl upgrade-all-packages [#{:pacman}] [& options]
  (pacman -Su "--noconfirm" "--noprogressbar" ~(stevedore/option-args options)))
(script/defimpl install-package [#{:pacman}] [package & options]
  (pacman -S "--noconfirm" "--noprogressbar"
   ~(stevedore/option-args options) ~package))
(script/defimpl upgrade-package [#{:pacman}] [package & options]
  (pacman -S "--noconfirm" "--noprogressbar"
   ~(stevedore/option-args options) ~package))
(script/defimpl remove-package [#{:pacman}] [package & options]
  (pacman -R "--noconfirm" ~(stevedore/option-args options) ~package))
(script/defimpl purge-package [#{:pacman}] [package & options]
  (pacman -R "--noconfirm" "--nosave"
   ~(stevedore/option-args options) ~package))

brew

(script/defimpl update-package-list [#{:brew}] [& options]
  (brew update ~(stevedore/option-args options)))
(script/defimpl upgrade-all-packages [#{:brew}] [& options]
  (comment "No command to do this"))
(script/defimpl install-package [#{:brew}] [package & options]
  (brew install -y ~(stevedore/option-args options) ~package))
(script/defimpl remove-package [#{:brew}] [package & options]
  (brew uninstall ~(stevedore/option-args options) ~package))
(script/defimpl purge-package [#{:brew}] [package & options]
  (brew uninstall ~(stevedore/option-args options) ~package))
(script/defscript debconf-set-selections [& selections])
(script/defimpl debconf-set-selections :default [& selections] )
(script/defimpl debconf-set-selections [#{:aptitude}] [& selections]
  ("{ debconf-set-selections"
   ~(str "<<EOF\n" (string/join \newline selections) "\nEOF\n}")))
(script/defscript package-manager-non-interactive [])
(script/defimpl package-manager-non-interactive :default [] )
(script/defimpl package-manager-non-interactive [#{:aptitude}] []
  (~debconf-set-selections
   "debconf debconf/frontend select noninteractive"
   "debconf debconf/frontend seen false"))

Service functions

(script/defscript configure-service
  [name action options])
(def debian-configure-option-names
     {:force :f})
(defn debian-options [options]
  (zipmap
   (map #(% debian-configure-option-names %) (keys options))
   (vals options)))
(script/defimpl configure-service :default [name action options]
  ~(condp = action
       :disable (stevedore/script
                 ("update-rc.d"
                  ~(stevedore/map-to-arg-string
                    (select-keys [:f :n] (debian-options options)))
                  ~name remove))
       :enable (stevedore/script
                ("update-rc.d"
                 ~(stevedore/map-to-arg-string
                   (select-keys [:n] (debian-options options)))
                 ~name defaults
                 ~(:sequence-start options 20)
                 ~(:sequence-stop options (:sequence-start options 20))))
       :start-stop (stevedore/script ;; start/stop
                    ("update-rc.d"
                     ~(stevedore/map-to-arg-string
                       (select-keys [:n] (debian-options options)))
                     ~name
                     start ~(:sequence-start options 20)
                     "."
                     stop ~(:sequence-stop options (:sequence-start options 20))
                     "."))))
(def ^{:private true} chkconfig-default-options
  [20 2 3 4 5])
(defn- chkconfig-levels
  [options]
  (->> options (drop 1 ) (map str) string/join))
(script/defimpl configure-service [#{:yum}] [name action options]
  ~(condp = action
       :disable (stevedore/script ("/sbin/chkconfig" ~name off))
       :enable (stevedore/script
                ("/sbin/chkconfig"
                 ~name on
                 "--level" ~(chkconfig-levels
                             (:sequence-start
                              options chkconfig-default-options))))
       :start-stop (stevedore/script ;; start/stop
                    ("/sbin/chkconfig"
                     ~name on
                     "--level" ~(chkconfig-levels
                                 (:sequence-start
                                  options chkconfig-default-options))))))

Functions to return distribution specific paths.

These script functions are meant to help build distribution agnostic crates. * Links - man 7 hier - http://www.pathname.com/fhs/ - http://wiki.apache.org/httpd/DistrosDefaultLayout

(script/defscript etc-default [])
(script/defimpl etc-default [#{:ubuntu :debian :jeos}] []
  "/etc/default")
(script/defimpl etc-default [#{:centos :rhel :amzn-linux :fedora}] []
  "/etc/sysconfig")
(script/defimpl etc-default [#{:os-x :darwin}] []
  "/etc/defaults")
(script/defscript log-root [])
(script/defimpl log-root :default []
  "/var/log")
(script/defscript pid-root [])
(script/defimpl pid-root :default []
  "/var/run")
(script/defscript config-root [])
(script/defimpl config-root :default []
  "/etc")
(script/defscript etc-hosts [])
(script/defimpl etc-hosts :default []
  "/etc/hosts")
(script/defscript etc-init [])
(script/defimpl etc-init :default [] "/etc/init.d")
(script/defimpl etc-init [:pacman] [] "/etc/rc.d")

Some of the packagers, like brew, are "add-ons" in the sense that they are outside of the base system. These paths refer to locations of packager installed files.

(script/defscript pkg-etc-default [])
(script/defimpl pkg-etc-default :default [] (~etc-default))
(script/defimpl etc-default [:brew] [] "/usr/local/etc/default")
(script/defscript pkg-log-root [])
(script/defimpl pkg-log-root :default [] (~log-root))
(script/defimpl pkg-log-root [:brew] [] "/usr/local/var/log")
(script/defscript pkg-pid-root [])
(script/defimpl pkg-pid-root :default [] (~pid-root))
(script/defimpl pkg-pid-root [:brew] [] "/usr/local/var/run")
(script/defscript pkg-config-root [])
(script/defimpl pkg-config-root :default [] (~config-root))
(script/defimpl pkg-config-root [:brew] [] "/usr/local/etc")
(script/defscript pkg-sbin [])
(script/defimpl pkg-sbin :default [] "/sbin")
(script/defimpl pkg-sbin [:brew] [] "/usr/local/sbin")

Register changed files

(script/defscript file-changed [path])
(script/defimpl file-changed :default [path]
  (assoc! changed_files path 1))
(script/defscript set-flag [path])
(script/defimpl set-flag :default [path]
  (assoc! flags_hash ~(name path) 1))
(script/defscript flag? [path])
(script/defimpl flag? :default [path]
  (get flags_hash ~(name path)))

selinux

(script/defscript selinux-file-type
  "Set the selinux file type"
  [path type])
(script/defimpl selinux-file-type :default
  [path type]
  (if (&& (~has-command? chcon) (directory? "/etc/selinux"))
    (chcon -Rv ~(str "--type=" type) ~path)))
(script/defscript selinux-bool
  "Set the selinux boolean value"
  [flag value & {:keys [persist]}])
(script/defimpl selinux-bool :default
  [flag value & {:keys [persist]}]
  (if (&& (&& (~has-command? setsebool) (directory? "/etc/selinux"))
          (file-exists? "/selinux/enforce"))
    (setsebool ~(if persist "-P" ) ~(name flag) ~value)))
 

Functions for querying sessions.

This is the official crate API for extracting information from the session.

(ns pallet.session
  "Functions for querying sessions.
   This is the official crate API for extracting information from the session."
  (:require
   [pallet.compute :as compute]
   [pallet.node :as node]
   [pallet.utils :as utils]))
(defn safe-id
  "Computes a configuration and filesystem safe identifier corresponding to a
  potentially unsafe ID"
  [#^String unsafe-id]
  (utils/base64-md5 unsafe-id))
(defn phase
  "Current phase"
  [session]
  (:phase session))
(defn target-node
  "Target compute service node."
  [session]
  (-> session :server :node))
(defn phase
  "Current phase"
  [session]
  (:phase session))
(defn target-name
  "Name of the target-node."
  [session]
  (node/hostname (target-node session)))
(defn target-id
  "Id of the target-node (unique for provider)."
  [session]
  (-> session :server :node-id))
(defn target-ip
  "IP of the target-node."
  [session]
  (node/primary-ip (target-node session)))
(defn target-roles
  "Roles of the target server."
  [session]
  (-> session :server :roles))
(defn base-distribution
  "Base distribution of the target-node."
  [session]
  (compute/base-distribution (-> session :server :image)))
(defn os-family
  "OS-Family of the target-node."
  [session]
  (-> session :server :image :os-family))
(defn os-version
  "OS-Family of the target-node."
  [session]
  (-> session :server :image :os-version))
(defn group-name
  "Group name of the target-node."
  [session]
  (-> session :server :group-name))
(defn safe-name
  "Safe name for target machine.
   Some providers don't allow for node names, only node ids, and there is
   no guarantee on the id format."
  [session]
  (format
   "%s%s"
   (name (group-name session)) (safe-id (name (target-id session)))))
(defn nodes-in-group
  "All nodes in the same tag as the target-node, or with the specified tag."
  ([session] (nodes-in-group session (group-name session)))
  ([session group-name]
     (filter
      #(= (name group-name) (node/group-name %))
      (:all-nodes session))))
(defn groups-with-role
  "All target groups with the specified role."
  [session role]
  (->>
   (:node-set session)
   (filter #(when-let [roles (:roles %)] (roles role)))
   (map :group-name)))
(defn nodes-with-role
  "All target nodes with the specified role."
  [session role]
  (mapcat #(nodes-in-group session %) (groups-with-role session role)))
(defn packager
  [session]
  (get-in session [:server :packager]))
(defn admin-user
  "User that remote commands are run under"
  [session]
  (:user session))
(defn admin-group
  "User that remote commands are run under"
  [session]
  (compute/admin-group (:server session)))
(defn is-64bit?
  "Predicate for a 64 bit target"
  [session]
  (node/is-64bit? (target-node session)))
 

A modified version of clojure.java.shell, that allows for reading of shell output as it is produced.

(ns
  ^{:author "Chris Houser, Stuart Halloway, Hugo Duncan",
    :doc "Conveniently launch a sub-process providing its stdin and
collecting its stdout"}
  pallet.shell
  (:use [clojure.java.io :only (as-file copy)])
  (:import (java.io OutputStreamWriter ByteArrayOutputStream StringWriter)
           (java.nio.charset Charset)))
(def ^{:dynamic true} *sh-dir* nil)
(def ^{:dynamic true} *sh-env* nil)
(defmacro with-sh-dir
  "Sets the directory for use with sh, see sh for details."
  {:added "1.2"}
  [dir & forms]
  `(binding [*sh-dir* ~dir]
     ~@forms))
(defmacro with-sh-env
  "Sets the environment for use with sh, see sh for details."
  {:added "1.2"}
  [env & forms]
  `(binding [*sh-env* ~env]
     ~@forms))
(defn- aconcat
  "Concatenates arrays of given type."
  [type & xs]
  (let [target (make-array type (apply + (map count xs)))]
    (loop [i 0 idx 0]
      (when-let [a (nth xs i nil)]
        (System/arraycopy a 0 target idx (count a))
        (recur (inc i) (+ idx (count a)))))
    target))
(defn- parse-args
  [args]
  (let [default-encoding "UTF-8" ;; see sh doc string
        default-opts {:out-enc default-encoding
                      :in-enc default-encoding
                      :dir *sh-dir*
                      :env *sh-env*}
        [cmd opts] (split-with string? args)]
    [cmd (merge default-opts (apply hash-map opts))]))
(defn- ^"[Ljava.lang.String;" as-env-strings
  "Helper so that callers can pass a Clojure map for the :env to sh."
  [arg]
  (cond
   (nil? arg) nil
   (map? arg) (into-array String (map (fn [[k v]] (str (name k) "=" v)) arg))
   true arg))
(defn- stream-to-bytes
  [in]
  (with-open [bout (ByteArrayOutputStream.)]
    (copy in bout)
    (.toByteArray bout)))
(defn- stream-to-string
  ([in] (stream-to-string in (.name (Charset/defaultCharset))))
  ([in enc]
     (with-open [bout (StringWriter.)]
       (copy in bout :encoding enc)
       (.toString bout))))
(defn- stream-to-enc
  [stream enc]
  (if (= enc :bytes)
    (stream-to-bytes stream)
    (stream-to-string stream enc)))
(defn sh
  "Passes the given strings to Runtime.exec() to launch a sub-process.
  Options are
  :in      may be given followed by a String or byte array specifying input
           to be fed to the sub-process's stdin.
  :in-enc  option may be given followed by a String, used as a character
           encoding name (for example \"UTF-8\" or \"ISO-8859-1\") to
           convert the input string specified by the :in option to the
           sub-process's stdin.  Defaults to UTF-8.
           If the :in option provides a byte array, then the bytes are passed
           unencoded, and this option is ignored.
  :out-enc option may be given followed by :bytes, :stream or a String. If a
           String is given, it will be used as a character encoding
           name (for example \"UTF-8\" or \"ISO-8859-1\") to convert
           the sub-process's stdout to a String which is returned.
           If :bytes is given, the sub-process's stdout will be stored
           in a byte array and returned.  Defaults to UTF-8.
  :async   If true, returns a map with :out, :err and :proc keys, and
           the caller is responsible for reading these and
           the sxit status.
  :env     override the process env with a map (or the underlying Java
           String[] if you are a masochist).
  :dir     override the process dir with a String or java.io.File.
  You can bind :env or :dir for multiple operations using with-sh-env
  and with-sh-dir.
  sh returns a map of
    :exit => sub-process's exit code
    :out  => sub-process's stdout (as byte[] or String)
    :err  => sub-process's stderr (String via platform default encoding)"
  {:added "1.2"}
  [& args]
  (let [[cmd opts] (parse-args args)
        proc (.exec (Runtime/getRuntime)
                    ^"[Ljava.lang.String;" (into-array cmd)
                    (as-env-strings (:env opts))
                    (as-file (:dir opts)))
        {:keys [in in-enc out-enc async]} opts]
    (if in
      (future
       (if (instance? (class (byte-array 0)) in)
         (with-open [os (.getOutputStream proc)]
           (.write os ^"[B" in))
         (with-open [osw (OutputStreamWriter.
                          (.getOutputStream proc) ^String in-enc)]
           (.write osw ^String in))))
      (.close (.getOutputStream proc)))
    (if async
      {:out (.getInputStream proc)
       :err (.getErrorStream proc)
       :proc proc}
      (with-open [stdout (.getInputStream proc)
                  stderr (.getErrorStream proc)]
        (let [out (future (stream-to-enc stdout out-enc))
              err (future (stream-to-string stderr))
              exit-code (.waitFor proc)]
          {:exit exit-code :out @out :err @err})))))
(comment

(println (sh "ls" "-l"))
(println (sh "ls" "-l" "/no-such-thing"))
(println (sh "sed" "s/[aeiou]/oo/g" :in "hello there\n"))
(println (sh "cat" :in "x\u25bax\n"))
(println (sh "echo" "x\u25bax"))
(println
 (sh "echo" "x\u25bax" :out-enc "ISO-8859-1")) ; reads 4 single-byte chars
(println
 (sh "cat" "myimage.png" :out-enc :bytes)) ; reads binary file into bytes[]
(println (sh "cmd" "/c dir 1>&2"))

)
 

Runtime string interpolation built on top of clojure.contrib.strint.

(ns pallet.strint
 (:use pallet.common.strint)
 (:require
   clojure.walk))
(defmacro capture-values
  "Capture the values of the specified symbols in a symbol->value map."
  [& values]
  (into {} (map (fn [s] [ `'~s s]) values)))
(defn <<!
  "Interpolate a string given a map of symbol->value"
  [f value-map]
  (apply str
         (map (fn [x] (if (symbol? x)
                            (value-map x)
                            (if (seq x)
                              (eval (clojure.walk/prewalk-replace value-map x))
                              x)))
                  (#'pallet.common.strint/interpolate f))))
 

Compatibility namespace

(ns pallet.target
  (:require
   [pallet.common.deprecate :as deprecate]))
(defn os-family
  "OS family"
  {:deprecated "0.5.0"}
  [target]
  (deprecate/deprecated
   "pallet.target/os-family is deprecated, please use pallet.session/os-family")
  (:os-family target))
(defn admin-group
  "Default administrator group"
  [target]
  (deprecate/deprecated
   "pallet.target/admin-group is deprecated, please use pallet.session/admin-group")
  (case (os-family target)
    :yum "wheel"
    "adm"))
 

Add a service definition to pallet.

This doesn't work, see: http://stackoverflow.com/questions/3790889/clojure-lein-read-line-stdin-woes

(ns pallet.task.add-service
  "Add a service definition to pallet.
   This doesn't work, see:
   http://stackoverflow.com/questions/3790889/clojure-lein-read-line-stdin-woes"
  (:require
   [clojure.java.io :as io]
   [clojure.string :as string]
   [pallet.compute :as compute]))
(defn warn-on-invalid-provider-name
  [provider-name available-services]
  (if (not (and provider-name (some #(= provider-name %) available-services)))
    (do
      (println "WARNING:" provider-name "is not an available provider")
      (println "         Currently loaded providers are:")
      (doseq [provider available-services]
        (println "           " provider))
      (println "Try adding " (str "org.jclouds/" provider-name)
               "or org.jclouds/jclouds-all as a dependency if you can not see"
               "the provider you want. Writing configuration file with"
               "specified provider anyway."))))
(defn write-service
  [file service-name provider-name identity credential]
  (.. (java.io.File. (.getParent file)) mkdirs)
  (spit file (pr-str {(keyword service-name) {:provider provider-name
                                              :identity identity
                                              :credential credential}})))
(defn add-service*
  [file service-name provider-name identity credential]
  (let [service-name (name service-name)
        available-services (compute/supported-providers)]
    (warn-on-invalid-provider-name provider-name available-services)
    (write-service file service-name provider-name identity credential)))
(defn usage []
  (binding [*out* *err*]
    (println "incorrect arguments:")
    (println "  lein pallet service-name provider-name identity credential")))
(defn
  ^{:no-service-required true}
  add-service
  "Add a service provider definition to your pallet configuration.
       lein pallet add-serivce name [provider [identity [credential]]]
   This will create ~/.pallet/services/name.clj"
  [ & [service-name provider-name identity credential & _]]
  (if (and service-name provider-name identity credential)
    (let [service-name (name service-name)
          path (io/file
                (System/getProperty "user.home")
                ".pallet" "services" service-name)]
      (if (.exists path)
        (do
          (println
           "Service configuration file" (.getPath path) "already exists")
          1)
        (add-service*
         path service-name
         (name provider-name)
         (name identity)
         (name credential))))
    (usage)))
 

List contianers.

(ns pallet.task.containers
  (:require
   [pallet.blobstore :as blobstore]))
(defn containers
  "List containers."
  [request & args]
  (doseq [container (blobstore/containers (:blobstore request))
          :let [container (bean container)
                location (-> container :location)]]
    (println
     (format
      "\t%20s  %s"
      (:name container) (.getDescription location)))))
 

Adjust node counts.

(ns pallet.task.converge
  (:require
   [pallet.core :as core]
   [clojure.tools.logging :as logging]))
(defn- build-args [args]
  (loop [args args
         prefix nil
         m nil
         phases []]
    (if-let [a (first args)]
      (cond
       (and (nil? m) (symbol? a) (nil? (namespace a))) (recur
                                                        (next args)
                                                        (name a)
                                                        m
                                                        phases)
       (not (keyword? a)) (recur
                           (nnext args)
                           prefix
                           (assoc (or m {}) a (fnext args))
                           phases)
       :else (recur (next args) prefix m (conj phases a)))
      (concat [m] (if prefix [:prefix prefix] []) [:phase phases]))))
(defn converge
  "Adjust node counts.  Requires a map of node-type, count pairs.
     eg. pallet converge mynodes/my-node 1
   The node-types should be namespace qualified."
  [request & args]
  (let [args (build-args args)]
    (apply core/converge
           (concat args
                   (apply concat
                          (->
                           request
                           (dissoc :config :project)
                           (assoc :environment
                             (or (:environment request)
                                 (-> request :project :environment)))))))))
 

Adjust node counts for a cluster.

(ns pallet.task.converge-cluster
  (:require
   [pallet.core :as core]
   [clojure.tools.logging :as logging]))
(defn- build-args [args]
  (loop [args args
         prefix nil
         m nil
         phases []]
    (if-let [a (first args)]
      (cond
       (and (nil? m) (symbol? a) (nil? (namespace a))) (recur
                                                        (next args)
                                                        (name a)
                                                        m
                                                        phases)
       (nil? m) (recur (next args) prefix a phases)
       :else (recur (next args) prefix m (conj phases a)))
      (concat [m] (if prefix [:prefix prefix] []) [:phase phases]))))
(defn converge-cluster
  "Adjust node counts of a cluster.  Requires the name of the cluster.
       pallet converge-cluster org.mynodes/my-cluster
       pallet converge-cluster org.mynodes/my-cluster :install :configure
   The cluster name should be namespace qualified."
  [request & args]
  (let [args (build-args args)]
    (apply core/converge-cluster
           (concat args
                   (apply concat
                          (->
                           request
                           (dissoc :config :project)
                           (assoc :environment
                             (or (:environment request)
                                 (-> request :project :environment)))))))))
 

Adjust node counts.

(ns pallet.task.describe-node
  (:require
   [pallet.core :as core]
   [clojure.tools.logging :as logging]))
(defn describe-node
  "Display the node definition for the given node-types."
  {:no-service-required true}
  [& args]
  (doseq [arg args]
    (println (format "%s\t %s" (arg :tag) (arg :image)))))
 

Destroy nodes for a cluster.

(ns pallet.task.destroy-cluster
  (:require
   [pallet.core :as core]
   [clojure.tools.logging :as logging]))
(defn- build-args [args]
  (loop [args args
         prefix nil
         m nil
         phases []]
    (if-let [a (first args)]
      (cond
       (and (nil? m) (symbol? a) (nil? (namespace a))) (recur
                                                        (next args)
                                                        (name a)
                                                        m
                                                        phases)
       (not (keyword? a)) (recur (next args) prefix a phases)
       :else (recur (next args) prefix m (conj phases a)))
      (concat [m] (if prefix [:prefix prefix] []) [:phase phases]))))
(defn destroy-cluster
  "Adjust node counts of a cluster.  Requires the name of the cluster.
     eg. pallet converge-cluster org.mynodes/my-cluster
   The cluster name should be namespace qualified."
  [request & args]
  (let [args (build-args args)]
    (apply core/destroy-cluster
           (concat args
                   (apply concat
                          (->
                           request
                           (dissoc :config :project)
                           (assoc :environment
                             (or (:environment request)
                                 (-> request :project :environment)))))))))
 

Display a list of tasks or help for a given task.

(ns pallet.task.help)
(def impl-ns #"^pallet\.task\.")
(def task-list (atom nil))
(defn tasks
  "Find the available tasks."
  []
  (try
   (require 'clojure.tools.namespace)
   (let [find-namespaces-on-classpath
         (find-var 'clojure.tools.namespace/find-namespaces-on-classpath)]
     (or @task-list
         (reset! task-list
                 (set (filter #(re-find impl-ns (name %))
                              (find-namespaces-on-classpath))))))
   (catch java.io.FileNotFoundException e
     #{'pallet.task.help
       'pallet.task.new-project})))
(defn help-for
  "Help for a task is stored in its docstring, or if that's not present
  in its namespace."
  [task]
  (let [task-ns (symbol (str "pallet.task." task))
        _ (require task-ns)
        task (ns-resolve task-ns (symbol task))]
    (or (:doc (meta task))
        (:doc (meta (find-ns task-ns))))))

affected by clojure ticket #130: bug of AOT'd namespaces losing metadata

(defn help-summary-for [task-ns]
  (require task-ns)
  (let [task-name (last (.split (name task-ns) "\\."))]
    (str task-name (apply str (repeat (- 8 (count task-name)) " "))
         " - " (:doc (meta (find-ns task-ns))))))
(defn help
  {:no-service-required true}
  ([task] (println (help-for task)))
  ([]
     (println "Pallet is a cloud administration tool.\n")
     (println "Several tasks are available:")
     (doseq [task-ns (tasks)]
       ;; (println (help-summary-for task-ns))
       (println " " (last (.split (name task-ns) "\\."))))
     (println "\nRun pallet help $TASK for details.")
     (if @task-list
       (do
         (println "\nYou can write project specific tasks under the\n"
                  "pallet.task namespace.")
         (println "\nOptions:")
         (println "  -progvide    name-of-cloud-provider")
         (println "  -identity    login for cloud service API")
         (println "  -credential  key or password for cloud service API")
         (println "\nIf no options are given, the following sequence is used to")
         (println "find a service to use.")
         (println "\n  the pallet.config.service property is checked for the")
         (println "    name of a var to use for the service,")
         (println "\n  the ~/.pallet/config.clj is checked for an active profile")
         (println "    specified with `defpallet`.  e.g.")
         (println "      (defpallet")
         (println "        :services {")
         (println "          :aws {:provider \"ec2\)
         (println "                :identity \"username or key\)
         (println "                :credential \"password, key or secret key\"}})")
         (println "\n  the ~/.m2/settings.xml is checked for an active profile")
         (println "    with the following properties:")
         (println "      pallet.compute.provider")
         (println "      pallet.compute.identity")
         (println "      pallet.compute.credential,")
         (println "\n  the pallet.config/service is used if it exists."))
       (do
         (println "Run the new-project task to create a pallet project.\n")))
     (println "\nSee http://github.com/hugoduncan/pallet.")))
 

List images.

(ns pallet.task.images
  (:require
   [pallet.compute :as compute]))
(defn images
  "List available images."
  [request & args]
  (doseq [image (compute/images (:compute request))
          :let [image (bean image)]]
    (println (pr-str image))))
 

Apply configuration.

(ns pallet.task.lift
  (:require
   [pallet.core :as core]
   [clojure.tools.logging :as logging]))
(defn- build-args [args]
  (loop [args args
         prefix nil
         m nil
         phases []]
    (if-let [a (first args)]
      (cond
       (and (nil? m) (symbol? a) (nil? (namespace a))) (recur
                                                        (next args)
                                                        (name a)
                                                        m
                                                        phases)
       (not (keyword? a)) (recur
                           (next args)
                           prefix
                           (conj (or m []) a)
                           phases)
       :else (recur (next args) prefix m (conj phases a)))
      (concat (if prefix [prefix] []) [(set m)] [:phase phases]))))
(defn lift
  "Apply configuration.
     eg. pallet lift mynodes/my-node
   The node-types should be namespace qualified."
  [request & args]
  (let [args (build-args args)]
    (apply core/lift
           (concat args
                   (apply concat
                          (->
                           request
                           (dissoc :config :project)
                           (assoc :environment
                             (or (:environment request)
                                 (-> request :project :environment)))))))))
 

Create a new pallet project. pallet new-project .

(ns pallet.task.new-project
  (:import
   [java.io
    File OutputStreamWriter FileOutputStream PrintWriter]))

We don't want this task to depend on clojure.contrib, or on lein

(defn spit "Opposite of slurp. Opens f, writes content, then closes f." [f content] (with-open [w (PrintWriter. (OutputStreamWriter. (FileOutputStream. f)))] (.print w content)))

(defn file
  [& args]
  (File. (apply str (interpose "/" args))))
(defn ns->path [n]
  (str (.. (str n)
           (replace \- \_)
           (replace \. \/))
       ".clj"))
(defn new-project-lein
  [project-name project-dir]
  (let [project-name (symbol project-name)
        group-id (namespace project-name)
        artifact-id (name project-name)]
    (.mkdirs (File. project-dir))
    (spit (file project-dir "project.clj")
          (str "(defproject " project-name " \"1.0.0-SNAPSHOT\"\n"
               "  :description \"FIXME: write\"\n"
               "  :dependencies [[pallet/pallet \"0.0.1-SNAPSHOT\"]])\n"))
    (let [project-ns  (str (.replace (str project-name) "/" ".") ".nodes")
          project-clj (ns->path project-ns)
          test-clj (.replace project-clj ".clj" "_test.clj")]
      (.mkdirs (file project-dir "test"))
      (.mkdirs (.getParentFile (file project-dir "src" project-clj)))
      (spit (file project-dir "src" project-clj)
            (str "(ns " project-ns
                 "\n  \"Admin and provisioning for FIXME:project.\" "
                 "\n  (:require"
                 "\n    [pallet.core :as core]))\n"))
      (.mkdirs (.getParentFile (file project-dir "test" test-clj)))
      (spit (file project-dir "test" test-clj)
            (str "(ns " (str project-ns "-test")
                 "\n  (:use [" project-ns "] :reload-all)"
                 "\n  (:use [clojure.test]))\n\n"
                 "(deftest replace-me ;; FIXME: write\n  (is false))\n"))
      (spit (file project-dir ".gitignore")
            (apply str (interpose"\n" ["pom.xml" "*jar" "lib" "classes"])))
      (spit (file project-dir "README")
            (apply str (interpose "\n\n" [(str "# " artifact-id)
                                          "FIXME: write description"
                                          "## Usage" "FIXME: write"
                                          "## Installation" "FIXME: write"
                                          "## License" "FIXME: write\n"])))
      (println "Created new project in:" project-dir)
      (println "You should now run 'lein deps' in that directory."))))
(defn new-project
  {:no-service-required true}
  [& args]
  (let [name (first args)
        dir (or (second args) "pallet")]
    (if (.exists (File. dir))
      (do
        (println "Directory" dir "already exists.")
        (System/exit 1))
      (new-project-lein name dir))))
 

list nodes.

(ns pallet.task.nodes
  (:require
   [pallet.compute :as compute]
   [clojure.pprint :as pprint])
  (:use clojure.tools.logging))
(defn nodes
  [request]
  (let [ns (compute/nodes (:compute request))]
    (doseq [n ns]
      (println n))))
 

Provide information on the supported and enabled providers.

(ns pallet.task.providers
  (:require
   [pallet.utils :as utils]))
(defn- provider-properties []
  (apply
   hash-map
   (apply concat
          (filter #(re-find #"(.*)\.contextbuilder" (first %))
                  (utils/resource-properties "rest.properties")))))
(defn- enabled?
  [provider]
  (try
   (Class/forName provider)
   (catch java.lang.ClassNotFoundException e)))
(defn providers
  "Provide information on the supported and enabled providers."
  {:no-service-required true}
  [& _]
  (println "Pallet uses jcloud's providers.\n")
  (doseq [supported (sort #(compare (first %1) (first %2))
                          (provider-properties))
          :let [key (first supported)
                name (.substring key 0 (.indexOf key "."))]]
    (println
     (format
      "\t%20s  %s"
      name
      (if (enabled? (second supported)) "Enabled" "Disabled"))))
  (println "\nProviders can be enabled by adding a dependency on the jclouds ")
  (println "provider into your project.clj or pom.xml."))
 

Upload to a blob.

(ns pallet.task.to-blob
  (:require
   [pallet.blobstore :as blobstore]))
(defn war-file-name
  [project]
  (format "%s-%s.war" (:name project) (:version project)))
(defn find-war
  [project]
  (some
   #(let [f (% project)] (and (.exists (java.io.File. f)) f))
   [war-file-name]))
(defn to-blob
  "Upload to a blob.
    to-blob container path filename
   By default tries to upload the project war file."
  [request & args]
  (let [[container path & files] (map name args)
        file (or (first files) (find-war (:project request)))
        options (-> request :project :pallet)]
    (if file
      (do
        (println "Uploading" file)
        (blobstore/put-file (:blobstore request) container path file))
      (println "Nothing to upload"))))
 

Print Pallet's version to standard out.

(ns pallet.task.version)
(defn version
  {:no-service-required true}
  []
  (println "Pallet" (System/getProperty "pallet.version")
           "on Java" (System/getProperty "java.version")
           (System/getProperty "java.vm.name")))
 

A template for writing properties style config files.

(ns pallet.template.properties
  (:use [pallet.utils :only [as-string]]))
(defn property-section [[name settings]]
  (apply
   str
   "[" (as-string name) "]" \newline
   (map #(format "%s = %s\n" (as-string (first %)) (as-string (second %))) settings)))
(defn property-set [p]
  (apply str (map property-section p)))
(defn properties
  "Write a properties file based on the input argument."
  [values]
  (apply str (map property-set values)))
 

Template file writing

(ns pallet.template
  (:require
   [pallet.compute :as compute]
   [pallet.script.lib :as lib]
   [pallet.session :as session]
   [pallet.stevedore :as stevedore]
   [pallet.strint :as strint]
   [pallet.target :as target]
   [pallet.utils :as utils]
   [clojure.string :as string]
   [clojure.tools.logging :as logging]))
(defn get-resource
  "Loads a resource. Returns a URI."
  [path]
  (-> (clojure.lang.RT/baseLoader) (.getResource path)))
(defn path-components
  "Split a resource path into path, basename and extension components."
  [path]
  (let [p (inc (.lastIndexOf path "/"))
        i (.lastIndexOf path ".")]
    [(when (pos? p) (subs path 0 (dec p)))
     (if (neg? i) (subs path p) (subs path p i))
     (if (neg? i) nil (subs path (inc i)))]))
(defn pathname
  "Build a pathname from a list of path and filename parts.  Last part is
   assumed to be a file extension.
   'The name of a resource is a '/'-separated path name that identifies the
   resource.'"
  [path file ext]
  (str (when path (str path "/")) file (when ext (str "." ext))))
(defn- candidate-templates
  "Generate a prioritised list of possible template paths."
  [path tag session]
  (let [[dirpath base ext] (path-components path)
        variants (fn [specifier]
                   (let [p (pathname
                            dirpath
                            (if specifier (str base "_" specifier) base)
                            ext)]
                     [p (str "resources/" p)]))]
    (concat
     (variants tag)
     (variants (name (or (session/os-family session) "unknown")))
     (variants (name (or (session/packager session) "unknown")))
     (variants nil))))
(defn find-template
  "Find a template for the specified path, for application to the given node.
   Templates may be specialised."
  [path session]
  {:pre [(map? session) (session :server)]}
  (some
   get-resource
   (candidate-templates
    path (-> session :server :group-name) session)))
(defn interpolate-template
  "Interpolate the given template."
  [path values session]
  (strint/<<!
   (utils/load-resource-url
    (find-template path session))
   (utils/map-with-keys-as-symbols values)))

programatic templates - umm not really templates at all

(defmacro deftemplate [template [& args] m]
  `(defn ~template [~@args]
     ~m))
(defn- apply-template-file [[file-spec content]]
  (logging/trace (str "apply-template-file " file-spec \newline content))
  (let [path (:path file-spec)]
    (string/join
     (filter (complement nil?)
             [(stevedore/script
               (var file ~path)
               ((~lib/cat ) > @file <<EOF))
              content
              "\nEOF\n"
              (when-let [mode (:mode file-spec)]
                (stevedore/script (do (chmod ~mode @file))))
              (when-let [group (:group file-spec)]
                (stevedore/script (do (chgrp ~group @file))))
              (when-let [owner (:owner file-spec)]
                (stevedore/script (do (chown ~owner @file))))]))))

TODO - add chmod, owner, group

(defn apply-templates [template-fn args]
  (string/join  (map apply-template-file (apply template-fn args))))
 

Utilities used across pallet.

(ns pallet.utils
  (:require
   [clojure.java.io :as io]
   [clojure.pprint :as pprint]
   [clojure.tools.logging :as logging])
  (:use
   clojure.tools.logging)
  (:import
   (java.security
    NoSuchAlgorithmException
    MessageDigest)
   (org.apache.commons.codec.binary Base64)))
(defn pprint-lines
  "Pretty print a multiline string"
  [s]
  (pprint/pprint (seq (.split #"\r?\n" s))))
(defn quoted
  "Return the string value of the argument in quotes."
  [s]
  (str "\ s "\))
(defn underscore [s]
  "Change - to _"
  (apply str (interpose "_"  (.split s "-"))))
(defn as-string
  "Return the string value of the argument."
  [arg]
  (cond
   (symbol? arg) (name arg)
   (keyword? arg) (name arg)
   :else (str arg)))
(defmacro apply-map
  "Applies fn f to the argument list formed by prepending args to
  (apply concat argmap). Similar to clojure.core/apply, but taking a final map
  instead of a sequence."
  {:arglists '([f args* argmap])
   :added "0.6.8"}
  [& args]
  `(apply ~@(drop-last args) (apply concat ~(last args))))
(defn resource-path [name]
  (let [loader (.getContextClassLoader (Thread/currentThread))
        resource (. loader getResource name)]
    (when resource
      (.getFile resource))))
(defn load-resource
  [name]
  (let [loader (.getContextClassLoader (Thread/currentThread))]
    (.getResourceAsStream loader name)))
(defn load-resource-url
  [name]
  (logging/tracef "load-resource-url %s" name)
  (with-open [stream (.getContent name)
              r (new java.io.BufferedReader
                     (new java.io.InputStreamReader
                          stream (.name (java.nio.charset.Charset/defaultCharset))))]
    (let [sb (new StringBuilder)]
      (loop [c (.read r)]
        (if (neg? c)
          (str sb)
          (do
            (.append sb (char c))
            (recur (.read r))))))))
(defn resource-properties
  "Given a resource `path`, load it as a java properties file.
   Returns nil if resource not found."
  [path]
  (let [loader (.getContextClassLoader (Thread/currentThread))
        stream (.getResourceAsStream loader path)]
    (when stream
      (with-open [stream stream]
        (let [properties (new java.util.Properties)]
          (.load properties stream)
          (let [keysseq (enumeration-seq (. properties propertyNames))]
            (reduce (fn [a b] (assoc a b (. properties getProperty b)))
                    {} keysseq)))))))
(defn slurp-as-byte-array
  "Read the given file as a byte array."
  [#^java.io.File file]
  (let [size (.length file)
        bytes #^bytes (byte-array size)
        stream (new java.io.FileInputStream file)]
    bytes))
(defn find-var-with-require
  "Find the var for the given namespace and symbol. If the namespace does
   not exist, then it will be required.
       (find-var-with-require 'my.ns 'a-symbol)
       (find-var-with-require 'my.ns/a-symbol)"
  ([sym]
     (find-var-with-require (symbol (namespace sym)) (symbol (name sym))))
  ([ns sym]
     (try
       (when-not (find-ns ns)
         (require ns))
       (when-let [v (ns-resolve ns sym)]
         (var-get v))
       (catch Exception _))))
(defn default-private-key-path
  "Return the default private key path."
  []
  (str (System/getProperty "user.home") "/.ssh/id_rsa"))
(defn default-public-key-path
  "Return the default public key path"
  []
  (str (System/getProperty "user.home") "/.ssh/id_rsa.pub"))
(defrecord User
  [username public-key-path private-key-path passphrase
   password sudo-password no-sudo])
(defn user? [user]
  (instance? pallet.utils.User user))
(defn make-user
  "Creates a User record with the given username and options. Generally used
   in conjunction with *admin-user* and pallet.core/with-admin-user, or passed
   to `lift` or `converge` as the named :user argument.
   Options:
    - :public-key-path (defaults to ~/.ssh/id_rsa.pub)
    - :private-key-path (defaults to ~/.ssh/id_rsa)
    - :passphrase
    - :password
    - :sudo-password (defaults to :password)
    - :no-sudo"
  [username & {:keys [public-key-path private-key-path passphrase
                      password sudo-password no-sudo] :as options}]
  (merge (User. username nil nil nil nil nil nil)
    {:private-key-path (default-private-key-path)
     :public-key-path (default-public-key-path)
     :sudo-password (:password options)}
    options))
(def
  ^{:doc "The admin user is used for running remote admin commands that require
   root permissions.  The default admin user is taken from the
   pallet.admin.username property.  If not specified then the user.name property
   is used. The admin user can also be specified in config.clj when running
   tasks from the command line."
    :dynamic true}
  *admin-user*
  (make-user (or (. System getProperty "pallet.admin.username")
                 (. System getProperty "user.name"))))
(defmacro with-temp-file
  "Create a block where `varname` is a temporary `File` containing `content`."
  [[varname content] & body]
  `(let [~varname (java.io.File/createTempFile "stevedore", ".tmp")]
     (io/copy ~content ~varname)
     (let [rv# (do ~@body)]
       (.delete ~varname)
       rv#)))
(defn tmpfile
  "Create a temporary file"
  ([] (java.io.File/createTempFile "pallet_" "tmp"))
  ([^java.io.File dir] (java.io.File/createTempFile "pallet_" "tmp" dir)))
(defn tmpdir
  "Create a temporary directory."
  []
  (doto (java.io.File/createTempFile "pallet_" "tmp")
    (.delete) ; this is a potential cause of non-unique names
    (.mkdir)))
(defmacro with-temporary
  "A block scope allowing multiple bindings to expressions.  Each binding will
   have the member function `delete` called on it."
  [bindings & body] {:pre
   [(vector?  bindings)
         (even? (count bindings))]}
  (cond
   (= (count bindings) 0) `(do ~@body)
   (symbol? (bindings 0)) `(let ~(subvec bindings 0 2)
                             (try
                              (with-temporary ~(subvec bindings 2) ~@body)
                              (finally
                               (. ~(bindings 0) delete))))
   :else (throw (IllegalArgumentException.
                 "with-temporary only allows Symbols in bindings"))))
(defn map-with-keys-as-symbols
  "Produce a map that is the same as m, but with all keys are converted to
  symbols."
  [m]
  (letfn [(to-symbol [x]
                     (cond
                      (symbol? x) x
                      (string? x) (symbol x)
                      (keyword? x) (symbol (name x))))]
    (zipmap (map to-symbol (keys m)) (vals m))))
(defn dissoc-keys
  "Like clojure.core/dissoc, except it takes a vector of keys to remove"
  [m keys]
  (apply dissoc m keys))
(defn dissoc-if-empty
  "Like clojure.core/dissoc, except it only dissoc's if the value at the
   keyword is nil."
  [m key]
  (if (empty? (m key)) (dissoc m key) m))
(defn maybe-update-in
  "'Updates' a value in a nested associative structure, where ks is a
  sequence of keys and f is a function that will take the old value
  and any supplied args and return the new value, and returns a new
  nested structure.  If any levels do not exist, hash-maps will be
  created only if the update function returns a non-nil value. If
  the update function returns nil, the map is returned unmodified."
  ([m [& ks] f & args]
     (let [v (f (get-in m ks))]
       (if v
         (assoc-in m ks v)
         m))))
(defmacro pipe
  "Build a session processing pipeline from the specified forms."
  [& forms]
  (let [[middlewares etc] (split-with #(or (seq? %) (symbol? %)) forms)
        middlewares (reverse middlewares)
        [middlewares [x :as etc]]
          (if (seq etc)
            [middlewares etc]
            [(rest middlewares) (list (first middlewares))])
          handler x]
    (if (seq middlewares)
      `(-> ~handler ~@middlewares)
      handler)))
(defn base64-md5
  "Computes the base64 encoding of the md5 of a string"
  [#^String unsafe-id]
  (let [alg (doto (MessageDigest/getInstance "MD5")
              (.reset)
              (.update (.getBytes unsafe-id)))]
    (try
      (Base64/encodeBase64URLSafeString (.digest alg))
      (catch NoSuchAlgorithmException e
        (throw (new RuntimeException e))))))
(defmacro middleware
  "Build a middleware processing pipeline from the specified forms.
   The result is a middleware."
  [& forms]
  (let [[middlewares] (split-with #(or (seq? %) (symbol? %)) forms)
        middlewares (reverse middlewares)]
    (if (seq middlewares)
      `(fn [handler#] (-> handler# ~@middlewares))
      `(fn [handler#] handler#))))

see http://weblogs.java.net/blog/kohsuke/archive/2007/04/howtoconvert.html

(defn file-for-url
  "Convert a URL to a File. "
  [^java.net.URL url]
  (try
    (java.io.File. (.toURI url))
    (catch java.net.URISyntaxException _
      (java.io.File. (.getPath url)))))
(defn classpath-urls
  "Return the classpath URL's for the current clojure classloader."
  []
  (.getURLs (.getClassLoader clojure.lang.RT)))
(defn classpath
  "Return the classpath File's for the current clojure classloader."
  []
  (map file-for-url (classpath-urls)))
(defn jar-file?
  "Returns true if file is a normal file with a .jar or .JAR extension."
  [^java.io.File file]
  (and (.isFile file)
       (or (.endsWith (.getName file) ".jar")
           (.endsWith (.getName file) ".JAR"))))
(defn classpath-jarfiles
  "Returns a sequence of JarFile objects for the JAR files on classpath."
  []
  (filter
   identity
   (map
    #(try
       (java.util.jar.JarFile. %)
       (catch Exception _
         (logging/warnf "Unable to open jar file on classpath: %s" %)))
    (filter jar-file? (classpath)))))
(defmacro forward-to-script-lib
  "Forward a script to the new script lib"
  [& symbols]
  `(do
     ~@(for [sym symbols]
         (list `def sym (symbol "pallet.script.lib" (name sym))))))
(defmacro fwd-to-configure [name & [as-name & _]]
  `(defn ~name [& args#]
     (require '~'pallet.configure)
     (let [f# (ns-resolve '~'pallet.configure '~(or as-name name))]
       (apply f# args#))))

forward with deprecation warnings admin-user-from-config-var admin-user-from-config

(fwd-to-configure admin-user-from-config-var)
(fwd-to-configure admin-user-from-config)
(defmacro with-redef
  [[& bindings] & body]
  (if (find-var 'clojure.core/with-redefs)
    `(clojure.core/with-redefs [~@bindings] ~@body)
    `(binding [~@bindings] ~@body)))