leiningen-core

2.2.0


Library for core functionality of Leiningen.

dependencies

org.clojure/clojure
1.5.1
bultitude
0.2.2
classlojure
0.6.6
useful
0.8.6
robert/hooke
1.3.0
com.cemerick/pomegranate
0.2.0
org.apache.maven.wagon/wagon-http
2.4
com.hypirion/io
0.2.0-RC1



(this space intentionally left almost blank)
 

Calculate project classpaths by resolving dependencies via Aether.

(ns leiningen.core.classpath
  (:require [cemerick.pomegranate.aether :as aether]
            [cemerick.pomegranate :as pomegranate]
            [clojure.java.io :as io]
            [clojure.string :as str]
            [leiningen.core.user :as user]
            [leiningen.core.utils :as utils])
  (:import (java.util.jar JarFile)
           (org.sonatype.aether.resolution DependencyResolutionException)))

Basically just for re-throwing a more comprehensible error.

(defn- read-dependency-project [root dep]
  (let [project-file (io/file root "checkouts" dep "project.clj")]
    (if (.exists project-file)
      (let [project (.getAbsolutePath project-file)]
        ;; TODO: core.project and core.classpath currently rely upon each other *uk*
        (require 'leiningen.core.project)
        (try ((resolve 'leiningen.core.project/read) project [:default])
             (catch Exception e
               (throw (Exception. (format "Problem loading %s" project) e)))))
      (println
       "WARN ignoring checkouts directory" dep
       "as it does not contain a project.clj file."))))
(defn- checkout-dep-paths [project dep-project]
  ;; can't mapcat here since :checkout-deps-shares points to vectors and strings
  (flatten (map #(% dep-project) (:checkout-deps-shares project))))

Checkout dependencies are used to place source for a dependency project directly on the classpath rather than having to install the dependency and restart the dependent project.

(defn- checkout-deps-paths
  [project]
  (apply concat (for [dep (.list (io/file (:root project) "checkouts"))
                      :let [dep-project (read-dependency-project
                                         (:root project) dep)]
                      :when dep-project]
                  (checkout-dep-paths project dep-project))))
(defn extract-native-deps [files native-path native-prefixes]
  (doseq [file files
          :let [native-prefix (get native-prefixes file "native/")
                jar (JarFile. file)]
          entry (enumeration-seq (.entries jar))
          :when (.startsWith (.getName entry) native-prefix)]
    (let [f (io/file native-path (subs (.getName entry) (count native-prefix)))]
      (if (.isDirectory entry)
        (.mkdirs f)
        (do (.mkdirs (.getParentFile f))
            (io/copy (.getInputStream jar entry) f))))))

Call f with args when keys in project.clj have changed since the last run. Stores value of project keys in stale directory inside :target-path. Because multiple callers may check the same keys, you must also provide a token to keep your stale value separate. Returns true if the code was executed and nil otherwise.

(defn when-stale
  [token keys project f & args]
  (let [file (io/file (:target-path project) "stale"
                      (str (name token) "." (str/join "+" (map name keys))))
        current-value (pr-str (map (juxt identity project) keys))
        old-value (and (.exists file) (slurp file))]
    (when (and (:name project) (:target-path project)
               (not= current-value old-value))
      (apply f args)
      (.mkdirs (.getParentFile file))
      (spit file (doall current-value))
      true)))

Repository credentials (a map containing some of #{:username :password :passphrase :private-key-file}) are discovered from:

  1. Looking up the repository URL in the ~/.lein/credentials.clj.gpg map
  2. Scanning that map for regular expression keys that match the repository URL.

    So, a credentials map that contains an entry:

    {#"http://maven.company.com/.*" {:username "abc" :password "xyz"}}

    would be applied to all repositories with URLs matching the regex key that didn't have an explicit entry.

(defn add-repo-auth
  [[id repo]]
  [id (-> repo user/profile-auth user/resolve-credentials)])
(defn get-non-proxy-hosts []
  (let [system-no-proxy (System/getenv "no_proxy")
        lein-no-proxy (System/getenv "http_no_proxy")]
    (if (and (empty? lein-no-proxy) (not-empty system-no-proxy))
      (->> (str/split system-no-proxy #",")
           (map #(str "*" %))
           (str/join "|"))
      (System/getenv "http_no_proxy"))))

Returns a map of the JVM proxy settings

(defn get-proxy-settings
  ([] (get-proxy-settings "http_proxy"))
  ([key]
     (if-let [proxy (System/getenv key)]
       (let [url (utils/build-url proxy)
             user-info (.getUserInfo url)
             [username password] (and user-info (.split user-info ":"))]
         {:host (.getHost url)
          :port (.getPort url)
          :username username
          :password password
          :non-proxy-hosts (get-non-proxy-hosts)}))))
(defn- update-policies [update checksum [repo-name opts]]
  [repo-name (merge {:update (or update :daily)
                     :checksum (or checksum :fail)} opts)])
(defn- print-failures [e]
  (doseq [result (.getArtifactResults (.getResult e))
          :when (not (.isResolved result))
          exception (.getExceptions result)]
    (println (.getMessage exception)))
  (doseq [ex (.getCollectExceptions (.getResult e))
          ex2 (.getExceptions (.getResult ex))]
    (println (.getMessage ex2))))
(defn- root-cause [e]
  (last (take-while identity (iterate (memfn getCause) e))))
(def ^:private get-dependencies-memoized
  (memoize
   (fn [dependencies-key {:keys [repositories local-repo offline? update
                                 checksum mirrors] :as project}
        & {:keys [add-classpath? repository-session-fn]}]
     {:pre [(every? vector? (get project dependencies-key))]}
     (try
       ((if add-classpath?
          pomegranate/add-dependencies
          aether/resolve-dependencies)
        :repository-session-fn repository-session-fn
        :local-repo local-repo
        :offline? offline?
        :repositories (->> repositories
                           (map add-repo-auth)
                           (map (partial update-policies update checksum)))
        :coordinates (get project dependencies-key)
        :mirrors (->> mirrors
                      (map add-repo-auth)
                      (map (partial update-policies update checksum)))
        :transfer-listener
        (bound-fn [e]
          (let [{:keys [type resource error]} e]
            (let [{:keys [repository name size trace]} resource]
              (let [aether-repos (if trace (.getRepositories (.getData trace)))]
                (case type
                  :started
                  (if-let [repo (first (filter
                                        #(or (= (.getUrl %) repository)
                                             ;; sometimes the "base" url
                                             ;; doesn't have a slash on it
                                             (= (str (.getUrl %) "/") repository))
                                        aether-repos))]
                    (println "Retrieving"
                             name
                             "from"
                             (.getId repo))
                    ;;else case happens for metadata files)
                  nil)))))
        :proxy (get-proxy-settings))
       (catch DependencyResolutionException e
         (binding [*out* *err*]
           ;; Cannot recur from catch/finally so have to put this in its own defn
           (print-failures e)
           (println "This could be due to a typo in :dependencies or network issues.")
           #_(when-not (some #(= "https://clojars.org/repo/" (:url (second %))) repositories)
               (println "It's possible the specified jar is in the old Clojars Classic repo.")
               (println "If so see https://github.com/ato/clojars-web/wiki/Releases.")))
         (throw (ex-info "Could not resolve dependencies" {:suppress-msg true
                                                           :exit-code 1} e)))
       (catch Exception e
         (if (and (instance? java.net.UnknownHostException (root-cause e))
                  (not offline?))
           (get-dependencies-memoized dependencies-key (assoc project :offline? true))
           (throw e)))))))
(defn ^:internal get-dependencies [dependencies-key project & args]
  (apply get-dependencies-memoized
         dependencies-key (select-keys project [dependencies-key :repositories
                                                :local-repo :offline? :update
                                                :checksum :mirrors]) args))

Return a match to dep (a single dependency vector) in dependencies (a dependencies vector, such as :dependencies in project.clj). Matching is done on the basis of the group/artifact id and version.

(defn- get-original-dependency
  [dep dependencies]
  (some (fn [v] ; not certain if this is the best matching fn
          (when (= (subvec dep 0 2) (subvec v 0 2 )) v))
        dependencies))

Return the :native-prefix of a dependency vector, or nil.

(defn get-native-prefix
  [[id version & {:as opts}]]
  (get opts :native-prefix))

Given a dependencies vector (such as :dependencies in project.clj) and a dependencies tree, as returned by get-dependencies, return a mapping from the Files those dependencies entail to the :native-prefix, if any, referenced in the dependencies vector.

(defn- get-native-prefixes
  [dependencies dependencies-tree]
  (let [override-deps (->> (map #(get-original-dependency
                                  % dependencies)
                                (keys dependencies-tree))
                           (map get-native-prefix))]
    (->> (aether/dependency-files dependencies-tree)
         (#(map vector % override-deps))
         (filter second)
         (filter #(re-find #"\.(jar|zip)$" (.getName (first %))))
         (into {}))))

Delegate dependencies to pomegranate. This will ensure they are downloaded into ~/.m2/repository and that native components of dependencies have been extracted to :native-path. If :add-classpath? is logically true, will add the resolved dependencies to Leiningen's classpath.

Returns a seq of the dependencies' files.

(defn resolve-dependencies
  [dependencies-key {:keys [repositories native-path] :as project} & rest]
  (let [dependencies-tree (apply get-dependencies dependencies-key project rest)
        jars (->> dependencies-tree
                  (aether/dependency-files)
                  (filter #(re-find #"\.(jar|zip)$" (.getName %))))
        native-prefixes (get-native-prefixes (get project dependencies-key)
                                             dependencies-tree)]
    (when-not (= :plugins dependencies-key)
      (or (when-stale :extract-native [dependencies-key] project
                      extract-native-deps jars native-path native-prefixes)
          ;; Always extract native deps from SNAPSHOT jars.
          (extract-native-deps (filter #(re-find #"SNAPSHOT" (.getName %)) jars)
                               native-path
                               native-prefixes)))
    jars))

Returns a graph of the project's dependencies.

(defn dependency-hierarchy
  [dependencies-key project & options]
  (if-let [deps-list (get project dependencies-key)]
    (aether/dependency-hierarchy deps-list
                                 (apply get-dependencies dependencies-key
                                        project options))))
(defn- normalize-path [root path]
  (let [f (io/file path)] ; http://tinyurl.com/ab5vtqf
    (.getAbsolutePath (if (or (.isAbsolute f) (.startsWith (.getPath f) "\\"))
                        f (io/file root path)))))

Should the given dependency be loaded in the extensions classloader?

(defn ext-dependency?
  [dep]
  (second
   (some #(if (= :ext (first %)) dep)
         (partition 2 dep))))

Classpath of the extensions dependencies in project as a list of strings.

(defn ext-classpath
  [project]
  (seq
   (->> (filter ext-dependency? (:dependencies project))
        (assoc project :dependencies)
        (resolve-dependencies :dependencies)
        (map (memfn getAbsolutePath)))))

Return the classpath for project as a list of strings.

(defn get-classpath
  [project]
  (for [path (concat (:test-paths project)
                     (:source-paths project)
                     (:resource-paths project)
                     [(:compile-path project)]
                     (checkout-deps-paths project)
                     (for [dep (resolve-dependencies :dependencies project)]
                       (.getAbsolutePath dep)))
        :when path]
    (normalize-path (:root project) path)))
 

Evaluate code inside the context of a project.

(ns leiningen.core.eval
  (:require [classlojure.core :as cl]
            [clojure.java.io :as io]
            [clojure.string :as string]
            [cemerick.pomegranate :as pomegranate]
            [cemerick.pomegranate.aether :as aether]
            [leiningen.core.user :as user]
            [leiningen.core.project :as project]
            [leiningen.core.main :as main]
            [leiningen.core.classpath :as classpath]
            [leiningen.core.utils :as utils])
  (:import (com.hypirion.io Pipe ClosingPipe)))
(def ^:private arch-options
  {:x86 ["-d32"] :x86_64 ["-d64"]})

Returns a keyword naming the host OS. Deprecated, use leiningen.core.utils/get-os instead.

(def ^:deprecated get-os
  utils/get-os)

Returns a keyword naming the host architecture. Deprecated, use leiningen.core.utils/get-arch instead.

(def ^:deprecated get-arch
  utils/get-arch)

Returns a file destination that will discard output. Deprecated, use leiningen.core.utils/platform-nullsink instead.

(def ^:deprecated platform-nullsink
  utils/platform-nullsink)

Preparing for eval-in-project

Execute all the prep-tasks. A task can either be a string, or a vector if it takes arguments. see :prep-tasks in sample.project.clj for examples

(defn run-prep-tasks
  [{:keys [prep-tasks] :as project}]
  (doseq [task prep-tasks]
    (let [[task-name & task-args] (if (vector? task) task [task])
          task-name (main/lookup-alias task-name project)]
      (main/apply-task task-name (dissoc project :prep-tasks) task-args))))

Block on this to wait till the project is fully prepped.

Some tasks

(defonce 
  prep-blocker (atom (promise)))

Before we can run eval-in-project we need to prep the project by running javac, compile, and any other tasks the project specifies.

(defn prep
  [project]
  ;; This must exist before the project is launched.
  (when (:root project)
    (.mkdirs (io/file (:compile-path project "/tmp"))))
  (classpath/resolve-dependencies :dependencies project)
  (run-prep-tasks project)
  (deliver @prep-blocker true)
  (reset! prep-blocker (promise)))

Subprocess stuff

Paths to the os/arch-specific directory containing native libs.

(defn native-arch-paths
  [project]
  (let [os (:os project (get-os))
        arch (:arch project (get-arch))
        native-path (:native-path project)]
    (if (and os arch)
      (conj
       (->> (:dependencies project)
            (map classpath/get-native-prefix)
            (remove nil?)
            (map #(io/file native-path %)))
       (io/file native-path (name os) (name arch))))))
(defn- as-str [x]
  (if (instance? clojure.lang.Named x)
    (name x)
    (str x)))
(defn- d-property [[k v]]
  (format "-D%s=%s" (as-str k) v))

TODO: this would still screw up with something like this: export JAVA_OPTS="-Dmain.greeting=\"hello -main\" -Xmx512m"

(defn- join-broken-arg [args x]
  (if (= \- (first x))
    (conj args x)
    (conj (vec (butlast args))
          (str (last args) " " x))))
(defn ^:internal get-jvm-opts-from-env [env-opts]
  (and (seq env-opts)
       (reduce join-broken-arg []
               (.split (string/trim env-opts) " "))))

Calculate command-line arguments for launching java subprocess.

(defn- get-jvm-args
  [project]
  (let [native-arch-paths (native-arch-paths project)]
    `(~@(get-jvm-opts-from-env (System/getenv "JVM_OPTS"))
      ~@(:jvm-opts project)
      ~@(get arch-options (:arch project))
      ;; TODO: support -Xverify:none
      ~@(map d-property {:clojure.compile.path (:compile-path project)
                         (str (:name project) ".version") (:version project)
                         :file.encoding (or (System/getProperty "file.encoding") "UTF-8")
                         :clojure.debug (boolean (or (System/getenv "DEBUG")
                                                     (:debug project)))})
      ~@(if native-arch-paths
          (let [extant-paths (filter #(.exists %) native-arch-paths)]
            (if (seq extant-paths)
              [(d-property [:java.library.path
                            (string/join java.io.File/pathSeparatorChar
                                         extant-paths)])])))
      ~@(when-let [{:keys [host port non-proxy-hosts]} (classpath/get-proxy-settings)]
          [(d-property [:http.proxyHost host])
           (d-property [:http.proxyPort port])
           (d-property [:http.nonProxyHosts non-proxy-hosts])])
      ~@(when-let [{:keys [host port]} (classpath/get-proxy-settings "https_proxy")]
          [(d-property [:https.proxyHost host])
           (d-property [:https.proxyPort port])]))))

Directory in which to start subprocesses with eval-in-project or sh.

(def ^:dynamic *dir*
  (System/getProperty "user.dir"))

Environment map with which to start subprocesses with eval-in-project or sh. Merged into the current environment unless ^:replace metadata is attached.

(def ^:dynamic *env*
  nil)

Rebind this to false to disable forwarding in to subprocesses.

(def ^:dynamic *pump-in*
  true)
(def drip-env
  {"DRIP_INIT" nil
   "DRIP_INIT_CLASS" nil})

Returns an overridden version of the current environment as an Array of Strings of the form name=val, suitable for passing to Runtime#exec.

(defn- overridden-env
  [env]
  (->> (if (:replace (meta env))
         env
         (merge {} (System/getenv) drip-env env))
       (filter val)
       (map #(str (name (key %)) "=" (val %)))
       (into-array String)))

A version of clojure.java.shell/sh that streams in/out/err.

(defn sh
  [& cmd]
  (when *pump-in*
    (utils/rebind-io!))
  (let [env (overridden-env *env*)
        proc (.exec (Runtime/getRuntime) (into-array cmd) env (io/file *dir*))]
    (.addShutdownHook (Runtime/getRuntime)
                      (Thread. (fn [] (.destroy proc))))
    (with-open [out (io/reader (.getInputStream proc))
                err (io/reader (.getErrorStream proc))
                in (.getOutputStream proc)]
      (let [pump-out (doto (Pipe. out *out*) .start)
            pump-err (doto (Pipe. err *err*) .start)
            pump-in (ClosingPipe. System/in in)]
        (when *pump-in* (.start pump-in))
        (.join pump-out)
        (.join pump-err)
        (let [exit-value (.waitFor proc)]
          (when *pump-in*
            (.kill System/in)
            (.join pump-in)
            (.resurrect System/in))
          exit-value)))))
(defn- form-string [form eval-in]
  (if (and (= (get-os) :windows) (not= :trampoline eval-in))
    ;; On windows if a parameter is in double quotes, then all we need
    ;; to worry about are double quotes, which we must escape
    (string/replace (pr-str form) "\ "\\\)
    (pr-str form)))
(defn- agent-arg [coords file]
  (let [{:keys [options bootclasspath]} (apply hash-map coords)]
    (concat [(str "-javaagent:" file (and options (str "=" options)))]
            (if bootclasspath [(str "-Xbootclasspath/a:" file)]))))
(defn ^:internal classpath-arg [project]
  (let [classpath-string (string/join java.io.File/pathSeparatorChar
                                      (classpath/get-classpath project))
        agent-tree (classpath/get-dependencies :java-agents project)
        ;; Seems like you'd expect dependency-files to walk the whole tree
        ;; here, but it doesn't, which is what we want. but maybe a bug?
        agent-jars (aether/dependency-files (aether/dependency-hierarchy
                                             (:java-agents project) agent-tree))]
    `(~@(mapcat agent-arg (:java-agents project) agent-jars)
      ~@(if (:bootclasspath project)
          [(str "-Xbootclasspath/a:" classpath-string)]
          ["-classpath" classpath-string]))))

Calculate vector of strings needed to evaluate form in a project subprocess.

(defn shell-command
  [project form]
  `(~(or (:java-cmd project) (System/getenv "JAVA_CMD") "java")
    ~@(classpath-arg project)
    ~@(get-jvm-args project)
    "clojure.main" "-e" ~(form-string form (:eval-in project))))

eval-in multimethod

Evaluate the given form in various contexts.

(defmulti eval-in
  ;; Force it to be a keyword so that we can accept symbols too. That
  ;; way ^:replace and ^:displace metadata can be applied.
  (fn [project _] (keyword (name (:eval-in project :subprocess)))))
(defmethod eval-in :subprocess [project form]
  (binding [*dir* (:root project)]
    (let [exit-code (apply sh (shell-command project form))]
      (when (pos? exit-code)
        (throw (ex-info "Subprocess failed" {:exit-code exit-code}))))))
(defonce trampoline-forms (atom []))
(defonce trampoline-profiles (atom []))
(defmethod eval-in :trampoline [project form]
  (swap! trampoline-forms conj form)
  (swap! trampoline-profiles conj (select-keys project
                                               [:dependencies :source-paths
                                                :resource-paths :test-paths])))
(defmethod eval-in :classloader [project form]
  (when-let [classpath (map io/file (classpath/ext-classpath project))]
    (cl/wrap-ext-classloader classpath))
  (let [classpath   (map io/file (classpath/get-classpath project))
        classloader (cl/classlojure classpath)]
    (doseq [opt (get-jvm-args project)
            :when (.startsWith opt "-D")
            :let [[_ k v] (re-find #"^-D(.*?)=(.*)$" opt)]]
      (if (= k "java.library.path")
        (cl/alter-java-library-path!
         (constantly (string/split v (re-pattern java.io.File/pathSeparator))))
        (System/setProperty k v)))
    (try (cl/eval-in classloader form)
         (catch Exception e
           (println (str "Error evaluating in classloader: "
                         (class e) ":" (.getMessage e)))
           (.printStackTrace e)
           (throw (ex-info "Classloader eval failed" {:exit-code 1}))))))
(defmethod eval-in :nrepl [project form]
  (require 'clojure.tools.nrepl)
  (let [port-file (io/file (:target-path project) "repl-port")
        connect (resolve 'clojure.tools.nrepl/connect)
        client (resolve 'clojure.tools.nrepl/client)
        client-session (resolve 'clojure.tools.nrepl/client-session)
        message (resolve 'clojure.tools.nrepl/message)
        recv (resolve 'clojure.tools.nrepl.transport/recv)]
    (if (.exists port-file)
      (let [transport (connect :host "localhost"
                               :port (Integer. (slurp port-file)))
            client (client-session (client transport Long/MAX_VALUE))]
        (message client {:op "eval" :code (pr-str form)})
        (doseq [{:keys [out err status]} (repeatedly #(recv transport 100))
                :while (not (some #{"done" "interrupted" "error"} status))]
          (when out (println out))
          (when err (binding [*out* *err*] (println err)))))
      ;; TODO: warn that repl couldn't be used?
      (eval-in (assoc project :eval-in :subprocess) form))))
(defmethod eval-in :leiningen [project form]
  (when (:debug project)
    (System/setProperty "clojure.debug" "true"))
  ;; :dependencies are loaded the same way as plugins in eval-in-leiningen
  (project/load-plugins project :dependencies)
  (doseq [path (classpath/get-classpath project)]
    (pomegranate/add-classpath path))
  (doseq [opt (get-jvm-args project)
          :when (.startsWith opt "-D")
          :let [[_ k v] (re-find #"^-D(.*?)=(.*)$" opt)]]
    (System/setProperty k v))
  (eval form))

Executes form in isolation with the classpath and compile path set correctly for the project. If the form depends on any requires, put them in the init arg to avoid the Gilardi Scenario: http://technomancy.us/143

(defn eval-in-project
  ([project form init]
     (prep project)
     (when (:warn-on-reflection project)
       (println "WARNING: :warn-on-reflection is deprecated; use :global-vars."))
     (eval-in project
              `(do (set! ~'*warn-on-reflection*
                         ~(:warn-on-reflection project))
                   ~@(map (fn [[k v]] `(set! ~k ~v)) (:global-vars project))
                   ~init
                   ~@(:injections project)
                   ~form)))
  ([project form] (eval-in-project project form nil)))
 
(ns leiningen.core.main
  (:require [leiningen.core.user :as user]
            [leiningen.core.project :as project]
            [leiningen.core.classpath :as classpath]
            [leiningen.core.utils :as utils]
            [clojure.java.io :as io]
            [clojure.string :as string]
            [bultitude.core :as b]))
(def aliases {"-h" "help", "-help" "help", "--help" "help", "-?" "help",
              "-v" "version", "-version" "version", "--version" "version",
              "├╝berjar" "uberjar",
              "-o" ["with-profile" "+offline"]
              "-U" ["with-profile" "+update"]
              "cp" "classpath" "halp" "help"
              "with-profiles" "with-profile"
              "readme" ["help" "readme"]
              "tutorial" ["help" "tutorial"]
              "sample" ["help" "sample"]})

User profile aliases, used only when Lein is not within a project.

without a delay this loads profiles at the top-level which can result in exceptions thrown outside of a nice catching context.

(def ^:private profile-aliases
  (delay (atom (-> (user/profiles) :user :aliases))))

Returns a value associated with a key in a hash map contained in an atom, removing it if it exists.

(defn- get-and-dissoc!
  [atom key]
  (when-let [[k v] (find @atom key)]
    (swap! atom dissoc key)
    v))
(defn lookup-alias [task-name project & [not-found]]
  (or (aliases task-name)
      (get (:aliases project) task-name)
      (when-not project
        (get-and-dissoc! @profile-aliases task-name))
      task-name
      (or not-found "help")))
(defn task-args [args project]
  (if (= "help" (aliases (second args)))
    ["help" [(first args)]]
    [(lookup-alias (first args) project) (rest args)]))
(def ^:dynamic *debug* (System/getenv "DEBUG"))

Print if debug (from DEBUG environment variable) is truthy.

(defn debug
  [& args]
  (when *debug* (apply println args)))
(def ^:dynamic *info* true)

Print unless info has been rebound to false.

(defn info
  [& args]
  (when *info* (apply println args)))

Bind to false to suppress process termination.

(def ^:dynamic *exit-process?*
   true)

Exit the process. Rebind exit-process? in order to suppress actual process exits for tools which may want to continue operating. Never call System/exit directly in Leiningen's own process.

(defn exit
  ([exit-code]
     (if *exit-process?*
       (do (shutdown-agents)
           (System/exit exit-code))
       (throw (ex-info "Suppressed exit" {:exit-code exit-code}))))
  ([] (exit 0)))

Print msg to standard err and exit with a value of 1. Will not directly exit under some circumstances; see exit-process?.

(defn abort
  [& msg]
  (binding [*out* *err*]
    (when (seq msg)
      (apply println msg))
    (exit 1)))
(defn- distance [s t]
  (letfn [(iters [n f start]
            (take n (map second
                         (iterate f start))))]
    (let [m (inc (count s)), n (inc (count t))
          first-row (vec (range m))
          matrix (iters n (fn [[j row]]
                            [(inc j)
                             (vec (iters m (fn [[i col]]
                                             [(inc i)
                                              (if (= (nth s i)
                                                     (nth t j))
                                                (get row i)
                                                (inc (min (get row i)
                                                          (get row (inc i))
                                                          col)))])
                                         [0 (inc j)]))])
                        [0 first-row])]
      (last (last matrix)))))

Return a list of symbols naming all visible tasks.

(defn tasks
  []
  (->> (b/namespaces-on-classpath :prefix "leiningen")
       (filter #(re-find #"^leiningen\.(?!core|main|util)[^\.]+$" (name %)))
       (distinct)
       (sort)))

Suggest possible misspellings for task from list of tasks.

(defn suggestions
  [task tasks]
  (let [suggestions (into {} (for [t tasks
                                   :let [n (.replaceAll (name t)
                                                        "leiningen." "")]]
                               [n (distance n task)]))
        min (apply min (vals suggestions))]
    (if (<= min 4)
      (map first (filter #(= min (second %)) suggestions)))))
(defn ^:no-project-needed task-not-found [task & _]
  (binding [*out* *err*]
    (println (str "'" task "' is not a task. See 'lein help'."))
    (when-let [suggestions (suggestions task (tasks))]
      (println)
      (println "Did you mean this?")
      (doseq [suggestion suggestions]
        (println "        " suggestion))))
  (throw (ex-info "Task not found" {:exit-code 1 :suppress-msg true})))

TODO: got to be a cleaner way to do this, right?

(defn- drop-partial-args [pargs]
  #(for [[f & r] %
         :let [non-varargs (if (pos? (inc (.indexOf (or r []) '&)))
                             (min (count pargs) (.indexOf r '&))
                             (count pargs))]]
     (cons f (drop non-varargs r))))

Look up task function and perform partial application if applicable.

(defn resolve-task
  ([task not-found]
     (let [[task & pargs] (if (coll? task) task [task])]
       (if-let [task-var (utils/require-resolve (str "leiningen." task) task)]
         (with-meta
           (fn [project & args] (apply task-var project (concat pargs args)))
           (update-in (meta task-var) [:arglists] (drop-partial-args pargs)))
         (not-found task))))
  ([task] (resolve-task task #'task-not-found)))
(defn ^:internal matching-arity? [task args]
  (some (fn [parameters]
          (and (if (= '& (last (butlast parameters)))
                 (>= (count args) (- (count parameters) 3))
                 (= (count parameters) (inc (count args))))
               parameters))
        (:arglists (meta task))))

Removes an alias from the specified project and its metadata (which lies within :without-profiles) to avoid recursive alias calls.

(defn- remove-alias
  [project alias]
  (-> project
      (update-in [:aliases] #(if (map? %) (dissoc % alias) %))
      (vary-meta update-in [:without-profiles :aliases] dissoc alias)
      (vary-meta update-in [:profiles]
                 #(zipmap
                   (keys %)
                   (map (fn [p] (if (map? p) (remove-alias p alias) p))
                        (vals %))))))

Resolve task-name to a function and apply project and args if arity matches.

(defn apply-task
  [task-name project args]
  (let [[task-alias] (for [[k v] (:aliases project) :when (= v task-name)] k)
        project (and project (remove-alias project
                                           (or task-alias task-name)))
        task (resolve-task task-name)]
    (when-not (or (:root project) (:no-project-needed (meta task)))
      (abort "Couldn't find project.clj, which is needed for" task-name))
    (when-not (matching-arity? task args)
      (abort "Wrong number of arguments to" task-name "task."
             "\nExpected" (string/join " or " (map next (:arglists
                                                         (meta task))))))
    (debug "Applying task" task-name "to" args)
    (apply task project args)))
(defn resolve-and-apply [project args]
  (let [[task-name args] (task-args args project)]
    (apply-task task-name project args)))
(defn leiningen-version []
  (or (System/getenv "LEIN_VERSION")
      (with-open [reader (-> "META-INF/maven/leiningen/leiningen/pom.properties"
                             io/resource
                             io/reader)]
        (-> (doto (java.util.Properties.)
              (.load reader))
            (.getProperty "version")))))
(defn ^:internal version-satisfies? [v1 v2]
  (let [v1 (map #(Integer. %) (re-seq #"\d+" (first (string/split v1 #"-" 2))))
        v2 (map #(Integer. %) (re-seq #"\d+" (first (string/split v2 #"-" 2))))]
    (loop [versions (map vector v1 v2)
           [seg1 seg2] (first versions)]
      (cond (empty? versions) true
            (= seg1 seg2) (recur (rest versions) (first (rest versions)))
            (> seg1 seg2) true
            (< seg1 seg2) false))))

packagers should replace this string!

(def ^:private min-version-warning
  "*** Warning: This project requires Leiningen %s, but you have %s ***
Get the latest version of Leiningen at http://leiningen.org or by executing
\"lein upgrade\".")
(defn- verify-min-version
  [{:keys [min-lein-version]}]
  (when-not (version-satisfies? (leiningen-version) min-lein-version)
    (info (format min-version-warning min-lein-version (leiningen-version)))))
(defn user-agent []
  (format "Leiningen/%s (Java %s; %s %s; %s)"
          (leiningen-version) (System/getProperty "java.vm.name")
          (System/getProperty "os.name") (System/getProperty "os.version")
          (System/getProperty "os.arch")))
(defn- configure-http []
  "Set Java system properties controlling HTTP request behavior."
  (System/setProperty "aether.connector.userAgent" (user-agent))
  (when-let [{:keys [host port non-proxy-hosts]} (classpath/get-proxy-settings)]
    (System/setProperty "http.proxyHost" host)
    (System/setProperty "http.proxyPort" (str port))
    (when non-proxy-hosts
      (System/setProperty "http.nonProxyHosts" non-proxy-hosts)))
  (when-let [{:keys [host port]} (classpath/get-proxy-settings "https_proxy")]
    (System/setProperty "https.proxyHost" host)
    (System/setProperty "https.proxyPort" (str port))))

Command-line entry point.

(defn -main
  [& raw-args]
  (try
    (user/init)
    (let [project (project/init-project
                   (if (.exists (io/file "project.clj"))
                     (project/read)
                     (-> (project/make {:eval-in :leiningen :prep-tasks []})
                         project/project-with-profiles
                         (project/init-profiles [:default]))))]
      (when (:min-lein-version project) (verify-min-version project))
      (configure-http)
      (resolve-and-apply project raw-args))
    (catch Exception e
      (if (or *debug* (not (:exit-code (ex-data e))))
        (.printStackTrace e)
        (when-not (:suppress-msg (ex-data e))
          (println (.getMessage e))))
      (exit (:exit-code (ex-data e) 1))))
  (exit 0))
 

Read project.clj files.

(ns leiningen.core.project
  (:refer-clojure :exclude [read])
  (:require [clojure.walk :as walk]
            [clojure.java.io :as io]
            [clojure.set :as set]
            [clojure.string :as s]
            [cemerick.pomegranate :as pomegranate]
            [cemerick.pomegranate.aether :as aether]
            [leiningen.core.utils :as utils]
            [leiningen.core.ssl :as ssl]
            [leiningen.core.user :as user]
            [leiningen.core.classpath :as classpath]
            [useful.fn :refer [fix]]
            [useful.seq :refer [update-first find-first]]
            [useful.map :refer [update update-each map-vals]])
  (:import (clojure.lang DynamicClassLoader)
           (java.io PushbackReader)))

Project definition and normalization

(defn artifact-map
  [id]
  {:artifact-id (name id)
   :group-id (or (namespace id) (name id))})

Transform an exclusion vector into a map that is easier to combine with meta-merge. This allows a profile to override specific exclusion options.

(defn exclusion-map
  [spec]
  (if-let [[id & {:as opts}] (fix spec symbol? vector)]
    (-> opts
        (merge (artifact-map id))
        (with-meta (meta spec)))))

Transform an exclusion map back into a vector of the form: [name/group & opts]

(defn exclusion-vec
  [exclusion]
  (if-let [{:keys [artifact-id group-id]} exclusion]
    (into [(symbol group-id artifact-id)]
          (apply concat (dissoc exclusion :artifact-id :group-id)))))

Transform a dependency vector into a map that is easier to combine with meta-merge. This allows a profile to override specific dependency options.

(defn dependency-map
  [dep]
  (if-let [[id version & {:as opts}] dep]
    (-> opts
        (merge (artifact-map id))
        (assoc :version version)
        (update :exclusions #(if % (map exclusion-map %)))
        (with-meta (meta dep)))))

Transform a dependency map back into a vector of the form: [name/group "version" & opts]

(defn dependency-vec
  [dep]
  (if-let [{:keys [artifact-id group-id version]} dep]
    (-> dep
        (update :exclusions #(if % (map exclusion-vec %)))
        (dissoc :artifact-id :group-id :version)
        (->> (apply concat)
             (into [(symbol group-id artifact-id) version]))
        (with-meta (meta dep)))))

Returns the metadata of an object, or nil if the object cannot hold metadata.

(defn- meta*
  [obj]
  (if (instance? clojure.lang.IObj obj)
    (meta obj)
    nil))

Returns an object of the same type and value as obj, with map m as its metadata if the object can hold metadata.

(defn- with-meta*
  [obj m]
  (if (instance? clojure.lang.IObj obj)
    (with-meta obj m)
    obj))

Returns true if the object is marked as displaceable

(defn- displace?
  [obj]
  (-> obj meta* :displace))

Returns true if the object is marked as replaceable

(defn- replace?
  [obj]
  (-> obj meta* :replace))

Returns true if either left has a higher priority than right or vice versa.

(defn- different-priority?
  [left right]
  (boolean
   (some (some-fn nil? displace? replace?) [left right])))

Picks the highest prioritized element of left and right and merge their metadata.

(defn- pick-prioritized
  [left right]
  (cond (nil? left) right
        (nil? right) left
        (and (displace? left)   ;; Pick the rightmost
             (displace? right)) ;; if both are marked as displaceable
        (with-meta* right
          (merge (meta* left) (meta* right)))
        (and (replace? left)    ;; Pick the rightmost
             (replace? right))  ;; if both are marked as replaceable
        (with-meta* right
          (merge (meta* left) (meta* right)))
        (or (displace? left)
            (replace? right))
        (with-meta* right
          (merge (-> left meta* (dissoc :displace))
                 (-> right meta* (dissoc :replace))))
        (or (replace? left)
            (displace? right))
        (with-meta* left
          (merge (-> right meta* (dissoc :displace))
                 (-> left meta* (dissoc :replace))))))
(declare meta-merge)

Inside defproject forms, unquoting (~) allows for arbitrary evaluation.

TODO: drop this and use read-eval syntax in 3.0

(defn- unquote-project
  [args]
  (walk/walk (fn [item]
               (cond (and (seq? item) (= `unquote (first item))) (second item)
                     ;; needed if we want fn literals preserved
                     (or (seq? item) (symbol? item)) (list 'quote item)
                     :else (let [result (unquote-project item)]
                             ;; clojure.walk strips metadata
                             (if-let [m (meta item)]
                               (with-meta result m)
                               result))))
             identity
             args))
(def defaults
  ;; TODO: move :repositories here in 3.0
  {:source-paths ["src"]
   :resource-paths ["resources"]
   :test-paths ["test"]
   :native-path "target/native"
   :compile-path "target/classes"
   :target-path "target/%s"
   :prep-tasks ["javac" "compile"]
   :jar-exclusions [#"^\."]
   :certificates ["clojars.pem"]
   :offline? (not (nil? (System/getenv "LEIN_OFFLINE")))
   :uberjar-exclusions [#"(?i)^META-INF/[^/]*\.(SF|RSA|DSA)$"]
   :global-vars {}})

The unique key used to dedupe dependencies.

(defn- dep-key
  [[id version & opts]]
  (-> (apply hash-map opts)
      (select-keys [:classifier :extension])
      (assoc :id id)))
(defn- add-dep [deps dep]
  (let [k (dep-key dep)]
    (update-first deps #(= k (dep-key %))
                  (fn [existing]
                    (dependency-vec
                     (meta-merge (dependency-map existing)
                                 (dependency-map dep)))))))

Normalizes a repository to the canonical repository form.

(defn- normalize-repo
  [[id opts :as repo]]
  (with-meta
    [id (fix opts string? (partial hash-map :url))]
    (meta repo)))

Normalizes a vector of repositories to the canonical repository form.

(defn- normalize-repos
  [repos]
  (with-meta
    (mapv normalize-repo repos)
    (meta repos)))
(defn- add-repo [repos [id opts :as repo]]
  (update-first repos #(= id (first %))
                (fn [[_ existing :as original]]
                  (let [opts (if (keyword? opts)
                               (-> (find-first #(= (first %)
                                                   (name opts))
                                               repos)
                                   second)
                               opts)
                        repo (with-meta [id opts] (meta repo))]
                    (if (different-priority? repo original)
                      (pick-prioritized repo original)
                      (with-meta [id (meta-merge existing opts)]
                        (merge (meta original) (meta repo))))))))
(def empty-dependencies
  (with-meta [] {:reduce add-dep}))
(def empty-repositories
  (with-meta [] {:reduce add-repo}))
(def empty-paths
  (with-meta [] {:prepend true}))
(def default-repositories
  (with-meta
    [["central" {:url "http://repo1.maven.org/maven2/" :snapshots false}]
     ["clojars" {:url "https://clojars.org/repo/"}]]
    {:reduce add-repo}))
(def deploy-repositories
  (with-meta
    [["clojars" {:url "https://clojars.org/repo/"
                 :password :gpg :username :gpg}]]
    {:reduce add-repo}))

Like update-each, but will only update if the key is within the map.

(defn update-if-in-map
  [m ks f & args]
  (apply update-each m (filter (partial contains? m) ks) f args))

Transform values within a project or profile map to normalized values, such that internal functions can assume that the values are already normalized.

(defn normalize-values
  [map]
  (-> map
      (update-if-in-map [:repositories :deploy-repositories
                         :mirrors :plugin-repositories] normalize-repos)
      (update-if-in-map [:profiles] map-vals normalize-values)))
(defn make
  ([project project-name version root]
     (make (with-meta (assoc project
                        :name (name project-name)
                        :group (or (namespace project-name)
                                   (name project-name))
                        :version version
                        :root root)
             (meta project))))
  ([project]
     (let [repos (if (:omit-default-repositories project)
                   (do (println "WARNING:"
                                ":omit-default-repositories is deprecated;"
                                "use :repositories ^:replace [...] instead.")
                       empty-repositories)
                   default-repositories)]
       (with-meta
         (meta-merge
          {:repositories repos
           :plugin-repositories repos
           :deploy-repositories deploy-repositories
           :plugins empty-dependencies
           :dependencies empty-dependencies
           :source-paths empty-paths
           :resource-paths empty-paths
           :test-paths empty-paths}
          (-> (merge defaults project)
              (assoc :jvm-opts (or (:jvm-opts project) (:java-opts project)
                                   (:jvm-opts defaults)))
              (dissoc :eval-in-leiningen :omit-default-repositories :java-opts)
              (assoc :eval-in (or (:eval-in project)
                                  (if (:eval-in-leiningen project)
                                    :leiningen, :subprocess)))
              (normalize-values)))
         (meta project)))))

The project.clj file must either def a project map or call this macro. See lein help sample to see what arguments it accepts.

(defmacro defproject
  [project-name version & {:as args}]
  `(let [args# ~(unquote-project args)
         root# ~(.getParent (io/file *file*))]
     (def ~'project
       (make args# '~project-name ~version root#))))
(defn- add-exclusions [exclusions dep]
  (dependency-vec
   (update (dependency-map dep) :exclusions
           into (map exclusion-map exclusions))))
(defn- add-global-exclusions [project]
  (let [{:keys [dependencies exclusions]} project]
    (if-let [exclusions (and (seq dependencies) (seq exclusions))]
      (assoc project
        :dependencies (with-meta
                        (mapv (partial add-exclusions exclusions)
                              dependencies)
                        (meta dependencies)))
      project)))
(defn- absolutize [root path]
  (str (if (.isAbsolute (io/file path))
         path
         (io/file root path))))
(defn- absolutize-path [{:keys [root] :as project} key]
  (cond (re-find #"-path$" (name key))
        (update-in project [key] (partial absolutize root))
        (re-find #"-paths$" (name key))
        (update-in project [key] (partial map (partial absolutize root)))
        :else project))
(defn absolutize-paths [project]
  (reduce absolutize-path project (keys project)))
(defn- sha1 [content]
  (.toString (BigInteger. 1 (-> (java.security.MessageDigest/getInstance "SHA1")
                                (.digest (.getBytes content)))) 16))
(defn profile-scope-target-path [project profiles]
  (let [n #(if (map? %) (subs (sha1 (pr-str %)) 0 8) (name %))]
    (if (:target-path project)
      (update-in project [:target-path] format (s/join "+" (map n profiles)))
      project)))

Profiles: basic merge logic

(def ^:private hooke-injection
  (with-open [rdr (-> "robert/hooke.clj" io/resource io/reader PushbackReader.)]
    `(do (ns ~'leiningen.core.injected)
         ~@(doall (take-while #(not= % ::eof)
                              (rest (repeatedly #(clojure.core/read
                                                  rdr false ::eof)))))
         (ns ~'user))))

users of old JVMs will have to set LEINJVMOPTS to turn off tiered compilation, so if they've done that we should do the same for project JVMs

(def tiered-jvm-opts
  (if (.contains (or (System/getenv "LEIN_JVM_OPTS") ) "Tiered")
    ["-XX:+TieredCompilation" "-XX:TieredStopAtLevel=1"] []))

Profiles get merged into the project map. The :dev, :provided, and :user profiles are active by default.

(def default-profiles
  (atom {:default [:base :system :user :provided :dev]
         :base {:resource-paths ["dev-resources"]
                :jvm-opts tiered-jvm-opts
                :test-selectors {:default (with-meta '(constantly true)
                                            {:displace true})}
                :target-path "target"
                :dependencies '[[org.clojure/tools.nrepl "0.2.3"]
                                [clojure-complete "0.2.3"]]
                :checkout-deps-shares [:source-paths
                                       :test-paths
                                       :resource-paths
                                       :compile-path]}
         :leiningen/test {:injections [hooke-injection]
                          :test-selectors {:default (with-meta
                                                      '(constantly true)
                                                      {:displace true})}}
         :uberjar {} ; TODO: use :aot :all here in 3.0
         :update {:update :always}
         :offline {:offline? true}
         :debug {:debug true}}))

Recursively merge values based on the information in their metadata.

(defn- meta-merge
  [left right]
  (cond (different-priority? left right)
        (pick-prioritized left right)
        (-> left meta :reduce)
        (-> left meta :reduce
            (reduce left right)
            (with-meta (meta left)))
        (and (map? left) (map? right))
        (merge-with meta-merge left right)
        (and (set? left) (set? right))
        (set/union right left)
        (and (coll? left) (coll? right))
        (if (or (-> left meta :prepend)
                (-> right meta :prepend))
          (-> (concat right left)
              (with-meta (merge (meta left)
                                (select-keys (meta right) [:displace]))))
          (concat left right))
        (= (class left) (class right)) right
        :else
        (do (println left "and" right "have a type mismatch merging profiles.")
            right)))
(defn- apply-profiles [project profiles]
  (reduce (fn [project profile]
            (with-meta
              (meta-merge project profile)
              (meta-merge (meta project) (meta profile))))
          project
          profiles))

Lookup a profile in the given profiles map, warning when the profile doesn't exist. Recurse whenever a keyword or vector is found, combining all profiles in the vector.

(defn- lookup-profile
  [profiles profile]
  (cond (keyword? profile)
        (let [result (get profiles profile)]
          (when-not (or result (#{:provided :dev :user :test :base :default
                                  :production :system :repl}
                                profile))
            (println "Warning: profile" profile "not found."))
          (vary-meta (lookup-profile profiles result)
                     update-in [:active-profiles] (fnil conj []) profile))
        ;; composite profile
        (vector? profile)
        (apply-profiles {} (map (partial lookup-profile profiles) profile))
        :else (or profile {})))
(defn- warn-user-repos [profiles]
  (let [has-url? (fn [entry] (or (string? entry) (:url entry)))
        repo-profiles (filter #(->> (second %)
                                    :repositories
                                    (map second)
                                    (some has-url?))
                              profiles)]
    (when (and (seq repo-profiles)
               (not (System/getenv "LEIN_SUPPRESS_USER_LEVEL_REPO_WARNINGS")))
      (println ":repositories detected in user-level profiles!"
               (vec (map first repo-profiles)) "\nSee"
               "https://github.com/technomancy/leiningen/wiki/Repeatability"))))
(alter-var-root #'warn-user-repos memoize)
(defn- warn-user-profile [profiles]
  (when (contains? profiles :user)
    (println "WARNING: user-level profile defined in project files.")))
(alter-var-root #'warn-user-profile memoize)
(defn- system-profiles []
  (let [sys-profile-dir (if (= :windows (utils/get-os))
                          (io/file (System/getenv "AllUsersProfile") "Leiningen")
                          (io/file "/etc" "leiningen"))]
    (user/load-profiles sys-profile-dir)))
(defn- project-profiles [project]
  (let [profiles (utils/read-file (io/file (:root project) "profiles.clj"))]
    (warn-user-profile profiles)
    profiles))

Read profiles from a variety of sources.

We check Leiningen's defaults, system-level profiles (usually in /etc), the profiles.clj file in ~/.lein, the profiles.clj file in the project root, and the :profiles key from the project map.

(defn read-profiles
  [project]
  (warn-user-repos (concat (user/profiles) (system-profiles)))
  (warn-user-profile (:profiles project))
  (merge @default-profiles (system-profiles) (user/profiles)
         (:profiles project) (project-profiles project)))

Lower-level profile plumbing: loading plugins, hooks, middleware, certs

(defn ensure-dynamic-classloader []
  (let [thread (Thread/currentThread)
        cl (.getContextClassLoader thread)]
    (when-not (pomegranate/modifiable-classloader? cl)
      (.setContextClassLoader thread (DynamicClassLoader. cl)))))
(def ^:private registered-wagon-files (atom #{}))
(defn load-plugins
  ([project key]
     (when (seq (get project key))
       (ensure-dynamic-classloader)
       (classpath/resolve-dependencies
        key project
        :add-classpath? true))
     (doseq [wagon-file (-> (.getContextClassLoader (Thread/currentThread))
                            (.getResources "leiningen/wagons.clj")
                            (enumeration-seq))
             :when (not (@registered-wagon-files wagon-file))
             [hint factory] (read-string (slurp wagon-file))]
       (aether/register-wagon-factory! hint (eval factory))
       (swap! registered-wagon-files conj wagon-file))
     project)
  ([project] (load-plugins project :plugins)))
(defn plugin-vars [project type]
  (for [[plugin _ & {:as opts}] (:plugins project)
        :when (get opts type true)]
    (-> (symbol (str (name plugin) ".plugin") (name type))
        (with-meta {:optional true}))))
(defn- plugin-hooks [project]
  (plugin-vars project :hooks))
(defn- plugin-middleware [project]
  (plugin-vars project :middleware))
(defn- load-hook [hook-name]
  (if-let [hook (try (utils/require-resolve hook-name)
                     (catch Throwable e
                       (utils/error "problem requiring" hook-name "hook")
                       (throw e)))]
    (try (hook)
         (catch Throwable e
           (utils/error "problem activating" hook-name "hook")
           (throw e)))
    (when-not (:optional (meta hook-name))
      (utils/error "cannot resolve" hook-name "hook"))))
(defn load-hooks [project & [ignore-missing?]]
  (doseq [hook-name (concat (plugin-hooks project) (:hooks project))]
    ;; if hook-name is just a namespace assume hook fn is called activate
    (let [hook-name (if (namespace hook-name)
                      hook-name
                      (symbol (name hook-name) "activate"))]
      (load-hook hook-name)))
  project)
(defn apply-middleware
  ([project]
     (reduce apply-middleware project
             (concat (plugin-middleware project)
                     (:middleware project))))
  ([project middleware-name]
     (if-let [middleware (utils/require-resolve middleware-name)]
       (middleware project)
       (do (when-not (:optional (meta middleware-name))
             (utils/error "cannot resolve" middleware-name "middleware"))
           project))))

Load the SSL certificates specified by the project and register them for use by Aether.

(defn load-certificates
  [project]
  (let [certs (mapcat ssl/read-certs (:certificates project))
        context (ssl/make-sslcontext (into (ssl/default-trusted-certs) certs))]
    (ssl/register-scheme (ssl/https-scheme context))
    project))

A helper function to apply middleware and then load certificates and hooks, since we always do these three things together, at least so far.

(defn activate-middleware
  [project]
  (doto (apply-middleware project)
    (load-certificates)
    (load-hooks)))
(defn project-with-profiles-meta [project profiles]
  ;;; should this dissoc :default?
  ;; (vary-meta project assoc :profiles (dissoc profiles :default))
  (vary-meta project assoc
             :profiles profiles))
(defn project-with-profiles [project]
  (project-with-profiles-meta project (read-profiles project)))

Compute a fresh version of the project map, including and excluding the specified profiles.

(defn ^:internal init-profiles
  [project include-profiles & [exclude-profiles]]
  (let [project (with-meta
                  (:without-profiles (meta project) project)
                  (meta project))
        profile-map (apply dissoc (:profiles (meta project)) exclude-profiles)
        profiles (map (partial lookup-profile profile-map) include-profiles)
        normalized-profiles (map normalize-values profiles)]
    (-> project
        (apply-profiles normalized-profiles)
        (absolutize-paths)
        (profile-scope-target-path include-profiles)
        (add-global-exclusions)
        (vary-meta merge {:without-profiles project
                          :included-profiles include-profiles
                          :excluded-profiles exclude-profiles}))))

High-level profile operations

Compute a fresh version of the project map, with middleware applied, including and excluding the specified profiles.

(defn set-profiles
  [project include-profiles & [exclude-profiles]]
  (-> project
      (init-profiles include-profiles exclude-profiles)
      (load-plugins)
      (activate-middleware)))

Compute a fresh version of the project map with the given profiles merged into list of active profiles and the appropriate middleware applied.

(defn merge-profiles
  [project profiles]
  (let [{:keys [included-profiles excluded-profiles]} (meta project)]
    (set-profiles project
                  (concat included-profiles profiles)
                  (remove (set profiles) excluded-profiles))))

Compute a fresh version of the project map with the given profiles unmerged from list of active profiles and the appropriate middleware applied.

(defn unmerge-profiles
  [project profiles]
  (let [{:keys [included-profiles excluded-profiles]} (meta project)]
    (set-profiles project
                  (remove (set profiles) included-profiles)
                  (concat excluded-profiles profiles))))

Adds dependencies to Leiningen's classpath if required.

(defn- init-lein-classpath
  [project]
  (when (= :leiningen (:eval-in project))
    (doseq [path (classpath/get-classpath project)]
      (pomegranate/add-classpath path))))

Initializes a project. This is called at startup with the default profiles.

(defn init-project
  [project]
  (-> (doto project
        (load-certificates)
        (init-lein-classpath)
        (load-plugins))
      (activate-middleware)))

Add the profiles in the given profiles map to the project map, taking care to preserve project map metadata. Note that these profiles are not merged, merely made available to merge by name.

(defn add-profiles
  [project profiles-map]
  ;; Merge new profiles into both the project and without-profiles meta
  (vary-meta (update-in project [:profiles] merge profiles-map)
             merge
             {:without-profiles (update-in (:without-profiles (meta project)
                                                              project)
                                           [:profiles] merge
                                           profiles-map)}))

Read project map out of file, which defaults to project.clj.

(defn read
  ([file profiles]
     (locking read
       (binding [*ns* (find-ns 'leiningen.core.project)]
         (try (load-file file)
              (catch Exception e
                (throw (Exception. (format "Error loading %s" file) e)))))
       (let [project (resolve 'leiningen.core.project/project)]
         (when-not project
           (throw (Exception. (format "%s must define project map" file))))
         ;; return it to original state
         (ns-unmap 'leiningen.core.project 'project)
         (init-profiles (project-with-profiles @project) profiles))))
  ([file] (read file [:default]))
  ([] (read "project.clj")))
 
(ns leiningen.core.ssl
  (:require [clojure.java.io :as io]
            [leiningen.core.user :as user])
  (:import java.security.KeyStore
           java.security.KeyStore$TrustedCertificateEntry
           java.security.Security
           java.security.cert.CertificateFactory
           javax.net.ssl.KeyManagerFactory
           javax.net.ssl.SSLContext
           javax.net.ssl.TrustManagerFactory
           javax.net.ssl.X509TrustManager
           java.io.FileInputStream
           org.apache.http.conn.ssl.SSLSocketFactory
           org.apache.http.conn.scheme.Scheme
           org.apache.maven.wagon.providers.http.HttpWagon
           org.apache.http.conn.ssl.BrowserCompatHostnameVerifier))
(defn ^TrustManagerFactory trust-manager-factory [^KeyStore keystore]
  (doto (TrustManagerFactory/getInstance "PKIX")
    (.init keystore)))
(defn default-trust-managers []
  (let [tmf (trust-manager-factory nil)
        tms (.getTrustManagers tmf)]
    (filter #(instance? X509TrustManager %) tms)))
(defn key-manager-props []
  (let [read #(java.lang.System/getProperty %)]
    (merge {:file (read "javax.net.ssl.keyStore")
            :type (read "javax.net.ssl.keyStoreType")
            :provider (read "javax.net.ssl.keyStoreProvider")
            :password (read "javax.net.ssl.keyStorePassword")}
           (-> (user/profiles) :user :key-manager-properties))))
(defn key-manager-factory [{:keys [file type provider password]}]
  (let [type (or type (KeyStore/getDefaultType))
        fis (if-not (empty? file) (FileInputStream. file))
        pwd (and password (.toCharArray password))
        store (if provider
                (KeyStore/getInstance type provider)
                (KeyStore/getInstance type))]
    (.load store fis pwd)
    (when fis (.close fis))
    (doto (KeyManagerFactory/getInstance
           (KeyManagerFactory/getDefaultAlgorithm))
      (.init store pwd))))

Lists the CA certificates trusted by the JVM.

(defn default-trusted-certs
  []
  (mapcat #(.getAcceptedIssuers %) (default-trust-managers)))

Read one or more X.509 certificates in DER or PEM format.

(defn read-certs
  [f]
  (let [cf (CertificateFactory/getInstance "X.509")
        in (io/input-stream (or (io/resource f) (io/file f)))]
    (.generateCertificates cf in)))

Construct a KeyStore that trusts a collection of certificates.

(defn make-keystore
  [certs]
  (let [ks (KeyStore/getInstance "jks")]
    (.load ks nil nil)
    (doseq [[i cert] (map vector (range) certs)]
      (.setEntry ks (str i) (KeyStore$TrustedCertificateEntry. cert) nil))
    ks))

Construct an SSLContext that trusts a collection of certificatess.

TODO: honor settings from project.clj, not just user profile

(defn make-sslcontext
  [trusted-certs]
  (let [ks (make-keystore trusted-certs)
        kmf (key-manager-factory (key-manager-props))
        tmf (trust-manager-factory ks)]
    (doto (SSLContext/getInstance "TLS")
      (.init (.getKeyManagers kmf) (.getTrustManagers tmf) nil))))
(alter-var-root #'make-sslcontext memoize)

Construct a Scheme that uses a given SSLContext.

(defn https-scheme
  ([context] (https-scheme context 443))
  ([context port]
     (let [factory (SSLSocketFactory. context (BrowserCompatHostnameVerifier.))]
       (Scheme. "https" port factory))))

Register a scheme with the HTTP Wagon for use with Aether.

(def register-scheme
  (memoize (fn [scheme]
             (-> (.getConnectionManager (HttpWagon.))
                 (.getSchemeRegistry)
                 (.register scheme)))))
 

Functions exposing user-level configuration.

(ns leiningen.core.user
  (:require [clojure.java.io :as io]
            [clojure.string :as str]
            [clojure.java.shell :as shell]
            [useful.map :refer [map-vals]]
            [leiningen.core.utils :as utils])
  (:import (java.util.regex Pattern)))

Wrap System/getProperty for testing purposes.

(defn getprop
  [prop-name]
  (System/getProperty prop-name))

Wrap System/getenv for testing purposes.

(defn getenv
  [name]
  (System/getenv name))

Return full path to the user's Leiningen home directory.

(defn leiningen-home
  []
  (let [lein-home (getenv "LEIN_HOME")
        lein-home (or (and lein-home (io/file lein-home))
                      (io/file (System/getProperty "user.home") ".lein"))]
    (.getAbsolutePath (doto lein-home .mkdirs))))

Load the user's ~/.lein/init.clj file, if present.

TODO: move all these memoized fns into delays

(def init
  (memoize (fn []
             (let [init-file (io/file (leiningen-home) "init.clj")]
               (when (.exists init-file)
                 (try (load-file (.getAbsolutePath init-file))
                      (catch Exception e
                        (.printStackTrace e))))))))

Returns a map entry containing the filename (without .clj) associated with its contents. The content will be tagged with its origin.

(defn- load-profiles-d-file
  [file]
  (try
    (let [kw (->> file .getName (re-find #".+(?=\.clj)") keyword)
          contents (with-meta (utils/read-file file) ;; assumes the file exist
                     {:origin (.getAbsolutePath file)})]
      [kw contents])
    (catch Exception e
      (binding [*out* *err*]
        (println "Error reading" (.getName file)
                 "from" (-> file .getParentFile .getAbsolutePath (str ":")))
        (println (.getMessage e))))))

Load all Clojure files from the profiles.d folder in your Leiningen home if present. Returns a seq with map entries of the different profiles.

(def profiles-d-profiles
  (memoize
   (fn []
     (let [profile-dir (io/file (leiningen-home) "profiles.d")]
       (if (.isDirectory profile-dir)
         (for [file (.listFiles profile-dir)
               :when (-> file .getName (.endsWith ".clj"))]
           (load-profiles-d-file file)))))))

Load profiles.clj from dir if present. Tags all profiles with its origin.

(def ^:internal load-profiles
  (memoize
   (fn [dir]
     (try
       (if-let [contents (utils/read-file (io/file dir "profiles.clj"))]
         (map-vals contents with-meta
                   {:origin (.getAbsolutePath (io/file dir "profiles.clj"))}))
       (catch Exception e
         (binding [*out* *err*]
           (println "Error reading profiles.clj from" dir)
           (println (.getMessage e))))))))

Load profiles.clj from your Leiningen home and profiles.d if present.

(def profiles
  (memoize
   (fn []
     (let [error-fn
           (fn [a b]
             (binding [*out* *err*]
               (println "Error: A profile is defined in both"
                        (-> a meta :origin) "and in" (-> b meta :origin)))
             (throw (ex-info "Multiple profiles defined in ~/.lein"
                             {:exit-code 1})))]
       (merge-with error-fn
                   (load-profiles (leiningen-home))
                   (into {} (profiles-d-profiles)))))))

Lookup the gpg program to use, defaulting to 'gpg'

(defn gpg-program
  []
  (or (getenv "LEIN_GPG") "gpg"))

Shells out to (gpg-program) with the given arguments

(defn gpg
  [& args]
  (try
    (apply shell/sh (gpg-program) args)
    (catch java.io.IOException e
      {:exit 1 :err (.getMessage e)})))

Verifies (gpg-program) exists

(defn gpg-available?
  []
  (zero? (:exit (gpg "--version"))))

Decrypt map from credentials.clj.gpg in Leiningen home if present.

(defn credentials-fn
  ([] (let [cred-file (io/file (leiningen-home) "credentials.clj.gpg")]
        (if (.exists cred-file)
          (credentials-fn cred-file))))
  ([file]
     (let [{:keys [out err exit]} (gpg "--quiet" "--batch"
                                       "--decrypt" "--" (str file))]
       (if (pos? exit)
         (binding [*out* *err*]
           (println "Could not decrypt credentials from" (str file))
           (println err)
           (println "See `lein help gpg` for how to install gpg."))
         (read-string out)))))
(def credentials (memoize credentials-fn))
(defn- match-credentials [settings auth-map]
  (get auth-map (:url settings)
       (first (for [[re? cred] auth-map
                    :when (and (instance? Pattern re?)
                               (re-find re? (:url settings)))]
                cred))))

Resolve key-value pair from result into a credential, updating result.

(defn- resolve-credential
  [source-settings result [k v]]
  (letfn [(resolve [v]
            (cond (= :env v)
                  (getenv (str "LEIN_" (str/upper-case (name k))))
                  (and (keyword? v) (= "env" (namespace v)))
                  (getenv (str/upper-case (name v)))
                  (= :gpg v)
                  (get (match-credentials source-settings (credentials)) k)
                  (coll? v) ;; collection of places to look
                  (->> (map resolve v)
                       (remove nil?)
                       first)
                  :else v))]
    (if (#{:username :password :passphrase :private-key-file} k)
      (assoc result k (resolve v))
      (assoc result k v))))

Applies credentials from the environment or ~/.lein/credentials.clj.gpg as they are specified and available.

(defn resolve-credentials
  [settings]
  (let [gpg-creds (if (= :gpg (:creds settings))
                    (match-credentials settings (credentials)))
        resolved (reduce (partial resolve-credential settings)
                         (empty settings)
                         settings)]
    (if gpg-creds
      (dissoc (merge gpg-creds resolved) :creds)
      resolved)))

Look up credentials for a given repository in :auth profile.

(defn profile-auth
  [settings]
  (if-let [repo-auth (-> (profiles) :auth :repository-auth)]
    (merge settings (match-credentials settings repo-auth))
    settings))
 
(ns leiningen.core.utils
  (:require [clojure.java.io :as io])
  (:import (com.hypirion.io RevivableInputStream)
           (clojure.lang LineNumberingPushbackReader)
           (java.io File FileDescriptor FileInputStream InputStreamReader)
           (java.net URL)))
(def rebound-io? (atom false))
(defn rebind-io! []
  (when-not @rebound-io?
    (let [new-in (-> FileDescriptor/in FileInputStream. RevivableInputStream.)]
      (System/setIn new-in)
      (.bindRoot #'*in* (-> new-in InputStreamReader.
                            LineNumberingPushbackReader.)))
    (reset! rebound-io? true)))

Creates java.net.URL from string

(defn build-url
  [url]
  (try (URL. url)
       (catch java.net.MalformedURLException _
         (URL. (str "http://" url)))))

Read the contents of file if it exists.

(defn read-file
  [file]
  (if (.exists file)
    (read-string (slurp file))))

Checks if a File is a symbolic link or points to another file.

(defn symlink?
  [file]
  (let [canon (if-not (.getParent file)
                file
                (-> (.. file getParentFile getCanonicalFile)
                    (File. (.getName file))))]
    (not= (.getCanonicalFile canon)
          (.getAbsoluteFile canon))))
(defn ns-exists? [namespace]
  (some (fn [suffix]
          (-> (#'clojure.core/root-resource namespace)
              (subs 1)
              (str suffix)
              io/resource))
        [".clj" (str clojure.lang.RT/LOADER_SUFFIX ".class")]))
(defn error [& args]
  (binding [*out* *err*]
    (apply println "Error:" args)))

Resolve a fully qualified symbol by first requiring its namespace.

(defn require-resolve
  ([sym]
     (when-let [ns (namespace sym)]
       (when (ns-exists? ns)
         (let [ns (symbol ns)]
           (when-not (find-ns ns)
             (require ns)))
         (resolve sym))))
  ([ns sym] (require-resolve (symbol ns sym))))

OS detection

Gets a value from map m, but uses the keys as regex patterns, trying to match against k instead of doing an exact match.

(defn- get-by-pattern
  [m k]
  (m (first (drop-while #(nil? (re-find (re-pattern %) k))
                        (keys m)))))
(def ^:private native-names
  {"Mac OS X" :macosx "Windows" :windows "Linux" :linux
   "FreeBSD" :freebsd "OpenBSD" :openbsd
   "amd64" :x86_64 "x86_64" :x86_64 "x86" :x86 "i386" :x86
   "arm" :arm "SunOS" :solaris "sparc" :sparc "Darwin" :macosx})

Returns a keyword naming the host OS.

(defn get-os
  []
  (get-by-pattern native-names (System/getProperty "os.name")))

Returns a keyword naming the host architecture

(defn get-arch
  []
  (get-by-pattern native-names (System/getProperty "os.arch")))

Returns a file destination that will discard output.

(defn platform-nullsink
  []
  (io/file (if (= :windows (get-os))
             "NUL"
             "/dev/null")))