;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.

(ns containium.systems.mail
  "A mail sending system."
  (:require [containium.systems :refer (require-system Startable)]
            [containium.systems.config :as config :refer (Config)]
            [containium.systems.logging :refer (SystemLogger refer-logging)]
            [postal.core :as postal]
            [clojure.xml :as xml]
            [clojure.zip :as zip]
            [clojure.java.io :as io :refer (resource as-file)])
  (:import [java.io ByteArrayInputStream FileInputStream BufferedInputStream File]
           [java.nio.file Files]
           [java.net URLConnection]))
(refer-logging)

;;; The public API

(defprotocol Mail
  (send-message
    [this from to subject body]
    [this from to subject body options]))

;;; An SMTP implementation using Postal

(defrecord Postal [logger smtp]
  Mail
  (send-message [this from to subject body]
    (send-message this from to subject body nil))

  (send-message [this from to subject body opts]
    (let [from (str from)
          to (map str (flatten [to]))]
      (debug logger "Sending email from" from "to" (apply str (interpose ", " to)) "with subject" subject "using options" opts)
      (postal/send-message smtp (merge {:from from, :to to, :subject subject, :body body} opts)))))

(def ^{:doc "This Startable needs a Config system to in the systems. The
            configuration is read from the :postal key within that
            config. It should hold the SMTP data as specified by the
            postal library.

            The started Postal instance can be used to send e-mail
            messages. The body can be anything that the postal library
            supports. The optional `opts` parameter is merged with the
            send info, such as extra headers."}
  postal
  (reify Startable
    (start [_ systems]
      (let [config (config/get-config (require-system Config systems) :postal)
            logger (require-system SystemLogger systems)]
        (info logger "Starting Postal system, using config:" config)
        (Postal. logger config)))))

(defn- file-content-type
  [^File file]
  (with-open [stream (-> file FileInputStream. BufferedInputStream.)]
    (URLConnection/guessContentTypeFromStream stream)))

(defn- make-inline
  [html-str src-root src-map]
  (let [src-root (str src-root (when-not (= (last src-root) \/) "/"))]
    (loop [loc (zip/xml-zip (xml/parse (ByteArrayInputStream. (.getBytes (.trim html-str)))))
           contents []]
      (if (zip/end? loc)
        (cons {:type "text/html; charset=utf-8"
               :content (with-out-str (xml/emit-element (zip/node loc)))}
              contents)
        (let [node (zip/node loc)]
          (if (= :img (:tag node))
            (let [cid (str (gensym "img-"))
                  src (-> node :attrs :src)
                  content (as-file (or (get src-map src) (resource (str src-root src))))
                  content-type (file-content-type content)]
              (recur (zip/next (zip/edit loc assoc-in [:attrs :src] (str "cid:" cid)))
                     (cond-> contents
                             content (conj {:type :inline, :content content, :content-id cid
                                            :content-type content-type}))))
            (recur (zip/next loc) contents)))))))

(defn send-html-message
  "Use this function to send a HTML mail with the Postal SMTP Mail
  system. It needs at least the mail system, the from address, the to
  address, a subject, and the HTML string. The following options are
  also available:

  :text - You can supply a plain text version of the message, which
    will be included as an alternative.

  :src-root - The root directory/package in which the image resources
    can be found on the classpath for inlining. Note that due to a
    limitation in javax.mail/Postal the actual resource must be
    unpacked, i.e. not in a JAR.

  :src-map - This is a map holding files for image tags that, taking
    the 'src' attribute as key, contains resource values for inline
    use. This map overrides the default lookup when inlining. Note
    that the values in this map must support being passed to
    clojure.java.io/file."
  [mail-system from to subject html & {:keys [text src-root src-map]}]
  (let [html-contents (make-inline html src-root src-map)
        contents (remove nil? [:alternative
                               (when text {:type "text/plain" :content text})
                               (cons :related html-contents)])]
    (send-message mail-system from to subject contents)))

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.

(ns containium.systems.mail
  "A mail sending system."
  (:require [containium.systems :refer (require-system Startable)]
            [containium.systems.config :as config :refer (Config)]
            [containium.systems.logging :refer (SystemLogger refer-logging)]
            [postal.core :as postal]
            [clojure.xml :as xml]
            [clojure.zip :as zip]
            [clojure.java.io :as io :refer (resource as-file)])
  (:import [java.io ByteArrayInputStream FileInputStream BufferedInputStream File]
           [java.nio.file Files]
           [java.net URLConnection]))
(refer-logging)

;;; The public API

(defprotocol Mail
  (send-message
    [this from to subject body]
    [this from to subject body options]))

;;; An SMTP implementation using Postal

(defrecord Postal [logger smtp]
  Mail
  (send-message [this from to subject body]
    (send-message this from to subject body nil))

  (send-message [this from to subject body opts]
    (let [from (str from)
          to (map str (flatten [to]))]
      (debug logger "Sending email from" from "to" (apply str (interpose ", " to)) "with subject" subject "using options" opts)
      (postal/send-message smtp (merge {:from from, :to to, :subject subject, :body body} opts)))))

(def ^{:doc "This Startable needs a Config system to in the systems. The
            configuration is read from the :postal key within that
            config. It should hold the SMTP data as specified by the
            postal library.

            The started Postal instance can be used to send e-mail
            messages. The body can be anything that the postal library
            supports. The optional `opts` parameter is merged with the
            send info, such as extra headers."}
  postal
  (reify Startable
    (start [_ systems]
      (let [config (config/get-config (require-system Config systems) :postal)
            logger (require-system SystemLogger systems)]
        (info logger "Starting Postal system, using config:" config)
        (Postal. logger config)))))

(defn- file-content-type
  [^File file]
  (with-open [stream (-> file FileInputStream. BufferedInputStream.)]
    (URLConnection/guessContentTypeFromStream stream)))

(defn- make-inline
  [html-str src-root src-map]
  (let [src-root (str src-root (when-not (= (last src-root) \/) "/"))]
    (loop [loc (zip/xml-zip (xml/parse (ByteArrayInputStream. (.getBytes (.trim html-str)))))
           contents []]
      (if (zip/end? loc)
        (cons {:type "text/html; charset=utf-8"
               :content (with-out-str (xml/emit-element (zip/node loc)))}
              contents)
        (let [node (zip/node loc)]
          (if (= :img (:tag node))
            (let [cid (str (gensym "img-"))
                  src (-> node :attrs :src)
                  content (as-file (or (get src-map src) (resource (str src-root src))))
                  content-type (file-content-type content)]
              (recur (zip/next (zip/edit loc assoc-in [:attrs :src] (str "cid:" cid)))
                     (cond-> contents
                             content (conj {:type :inline, :content content, :content-id cid
                                            :content-type content-type, :file-name src}))))
            (recur (zip/next loc) contents)))))))

(defn send-html-message
  "Use this function to send a HTML mail with the Postal SMTP Mail
  system. It needs at least the mail system, the from address, the to
  address, a subject, and the HTML string. The following options are
  also available:

  :text - You can supply a plain text version of the message, which
    will be included as an alternative.

  :src-root - The root directory/package in which the image resources
    can be found on the classpath for inlining. Note that due to a
    limitation in javax.mail/Postal the actual resource must be
    unpacked, i.e. not in a JAR.

  :src-map - This is a map holding files for image tags that, taking
    the 'src' attribute as key, contains resource values for inline
    use. This map overrides the default lookup when inlining. Note
    that the values in this map must support being passed to
    clojure.java.io/file."
  [mail-system from to subject html & {:keys [text src-root src-map]}]
  (let [html-contents (make-inline html src-root src-map)
        contents (remove nil? [:alternative
                               (when text {:type "text/plain" :content text})
                               (cons :related html-contents)])]
    (send-message mail-system from to subject contents)))

Use original file name when inlining mail images


(ns pdok.featured.feature
  (:refer-clojure :exclude [type])
  (:require [clojure.string :as str]
            [clojure.core.cache :as cache]
            [clojure.java.io :as io]
            [clojure.java.jdbc :as j]
            [pdok.postgres :as pg]
            [cognitect.transit :as transit]
            [clojure.java.io :as io]
            [clojure.tools.logging :as log])
  (:import [nl.pdok.gml3 GML3Parser]
           [pdok.featured.xslt TransformXSLT]
           [pdok.featured.converters Transformer]
           [com.vividsolutions.jts.geom Geometry]
           [com.vividsolutions.jts.io WKTWriter]))

(def lower-case
  (fnil str/lower-case ""))

(def memoized-resolve (memoize resolve))

(deftype NilAttribute [symbol]
  Object
  (toString [_] nil)
  clojure.lang.IEditableCollection
  (asTransient [this] this)
  clojure.lang.ITransientAssociative
  (conj [this _] this)
  (persistent [v] v)
  (assoc [this _ _] this)
  (valAt [_ _] symbol)
  (valAt [_ _ _] symbol)
  j/ISQLValue
  (sql-value [v] nil)
  clojure.lang.IMeta
  (meta [_] {:type (memoized-resolve symbol)})
  clojure.lang.Seqable
   (seq [_] nil)
  )

(defn nilled [class]
  (->NilAttribute class))

(def nil-attribute-writer
  (transit/write-handler
   "x"
   (fn [^NilAttribute v] (str (.symbol v)))
   (fn [^NilAttribute v] (str (.symbol v)))))

(def nil-attribute-reader
  (transit/read-handler
   (fn [v]
     (->NilAttribute (symbol v)))))

(pg/register-transit-write-handler pdok.featured.feature.NilAttribute nil-attribute-writer)
(pg/register-transit-read-handler "x" nil-attribute-reader)

(def xslt-simple-gml (io/resource "pdok/featured/xslt/imgeo2simple-gml.xsl"))

(def simple-gml-transfomer (TransformXSLT. (io/input-stream xslt-simple-gml)))

(def gml3-parser (GML3Parser.))

(defn gml3-as-jts [gml]
  (locking gml3-parser (.toJTSGeometry ^GML3Parser gml3-parser gml)))

(def wkt-writer (WKTWriter.))

(defn jts-as-wkt [jts]
  (.write ^WKTWriter wkt-writer jts))

(defmulti valid-geometry? (fn [obj] (lower-case (get obj "type"))))
(defmethod valid-geometry? :default [_] nil)
(defmethod valid-geometry? "gml" [obj]
  (if (get obj "gml") true false))

(defmethod valid-geometry? "jts" [obj]
  true)

(defmulti as-gml (fn [obj] (lower-case (get obj "type"))))
(defmethod as-gml "gml" [obj] (when-let [gml (get obj "gml")]
                                (str/trim (reduce str (str/split-lines (str/trim-newline (str/replace gml #"<\?[^\?]*\?>" "")))))))
(defmethod as-gml :default [obj] nil)

(defmulti as-jts (fn [obj] (lower-case (get obj "type"))))
(defmethod as-jts :default [_] nil)

(def gml->jts-cache (atom (cache/fifo-cache-factory {} :threshold 15000)))
(defmethod as-jts "gml" [obj]
 (when-let [gml (get obj "gml")]
   (if (cache/has? @gml->jts-cache gml)
     (cache/lookup @gml->jts-cache gml)
     (let [jts (gml3-as-jts gml)
           _ (swap! gml->jts-cache #(cache/miss % gml jts))]
       jts))))

(defmethod as-jts "jts" [obj]
  (get obj "jts"))

(defn as-rd [^Geometry geometry]
  (when geometry
    (if (= 28992 (.getSRID geometry))
      geometry
      (.transform Transformer/ETRS89ToRD geometry))))

(defn as-etrs89 [^Geometry geometry]
  (when geometry
    (if (= 4258 (.getSRID geometry))
      geometry
      (.transform Transformer/RDToETRS89 geometry))))

(defmulti as-simple-gml (fn [obj] lower-case (get obj "type")))
(defmethod as-simple-gml "gml" [obj]
  (when-let [gml (get obj "gml")]
    (.transform ^TransformXSLT simple-gml-transfomer gml)))
(defmethod as-simple-gml :default [obj] nil)

(defmulti as-wkt (fn [obj] lower-case (get obj "type")))
(defmethod as-wkt "gml" [obj]
  (let [jts (as-jts obj)
        wkt (jts-as-wkt jts)]
    wkt))

(defmulti geometry-group
  "returns :point, :line or :polygon"
  (fn [obj] (lower-case (get obj "type"))))

(defmethod geometry-group :default [_] nil)

(defn- geometry-group*
  ([point-types line-types test-value]
   (geometry-group* point-types line-types test-value get))
  ([point-types line-types test-value predicate]
    (condp predicate test-value
      point-types :point
      line-types :line
      :polygon)))

;; http://schemas.opengis.net/gml/3.1.1/base/geometryPrimitives.xsd

(def gml-point-types
  #{"Point" "MultiPoint"})

;; TODO alles toevoegen, of starts with
(def gml-line-types
  #{"Curve" "CompositeCurve" "Arc" "ArcString" "Circle" "LineString"})

(defmethod geometry-group "gml" [obj]
  (when-let [gml-str (get obj "gml")]
    (let [re-result (re-find #"^(<\?[^\?]*\?>)?<([a-zA-Z0-9]+:)?([^\s]+)" gml-str)
          type (when re-result (nth re-result 3))]
      (geometry-group* gml-point-types gml-line-types type))))

(def jts-point-types
  "Geometry types of Point-category"
  #{"Point" "MultiPoint"})

(def jts-line-types
  "Geometry types of Line-category"
  #{"Line" "LineString" "MultiLine"})

(defmethod geometry-group "jts" [obj]
  (let [type (.getGeometryType ^Geometry (get obj "jts"))]
    (geometry-group* jts-point-types jts-line-types type)))

(ns pdok.featured.feature
  (:refer-clojure :exclude [type])
  (:require [clojure.string :as str]
            [clojure.java.io :as io]
            [clojure.java.jdbc :as j]
            [pdok.postgres :as pg]
            [cognitect.transit :as transit]
            [clojure.java.io :as io]
            [clojure.tools.logging :as log])
  (:import [nl.pdok.gml3 GML3Parser]
           [pdok.featured.xslt TransformXSLT]
           [pdok.featured.converters Transformer]
           [com.vividsolutions.jts.geom Geometry]
           [com.vividsolutions.jts.io WKTWriter]))

(def lower-case
  (fnil str/lower-case ""))

(def memoized-resolve (memoize resolve))

(deftype NilAttribute [symbol]
  Object
  (toString [_] nil)
  clojure.lang.IEditableCollection
  (asTransient [this] this)
  clojure.lang.ITransientAssociative
  (conj [this _] this)
  (persistent [v] v)
  (assoc [this _ _] this)
  (valAt [_ _] symbol)
  (valAt [_ _ _] symbol)
  j/ISQLValue
  (sql-value [v] nil)
  clojure.lang.IMeta
  (meta [_] {:type (memoized-resolve symbol)})
  clojure.lang.Seqable
   (seq [_] nil)
  )

(defn nilled [class]
  (->NilAttribute class))

(def nil-attribute-writer
  (transit/write-handler
   "x"
   (fn [^NilAttribute v] (str (.symbol v)))
   (fn [^NilAttribute v] (str (.symbol v)))))

(def nil-attribute-reader
  (transit/read-handler
   (fn [v]
     (->NilAttribute (symbol v)))))

(pg/register-transit-write-handler pdok.featured.feature.NilAttribute nil-attribute-writer)
(pg/register-transit-read-handler "x" nil-attribute-reader)

(def xslt-simple-gml (io/resource "pdok/featured/xslt/imgeo2simple-gml.xsl"))

(def simple-gml-transfomer (TransformXSLT. (io/input-stream xslt-simple-gml)))

(def gml3-parser (GML3Parser.))

(defn gml3-as-jts [gml]
  (.toJTSGeometry ^GML3Parser gml3-parser gml))

(def wkt-writer (WKTWriter.))

(defn jts-as-wkt [jts]
  (.write ^WKTWriter wkt-writer jts))

(defmulti valid-geometry? (fn [obj] (lower-case (get obj "type"))))
(defmethod valid-geometry? :default [_] nil)
(defmethod valid-geometry? "gml" [obj]
  (if (get obj "gml") true false))

(defmethod valid-geometry? "jts" [obj]
  true)

(defmulti as-gml (fn [obj] (lower-case (get obj "type"))))
(defmethod as-gml "gml" [obj] (when-let [gml (get obj "gml")]
                                (str/trim (reduce str (str/split-lines (str/trim-newline (str/replace gml #"<\?[^\?]*\?>" "")))))))
(defmethod as-gml :default [obj] nil)

(defmulti as-jts (fn [obj] (lower-case (get obj "type"))))
(defmethod as-jts :default [_] nil)
(defmethod as-jts "gml" [obj]
 (when-let [gml (get obj "gml")]
  (gml3-as-jts gml)))
(defmethod as-jts "jts" [obj]
  (get obj "jts"))

(defn as-rd [^Geometry geometry]
  (when geometry
    (if (= 28992 (.getSRID geometry))
      geometry
      (.transform Transformer/ETRS89ToRD geometry))))

(defn as-etrs89 [^Geometry geometry]
  (when geometry
    (if (= 4258 (.getSRID geometry))
      geometry
      (.transform Transformer/RDToETRS89 geometry))))

(defmulti as-simple-gml (fn [obj] lower-case (get obj "type")))
(defmethod as-simple-gml "gml" [obj]
  (when-let [gml (get obj "gml")]
    (.transform ^TransformXSLT simple-gml-transfomer gml)))
(defmethod as-simple-gml :default [obj] nil)

(defmulti as-wkt (fn [obj] lower-case (get obj "type")))
(defmethod as-wkt "gml" [obj]
  (let [jts (as-jts obj)
        wkt (jts-as-wkt jts)]
    wkt))

(defmulti geometry-group
  "returns :point, :line or :polygon"
  (fn [obj] (lower-case (get obj "type"))))

(defmethod geometry-group :default [_] nil)

(defn- geometry-group*
  ([point-types line-types test-value]
   (geometry-group* point-types line-types test-value get))
  ([point-types line-types test-value predicate]
    (condp predicate test-value
      point-types :point
      line-types :line
      :polygon)))

;; http://schemas.opengis.net/gml/3.1.1/base/geometryPrimitives.xsd

(def gml-point-types
  #{"Point" "MultiPoint"})

;; TODO alles toevoegen, of starts with
(def gml-line-types
  #{"Curve" "CompositeCurve" "Arc" "ArcString" "Circle" "LineString"})

(defmethod geometry-group "gml" [obj]
  (when-let [gml-str (get obj "gml")]
    (let [re-result (re-find #"^(<\?[^\?]*\?>)?<([a-zA-Z0-9]+:)?([^\s]+)" gml-str)
          type (when re-result (nth re-result 3))]
      (geometry-group* gml-point-types gml-line-types type))))

(def jts-point-types
  "Geometry types of Point-category"
  #{"Point" "MultiPoint"})

(def jts-line-types
  "Geometry types of Line-category"
  #{"Line" "LineString" "MultiLine"})

(defmethod geometry-group "jts" [obj]
  (let [type (.getGeometryType ^Geometry (get obj "jts"))]
    (geometry-group* jts-point-types jts-line-types type)))

Revert "feat: cached jts (for gml)"

Revert "feat: cached jts (for gml)"

This reverts commit d1e4489a95eb7f33a34ccf50a3a6445c54fae0d9.


(ns braid.client.quests.styles
  (:require [garden.units :refer [em px rem]]
            [garden.arithmetic :as m]
            [braid.client.ui.styles.vars :as vars]
            [braid.client.ui.styles.mixins :as mixins]))

(def quest-icon-size (rem 2))

(defn quests-header [header-text header-height]
  [:&
   [:.quests-header
    {:position "relative"}

    [".bar:hover + .quests-menu"
     ".quests-menu:hover"
     {:display "inline-block"}]

    [:.bar
     (header-text)

     [:&:before
      (mixins/fontawesome \uf091)
      {:margin-right (em 0.5)}]]

    [:.quests-menu
     (mixins/context-menu)
     {:position "absolute"
      :top header-height
      :right 0
      :z-index 150
      :display "none"}

     [:.content

      [:.congrats
       {:min-width (em 22)}

       [:&::before
        (mixins/fontawesome \uf091)
        {:font-size (em 4.5)
         :float "left"
         :margin-right (rem 0.75)}]

       [:h1
        {:font-size (em 1.2)
         :margin 0}]

        [:p
         {:margin 0}]]

      [:.quests

       [:.quest
        {:margin-bottom (em 2)
         :display "flex"
         :justify-content "space-between"}

        [:&:last-child
         {:margin-bottom 0}]

        [:&:before
         {:content "attr(data-icon)"
          :font-family "FontAwesome"
          :display "block"
          :font-size quest-icon-size
          :color "#666"
          :margin [[0 vars/pad 0 (m// vars/pad 2)]]
          :align-self "center"}]

        [:.info
         {:margin-right (em 1)}

         [:h1
          {:font-size (em 1.2)
           :margin 0
           :display "inline-block"}]

         [:.progress
          {:display "inline-block"
           :float "right"}

          [:.icon
           {:display "inline-block"
            :font-size (em 1.2)
            :margin-right (em 0.5)
            :vertical-align "bottom"}

           [:&.incomplete::before
            (mixins/fontawesome \uf10c)]

           [:&.complete::before
            (mixins/fontawesome \uf058)]]]

         [:p
          {:margin 0
           :width (em 18)}]]

        [:.actions
         {:align-self "center"}
         [:a
          (mixins/outline-button)
          {:margin-left (em 0.5)}]]]]]]]])

(ns braid.client.quests.styles
  (:require [garden.units :refer [em px rem]]
            [garden.arithmetic :as m]
            [braid.client.ui.styles.vars :as vars]
            [braid.client.ui.styles.mixins :as mixins]))

(def quest-icon-size (rem 2.5))

(defn quests-header [header-text header-height]
  [:&

   [:.quests-header
    {:position "relative"}

    [".bar:hover + .quests-menu"
     ".quests-menu:hover"
     {:display "inline-block"}]

    [:.bar
     (header-text)

     [:&:before
      (mixins/fontawesome \uf091)
      {:margin-right (em 0.5)}]]

    [:.quests-menu
     (mixins/context-menu)
     {:position "absolute"
      :top header-height
      :right 0
      :z-index 150
      :display "none"}

     [:.content

      [:.congrats
       {:min-width (em 22)}

       [:&::before
        (mixins/fontawesome \uf091)
        {:font-size (em 4.5)
         :float "left"
         :margin-right (rem 0.75)}]

       [:h1
        {:font-size (em 1.2)
         :margin 0}]

        [:p
         {:margin 0}]]

      [:.quests

       [:.quest
        {:margin-bottom (em 2)
         :display "flex"
         :justify-content "space-between"}

        [:&:last-child
         {:margin-bottom 0}]

        [:&:before
         {:content "attr(data-icon)"
          :font-family "FontAwesome"
          :display "block"
          :font-size quest-icon-size
          :color "#666"
          :margin [[0 vars/pad 0 (m// vars/pad 2)]]
          :align-self "center"}]

        [:.info
         {:margin-right (em 1)}

         [:h1
          {:font-size (em 1.2)
           :margin 0
           :display "inline-block"}]

         [:.progress
          {:display "inline-block"
           :float "right"}

          [:.icon
           {:display "inline-block"
            :font-size (em 1.2)
            :margin-right (em 0.5)
            :vertical-align "bottom"}

           [:&.incomplete::before
            (mixins/fontawesome \uf10c)]

           [:&.complete::before
            (mixins/fontawesome \uf058)]]]

         [:p
          {:margin 0
           :width (em 20)}]]

        [:.actions
         {:align-self "center"}
         [:a
          (mixins/outline-button)
          {:margin-left (em 0.5)}]]]]]]]])

Increase quest icon size

Increase quest icon size


(ns circle.backend.nodes.circle
  (:require pallet.core
            pallet.phase
            [pallet.action.directory :as directory]
            [pallet.action.exec-script :as exec-script]
            [pallet.action.file :as file]
            [pallet.action.package :as package]
            [pallet.action.remote-file :as remote-file]
            [pallet.action.service :as service]
            [pallet.action.user :as user]
            [pallet.crate.automated-admin-user :as automated-admin-user]
            [pallet.crate.git :as git]
            [pallet.crate.java :as java]
            [pallet.crate.lein :as lein]
            [pallet.crate.network-service :as network-service]
            [pallet.crate.nginx :as nginx]
            [pallet.crate.postgres :as postgres]
            [pallet.crate.rvm :as rvm]
            [pallet.crate.ssh-key :as ssh-key]
            [pallet.crate.rubygems :as rubygems]
            [pallet.stevedore :as stevedore]
            [pallet.thread-expr :as thread-expr]
            [circle.sh :as sh]
            [circle.backend.ssh :as ssh]
            [circle.backend.nodes :as nodes])
  (:use [arohner.utils :only (inspect)]))

;; this is our "memoized" circle box
(def circle-group
  (pallet.core/group-spec
   "circle"
   :circle-node-spec {:ami "ami-3bb46152"
                      :name "www"
                      :availability-zone "us-east-1a"
                      :instance-type "m1.small"
                      :keypair-name "www"
                      :security-groups ["www" "allow-DB"]
                      :username "ubuntu"
                      :public-key (slurp "www.id_rsa.pub")
                      :private-key (slurp "www.id_rsa")}))

(defmacro user-code
  "Runs a seq of stevedore commands as the non-sudo user"
  [session & cmds]
  `(let [cmds# (stevedore/with-script-language :pallet.stevedore.bash/bash
                (clojure.string/join ";" (map (fn [c#]
                                                (stevedore/emit-script [c#])) (quote ~cmds))))]
    (-> ~session
        (exec-script/exec-checked-script
         "rvm cmd"
         ("sudo" "-i" "-u" (unquote (-> ~session :user :username)) "bash" "-c" (unquote (format "\"%s\"" cmds#)))))))

(defn install-rvm-profile [session]
  (-> session
      (remote-file/remote-file "~/rvm.sed" :local-file "pallet/ruby/rvm.sed" :no-versioning true)
      (exec-script/exec-checked-script
       "Installing RVM in the profile"
       (sudo "-i" "-u" ~(-> session :user :username) bash "-c" "\"sed -f rvm.sed ~/.bashrc > ~/.bashrc-new && mv ~/.bashrc-new ~/.bashrc\""))))

;; The configuration to build the circle box from scratch
(def circle-raw-group
  (pallet.core/group-spec
   "circle"
   :circle-node-spec {:ami "ami-06ad526f" ;; clean ubuntu 11.10
                      :availability-zone "us-east-1a"
                      :instance-type "m1.small"
                      :keypair-name "www"
                      :security-groups ["www" "allow-DB"]
                      :username "ubuntu"
                      :public-key (slurp "www.id_rsa.pub")
                      :private-key (slurp "www.id_rsa")}
   :phases {:bootstrap (pallet.phase/phase-fn
                        (automated-admin-user/automated-admin-user))
            :configure (fn [session]
                         (-> session
                             (package/package-source "ubuntu-archive"
                                                     ;; by default, EC2
                                                     ;; ubuntu images only
                                                     ;; use ubuntu mirrors
                                                     ;; hosted on EC2,
                                                     ;; which sometimes go
                                                     ;; down. Add this as
                                                     ;; another mirror for
                                                     ;; reliability
                                                     :aptitude {:url "http://us.archive.ubuntu.com/ubuntu/"
                                                                :scopes ["main" "natty-updates" "universe" "multiverse"]}) ;; TODO the natty is specific to 11.04, change later.
                             (package/packages :aptitude ["nginx" "htop" "mongodb" "rubygems" "libsqlite3-dev" "nodejs"])
                             (java/java :openjdk :jdk)
                             (git/git)
                             (exec-script/exec-script
                              ~(stevedore/checked-script
                                "Update rubygems"
                                (sudo "REALLY_GEM_UPDATE_SYSTEM=true" gem update --system)))

                             (rvm/rvm)
                             (install-rvm-profile)
                             (user-code
                              (source "~/.bashrc") ;; make sure RVM is loaded
                              (rvm install jruby)
                              (rvm use jruby)
                              (rvm gemset create circle)
                              (rvm gemset use circle)
                              (gem install bundler)
                              (gem install rspec))

                             (directory/directory "/etc/nginx/certs" :action :create)
                             (file/file "/etc/nginx/sites-enabled/default" :action :delete)
                             (remote-file/remote-file "/etc/nginx/sites-enabled/circle" :local-file "nginx-circle.conf" :no-versioning true)
                             (remote-file/remote-file "/etc/nginx/certs/circleci.com.crt" :local-file "circleci.com.crt" :no-versioning true)
                             (remote-file/remote-file "/etc/nginx/certs/circleci.com.key" :local-file "circleci.com.key" :no-versioning true)
                             (service/service "nginx" :action :enable)

                             ;;users
                             (thread-expr/let->
                              [username (-> session :user :username)
                               home (str "/home/" (-> session :user :username))]
                              (directory/directory  (str home "/.ssh/")
                                                    :create :action
                                                    :owner username
                                                    :group  username
                                                    :mode "600"
                                                    :path true)
                              (ssh-key/install-key username
                                                   "id_rsa"
                                                   (slurp "www.id_rsa")
                                                   (slurp "www.id_rsa.pub"))
                              (lein/lein)
                              (remote-file/remote-file (str home "/.ssh/config") :content "Host github.com\n\tStrictHostKeyChecking no\n"
                                                       :owner username
                                                       :group username
                                                       :mode "600")
                              (directory/directory (str home "/.pallet/")
                                                   :create :action
                                                   :path true)
                              (remote-file/remote-file (str home "/.pallet/config.clj") :local-file "src/circle/pallet_config.clj" :no-versioning true))))}))

(ns circle.backend.nodes.circle
  (:require pallet.core
            pallet.phase
            [pallet.action.directory :as directory]
            [pallet.action.exec-script :as exec-script]
            [pallet.action.file :as file]
            [pallet.action.package :as package]
            [pallet.action.remote-file :as remote-file]
            [pallet.action.service :as service]
            [pallet.action.user :as user]
            [pallet.crate.automated-admin-user :as automated-admin-user]
            [pallet.crate.git :as git]
            [pallet.crate.java :as java]
            [pallet.crate.lein :as lein]
            [pallet.crate.network-service :as network-service]
            [pallet.crate.nginx :as nginx]
            [pallet.crate.postgres :as postgres]
            [pallet.crate.rvm :as rvm]
            [pallet.crate.ssh-key :as ssh-key]
            [pallet.crate.rubygems :as rubygems]
            [pallet.stevedore :as stevedore]
            [pallet.thread-expr :as thread-expr]
            [circle.sh :as sh]
            [circle.backend.ssh :as ssh]
            [circle.backend.nodes :as nodes]
            [circle.backend.pallet :as circle-pallet])
  (:use [arohner.utils :only (inspect)]))

;; this is our "memoized" circle box
(def circle-group
  (pallet.core/group-spec
   "circle"
   :circle-node-spec {:ami "ami-3bb46152"
                      :name "www"
                      :availability-zone "us-east-1a"
                      :instance-type "m1.small"
                      :keypair-name "www"
                      :security-groups ["www" "allow-DB"]
                      :username "ubuntu"
                      :public-key (slurp "www.id_rsa.pub")
                      :private-key (slurp "www.id_rsa")}))

;; The configuration to build the circle box from scratch
(def circle-raw-group
  (pallet.core/group-spec
   "circle"
   :circle-node-spec {:ami "ami-06ad526f" ;; clean ubuntu 11.10
                      :availability-zone "us-east-1a"
                      :instance-type "m1.small"
                      :keypair-name "www"
                      :security-groups ["www" "allow-DB"]
                      :username "ubuntu"
                      :public-key (slurp "www.id_rsa.pub")
                      :private-key (slurp "www.id_rsa")}
   :phases {:bootstrap (pallet.phase/phase-fn
                        (automated-admin-user/automated-admin-user))
            :configure (fn [session]
                         (-> session
                             (package/package-source "ubuntu-archive"
                                                     ;; by default, EC2
                                                     ;; ubuntu images only
                                                     ;; use ubuntu mirrors
                                                     ;; hosted on EC2,
                                                     ;; which sometimes go
                                                     ;; down. Add this as
                                                     ;; another mirror for
                                                     ;; reliability
                                                     :aptitude {:url "http://us.archive.ubuntu.com/ubuntu/"
                                                                :scopes ["main" "natty-updates" "universe" "multiverse"]}) ;; TODO the natty is specific to 11.04, change later.
                             (package/packages :aptitude ["nginx" "htop" "mongodb" "rubygems" "libsqlite3-dev" "nodejs"])
                             (java/java :openjdk :jdk)
                             (git/git)
                             (exec-script/exec-script
                              ~(stevedore/checked-script
                                "Update rubygems"
                                (sudo "REALLY_GEM_UPDATE_SYSTEM=true" gem update --system)))

                             (rvm/rvm)
                             (circle-pallet/install-rvm-profile)
                             (circle-pallet/user-code
                              (source "~/.bashrc") ;; make sure RVM is loaded
                              (rvm install jruby)
                              (rvm use jruby)
                              (rvm gemset create circle)
                              (rvm gemset use circle)
                              (gem install bundler)
                              (gem install rspec))

                             (directory/directory "/etc/nginx/certs" :action :create)
                             (file/file "/etc/nginx/sites-enabled/default" :action :delete)
                             (remote-file/remote-file "/etc/nginx/sites-enabled/circle" :local-file "nginx-circle.conf" :no-versioning true)
                             (remote-file/remote-file "/etc/nginx/certs/circleci.com.crt" :local-file "circleci.com.crt" :no-versioning true)
                             (remote-file/remote-file "/etc/nginx/certs/circleci.com.key" :local-file "circleci.com.key" :no-versioning true)
                             (service/service "nginx" :action :enable)

                             ;;users
                             (thread-expr/let->
                              [username (-> session :user :username)
                               home (str "/home/" (-> session :user :username))]
                              (directory/directory  (str home "/.ssh/")
                                                    :create :action
                                                    :owner username
                                                    :group  username
                                                    :mode "600"
                                                    :path true)
                              (ssh-key/install-key username
                                                   "id_rsa"
                                                   (slurp "www.id_rsa")
                                                   (slurp "www.id_rsa.pub"))
                              (lein/lein)
                              (remote-file/remote-file (str home "/.ssh/config") :content "Host github.com\n\tStrictHostKeyChecking no\n"
                                                       :owner username
                                                       :group username
                                                       :mode "600")
                              (directory/directory (str home "/.pallet/")
                                                   :create :action
                                                   :path true)
                              (remote-file/remote-file (str home "/.pallet/config.clj") :local-file "src/circle/pallet_config.clj" :no-versioning true))))}))

Refactor several pallet fns out of circle, so they can be used w/ the rails node


(ns made-merits.routes.home
  (:require [made-merits.layout :as layout]
            [compojure.core :refer [defroutes GET POST]]
            [ring.util.http-response :as response]
            [made-merits.db.core :as db]
            [clojure.java.io :as io]))

(defn home-page []
  (layout/render
    "home.html" {:docs (-> "docs/docs.md" io/resource slurp)}))

(defn merits-page []
  (layout/render "merits.html" {:users (db/get-users) :merits (db/get-merits)}))

(defn add-merits [id reason]
  (layout/render "merits.html" {:users (db/get-users)}))

(defroutes home-routes
  (GET "/" [] (home-page))
  (GET "/merits" [] (merits-page))
  (POST "/merits" [id reason] (add-merits id reason)))

(ns made-merits.routes.home
  (:require [made-merits.layout :as layout]
            [compojure.core :refer [defroutes GET POST]]
            [ring.util.http-response :as response]
            [made-merits.db.core :as db]
            [clojure.java.io :as io]))

(defn home-page []
  (layout/render
    "home.html" {:docs (-> "docs/docs.md" io/resource slurp)}))

(defn merits-page []
  (layout/render "merits.html" {:users (db/get-users) :merits (db/get-merits)}))

(defn add-merits [merit_id user_id]
  (db/add-merit-to-user {:merit_id merit_id :user_id user_id })
  (layout/render "merits.html" {:users (db/get-users) :merits (db/get-merits)}))

(defroutes home-routes
  (GET "/" [] (home-page))
  (GET "/merits" [] (merits-page))
  (POST "/merits" [merit_id user_id] (add-merits merit_id user_id)))

Add merit functionality.

Add merit functionality.


(ns org.openforis.ceo.https
  (:require [clojure.java.io :as io]
            [clojure.java.shell :as sh]
            [clojure.string :as str]
            [org.openforis.ceo.logging :refer [log-str]]))

(def path-env (System/getenv "PATH"))

;; Helper functions

(defn parse-as-sh-cmd
  "Split string into an array for use with clojure.java.shell/sh."
  [s]
  (loop [chars (seq s)
         acc   []]
    (if (empty? chars)
      acc
      (if (= \` (first chars))
        (recur (->> chars (rest) (drop-while #(not= \` %)) (rest))
               (->> chars (rest) (take-while #(not= \` %)) (apply str) (str/trim) (conj acc)))
        (recur (->> chars (drop-while #(not= \` %)))
               (->> chars (take-while #(not= \` %)) (apply str) (str/trim) (#(str/split % #" ")) (remove str/blank?) (into acc)))))))

(defn sh-wrapper [dir env & commands]
  (io/make-parents (str dir "/dummy"))
  (sh/with-sh-dir dir
    (sh/with-sh-env (merge {:PATH path-env} env)
      (every?
       (fn [cmd] (log-str cmd)
         (let [{:keys [out err]} (apply sh/sh (parse-as-sh-cmd cmd))]
           (log-str "out: "   out)
           (log-str "error: " err)
           (= err "")))
       commands))))

(defn package-certificate [domain certbot-dir]
  (sh-wrapper "./"
              {}
              (str "sudo openssl pkcs12 -export -out ./.key/keystore.pkcs12"
                   " -in " certbot-dir "/live/" domain "/fullchain.pem"
                   " -inkey " certbot-dir "/live/" domain "/privkey.pem"
                   " -passout pass:foobar")))

(defn initial-certificate [domain certbot-dir]
  (let [repo-path (.getAbsolutePath (io/file ""))]
    (spit "certbot-deploy-hook.sh"
          (str "#!/bin/sh"
               "\ncd " repo-path
               "\nclojure -A:package-cert " domain " " certbot-dir))
    (sh-wrapper "./"
                {}
                "chmod +x certbot-deploy-hook.sh"
                (str "sudo certbot certonly"
                     " --quiet"
                     " --non-interactive"
                     " --agree-tos"
                     " -m support@sig-gis.com"
                     " --webroot"
                     " -w ./resources/public"
                     " -d " domain
                     " --deploy-hook " repo-path "/certbot-deploy-hook.sh"))))

(defn -main [& [type domain certbot-dir]]
  (if domain
    (case type
      "certbot-init" (initial-certificate domain (or certbot-dir "/etc/letsencrypt"))
      "package-cert" (package-certificate domain (or certbot-dir "/etc/letsencrypt"))
      (println "Valid options are:"
               "\n  certbot-init domain [certbot-dir]    to initialize certbot"
               "\n  package-cert domian [certbot-dir]    to repackage certificates after an update"))
    (println "You must provide a domain to create an SSL key."))
  (shutdown-agents))

(ns org.openforis.ceo.https
  (:require [clojure.java.io :as io]
            [clojure.java.shell :as sh]
            [clojure.string :as str]
            [org.openforis.ceo.logging :refer [log-str]]))

(def path-env (System/getenv "PATH"))

;; Helper functions

(defn parse-as-sh-cmd
  "Split string into an array for use with clojure.java.shell/sh."
  [s]
  (loop [chars (seq s)
         acc   []]
    (if (empty? chars)
      acc
      (if (= \` (first chars))
        (recur (->> chars (rest) (drop-while #(not= \` %)) (rest))
               (->> chars (rest) (take-while #(not= \` %)) (apply str) (str/trim) (conj acc)))
        (recur (->> chars (drop-while #(not= \` %)))
               (->> chars (take-while #(not= \` %)) (apply str) (str/trim) (#(str/split % #" ")) (remove str/blank?) (into acc)))))))

(defn sh-wrapper [dir env & commands]
  (io/make-parents (str dir "/dummy"))
  (sh/with-sh-dir dir
    (sh/with-sh-env (merge {:PATH path-env} env)
      (every?
       (fn [cmd] (log-str cmd)
         (let [{:keys [out err]} (apply sh/sh (parse-as-sh-cmd cmd))]
           (log-str "out: "   out)
           (log-str "error: " err)
           (= err "")))
       commands))))

(defn package-certificate [domain certbot-dir]
  (sh-wrapper "./"
              {}
              (str "sudo openssl pkcs12 -export -out ./.key/keystore.pkcs12"
                   " -in " certbot-dir "/live/" domain "/fullchain.pem"
                   " -inkey " certbot-dir "/live/" domain "/privkey.pem"
                   " -passout pass:foobar")))

(defn initial-certificate [domain certbot-dir]
  (let [repo-path (.getAbsolutePath (io/file ""))]
    (spit "certbot-deploy-hook.sh"
          (str "#!/bin/sh"
               "\ncd " repo-path
               "\nclojure -A:package-cert " domain " " certbot-dir))
    (sh-wrapper "./"
                {}
                "chmod +x certbot-deploy-hook.sh"
                (str "sudo certbot certonly"
                     " --quiet"
                     " --non-interactive"
                     " --agree-tos"
                     " -m support@sig-gis.com"
                     " --webroot"
                     " -w ./resources/public"
                     " -d " domain
                     " --deploy-hook " repo-path "/certbot-deploy-hook.sh"))))

(defn -main [& [type domain certbot-dir]]
  (if domain
    (case type
      "certbot-init" (initial-certificate domain (or certbot-dir "/etc/letsencrypt"))
      "package-cert" (package-certificate domain (or certbot-dir "/etc/letsencrypt"))
      (println "Valid options are:"
               "\n  certbot-init domain [certbot-dir]    to initialize certbot"
               "\n  package-cert domain [certbot-dir]    to repackage certificates after an update"))
    (println "You must provide a domain to create an SSL key."))
  (shutdown-agents))

Fix typo in https.clj.

Fix typo in https.clj.


(ns spekl-package-manager.command-list
  (:require [spekl-package-manager.net :as net]
            [clojure.core.reducers :as r]
            [clojure.string :as string]

            ))

(def nl "\n                                                   ")

(defn block-format-string [ls len]
  (let [ss (into [] (seq ls))]
    (string/join "" (flatten (r/reduce (fn [acc x]
                          (if (and (> (count acc) 0 ) (= 0 (mod (count acc) len)))
                            (conj acc [nl x])
                            (conj acc x))) [] ss)))))

(defn print-listing [packages]
  (doseq [x packages] (println
                       (format "(%s) %-20s %-20s - %s " (x "kind") (x "name")  (format "(v%s)" (x "version")) (block-format-string (x "description") 80)))))

(defn run-list []
  (do
    (print-listing (net/load-packages :tools))
    (print-listing (net/load-packages :specs))
    ))

(defn run [arguments]
  (case (first arguments)
    "specs" (print-listing (net/load-packages :specs))
    "tools" (print-listing (net/load-packages :tools))
    "all"   (run-list)
    nil     (run-list)
    (throw (IllegalArgumentException. "Invalid selection"))))

;;
;; New listing format
;;
;;
;;
;; (comment

;;   Package : saw
;;   Type    : tool
;;   Versions: 1.1.1, 1.1.12, 1.1.3*
;;   Description: The Software Analysis Workbench (SAW) provides the ability to formally verify properties of code written in C, Java, and Cryptol.
;;   ----------------------------------------------------------------------------------------------------------------------------------------------

;;   )

work on new listing format

work on new listing format


(ns onyx.log.accept-join-cluster-test
  (:require [onyx.extensions :as extensions]
            [onyx.log.entry :refer [create-log-entry]]
            [onyx.system]
            [midje.sweet :refer :all]))

(def entry (create-log-entry :accept-join-cluster
                             {:observer :d
                              :subject :b
                              :accepted-joiner :d
                              :accepted-observer :a}))

(def f (partial extensions/apply-log-entry entry))

(def rep-diff (partial extensions/replica-diff entry))

(def rep-reactions (partial extensions/reactions entry))

(def old-replica {:pairs {:a :b :b :c :c :a}
                  :accepted {:a :d}
                  :peers [:a :b :c]
                  :job-scheduler :onyx.job-scheduler/greedy})

(let [new-replica (f old-replica)
      diff (rep-diff old-replica new-replica)]
  (fact (get-in new-replica [:pairs :a]) => :d)
  (fact (get-in new-replica [:pairs :d]) => :b)
  (fact (get-in new-replica [:accepted]) => {})
  (fact (last (get-in new-replica [:peers])) => :d)
  (fact diff => {:observer :a :subject :d})
  (fact (rep-reactions old-replica new-replica diff {}) => nil))

(def f (partial extensions/apply-log-entry entry))

(def rep-diff (partial extensions/replica-diff entry))

(def rep-reactions (partial extensions/reactions entry))

(def old-replica {:pairs {} :accepted {:a :d} :peers [:a]
                  :job-scheduler :onyx.job-scheduler/greedy})

(let [new-replica (f old-replica)
      diff (rep-diff old-replica new-replica)]
  (fact (get-in new-replica [:pairs :d]) => :a)
  (fact (get-in new-replica [:pairs :a]) => :d)
  (fact (get-in new-replica [:accepted]) => {})
  (fact (last (get-in new-replica [:peers])) => :d)
  (fact diff => {:observer :a :subject :d})
  (fact (rep-reactions old-replica new-replica diff {}) => nil))

(ns onyx.log.accept-join-cluster-test
  (:require [onyx.extensions :as extensions]
            [onyx.log.entry :refer [create-log-entry]]
            [clojure.set :as s]
            [onyx.system]
            [midje.sweet :refer :all]))

(def entry (create-log-entry :accept-join-cluster
                             {:observer :d
                              :subject :b
                              :accepted-joiner :d
                              :accepted-observer :a}))

(def f (partial extensions/apply-log-entry entry))

(def rep-diff (partial extensions/replica-diff entry))

(def rep-reactions (partial extensions/reactions entry))

(def old-replica {:pairs {:a :b :b :c :c :a}
                  :accepted {:a :d}
                  :peers #{:a :b :c}
                  :job-scheduler :onyx.job-scheduler/greedy})

(let [new-replica (f old-replica)
      diff (rep-diff old-replica new-replica)]
  (fact (get-in new-replica [:pairs :a]) => :d)
  (fact (get-in new-replica [:pairs :d]) => :b)
  (fact (get-in new-replica [:accepted]) => {})
  (fact (s/difference (get-in new-replica [:peers])
                      (:peers old-replica))
        => #{:d})
  (fact diff => {:observer :a :subject :d})
  (fact (rep-reactions old-replica new-replica diff {}) => nil))

(def f (partial extensions/apply-log-entry entry))

(def rep-diff (partial extensions/replica-diff entry))

(def rep-reactions (partial extensions/reactions entry))

(def old-replica {:pairs {} :accepted {:a :d} :peers #{:a}
                  :job-scheduler :onyx.job-scheduler/greedy})

(let [new-replica (f old-replica)
      diff (rep-diff old-replica new-replica)]
  (fact (get-in new-replica [:pairs :d]) => :a)
  (fact (get-in new-replica [:pairs :a]) => :d)
  (fact (get-in new-replica [:accepted]) => {})
  (fact (s/difference (get-in new-replica [:peers])
                      (:peers old-replica))
        => #{:d})
  (fact diff => {:observer :a :subject :d})
  (fact (rep-reactions old-replica new-replica diff {}) => nil))

Switch to peers in set coll. Observer has changed.


(ns leiningen.new.jruby-sinatra
  (:require [leiningen.new.templates :refer [renderer name-to-path ->files]]
            [leiningen.core.main :as main]))

(def ^{:const true} project-version "1.0.0-SNAPSHOT")

(def render (renderer "jruby-sinatra"))

(defn jruby-sinatra
  "FIXME: write documentation"
  [name]
  (let [data {:name name
              :sanitized (name-to-path name)
              :clojure-version "1.5.1"
              :project-version project-version
              :jruby-version "jruby-1.7.8"}]

    (main/info "Generating fresh 'lein new' jruby-sinatra project" (:sanitized data))
    (->files data
             ; Dotfiles
             [".gitignote" (render "gitignore")]
             [".ruby-version" (render "ruby-version" data)]
             [".ruby-gemset" (render "ruby-gemset" data)]
             [".pryrc" (render "ruby/pryrc")]
             ["project.clj" (render "project.clj" data)]
             ; Readme
             ["README.md" (render "README.md" data)]
             ; Ruby files
             ["Gemfile" (render "ruby/Gemfile")]
             ["Rakefile" (render "ruby/Rakefile")]
             ["config.ru" (render "ruby/config.ru")]
             ["app/application_controller.rb" (render "ruby/application_controller.rb")]
             ["app/init.rb" (render "ruby/init.rb")]
             ["config/warble.rb" (render "ruby/warble.rb")])
    (main/info "All done! Croon away I say.")))

(ns leiningen.new.jruby-sinatra
  (:require [leiningen.new.templates :refer [renderer name-to-path ->files]]
            [leiningen.core.main :as main]))

(def ^{:const true} project-version "1.0.0-SNAPSHOT")

(def render (renderer "jruby-sinatra"))

(defn jruby-sinatra
  "FIXME: write documentation"
  [name]
  (let [data {:name name
              :sanitized (name-to-path name)
              :clojure-version "1.5.1"
              :project-version project-version
              :jruby-version "jruby-1.7.8"}]

    (main/info "Generating fresh 'lein new' jruby-sinatra project" (:sanitized data))
    (->files data
             ; Dotfiles
             [".gitignore" (render "gitignore")]
             [".ruby-version" (render "ruby-version" data)]
             [".ruby-gemset" (render "ruby-gemset" data)]
             [".pryrc" (render "ruby/pryrc")]
             ["project.clj" (render "project.clj" data)]
             ; Readme
             ["README.md" (render "README.md" data)]
             ; Ruby files
             ["Gemfile" (render "ruby/Gemfile")]
             ["Rakefile" (render "ruby/Rakefile")]
             ["config.ru" (render "ruby/config.ru")]
             ["app/application_controller.rb" (render "ruby/application_controller.rb")]
             ["app/init.rb" (render "ruby/init.rb")]
             ["config/warble.rb" (render "ruby/warble.rb")])
    (main/info "All done! Croon away I say.")))

Update jruby_sinatra.clj

Update jruby_sinatra.clj

Fix typo


(ns ^{:doc "Core print logic."
      :author "Roberto Acevedo"}
  clj-print.core
  (:require [clj-print [doc-flavors :as flavors]
                       [listeners :as listeners]]
            [clojure.java [io :as io]]
            [clojure.pprint :refer [pprint]]
            [taoensso.timbre :as timbre])
  (:import (java.io File FileInputStream FileNotFoundException)
           (java.net URL)
           (javax.print DocPrintJob
                        DocFlavor
                        PrintException
                        PrintService
                        PrintServiceLookup
                        SimpleDoc)
           (javax.print.attribute AttributeSet
                                  HashAttributeSet
                                  HashDocAttributeSet
                                  HashPrintJobAttributeSet
                                  HashPrintRequestAttributeSet
                                  HashPrintServiceAttributeSet
                                  DocAttribute
                                  PrintJobAttribute
                                  PrintRequestAttribute
                                  PrintServiceAttribute)
           (javax.print.attribute.standard Copies
                                           Chromaticity
                                           MediaTray
                                           OrientationRequested
                                           PrinterName
                                           PrintQuality)
           (javax.print.event PrintJobListener))
  (:gen-class))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Printers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn printers
  "Returns a seq of printers that supports the specified
   DocFlavor and Attributes acquired from PrintServiceLookup.
   With no arguments, returns a seq of all printers that
   PrintServiceLookup is aware of."
  {:since "0.0.1"}
  ([& {:keys [^DocFlavor flavor ^AttributeSet attrs]}]
     (seq (PrintServiceLookup/lookupPrintServices flavor attrs))))

(defn printer
  "Returns the printer with the specified name from PrintServiceLookup.
   With no arguments, returns the system default printer."
  {:since "0.0.1"}
  [name]
  (cond
   (= :default name) (PrintServiceLookup/lookupDefaultPrintService)
   (seq name) (let [attrs (doto (HashAttributeSet.) (.add (PrinterName. name nil)))]
                (some (fn [^PrintService p] (when (= name (.. p getName)) p)) (printers nil attrs)))
   :else nil))

(defn status
  "Returns a seq of this PrintService's status attributes."
  {:since "0.0.1"}
  [^PrintService p]
  (-> p .getAttributes .toArray seq))

;; TODO: Is this the best way to do this?
(defn attributes
  "Returns a flattened seq of this PrintService's supported
  atributes, for all of its supported Attribute classes."
  {:since "0.0.1"}
  [^PrintService p]
  (let [unflattened (for [c (.. p getSupportedAttributeCategories)]
                      (.. p (getSupportedAttributeValues c nil nil)))]
    (->> unflattened
         (map (fn [e] (if (.. ^Class (type e) isArray) (seq e) e)))
         flatten)))

(defn trays
  "Returns a seq of this PrintService's MediaTrays"
  {:since "0.0.1"}
  [^PrintService p]
  (filter (fn [attr] (instance? MediaTray attr)) (attributes p)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Util ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- choose-source-key
  "Returns a keyword representative of the document source's
   type."
  {:since "1.0"}
  [source]
  (cond (try (.. (io/file source) exists) (catch Throwable t)) :file
        (try (URL. source) (catch Throwable t)) :url
        :else nil))

(defn- choose-flavor
  "Attempts to guess the appropriate DocFlavor for the document.
   Returns nil if no suitable DocFlavor is found."
  {:since "1.0"}
  [source]
  (condp = (choose-source-key source)
    :file (:autosense flavors/input-streams)
    :url (:autosense flavors/urls)
    nil))

(defn- make-set
  "Takes a Clojure set and returns an AttributeSet implementation
   based on bound."
  [^clojure.lang.IPersistentSet s bound]
  (if (seq s)
    (condp = bound
      :service (HashPrintServiceAttributeSet. (into-array PrintServiceAttribute s))
      :job (HashPrintJobAttributeSet. (into-array PrintJobAttribute s))
      :doc (HashDocAttributeSet. (into-array DocAttribute s))
      :request (HashPrintRequestAttributeSet. (into-array PrintRequestAttribute s))
      nil)))

(defn- make-doc
  "Returns a javax.print.Doc object for the print data in this
   job map. SimpleDoc will throw an IllegalArgumentException if
   the doc-flavor is not representative of the data pointed to
   by doc-source."
  {:since "0.0.1"}
  [doc-map]
  (let [{^String source :source} doc-map
        {:keys [flavor attrs]
         :or {flavor (choose-flavor source)
              attrs #{MediaTray/MAIN}}} doc-map ;; Pretty sure I need this
              resource (condp = (choose-source-key source)
                         :file (FileInputStream. source)
                         :url (URL. source)
                         nil)]
    ;; TODO: Do I need the caching provided by this?
    (delay (SimpleDoc. resource flavor (-> attrs (make-set :doc))))))

(defn- valid-attrs?
  "Returns true if all of the Attribute objects in
   attrs are bounded by the type specified by k.
   Valid keywords for k are:
     :doc
     :job
     :request,
     :service"
  {:since "0.0.1"}
  [attrs k]
  (condp = k
    :doc (every? #(instance? DocAttribute %) attrs)
    :job (every? #(instance? PrintJobAttribute %) attrs)
    :request (every? #(instance? PrintRequestAttribute %) attrs)
    :service (every? #(instance? PrintServiceAttribute %) attrs)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Job ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;  A JobSpec might look something like this:
;;
;; {:doc {:source "/path/to/doc"
;;        :flavor (:autosense flavors/input-streams)
;;        :attrs #{Chromaticity/MONOCHROME
;;                 PrintQuality/HIGH
;;                 OrientationRequested/PORTRAIT}}
;;  :printer (printer "HP_Color_LaserJet_CP3505")
;;  :attrs #{(Copies. 5) MediaTray/MAIN}
;;  :listener SimpleJobListener}

(defprotocol ISpoolable
  "This protocol defines a contract that states the
   responsibilities of any implementation that wishes
   to be considered 'spoolable,' which implies that it
   can be queued for later processing such that it is
   another process' resonsibility to handle the ISpoolable
   and block until it has been processed. For an implementation
   to be spoolable, it must be able to do the following:"
  (submit [this]) ;; Submit the job
  (add-listener [this listener])) ;; Attach an event listener that
                                  ;; returns a value when the process is complete

(defrecord JobSpec [doc printer job attrs]
  ISpoolable
  (submit [this]
    (cond
     (:doc this) (let [{{obj :obj} :doc} this
                       {:keys [^DocPrintJob job attrs]} this]
                   (.. job (print @obj (make-set attrs :request))))
     (:docs this) (let [{docs :docs ^PrintService printer :printer} this]
                    (for [d docs]
                      [(make-doc d) (.. printer createPrintJob)]))
     :else nil))
  (add-listener [this listener]
    (if-let [{^DocPrintJob job :job} this]
      (do (doto job (.addPrintJobListener listener))
          (assoc this :listener listener))
      (throw IllegalStateException "No DocPrintJob keyed at :job."))))

(defn job-seq [job-map]
  (let [{docs :docs ^PrintService printer :printer} job-map]
    (for [d docs]
      [(make-doc d) (.. printer createPrintJob)])))

;; TODO: SEE http://oobaloo.co.uk/clojure-from-callbacks-to-sequences!!!
;;
;; (defprotocol IOperator
;;   "This protocol is to be used by implementations
;;    that wish to handle a print process by coordinating
;;    the processing of multiple documents within an ISpoolable."
;;   (process [this spec]))

;; (defrecord PrintOperator [spec]
;;   IOperator
;;   (process [this spec]
;;     (when-let [docs (seq (:docs spec))]
;;       (let [{^PrintService printer :printer} spec
;;             job (.. printer createPrintJob)]
;;         (submit spec)))))

;; TODO: Need to be able to ensure that the PrintService does not
;; process incoming jobs until it has finished processing the MultiDoc
;; (all calls to print on DocPrintJob objects dispensed by it should
;; block until the the current job signals completion/no more events).

(defn make-job
  "Returns a JobSpec map that is the result of
   assoc'ing required values to it. The values are:

   1. A SimpleDoc object (wrapped in a Delay) made from
   the map keyed at :doc.
   2. A DocPrintJob object that is retrieved from the
   PrintService.

   The following defaults are also assoc'd to the job-spec
   if no values are supplied for them:

   1. The default system printer.
   2. An attribute set with the single attribute MediaTray/MAIN.
   3. A basic PrintJobListener that prints any events that occur
   on the DocPrintJob."
  {:since "0.0.1"}
  [spec]
  (if (:doc spec)
    (let [{{doc-attrs :attrs} :doc} spec
          {:keys [doc ^PrintService printer attrs ^PrintJobtListener listener]
           :or {printer (printer :default)
                attrs #{MediaTray/MAIN}}} spec
          maybe-listen #(if listener (add-listener % listener) %)]
      (if (and (valid-attrs? doc-attrs :doc)
               (valid-attrs? attrs :job))
        (-> (map->JobSpec {:doc (assoc doc :obj (make-doc doc))
                           :printer printer
                           :attrs attrs
                           :job (.. printer createPrintJob)})
            maybe-listen)))))

(defn -main [& args]
  (if (seq args)
    (doseq [v args]
      (let [spec (read-string v)]
        (-> (make-job spec) submit)))))

(ns ^{:doc "Core print logic."
      :author "Roberto Acevedo"}
  clj-print.core
  (:require [clj-print [doc-flavors :as flavors]
                       [listeners :as listeners]]
            [clojure.java [io :as io]]
            [clojure.pprint :refer [pprint]]
            [taoensso.timbre :as timbre])
  (:import (java.io File FileInputStream FileNotFoundException)
           (java.net URL)
           (javax.print DocPrintJob
                        DocFlavor
                        PrintException
                        PrintService
                        PrintServiceLookup
                        SimpleDoc)
           (javax.print.attribute AttributeSet
                                  HashAttributeSet
                                  HashDocAttributeSet
                                  HashPrintJobAttributeSet
                                  HashPrintRequestAttributeSet
                                  HashPrintServiceAttributeSet
                                  DocAttribute
                                  PrintJobAttribute
                                  PrintRequestAttribute
                                  PrintServiceAttribute)
           (javax.print.attribute.standard Copies
                                           Chromaticity
                                           MediaTray
                                           OrientationRequested
                                           PrinterName
                                           PrintQuality)
           (javax.print.event PrintJobListener))
  (:gen-class))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Printers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn printers
  "Returns a seq of printers that supports the specified
   DocFlavor and Attributes acquired from PrintServiceLookup.
   With no arguments, returns a seq of all printers that
   PrintServiceLookup is aware of."
  {:since "0.0.1"}
  ([& {:keys [^DocFlavor flavor ^AttributeSet attrs]}]
     (seq (PrintServiceLookup/lookupPrintServices flavor attrs))))

(defn printer
  "Returns the printer with the specified name from PrintServiceLookup.
   With no arguments, returns the system default printer."
  {:since "0.0.1"}
  [name]
  (cond
   (= :default name) (PrintServiceLookup/lookupDefaultPrintService)
   (seq name) (let [attrs (doto (HashAttributeSet.) (.add (PrinterName. name nil)))]
                (some (fn [^PrintService p] (when (= name (.. p getName)) p)) (printers nil attrs)))
   :else nil))

(defn status
  "Returns a seq of this PrintService's status attributes."
  {:since "0.0.1"}
  [^PrintService p]
  (-> p .getAttributes .toArray seq))

;; TODO: Is this the best way to do this?
(defn attributes
  "Returns a flattened seq of this PrintService's supported
  atributes, for all of its supported Attribute classes."
  {:since "0.0.1"}
  [^PrintService p]
  (let [unflattened (for [c (.. p getSupportedAttributeCategories)]
                      (.. p (getSupportedAttributeValues c nil nil)))]
    (->> unflattened
         (map (fn [e] (if (.. ^Class (type e) isArray) (seq e) e)))
         flatten)))

(defn trays
  "Returns a seq of this PrintService's MediaTrays"
  {:since "0.0.1"}
  [^PrintService p]
  (filter (fn [attr] (instance? MediaTray attr)) (attributes p)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Util ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- choose-source-key
  "Returns a keyword representative of the document source's
   type."
  {:since "1.0"}
  [source]
  (cond (try (.. (io/file source) exists) (catch Throwable t)) :file
        (try (URL. source) (catch Throwable t)) :url
        :else nil))

(defn- choose-flavor
  "Attempts to guess the appropriate DocFlavor for the document.
   Returns nil if no suitable DocFlavor is found."
  {:since "1.0"}
  [source]
  (condp = (choose-source-key source)
    :file (:autosense flavors/input-streams)
    :url (:autosense flavors/urls)
    nil))

(defn- make-set
  "Takes a Clojure set and returns an AttributeSet implementation
   based on bound."
  [^clojure.lang.IPersistentSet s bound]
  (if (seq s)
    (condp = bound
      :service (HashPrintServiceAttributeSet. (into-array PrintServiceAttribute s))
      :job (HashPrintJobAttributeSet. (into-array PrintJobAttribute s))
      :doc (HashDocAttributeSet. (into-array DocAttribute s))
      :request (HashPrintRequestAttributeSet. (into-array PrintRequestAttribute s))
      nil)))

;; TODO: Validate attrs here?
(defn- make-doc
  "Returns a javax.print.Doc object for the print data in this
   job map. SimpleDoc will throw an IllegalArgumentException if
   the doc-flavor is not representative of the data pointed to
   by doc-source."
  {:since "0.0.1"}
  [doc-map]
  (let [{^String source :source} doc-map
        {:keys [flavor attrs]
         :or {flavor (choose-flavor source)
              attrs #{MediaTray/MAIN}}} doc-map ;; Pretty sure I need this
              resource (condp = (choose-source-key source)
                         :file (FileInputStream. source)
                         :url (URL. source)
                         nil)]
    ;; TODO: Do I need the caching provided by this?
    (delay (SimpleDoc. resource flavor (-> attrs (make-set :doc))))))

(defn- valid-attrs?
  "Returns true if all of the Attribute objects in
   attrs are bounded by the type specified by k.
   Valid keywords for k are:
     :doc
     :job
     :request,
     :service"
  {:since "0.0.1"}
  [attrs k]
  (condp = k
    :doc (every? #(instance? DocAttribute %) attrs)
    :job (every? #(instance? PrintJobAttribute %) attrs)
    :request (every? #(instance? PrintRequestAttribute %) attrs)
    :service (every? #(instance? PrintServiceAttribute %) attrs)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Job ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;  A JobSpec might look something like this:
;;
;; {:doc {:source "/path/to/doc"
;;        :flavor (:autosense flavors/input-streams)
;;        :attrs #{Chromaticity/MONOCHROME
;;                 PrintQuality/HIGH
;;                 OrientationRequested/PORTRAIT}}
;;  :printer (printer "HP_Color_LaserJet_CP3505")
;;  :attrs #{(Copies. 5) MediaTray/MAIN}
;;  :listener SimpleJobListener}

;; (defprotocol ISpoolable
;;   "This protocol defines a contract that states the
;;    responsibilities of any implementation that wishes
;;    to be considered 'spoolable,' which implies that it
;;    can be queued for later processing such that it is
;;    another process' resonsibility to handle the ISpoolable
;;    and block until it has been processed. For an implementation
;;    to be spoolable, it must be able to do the following:"
;;   (submit [this]) ;; Submit the job
;;   (add-listener [this listener]))
;; Attach an event listener that
                                  ;; returns a value when the process is complete

;; (defrecord JobSpec [doc printer job attrs]
;;   ISpoolable
;;   (submit [this]
;;     (let [{{obj :obj} :doc} this
;;           {:keys [^DocPrintJob job attrs]} this]
;;       (.. job (print @obj (make-set attrs :request)))))
;;   (add-listener [this listener]
;;     (if-let [{^DocPrintJob job :job} this]
;;       (do (doto job (.addPrintJobListener listener))
;;           (assoc this :listener listener))
;;       (throw IllegalStateException "No DocPrintJob keyed at :job."))))

(defn submit [jobspec]
  (let [{{obj :obj} :doc} jobspec
        {:keys [^DocPrintJob job attrs]}jobspec]
    (.. job (print @obj (make-set attrs :request)))))

(defn add-listener [jobspec listener]
    (if-let [{^DocPrintJob job :job} jobspec]
      (do (doto job (.addPrintJobListener listener))
          (assoc jobspec :listener listener))
      (throw IllegalStateException "No DocPrintJob keyed at :job.")))

;; (defn job-seq [job-map]
;;   (let [{docs :docs ^PrintService printer :printer} job-map]
;;     (for [d docs]
;;       [(make-doc d) (.. printer createPrintJob)])))

;; TODO: SEE http://oobaloo.co.uk/clojure-from-callbacks-to-sequences!!!
;;
;; (defprotocol IOperator
;;   "This protocol is to be used by implementations
;;    that wish to handle a print process by coordinating
;;    the processing of multiple documents within an ISpoolable."
;;   (process [this spec]))

;; (defrecord PrintOperator [spec]
;;   IOperator
;;   (process [this spec]
;;     (when-let [docs (seq (:docs spec))]
;;       (let [{^PrintService printer :printer} spec
;;             job (.. printer createPrintJob)]
;;         (submit spec)))))

;; TODO: Make this polymorphic using multimethods to prevent having to
;; create a record type (need to do some performance testing on this,
;; but for now I think it would be better to develop generically and
;; then adopt using records as needed
(defmulti job
  (fn [spec] (let [{:keys [doc docs]} spec]
              (or doc docs))))

(defmethod job :doc [spec]
  (let [{{doc-attrs :attrs} :doc} spec
        {:keys [doc ^PrintService printer attrs ^PrintJobtListener listener]
         :or {printer (printer :default)
              attrs #{MediaTray/MAIN}}} spec
              maybe-listen #(if listener (add-listener % listener) %)]
    (if (and (valid-attrs? doc-attrs :doc)
             (valid-attrs? attrs :job))
      (-> {:doc (assoc doc :obj (make-doc doc))
           :printer printer
           :attrs attrs
           :job (.. printer createPrintJob)}
          maybe-listen))))

(defmethod job :docs [spec]
  (let [{docs :docs} spec
        {:keys [doc ^PrintService printer attrs ^PrintJobtListener listener]
         :or {printer (printer :default)
              attrs #{MediaTray/MAIN}}} spec
              maybe-listen #(if listener (add-listener % listener) %)]
    (println "In :docs")
    (if (and (every? #(valid-attrs? (:attrs %) :doc) docs)
             (valid-attrs? attrs :job))
      (-> {:docs (map #(assoc % :obj (make-doc %)) docs)
           :printer printer
           :attrs attrs
           :job (.. printer createPrintJob)}
          maybe-listen))))

;; (defn make-job
;;   "Returns a JobSpec map that is the result of
;;    assoc'ing required values to it. The values are:

;;    1. A SimpleDoc object (wrapped in a Delay) made from
;;    the map keyed at :doc.
;;    2. A DocPrintJob object that is retrieved from the
;;    PrintService.

;;    The following defaults are also assoc'd to the job-spec
;;    if no values are supplied for them:

;;    1. The default system printer.
;;    2. An attribute set with the single attribute MediaTray/MAIN.
;;    3. A basic PrintJobListener that prints any events that occur
;;    on the DocPrintJob."
;;   {:since "0.0.1"}
;;   [spec]
;;   (cond
;;    (:doc spec) (let [{{doc-attrs :attrs} :doc} spec
;;                      {:keys [doc ^PrintService printer attrs ^PrintJobtListener listener]
;;                       :or {printer (printer :default)
;;                            attrs #{MediaTray/MAIN}}} spec
;;                            maybe-listen #(if listener (add-listener % listener) %)]
;;                  (if (and (valid-attrs? doc-attrs :doc)
;;                           (valid-attrs? attrs :job))
;;                    (-> {:doc (assoc doc :obj (make-doc doc))
;;                         :printer printer
;;                         :attrs attrs
;;                         :job (.. printer createPrintJob)}
;;                        maybe-listen)))
;;    (:docs spec) (let [{docs :docs} spec
;;                      {:keys [doc ^PrintService printer attrs ^PrintJobtListener listener]
;;                       :or {printer (printer :default)
;;                            attrs #{MediaTray/MAIN}}} spec
;;                            maybe-listen #(if listener (add-listener % listener) %)]
;;                   (println "In :docs")
;;                   (if (and (every? #(valid-attrs? (:attrs %) :doc) docs)
;;                            (valid-attrs? attrs :job))
;;                    (-> {:docs (map #(assoc % :obj (make-doc %)) docs)
;;                         :printer printer
;;                         :attrs attrs
;;                         :job (.. printer createPrintJob)}
;;                        maybe-listen)))
;;    :else nil))

(defn -main [& args]
  (if (seq args)
    (doseq [v args]
      (let [spec (read-string v)]
        (-> (make-job spec) submit)))))

Use multimethods, syncing before work, currently does NOT work


;; Copyright © 2016-2019, JUXT LTD.
(ns dev-extras
  (:require
   [clojure.test :refer [run-all-tests]]
   [edge.system :as system]
   [edge.system.meta :as system.meta]
   [integrant.repl]
   [integrant.repl.state]
   io.aviso.ansi
   clojure.tools.deps.alpha.repl)
  (:import
    [org.slf4j.bridge SLF4JBridgeHandler]))

(SLF4JBridgeHandler/removeHandlersForRootLogger)
(SLF4JBridgeHandler/install)

(when (try
        (require 'figwheel.main.logging)
        true
        (catch Throwable _))
  ;; Undo default logger being extremely fine grained in figwheel,
  ;; in order to configure figwheel to delegate to slf4j.
  (let [l @(resolve 'figwheel.main.logging/*logger*)]
    ((resolve 'figwheel.main.logging/remove-handlers) l)
    (.setUseParentHandlers l true)))

(defmacro ^:private proxy-ns
  [ns & vars]
  (cons `do
        (map (fn [v] `(do (def ~v ~(symbol (str ns) (str v)))
                          (alter-meta!
                            (resolve '~v)
                            merge
                            (select-keys (meta (resolve '~(symbol (str ns) (str v))))
                                         [:doc :file :line :column :arglists]))))
             vars)))

(proxy-ns integrant.repl clear halt prep init reset reset-all suspend)
(proxy-ns clojure.tools.deps.alpha.repl add-lib)

(defmacro ^:private watch-var
  [s alias]
  `(do
     (def ~alias ~s)
     (add-watch (var ~s)
                (keyword "dev-extras" ~(name alias))
                (fn [_# _# _# new#]
                  (alter-var-root
                    (var ~alias)
                    (constantly new#))))))

(watch-var integrant.repl.state/system system)
(watch-var integrant.repl.state/config system-config)

(defn go []
  (let [res (integrant.repl/go)]
    (doseq [message (system.meta/useful-infos system-config system)]
      (println (io.aviso.ansi/yellow (format "[Edge] %s" message))))
    (println (str (io.aviso.ansi/yellow "[Edge] Now make code changes, then enter ")
                  (io.aviso.ansi/bold-yellow "(reset)")
                  (io.aviso.ansi/yellow " here")))
    res))

(defn resume []
  (let [res (integrant.repl/resume)]
    (doseq [message (system.meta/useful-infos system-config system)]
      (println (io.aviso.ansi/yellow (format "[Edge] %s" message))))
    res))

(integrant.repl/set-prep! #(system/system-config {:profile :dev}))

(defn set-prep!
  [aero-opts]
  (integrant.repl/set-prep! #(system/system-config aero-opts)))

(defn test-all []
  (run-all-tests #"edge.*test$"))

(defn reset-and-test []
  (reset)
  (time (test-all)))

(defn cljs-repl
  "Start a ClojureScript REPL"
  ([]
   ;; ensure system is started - this could be less effectful perhaps?
   (go)
   (if (try
         (require 'figwheel-sidecar.repl-api)
         (catch java.io.FileNotFoundException _
           false))
     (eval
       `(do
          (require 'figwheel-sidecar.repl-api)
          (figwheel-sidecar.repl-api/cljs-repl)))
     (eval
       `(do
          (require 'figwheel.main.api)
          (require 'figwheel.main)
          (let [builds# (keys @figwheel.main/build-registry)]
            (if (= (count builds#) 1)
              (figwheel.main.api/cljs-repl (first builds#))
              (throw (ex-info "A build must be specified, please call with an argument"
                              {:builds builds#}))))))))
  ([build-id]
   ;; Register build with figwheel
   (go)
   ;; Assume figwheel main
   (eval
     `(do
        (require 'figwheel.main.api)
        (figwheel.main.api/cljs-repl ~build-id)))))

;; Copyright © 2016-2019, JUXT LTD.
(ns dev-extras
  (:require
   [clojure.test :refer [run-all-tests]]
   [edge.system :as system]
   [edge.system.meta :as system.meta]
   [integrant.repl]
   [integrant.repl.state]
   io.aviso.ansi
   clojure.tools.deps.alpha.repl)
  (:import
    [org.slf4j.bridge SLF4JBridgeHandler]))

(SLF4JBridgeHandler/removeHandlersForRootLogger)
(SLF4JBridgeHandler/install)

(when (try
        (require 'figwheel.main.logging)
        true
        (catch Throwable _))
  ;; Undo default logger being extremely fine grained in figwheel,
  ;; in order to configure figwheel to delegate to slf4j.
  (let [l @(resolve 'figwheel.main.logging/*logger*)]
    ((resolve 'figwheel.main.logging/remove-handlers) l)
    (.setUseParentHandlers l true)))

(defmacro ^:private proxy-ns
  [ns & vars]
  (cons `do
        (map (fn [v] `(do (def ~v ~(symbol (str ns) (str v)))
                          (alter-meta!
                            (resolve '~v)
                            merge
                            (select-keys (meta (resolve '~(symbol (str ns) (str v))))
                                         [:doc :file :line :column :arglists]))))
             vars)))

(proxy-ns integrant.repl clear halt prep init reset reset-all suspend)
(proxy-ns clojure.tools.deps.alpha.repl add-lib)

(defmacro ^:private watch-var
  [s alias]
  `(do
     (def ~alias ~s)
     (add-watch (var ~s)
                (keyword "dev-extras" ~(name alias))
                (fn [_# _# _# new#]
                  (alter-var-root
                    (var ~alias)
                    (constantly new#))))))

(watch-var integrant.repl.state/system system)
(watch-var integrant.repl.state/config system-config)

(defn go []
  (let [res (integrant.repl/go)]
    (doseq [message (system.meta/useful-infos system-config system)]
      (println (io.aviso.ansi/yellow (format "[Edge] %s" message))))
    (println (str (io.aviso.ansi/yellow "[Edge] Now make code changes, then enter ")
                  (io.aviso.ansi/bold-yellow "(reset)")
                  (io.aviso.ansi/yellow " here")))
    res))

(defn resume []
  (let [res (integrant.repl/resume)]
    (doseq [message (system.meta/useful-infos system-config system)]
      (println (io.aviso.ansi/yellow (format "[Edge] %s" message))))
    res))

(integrant.repl/set-prep! #(system/system-config {:profile :dev}))

(defn set-prep!
  [aero-opts]
  (integrant.repl/set-prep! #(system/system-config aero-opts)))

(defn test-all []
  (run-all-tests #"edge.*test$"))

(defn reset-and-test []
  (reset)
  (time (test-all)))

(defn cljs-repl
  "Start a ClojureScript REPL"
  ([]
   ;; ensure system is started - this could be less effectful perhaps?
   (go)
   (if (try
         (require 'figwheel-sidecar.repl-api)
         (catch java.io.FileNotFoundException _
           false))
     (eval
       `(do
          (require 'figwheel-sidecar.repl-api)
          (figwheel-sidecar.repl-api/cljs-repl)))
     (eval
       `(do
          (require 'figwheel.main.api)
          (require 'figwheel.main)
          (require 'figwheel.repl)
          (let [builds# (keys @figwheel.main/build-registry)]
            (if (= (count builds#) 1)
              (binding [figwheel.repl/*server* true]
                (figwheel.main.api/cljs-repl (first builds#)))
              (throw (ex-info "A build must be specified, please call with an argument"
                              {:builds builds#}))))))))
  ([build-id]
   ;; Register build with figwheel
   (go)
   ;; Assume figwheel main
   (eval
     `(do
        (require 'figwheel.main.api)
        (require 'figwheel.repl)
        (binding [figwheel.repl/*server* true]
          (figwheel.main.api/cljs-repl ~build-id))))))

Fix figwheel-main starting a server in repl phase

Reference https://github.com/bhauman/figwheel-main/issues/183

If figwheel looks at the server and it has been stopped, it will attempt
to start a server for you.
This causes port conflicts, as we control the server via the system
outside of this.


(ns overtone-workspace.grumbles
  (:use [overtone.live]))

;; Inspired by an example in an early chapter of the SuperCollider book

(definst grumble [speed 6 freq-mul 1]
  (let [snd (mix (map #(* (lf-tri (* % freq-mul 100))
                          (max 0 (+ (lf-noise1:kr speed)
                                    (env-gen (perc 20 100) :action FREE))))
                      [1 (/ 2 3) (/ 3 2) 2]))]
    (pan2 snd (sin-osc:kr 0.125))))

;;(stop)
;; (grumble)
;; (grumble :freq-mul 0.5)
;; (grumble :freq-mul 0.75)
;; (grumble :freq-mul 1)
;; (grumble :freq-mul 1.5)
;; (grumble :freq-mul 2)
;; (ctl grumble :speed 3000)

(volume (/  4  127))

(def metro (metronome 128))

(defn player [beat notes]
  (let [notes (if (empty? notes)
                [4 8 2 1.5]
                notes)]
    (at (metro beat)
        (do
          (if (zero? (mod beat 8)) (grumble :freq-mul 0.5))
          (if (zero? (mod beat 8)) (grumble :freq-mul 1))
          ))
    (at (metro (+ 0.5 beat))
        (if (zero? (mod beat 16))
          (grumble :freq-mul (choose notes))))
    (apply-by (metro (inc beat)) #'player (inc beat) (next notes) [])
    ))

;;(player (metro) [])
;;(stop)

;; (def dirty-kick (freesound 777))
;; (dirty-kick)
;; (def kick (sample (freesound-path 2086)))
;; (kick)
;; (def close-hihat (sample-player (sample (freesound-path 802))))

(ns overtone-workspace.grumbles
  (:use [overtone.live]))

;; Inspired by an example in an early chapter of the SuperCollider book

(definst grumble [speed 6 freq-mul 1 attack 10 release 50]
  (let [snd (mix (map #(* (lf-tri (* % freq-mul 100))
                          (max 0 (+ (lf-noise1:kr speed)
                                    (env-gen (perc attack release) :action FREE))))
                      [1 (/ 2 3) (/ 3 2) 2]))]
    (pan2 snd (sin-osc:kr 0.125))))

;;(stop)
;; (grumble)
;; (grumble :freq-mul 0.5)
;; (grumble :freq-mul 0.75)
;; (grumble :freq-mul 1)
;; (grumble :freq-mul 1.5)
;; (grumble :freq-mul 2)
;; (ctl grumble :speed 3000)

(volume (/  10  127))

(def metro (metronome 128))

(defn player [beat rates]
  (let [rates (if (empty? rates)
                [4 8 2 2 1.5 1.5]
                rates)
        bpm (metro :bpm)
        dur (/ 60.0 bpm)
        attack (* dur 4) ; 1bar
        rel (* dur (* 4 7))]  ; 7bars
    (at (metro beat)
        (do
          (if (zero? (mod beat 8)) (grumble :freq-mul 0.5 :attack attack :release rel))
          (if (zero? (mod beat 8)) (grumble :freq-mul 1 :attack attack :release rel))
          (if (zero? (mod beat 16))
            (grumble :freq-mul (choose rates) :attack attack :release rel))
          ))
    (apply-by (metro (inc beat)) #'player (inc beat) (next rates) [])
    ))

;;(player (metro) [])
;;(stop)

;; (def dirty-kick (freesound 777))
;; (dirty-kick)
;; (def kick (sample (freesound-path 2086)))
;; (kick)
;; (def close-hihat (sample-player (sample (freesound-path 802))))

Set tone duration to 8 bars

Set tone duration to 8 bars


(ns clj-gatling.core
  (:use [clojure.set :only [rename-keys]])
  (:import (io.gatling.charts.report ReportsGenerator)
           (io.gatling.charts.result.reader FileDataReader)
           (io.gatling.core.config GatlingConfiguration))
  (:require [clojure.core.async :as async :refer [go <! >!]]
            [clojure-csv.core :as csv])
  (:gen-class))

(defn run-request [id]
  ;(println (str "Simulating request for " id))
  (Thread/sleep (rand 1000))
  "OK")

(def test-scenario
  {:requests [{:name "Request1" :fn run-request}
              {:name "Request2" :fn run-request}]})

(defmacro bench [expr]
  `(let [start# (System/currentTimeMillis)
         result# ~expr]
      {:result result# :start start# :end (System/currentTimeMillis) }))

(defn run-scenario [scenario id]
  (assoc
    (rename-keys
      (bench
        (map #(assoc (bench ((:fn %) id)) :name (:name %) :id id) (:requests scenario)))
      {:result :requests})
    :id id))

(defn run-simulation [users]
  (println (str "Run simulation with " users " users"))
  (let [cs (repeatedly users async/chan)
        ps (map vector (iterate inc 0) cs)]
    (doseq [[i c] ps] (go (>! c (run-scenario test-scenario i))))
    (let [result (for [i (range users)]
      (let [[v c] (async/alts!! cs)]
        v))]
      (println result)
      (doseq [c cs] (async/close! c))
      result)))

(defn create-chart [dir]
  (let [conf (scala.collection.mutable.HashMap.)]
    (.put conf "gatling.core.directory.results" dir)
    (GatlingConfiguration/setUp conf)
    (ReportsGenerator/generateFor "out" (FileDataReader. "23"))))

(defn map-request [request]
  (let [start (.toString (:start request))
        end (.toString (:end request))
        execution-start start
        request-end start
        response-start end
        execution-end end]
    ["REQUEST" "Scenario name" (.toString (:id request)) "" (:name request) execution-start request-end response-start execution-end "OK" "\u0020"]))

(defn flatten-one-level [coll]
  (mapcat #(if (sequential? %) % [%]) coll))

(defn map-scenario [scenario]
  (let [start (.toString (:start scenario))
        end (.toString (:end scenario))
        requests (apply concat (map #(vector (map-request %)) (:requests scenario)))]
    (conj requests ["SCENARIO" "Scenario name" (.toString (:id scenario)) start end])))

(defn create-result-lines [result]
  (let [header ["RUN" "20140124213040" "basicexamplesimulation" "\u0020"]
        scenarios (apply concat (map #(vector (map-scenario %)) result))
       result-lines (conj (flatten-one-level scenarios) header)]
    (println result-lines)
    result-lines))

(defn -main [users]
  (let [result (run-simulation (read-string users))
        csv (csv/write-csv (create-result-lines result) :delimiter "\t" :end-of-line "\n")]
    (println csv)
    (spit "results/23/simulation.log" csv)
    (create-chart "results")
    (println "Open results/out/index.html")))

(ns clj-gatling.core
  (:use [clojure.set :only [rename-keys]]
        [clj-time.format :only [formatter unparse-local]])
  (:import (org.joda.time LocalDateTime)
           (io.gatling.charts.report ReportsGenerator)
           (io.gatling.charts.result.reader FileDataReader)
           (io.gatling.core.config GatlingConfiguration))
  (:require [clojure.core.async :as async :refer [go <! >!]]
            [clojure-csv.core :as csv])
  (:gen-class))

(defn run-request [id]
  ;(println (str "Simulating request for " id))
  (Thread/sleep (rand 1000))
  "OK")

(def test-scenario
  {:requests [{:name "Request1" :fn run-request}
              {:name "Request2" :fn run-request}]})

(defmacro bench [expr]
  `(let [start# (System/currentTimeMillis)
         result# ~expr]
      {:result result# :start start# :end (System/currentTimeMillis) }))

(defn run-scenario [scenario id]
  (assoc
    (rename-keys
      (bench
        (map #(assoc (bench ((:fn %) id)) :name (:name %) :id id) (:requests scenario)))
      {:result :requests})
    :id id))

(defn run-simulation [users]
  (println (str "Run simulation with " users " users"))
  (let [cs (repeatedly users async/chan)
        ps (map vector (iterate inc 0) cs)]
    (doseq [[i c] ps] (go (>! c (run-scenario test-scenario i))))
    (let [result (for [i (range users)]
      (let [[v c] (async/alts!! cs)]
        v))]
      (println result)
      (doseq [c cs] (async/close! c))
      result)))

(defn create-chart [dir]
  (let [conf (scala.collection.mutable.HashMap.)]
    (.put conf "gatling.core.directory.results" dir)
    (GatlingConfiguration/setUp conf)
    (ReportsGenerator/generateFor "out" (FileDataReader. "23"))))

(defn map-request [request]
  (let [start (.toString (:start request))
        end (.toString (:end request))
        execution-start start
        request-end start
        response-start end
        execution-end end]
    ["REQUEST" "Scenario name" (.toString (:id request)) "" (:name request) execution-start request-end response-start execution-end "OK" "\u0020"]))

(defn flatten-one-level [coll]
  (mapcat #(if (sequential? %) % [%]) coll))

(defn map-scenario [scenario]
  (let [start (.toString (:start scenario))
        end (.toString (:end scenario))
        requests (apply concat (map #(vector (map-request %)) (:requests scenario)))]
    (conj requests ["SCENARIO" "Scenario name" (.toString (:id scenario)) start end])))

(defn create-result-lines [result]
  (let [timestamp (unparse-local (formatter "yyyyMMddhhmmss") (LocalDateTime.))
        header ["RUN" timestamp "simulation" "\u0020"]
        scenarios (apply concat (map #(vector (map-scenario %)) result))
       result-lines (conj (flatten-one-level scenarios) header)]
    (println result-lines)
    result-lines))

(defn -main [users]
  (let [result (run-simulation (read-string users))
        csv (csv/write-csv (create-result-lines result) :delimiter "\t" :end-of-line "\n")]
    (println csv)
    (spit "results/23/simulation.log" csv)
    (create-chart "results")
    (println "Open results/out/index.html")))

Print out simulation timestamp properly

Print out simulation timestamp properly


(ns clj-gatling.core
  (:import (org.joda.time LocalDateTime))
  (:require [clojure-csv.core :as csv]
            [clj-gatling.chart :as chart]
            [clj-gatling.report :as report]
            [clj-gatling.simulation-util :refer [weighted-scenarios choose-runner timestamp-str]]
            [clj-gatling.simulation :as simulation]))

(def buffer-size 20000)

(defn create-dir [dir]
  (.mkdirs (java.io.File. dir)))

(defn- gatling-csv-writer [path idx result-lines]
  (let [csv (csv/write-csv result-lines :delimiter "\t" :end-of-line "\n")]
   (spit (str path "/simulation" idx ".log") csv)))

(defn run-simulation [scenarios concurrency & [options]]
 (let [start-time (LocalDateTime.)
       results-dir (str (or (:root options) "target/results")
                        "/"
                        (timestamp-str))
       step-timeout (or (:timeout-in-ms options) 5000)
       result (simulation/run-scenarios {:runner (choose-runner scenarios concurrency options)
                                         :timeout step-timeout
                                         :context (:context options)}
                                        (weighted-scenarios (range concurrency) scenarios))]
   (create-dir (str results-dir "/input"))
   (report/create-result-lines start-time
                               buffer-size
                               result
                               (partial gatling-csv-writer (str results-dir "/input")))
   (chart/create-chart results-dir)
   (println (str "Open " results-dir "/index.html"))))

(ns clj-gatling.core
  (:import (org.joda.time LocalDateTime))
  (:require [clojure-csv.core :as csv]
            [clj-gatling.chart :as chart]
            [clj-gatling.report :as report]
            [clj-gatling.simulation-util :refer [weighted-scenarios choose-runner timestamp-str]]
            [clj-gatling.simulation :as simulation]))

(def buffer-size 20000)

(defn create-dir [dir]
  (.mkdirs (java.io.File. dir)))

(defn- gatling-csv-writer [path idx result-lines]
  (let [csv (csv/write-csv result-lines :delimiter "\t" :end-of-line "\n")]
   (spit (str path "/simulation" idx ".log") csv)))

(defn run-simulation [scenarios concurrency & [options]]
  (let [start-time (LocalDateTime.)
        results-dir (str (or (:root options) "target/results")
                         "/"
                         (timestamp-str))
        step-timeout (or (:timeout-in-ms options) 5000)
        result (simulation/run-scenarios {:runner (choose-runner scenarios concurrency options)
                                          :timeout step-timeout
                                          :context (:context options)}
                                         (weighted-scenarios (range concurrency) scenarios))]
    (create-dir (str results-dir "/input"))
    (let [summary (report/create-result-lines start-time
                                              buffer-size
                                              result
                                              (partial gatling-csv-writer (str results-dir "/input")))]
      (chart/create-chart results-dir)
      (println (str "Open " results-dir "/index.html"))
      summary)))

Return summary from run-simulation

Return summary from run-simulation

Summary is following map
{:ok <number-of-successful-requests> :ko <number-of-failed-requests>}