(ns frontend.components.project.common
  (:require [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [frontend.async :refer [raise!]]
            [frontend.components.forms :as forms]
            [frontend.datetime :as time-utils]
            [frontend.models.plan :as plan-model]
            [frontend.models.user :as user-model]
            [frontend.models.project :as project-model]
            [frontend.routes :as routes]
            [frontend.utils :as utils :include-macros true]
            [frontend.utils.vcs-url :as vcs-url]
            [cljs-time.format :as time-format]
            [goog.string :as gstring]
            [goog.string.format]
            [inflections.core :refer (pluralize)]
            [om.core :as om :include-macros true]
            [sablono.core :as html :refer-macros [html]]))

(defn show-trial-notice? [project plan]
  (let [conditions [(not (project-model/oss? project))
                    (plan-model/trial? plan)
                    ;; only bug them if < 20 days left in trial
                    ;; note that this includes expired trials
                    (< (plan-model/days-left-in-trial plan) 20)

                    ;; only show freemium trial notices if the
                    ;; trial is still active.
                    (if (plan-model/freemium? plan)
                      (not (plan-model/trial-over? plan))
                      true)]]
    (utils/mlog (gstring/format "show-trial-notice? has conditions %s days left %d"
                                conditions (plan-model/days-left-in-trial plan)))
    (every? identity conditions)))

(defn non-freemium-trial-html [plan project project-name days org-name plan-path]
  (html
   [:div.alert {:class (when (plan-model/trial-over? plan) "alert-error")}
    (cond (plan-model/trial-over? plan)
          (list (gstring/format "The %s project is covered by %s's plan, whose trial ended %s ago. "
                                project-name org-name (pluralize (Math/abs days) "day"))
                [:a {:href plan-path} "Add a plan to continue running builds of private repositories"]
                ".")

          (> days 10)
          (list (gstring/format "The %s project is covered by %s's trial, enjoy! (or check out "
                                project-name org-name)
                [:a {:href plan-path} "our plans"]
                ").")

          (> days 7)
          (list (gstring/format "The %s project is covered by %s's trial which has %s left. "
                                project-name org-name (pluralize days "day"))
                [:a {:href plan-path} "Check out our plans"]
                ".")

          (> days 4)
          (list (gstring/format "The %s project is covered by %s's trial which has %s left. "
                                project-name org-name (pluralize days "day"))
                [:a {:href plan-path} "Add a plan"]
                " to keep running builds.")

          :else
          (list (gstring/format "The %s project is covered by %s's trial which expires in %s! "
                                project-name org-name (plan-model/pretty-trial-time plan))
                [:a {:href plan-path} "Add a plan"]
                " to keep running builds."))]))

(defn freemium-trial-html [plan project project-name days org-name plan-path]
  (html
   [:div.alert {:class "alert-success"}
    (list (gstring/format "The %s project is covered by %s's trial of %d containers. "
                          project-name org-name (plan-model/usable-containers plan))
          [:a {:href plan-path} "Add more containers"]
          " for parallel builds and reduced build queueing once the trial runs out.")]))

(defn trial-notice [data owner]
  (reify
    om/IRender
    (render [_]
      (let [plan (:plan data)
            project (:project data)
            project-name (gstring/format "%s/%s" (:username project) (:reponame project))
            days (plan-model/days-left-in-trial plan)
            org-name (:org_name plan)
            plan-path (routes/v1-org-settings-subpage {:org org-name :subpage "plan"})
            trial-notice-fn (if (plan-model/freemium? plan)
                              freemium-trial-html
                              non-freemium-trial-html)]
        (trial-notice-fn plan project project-name days org-name plan-path)))))

(defn show-enable-notice [project]
  (not (:has_usable_key project)))

(defn enable-notice [project owner]
  (reify
    om/IRender
    (render [_]
      (let [project-name (vcs-url/project-name (:vcs_url project))
            project-id (project-model/id project)]
        (html
         [:div.row-fluid
          [:div.offset1.span10
           [:div.alert.alert-error
            "Project "
            project-name
            " isn't configured with a deploy key or a github user, so we may not be able to test all pushes."
            (forms/managed-button
             [:button.btn.btn-primary
              {:data-loading-text "Adding...",
               :on-click #(raise! owner [:enabled-project {:project-id project-id
                                                           :project-name project-name}])}
              "Add SSH key"])]]])))))

(defn show-follow-notice [project]
  ;; followed here indicates that the user is following this project, not that the
  ;; project has followers
  (not (:followed project)))

(def email-prefs
  [["default" "Default"]
   ["all" "All builds"]
   ["smart" "My breaks and fixes"]
   ["none" "None"]])

(defn email-pref [{:keys [project user]} owner]
  (reify
    om/IRender
    (render [_]
      (let [{:keys [vcs_url]} project
            prefs (user-model/project-preferences user)
            pref (get-in prefs [vcs_url :emails] "default")
            ch (om/get-shared owner [:comms :controls])]
        (html
          [:div
           [:h3 (project-model/project-name project)]
           [:select {:value pref
                     :on-change #(let [value (.. % -target -value)
                                       args {vcs_url {:emails value}}]
                                   (raise! owner [:project-preferences-updated args]))}
            (for [[pref label] email-prefs]
              [:option {:value pref} label])]])))))

(ns frontend.components.project.common
  (:require [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [frontend.async :refer [raise!]]
            [frontend.components.forms :as forms]
            [frontend.datetime :as time-utils]
            [frontend.models.plan :as plan-model]
            [frontend.models.user :as user-model]
            [frontend.models.project :as project-model]
            [frontend.routes :as routes]
            [frontend.utils :as utils :include-macros true]
            [frontend.utils.vcs-url :as vcs-url]
            [cljs-time.format :as time-format]
            [goog.string :as gstring]
            [goog.string.format]
            [inflections.core :refer (pluralize)]
            [om.core :as om :include-macros true]
            [sablono.core :as html :refer-macros [html]]))

(defn show-trial-notice? [project plan]
  (let [conditions [(not (project-model/oss? project))
                    (plan-model/trial? plan)
                    ;; only bug them if < 20 days left in trial
                    ;; note that this includes expired trials
                    (< (plan-model/days-left-in-trial plan) 20)

                    ;; only show freemium trial notices if the
                    ;; trial is still active.
                    (if (plan-model/freemium? plan)
                      (not (plan-model/trial-over? plan))
                      true)]]
    (utils/mlog (gstring/format "show-trial-notice? has conditions %s days left %d"
                                conditions (plan-model/days-left-in-trial plan)))
    (every? identity conditions)))

(defn non-freemium-trial-html [plan project project-name days org-name plan-path]
  (html
   [:div.alert {:class (when (plan-model/trial-over? plan) "alert-error")}
    (cond (plan-model/trial-over? plan)
          (list (gstring/format "The %s project is covered by %s's plan, whose trial ended %s ago. "
                                project-name org-name (pluralize (Math/abs days) "day"))
                [:a {:href plan-path} "Add a plan to continue running builds of private repositories"]
                ".")

          (> days 10)
          (list (gstring/format "The %s project is covered by %s's trial, enjoy! (or check out "
                                project-name org-name)
                [:a {:href plan-path} "our plans"]
                ").")

          (> days 7)
          (list (gstring/format "The %s project is covered by %s's trial which has %s left. "
                                project-name org-name (pluralize days "day"))
                [:a {:href plan-path} "Check out our plans"]
                ".")

          (> days 4)
          (list (gstring/format "The %s project is covered by %s's trial which has %s left. "
                                project-name org-name (pluralize days "day"))
                [:a {:href plan-path} "Add a plan"]
                " to keep running builds.")

          :else
          (list (gstring/format "The %s project is covered by %s's trial which expires in %s! "
                                project-name org-name (plan-model/pretty-trial-time plan))
                [:a {:href plan-path} "Add a plan"]
                " to keep running builds."))]))

(defn freemium-trial-html [plan project project-name days org-name plan-path]
  (html
   [:div.alert {:class "alert-success"}
    (list (gstring/format "The %s project is covered by %s's trial of %d containers. "
                          project-name org-name (plan-model/usable-containers plan))
          [:a {:href plan-path} "Add more containers"]
          " for parallel builds and reduced build queueing once the trial runs out.")]))

(defn trial-notice [data owner]
  (reify
    om/IRender
    (render [_]
      (let [plan (:plan data)
            project (:project data)
            project-name (gstring/format "%s/%s" (:username project) (:reponame project))
            days (plan-model/days-left-in-trial plan)
            org-name (:org_name plan)
            plan-path (routes/v1-org-settings-subpage {:org org-name :subpage "plan"})
            trial-notice-fn (if (plan-model/freemium? plan)
                              freemium-trial-html
                              non-freemium-trial-html)]
        (trial-notice-fn plan project project-name days org-name plan-path)))))

(defn show-enable-notice [project]
  (not (:has_usable_key project)))

(defn enable-notice [project owner]
  (reify
    om/IRender
    (render [_]
      (let [project-name (vcs-url/project-name (:vcs_url project))
            project-id (project-model/id project)]
        (html
         [:div.row-fluid
          [:div.offset1.span10
           [:div.alert.alert-error
            "Project "
            project-name
            " isn't configured with a deploy key or a github user, so we may not be able to test all pushes."
            (forms/managed-button
             [:button.btn.btn-primary
              {:data-loading-text "Adding...",
               :on-click #(raise! owner [:enabled-project {:project-id project-id
                                                           :project-name project-name}])}
              "Add SSH key"])]]])))))

(def email-prefs
  [["default" "Default"]
   ["all" "All builds"]
   ["smart" "My breaks and fixes"]
   ["none" "None"]])

(defn email-pref [{:keys [project user]} owner]
  (reify
    om/IRender
    (render [_]
      (let [{:keys [vcs_url]} project
            prefs (user-model/project-preferences user)
            pref (get-in prefs [vcs_url :emails] "default")
            ch (om/get-shared owner [:comms :controls])]
        (html
          [:div
           [:h3 (project-model/project-name project)]
           [:select {:value pref
                     :on-change #(let [value (.. % -target -value)
                                       args {vcs_url {:emails value}}]
                                   (raise! owner [:project-preferences-updated args]))}
            (for [[pref label] email-prefs]
              [:option {:value pref} label])]])))))

remove show-follow-notice

remove show-follow-notice


(ns sass-dsl.transform
  (:require [clojure.zip :as zip]
            [clojure.string :refer [join split triml] :as srt]
            [sass-dsl.common :as common]))

(defn has-colon-suffix
  "Does this element end in a colon - ie is it potentially an attribute key?"
  [elem]
  (= \: (last elem)))

(defn drop-colon-suffix
  "Remove the colon suffix from this string."
  [input-string]
  (join (drop-last input-string)))

(defn ins-replacement
  "Insert a replacement."
  [loc reps]
  (if (empty? reps)
    loc
    (recur
     (zip/insert-right loc (first steps))
     (rest reps))))

(defn get-c-s-suffix-replacements
  "Replace the sass suffix for css and prefix it to everuthing in the
  collection."
  [cs coll]
  (let [cs-minux-suffix [drop-colon-suffix cs]]
    (map #(str cs-minus-suffix "-" %) coll)))

add replacements

add replacements


{:user
 {:plugins [[cider/cider-nrepl "0.14.0-SNAPSHOT"]
            [lein-pprint "1.1.1"]
            [refactor-nrepl "2.3.0-SNAPSHOT"]
            [venantius/ultra "0.4.1"]]
  :dependencies [[org.clojure/tools.nrepl "0.2.12"]]}}

{:user
 {:plugins [[cider/cider-nrepl "0.15.0-SNAPSHOT"]
            [lein-pprint "1.1.1"]
            [refactor-nrepl "2.3.0-SNAPSHOT"]
            [venantius/ultra "0.4.1"]]
  :dependencies [[org.clojure/tools.nrepl "0.2.12"]]}}

bump cider-nrepl version

bump cider-nrepl version


(ns onyx.plugin.core-async
  (:require [clojure.core.async :refer [chan >!! <!! alts!! timeout go <! alts! close!]]
            [onyx.peer.function :as function]
            [clojure.set :refer [join]]
            [onyx.peer.pipeline-extensions :as p-ext]
            [onyx.static.default-vals :refer [default-vals]]
            [onyx.static.uuid :as uuid]
            [onyx.types :as t]
            [taoensso.timbre :refer [debug info] :as timbre])
  (:import [clojure.core.async.impl.channels ManyToManyChannel]))

(defn inject-reader
  [event lifecycle]
  (when-not (:core.async/chan event)
    (throw (ex-info ":core.async/chan not found - add it using a :before-task-start lifecycle"
                    {:event-map-keys (keys event)})))

  (let [task (:onyx.core/task-map event)]
    (when (and (not= (:onyx/max-peers task) 1)
               (not (:core.async/allow-unsafe-concurrency? lifecycle)))
      (throw (ex-info ":onyx/max-peers must be set to 1 in the task map for core.async readers" {:task-map task}))))

  (let [pipeline (:onyx.core/pipeline event)]
    {:core.async/pending-messages (:pending-messages pipeline)
     :core.async/drained (:drained pipeline)
     :core.async/retry-ch (:retry-ch pipeline)
     :core.async/retry-count (:retry-count pipeline)}))

(defn log-retry-count
  [event lifecycle]
  (info "core.async input plugin stopping. Retry count:" @(:core.async/retry-count event))
  {})

(defn inject-writer
  [event lifecycle]
  (when-not (:core.async/chan event)
    (throw (ex-info ":core.async/chan not found - add it using a :before-task-start lifecycle"
                    {:event-map-keys (keys event)})))

  (let [task (:onyx.core/task-map event)]
    (when (and (not= (:onyx/max-peers task) 1)
               (not (:core.async/allow-unsafe-concurrency? lifecycle)))
      (throw (ex-info ":onyx/max-peers must be set to 1 in the task map for core.async writers" {:task-map task}))))

  {})

(def reader-calls
  {:lifecycle/before-task-start inject-reader
   :lifecycle/after-task-stop log-retry-count})

(def writer-calls
  {:lifecycle/before-task-start inject-writer})

(defrecord CoreAsyncInput [max-pending batch-size batch-timeout pending-messages
                           drained retry-ch retry-count]
  p-ext/Pipeline
  (write-batch
    [this event]
    (function/write-batch event))

  (read-batch [_ {:keys [core.async/chan] :as event}]
    (let [pending (count @pending-messages)
          max-segments (min (- max-pending pending) batch-size)
          ;; We reuse a single timeout channel. This allows us to
          ;; continually block against one thread that is continually
          ;; expiring. This property lets us take variable amounts of
          ;; time when reading each segment and still allows us to return
          ;; within the predefined batch timeout limit.
          timeout-ch (timeout batch-timeout)
          batch (if (pos? max-segments)
                  (loop [segments [] cnt 0]
                    (if (= cnt max-segments)
                      segments
                      (if-let [message (first (alts!! [retry-ch chan timeout-ch] :priority true))]
                        (recur (conj segments
                                     (t/input (uuid/random-uuid) message))
                               (inc cnt))
                        segments)))
                  (<!! timeout-ch))]
      (doseq [m batch]
        (swap! pending-messages assoc (:id m) (:message m)))
      (when (and (= 1 (count @pending-messages))
                 (= (count batch) 1)
                 (= (:message (first batch)) :done)
                 (zero? (count (.buf ^ManyToManyChannel retry-ch))))
        (reset! drained true))
      {:onyx.core/batch batch}))

  p-ext/PipelineInput

  (ack-segment [_ _ message-id]
    (swap! pending-messages dissoc message-id))

  (retry-segment
    [_ _ message-id]
    (when-let [msg (get @pending-messages message-id)]
      (when-not (= msg :done)
        (swap! retry-count inc))
      (>!! retry-ch msg)
      (swap! pending-messages dissoc message-id)))

  (pending?
    [_ _ message-id]
    (get @pending-messages message-id))

  (drained?
    [_ _]
    @drained))

(defn input [pipeline-data]
  (let [catalog-entry (:onyx.core/task-map pipeline-data)
        max-pending (or (:onyx/max-pending catalog-entry) (:onyx/max-pending default-vals))
        batch-size (:onyx/batch-size catalog-entry)
        batch-timeout (or (:onyx/batch-timeout catalog-entry) (:onyx/batch-timeout default-vals))]
    (->CoreAsyncInput max-pending batch-size batch-timeout
                      (atom {}) (atom false) (chan 10000) (atom 0))))

(defrecord CoreAsyncOutput []
  p-ext/Pipeline
  (read-batch
    [_ event]
    (function/read-batch event))

  (write-batch
    [_ {:keys [onyx.core/results core.async/chan] :as event}]
    (doseq [msg (mapcat :leaves (:tree results))]
      (>!! chan (:message msg)))
    {})

  (seal-resource
    [_ {:keys [core.async/chan]}]
    (>!! chan :done)))

(defn output [pipeline-data]
  (->CoreAsyncOutput))

(defn take-segments!
  "Takes segments off the channel until :done is found.
   Returns a seq of segments, including :done."
  ([ch] (take-segments! ch nil))
  ([ch timeout-ms]
   (when-let [tmt (if timeout-ms
                    (timeout timeout-ms)
                    (chan))]
     (loop [ret []]
       (let [[v c] (alts!! [ch tmt] :priority true)]
         (if (= c tmt)
           ret
           (if (and v (not= v :done))
             (recur (conj ret v))
             (conj ret :done))))))))

(def channels (atom {}))

(def default-channel-size 1000)

(defn get-channel
  ([id] (get-channel id default-channel-size))
  ([id size]
   (if-let [id (get @channels id)]
     id
     (do (swap! channels assoc id (chan size))
         (get-channel id)))))

(defn inject-in-ch
  [_ lifecycle]
  {:core.async/chan (get-channel (:core.async/id lifecycle))})
(defn inject-out-ch
  [_ lifecycle]
  {:core.async/chan (get-channel (:core.async/id lifecycle))})

(def in-calls
  {:lifecycle/before-task-start inject-in-ch})

(def out-calls
  {:lifecycle/before-task-start inject-out-ch})

(defn get-core-async-channels
  [{:keys [catalog lifecycles]}]
  (let [lifecycle-catalog-join (join catalog lifecycles {:onyx/name :lifecycle/task})]
    (reduce (fn [acc item]
              (assoc acc
                     (:onyx/name item)
                     (get-channel (:core.async/id item)))) {} (filter :core.async/id lifecycle-catalog-join))))

(ns onyx.plugin.core-async
  (:require [clojure.core.async :refer [chan >!! <!! alts!! timeout go <! alts! close! offer!]]
            [onyx.peer.function :as function]
            [clojure.set :refer [join]]
            [onyx.peer.pipeline-extensions :as p-ext]
            [onyx.static.default-vals :refer [default-vals]]
            [onyx.static.uuid :as uuid]
            [onyx.types :as t]
            [taoensso.timbre :refer [debug info] :as timbre])
  (:import [clojure.core.async.impl.channels ManyToManyChannel]))

(defn inject-reader
  [event lifecycle]
  (when-not (:core.async/chan event)
    (throw (ex-info ":core.async/chan not found - add it using a :before-task-start lifecycle"
                    {:event-map-keys (keys event)})))

  (let [task (:onyx.core/task-map event)]
    (when (and (not= (:onyx/max-peers task) 1)
               (not (:core.async/allow-unsafe-concurrency? lifecycle)))
      (throw (ex-info ":onyx/max-peers must be set to 1 in the task map for core.async readers" {:task-map task}))))

  (let [pipeline (:onyx.core/pipeline event)]
    {:core.async/pending-messages (:pending-messages pipeline)
     :core.async/drained (:drained pipeline)
     :core.async/retry-ch (:retry-ch pipeline)
     :core.async/retry-count (:retry-count pipeline)}))

(defn log-retry-count
  [event lifecycle]
  (info "core.async input plugin stopping. Retry count:" @(:core.async/retry-count event))
  {})

(defn inject-writer
  [event lifecycle]
  (when-not (:core.async/chan event)
    (throw (ex-info ":core.async/chan not found - add it using a :before-task-start lifecycle"
                    {:event-map-keys (keys event)})))

  (let [task (:onyx.core/task-map event)]
    (when (and (not= (:onyx/max-peers task) 1)
               (not (:core.async/allow-unsafe-concurrency? lifecycle)))
      (throw (ex-info ":onyx/max-peers must be set to 1 in the task map for core.async writers" {:task-map task}))))

  {})

(def reader-calls
  {:lifecycle/before-task-start inject-reader
   :lifecycle/after-task-stop log-retry-count})

(def writer-calls
  {:lifecycle/before-task-start inject-writer})

(defrecord CoreAsyncInput [max-pending batch-size batch-timeout pending-messages
                           drained retry-ch retry-count]
  p-ext/Pipeline
  (write-batch
    [this event]
    (function/write-batch event))

  (read-batch [_ {:keys [core.async/chan] :as event}]
    (let [pending (count @pending-messages)
          max-segments (min (- max-pending pending) batch-size)
          ;; We reuse a single timeout channel. This allows us to
          ;; continually block against one thread that is continually
          ;; expiring. This property lets us take variable amounts of
          ;; time when reading each segment and still allows us to return
          ;; within the predefined batch timeout limit.
          timeout-ch (timeout batch-timeout)
          batch (if (pos? max-segments)
                  (loop [segments [] cnt 0]
                    (if (= cnt max-segments)
                      segments
                      (if-let [message (first (alts!! [retry-ch chan timeout-ch] :priority true))]
                        (recur (conj segments
                                     (t/input (uuid/random-uuid) message))
                               (inc cnt))
                        segments)))
                  (<!! timeout-ch))]
      (doseq [m batch]
        (swap! pending-messages assoc (:id m) (:message m)))
      (when (and (= 1 (count @pending-messages))
                 (= (count batch) 1)
                 (= (:message (first batch)) :done)
                 (zero? (count (.buf ^ManyToManyChannel retry-ch))))
        (reset! drained true))
      {:onyx.core/batch batch}))

  p-ext/PipelineInput

  (ack-segment [_ _ message-id]
    (swap! pending-messages dissoc message-id))

  (retry-segment
    [_ _ message-id]
    (when-let [msg (get @pending-messages message-id)]
      (when-not (= msg :done)
        (swap! retry-count inc))
      (>!! retry-ch msg)
      (swap! pending-messages dissoc message-id)))

  (pending?
    [_ _ message-id]
    (get @pending-messages message-id))

  (drained?
    [_ _]
    @drained))

(defn input [pipeline-data]
  (let [catalog-entry (:onyx.core/task-map pipeline-data)
        max-pending (or (:onyx/max-pending catalog-entry) (:onyx/max-pending default-vals))
        batch-size (:onyx/batch-size catalog-entry)
        batch-timeout (or (:onyx/batch-timeout catalog-entry) (:onyx/batch-timeout default-vals))]
    (->CoreAsyncInput max-pending batch-size batch-timeout
                      (atom {}) (atom false) (chan 10000) (atom 0))))

(defrecord CoreAsyncOutput []
  p-ext/Pipeline
  (read-batch
    [_ event]
    (function/read-batch event))

  (write-batch
    [_ {:keys [onyx.core/results core.async/chan] :as event}]
    (doseq [msg (mapcat :leaves (:tree results))]
      (info "core.async: writing message to channel" (:message msg))
        (while (and (not (offer! chan (:message msg)))
                    (not (first (alts!! [(:task-kill-ch event) (:kill-ch event)] :default true))))
          (info "Blocked offering message to full output channel.")
          (Thread/sleep 500)))
    {})

  (seal-resource
    [_ {:keys [core.async/chan]}]
    (>!! chan :done)))

(defn output [pipeline-data]
  (->CoreAsyncOutput))

(defn take-segments!
  "Takes segments off the channel until :done is found.
   Returns a seq of segments, including :done."
  ([ch] (take-segments! ch nil))
  ([ch timeout-ms]
   (when-let [tmt (if timeout-ms
                    (timeout timeout-ms)
                    (chan))]
     (loop [ret []]
       (let [[v c] (alts!! [ch tmt] :priority true)]
         (if (= c tmt)
           ret
           (if (and v (not= v :done))
             (recur (conj ret v))
             (conj ret :done))))))))

(def channels (atom {}))

(def default-channel-size 1000)

(defn get-channel
  ([id] (get-channel id default-channel-size))
  ([id size]
   (if-let [id (get @channels id)]
     id
     (do (swap! channels assoc id (chan size))
         (get-channel id)))))

(defn inject-in-ch
  [_ lifecycle]
  {:core.async/chan (get-channel (:core.async/id lifecycle)
                                 (or (:core.async/size lifecycle)
                                     default-channel-size))})

(defn inject-out-ch
  [_ lifecycle]
  {:core.async/chan (get-channel (:core.async/id lifecycle)
                                 (or (:core.async/size lifecycle)
                                     default-channel-size))})

(def in-calls
  {:lifecycle/before-task-start inject-in-ch})

(def out-calls
  {:lifecycle/before-task-start inject-out-ch})

(defn get-core-async-channels
  [{:keys [catalog lifecycles]}]
  (let [lifecycle-catalog-join (join catalog lifecycles {:onyx/name :lifecycle/task})]
    (reduce (fn [acc item]
              (assoc acc
                     (:onyx/name item)
                     (get-channel (:core.async/id item)))) {} (filter :core.async/id lifecycle-catalog-join))))

Use offer instead of blocking put in core async plugin Fix bug where injected channel size was not big enough


(ns braid.core.server.db.thread
  (:require
   [braid.core.server.db :as db]
   [braid.core.server.db.common :refer :all]
   [braid.core.server.db.tag :as tag]
   [braid.core.server.db.group]
   [clj-time.coerce :refer [to-date-time to-long]]
   [clj-time.core :as t]
   [clojure.set :refer [difference]]
   [datomic.api :as d]))

;; Queries

(declare thread-add-last-open-at)

(defn thread-group-id
  [thread-id]
  (some-> (d/pull (db/db) [{:thread/group [:group/id]}]
                  [:thread/id thread-id])
          :thread/group :group/id))

(defn thread-by-id
  [thread-id]
  (some-> (d/pull (db/db) thread-pull-pattern [:thread/id thread-id])
          db->thread))

(defn threads-by-id
  [thread-ids]
  (->> thread-ids
       (map (fn [id] [:thread/id id]))
       (d/pull-many (db/db) thread-pull-pattern)
       (map db->thread)))

(defn thread-last-open-at
  [thread user-id]
  (let [user-hides-at (->> (d/q
                             '[:find [?inst ...]
                               :in $ ?thread-id ?user-id
                               :where
                               [?u :user/id ?user-id]
                               [?t :thread/id ?thread-id]
                               [?u :user/open-thread ?t ?tx false]
                               [?tx :db/txInstant ?inst]]
                             (d/history (db/db))
                             (thread :id)
                             user-id)
                           (map (fn [t] (.getTime t))))
        user-messages-at (->> (thread :messages)
                              (filter (fn [m] (= (m :user-id) user-id)))
                              (map :created-at)
                              (map (fn [t] (.getTime t))))]
    (apply max (concat [0] user-hides-at user-messages-at))))

(defn users-subscribed-to-thread
  [thread-id]
  (d/q '[:find [?user-id ...]
         :in $ ?thread-id
         :where
         [?user :user/id ?user-id]
         [?user :user/subscribed-thread ?thread]
         [?thread :thread/id ?thread-id]]
       (db/db)
       thread-id))

(defn users-with-thread-open
  [thread-id]
  (d/q '[:find [?user-id ...]
         :in $ ?thread-id
         :where
         [?user :user/id ?user-id]
         [?user :user/open-thread ?thread]
         [?thread :thread/id ?thread-id]]
       (db/db)
       thread-id))

(defn user-can-see-thread?
  [user-id thread-id]
  (or
    ;; user can see the thread if it's a new (i.e. not yet in the
    ;; database) thread...
    (nil? (d/entity (db/db) [:thread/id thread-id]))
    ;; ...or they're already subscribed to the thread...
    (contains? (set (users-subscribed-to-thread thread-id)) user-id)
    ;; ...or they're mentioned in the thread
    ;; TODO: is it possible for them to be mentioned but not subscribed?
    (contains? (-> (d/pull (db/db) [:thread/mentioned] [:thread/id thread-id])
                   :thread/mentioned set)
               user-id)
    ;; ...or they are in the group of any tags on the thread
    (seq (d/q '[:find (pull ?group [:group/id])
                :in $ ?thread-id ?user-id
                :where
                [?thread :thread/id ?thread-id]
                [?thread :thread/tag ?tag]
                [?tag :tag/group ?group]
                [?group :group/user ?user]
                [?user :user/id ?user-id]]
              (db/db) thread-id user-id))
    ;; ...or they're in the group & already have a message in the thread
    ;; this is quite the edge case -- can happen if a user creates a
    ;; thread, tags it, leaves the group, then re-joins it & deletes
    ;; the tag
    (-> (d/q '[:find ?m
               :in $ ?user-id ?thread-id
               :where
               [?u :user/id ?user-id]
               [?t :thread/id ?thread-id]
               [?t :thread/group ?g]
               [?g :group/user ?u]
               [?m :message/thread ?t]
               [?m :message/user ?u]]
             (db/db) user-id thread-id)
        seq boolean)))

(defn thread-has-tags?
  [thread-id]
  (seq (d/q '[:find ?tag
              :in $ ?thread-id
              :where
              [?thread :thread/id ?thread-id]
              [?thread :thread/tag ?tag]]
            (db/db) thread-id)))

(defn open-threads-for-user
  [user-id]
  (let [visible-tags (tag/tag-ids-for-user user-id)]
    (->> (d/q '[:find (pull ?thread pull-pattern)
                :in $ ?user-id pull-pattern
                :where
                [?e :user/id ?user-id]
                [?e :user/open-thread ?thread]]
              (db/db)
              user-id
              thread-pull-pattern)
         (into ()
               (map (comp
                      #(update-in % [:tag-ids]
                                  (partial into #{} (filter visible-tags)))
                      #(thread-add-last-open-at % user-id)
                      db->thread
                      first))))))

(defn recent-threads
  [{:keys [user-id group-id num-threads] :or {num-threads 10}}]
  (->> (d/q '[:find (pull ?thread pull-pattern)
              :in $ ?group-id ?cutoff pull-pattern
              :where
              [?g :group/id ?group-id]
              [?thread :thread/group ?g]
              [?msg :message/thread ?thread]
              [?msg :message/created-at ?time]
              [(clj-time.coerce/to-date-time ?time) ?dtime]
              [(clj-time.core/after? ?dtime ?cutoff)]]
            (db/db)
            group-id
            (t/minus (t/now) (t/weeks 1))
            thread-pull-pattern)
       (into ()
             (comp (map (comp db->thread first))
                   (filter (comp (partial user-can-see-thread? user-id) :id))
                   (map #(thread-add-last-open-at % user-id))))
       (sort-by (fn [t] (apply max (map (comp to-long :created-at) (t :messages))))
                #(compare %2 %1))
       (take num-threads)))

(defn public-threads
  [group-id]
  (->> (d/q '[:find (pull ?thread pull-pattern)
              :in $ ?group-id ?cutoff pull-pattern
              :where
              [?g :group/id ?group-id]
              [?thread :thread/group ?g]
              ;; any thread with at least one tag
              [?thread :thread/tag ?tag]
              [?tag :tag/group ?g]
              [?msg :message/thread ?thread]
              [?msg :message/created-at ?time]
              [(clj-time.coerce/to-date-time ?time) ?dtime]
              [(clj-time.core/after? ?dtime ?cutoff)]]
            (db/db) group-id (t/minus (t/now) (t/weeks 1))
            thread-pull-pattern)
      (map (comp db->thread first))
      (sort-by (fn [t] (apply max (map (comp to-long :created-at) (t :messages))))
               #(compare %2 %1))))

(defn subscribed-thread-ids-for-user
  [user-id]
  (d/q '[:find [?thread-id ...]
         :in $ ?user-id
         :where
         [?user :user/id ?user-id]
         [?user :user/subscribed-thread ?thread]
         [?thread :thread/id ?thread-id]]
       (db/db)
       user-id))

(defn thread-newest-message
  [thread-id]
  (d/q '[:find (max ?time) .
         :in $ ?t-id
         :where
         [?t :thread/id ?t-id]
         [?m :message/thread ?t]
         [?m :message/created-at ?time]]
       (db/db) thread-id))

;; Transactions

(defn user-hide-thread-txn
  [user-id thread-id]
  [[:db/retract [:user/id user-id] :user/open-thread [:thread/id thread-id]]])

(defn user-show-thread-txn
  [user-id thread-id]
  [[:db/add [:user/id user-id] :user/open-thread [:thread/id thread-id]]])

(defn update-thread-last-open!
  "Bump the tx time of the user opening the thread.  Needs to explicitly be two
  separate transactions, since redundant datoms are eliminated, meaning we
  can't have a transaction that just changes the tx"
  [thread-id user-id]
  (when (seq (d/q '[:find ?t
                    :in $ ?user-id ?thread-id
                    :where
                    [?u :user/id ?user-id]
                    [?t :thread/id ?thread-id]
                    [?u :user/open-thread ?t]]
                  (db/db) user-id thread-id))
    (db/run-txns! (user-hide-thread-txn user-id thread-id))
    (db/run-txns! (user-show-thread-txn user-id thread-id))))

(defn user-unsubscribe-from-thread-txn
  [user-id thread-id]
  [[:db/retract [:user/id user-id] :user/subscribed-thread [:thread/id thread-id]]
   [:db/retract [:user/id user-id] :user/open-thread [:thread/id thread-id]]])

(defn tag-thread-txn
  [group-id thread-id tag-id]
  (concat
    ; upsert-thread
    (if-not (d/entity (db/db) [:thread/id thread-id])
      [{:db/id (d/tempid :entities)
        :thread/id thread-id
        :thread/group [:group/id group-id]}]
      [])
    ; add tag to thread
    [[:db/add [:thread/id thread-id]
      :thread/tag [:tag/id tag-id]]]
    ; open and subscribe thread for users subscribed to tag
    ; ...unless they're already subscribed, which means they've seen it
    (mapcat
      (fn [user-id]
        [[:db/add [:user/id user-id]
          :user/subscribed-thread [:thread/id thread-id]]
         [:db/add [:user/id user-id]
          :user/open-thread [:thread/id thread-id]]])
      (difference (set (tag/users-subscribed-to-tag tag-id))
                  (set (users-subscribed-to-thread thread-id))))))

;; Misc

(defn thread-add-last-open-at
  [thread user-id]
  (assoc thread :last-open-at (thread-last-open-at thread user-id)))

(ns braid.core.server.db.thread
  (:require
   [braid.core.server.db :as db]
   [braid.core.server.db.common :refer :all]
   [braid.core.server.db.tag :as tag]
   [clj-time.coerce :refer [to-date-time to-long]]
   [clj-time.core :as t]
   [clojure.set :refer [difference]]
   [datomic.api :as d]))

;; Queries

(declare thread-add-last-open-at)

(defn thread-group-id
  [thread-id]
  (some-> (d/pull (db/db) [{:thread/group [:group/id]}]
                  [:thread/id thread-id])
          :thread/group :group/id))

(defn thread-by-id
  [thread-id]
  (some-> (d/pull (db/db) thread-pull-pattern [:thread/id thread-id])
          db->thread))

(defn threads-by-id
  [thread-ids]
  (->> thread-ids
       (map (fn [id] [:thread/id id]))
       (d/pull-many (db/db) thread-pull-pattern)
       (map db->thread)))

(defn thread-last-open-at
  [thread user-id]
  (let [user-hides-at (->> (d/q
                             '[:find [?inst ...]
                               :in $ ?thread-id ?user-id
                               :where
                               [?u :user/id ?user-id]
                               [?t :thread/id ?thread-id]
                               [?u :user/open-thread ?t ?tx false]
                               [?tx :db/txInstant ?inst]]
                             (d/history (db/db))
                             (thread :id)
                             user-id)
                           (map (fn [t] (.getTime t))))
        user-messages-at (->> (thread :messages)
                              (filter (fn [m] (= (m :user-id) user-id)))
                              (map :created-at)
                              (map (fn [t] (.getTime t))))]
    (apply max (concat [0] user-hides-at user-messages-at))))

(defn users-subscribed-to-thread
  [thread-id]
  (d/q '[:find [?user-id ...]
         :in $ ?thread-id
         :where
         [?user :user/id ?user-id]
         [?user :user/subscribed-thread ?thread]
         [?thread :thread/id ?thread-id]]
       (db/db)
       thread-id))

(defn users-with-thread-open
  [thread-id]
  (d/q '[:find [?user-id ...]
         :in $ ?thread-id
         :where
         [?user :user/id ?user-id]
         [?user :user/open-thread ?thread]
         [?thread :thread/id ?thread-id]]
       (db/db)
       thread-id))

(defn user-can-see-thread?
  [user-id thread-id]
  (or
    ;; user can see the thread if it's a new (i.e. not yet in the
    ;; database) thread...
    (nil? (d/entity (db/db) [:thread/id thread-id]))
    ;; ...or they're already subscribed to the thread...
    (contains? (set (users-subscribed-to-thread thread-id)) user-id)
    ;; ...or they're mentioned in the thread
    ;; TODO: is it possible for them to be mentioned but not subscribed?
    (contains? (-> (d/pull (db/db) [:thread/mentioned] [:thread/id thread-id])
                   :thread/mentioned set)
               user-id)
    ;; ...or they are in the group of any tags on the thread
    (seq (d/q '[:find (pull ?group [:group/id])
                :in $ ?thread-id ?user-id
                :where
                [?thread :thread/id ?thread-id]
                [?thread :thread/tag ?tag]
                [?tag :tag/group ?group]
                [?group :group/user ?user]
                [?user :user/id ?user-id]]
              (db/db) thread-id user-id))
    ;; ...or they're in the group & already have a message in the thread
    ;; this is quite the edge case -- can happen if a user creates a
    ;; thread, tags it, leaves the group, then re-joins it & deletes
    ;; the tag
    (-> (d/q '[:find ?m
               :in $ ?user-id ?thread-id
               :where
               [?u :user/id ?user-id]
               [?t :thread/id ?thread-id]
               [?t :thread/group ?g]
               [?g :group/user ?u]
               [?m :message/thread ?t]
               [?m :message/user ?u]]
             (db/db) user-id thread-id)
        seq boolean)))

(defn thread-has-tags?
  [thread-id]
  (seq (d/q '[:find ?tag
              :in $ ?thread-id
              :where
              [?thread :thread/id ?thread-id]
              [?thread :thread/tag ?tag]]
            (db/db) thread-id)))

(defn open-threads-for-user
  [user-id]
  (let [visible-tags (tag/tag-ids-for-user user-id)]
    (->> (d/q '[:find (pull ?thread pull-pattern)
                :in $ ?user-id pull-pattern
                :where
                [?e :user/id ?user-id]
                [?e :user/open-thread ?thread]]
              (db/db)
              user-id
              thread-pull-pattern)
         (into ()
               (map (comp
                      #(update-in % [:tag-ids]
                                  (partial into #{} (filter visible-tags)))
                      #(thread-add-last-open-at % user-id)
                      db->thread
                      first))))))

(defn recent-threads
  [{:keys [user-id group-id num-threads] :or {num-threads 10}}]
  (->> (d/q '[:find (pull ?thread pull-pattern)
              :in $ ?group-id ?cutoff pull-pattern
              :where
              [?g :group/id ?group-id]
              [?thread :thread/group ?g]
              [?msg :message/thread ?thread]
              [?msg :message/created-at ?time]
              [(clj-time.coerce/to-date-time ?time) ?dtime]
              [(clj-time.core/after? ?dtime ?cutoff)]]
            (db/db)
            group-id
            (t/minus (t/now) (t/weeks 1))
            thread-pull-pattern)
       (into ()
             (comp (map (comp db->thread first))
                   (filter (comp (partial user-can-see-thread? user-id) :id))
                   (map #(thread-add-last-open-at % user-id))))
       (sort-by (fn [t] (apply max (map (comp to-long :created-at) (t :messages))))
                #(compare %2 %1))
       (take num-threads)))

(defn public-threads
  [group-id]
  (->> (d/q '[:find (pull ?thread pull-pattern)
              :in $ ?group-id ?cutoff pull-pattern
              :where
              [?g :group/id ?group-id]
              [?thread :thread/group ?g]
              ;; any thread with at least one tag
              [?thread :thread/tag ?tag]
              [?tag :tag/group ?g]
              [?msg :message/thread ?thread]
              [?msg :message/created-at ?time]
              [(clj-time.coerce/to-date-time ?time) ?dtime]
              [(clj-time.core/after? ?dtime ?cutoff)]]
            (db/db) group-id (t/minus (t/now) (t/weeks 1))
            thread-pull-pattern)
      (map (comp db->thread first))
      (sort-by (fn [t] (apply max (map (comp to-long :created-at) (t :messages))))
               #(compare %2 %1))))

(defn subscribed-thread-ids-for-user
  [user-id]
  (d/q '[:find [?thread-id ...]
         :in $ ?user-id
         :where
         [?user :user/id ?user-id]
         [?user :user/subscribed-thread ?thread]
         [?thread :thread/id ?thread-id]]
       (db/db)
       user-id))

(defn thread-newest-message
  [thread-id]
  (d/q '[:find (max ?time) .
         :in $ ?t-id
         :where
         [?t :thread/id ?t-id]
         [?m :message/thread ?t]
         [?m :message/created-at ?time]]
       (db/db) thread-id))

;; Transactions

(defn user-hide-thread-txn
  [user-id thread-id]
  [[:db/retract [:user/id user-id] :user/open-thread [:thread/id thread-id]]])

(defn user-show-thread-txn
  [user-id thread-id]
  [[:db/add [:user/id user-id] :user/open-thread [:thread/id thread-id]]])

(defn update-thread-last-open!
  "Bump the tx time of the user opening the thread.  Needs to explicitly be two
  separate transactions, since redundant datoms are eliminated, meaning we
  can't have a transaction that just changes the tx"
  [thread-id user-id]
  (when (seq (d/q '[:find ?t
                    :in $ ?user-id ?thread-id
                    :where
                    [?u :user/id ?user-id]
                    [?t :thread/id ?thread-id]
                    [?u :user/open-thread ?t]]
                  (db/db) user-id thread-id))
    (db/run-txns! (user-hide-thread-txn user-id thread-id))
    (db/run-txns! (user-show-thread-txn user-id thread-id))))

(defn user-unsubscribe-from-thread-txn
  [user-id thread-id]
  [[:db/retract [:user/id user-id] :user/subscribed-thread [:thread/id thread-id]]
   [:db/retract [:user/id user-id] :user/open-thread [:thread/id thread-id]]])

(defn tag-thread-txn
  [group-id thread-id tag-id]
  (concat
    ; upsert-thread
    (if-not (d/entity (db/db) [:thread/id thread-id])
      [{:db/id (d/tempid :entities)
        :thread/id thread-id
        :thread/group [:group/id group-id]}]
      [])
    ; add tag to thread
    [[:db/add [:thread/id thread-id]
      :thread/tag [:tag/id tag-id]]]
    ; open and subscribe thread for users subscribed to tag
    ; ...unless they're already subscribed, which means they've seen it
    (mapcat
      (fn [user-id]
        [[:db/add [:user/id user-id]
          :user/subscribed-thread [:thread/id thread-id]]
         [:db/add [:user/id user-id]
          :user/open-thread [:thread/id thread-id]]])
      (difference (set (tag/users-subscribed-to-tag tag-id))
                  (set (users-subscribed-to-thread thread-id))))))

;; Misc

(defn thread-add-last-open-at
  [thread user-id]
  (assoc thread :last-open-at (thread-last-open-at thread user-id)))

Remove accidental require causing circular dep


(ns koeeoadi.themebuilder
  (:require [koeeoadi.reconciler :refer [reconciler]]
            [koeeoadi.util :refer [dark?]]
            [cljs.reader :as reader]))

;;; General
(defn sub-color [{:keys [:face/color-bg :face/color-fg] :as face}]
  (let [rec @reconciler]
    (assoc face
      :face/color-bg (:color/hex (get-in rec color-bg))
      :face/color-fg (:color/hex (get-in rec color-fg)))))

(defn sub-colors [faces]
  (map sub-color faces))

(defn filter-by-editor [editor user-faces]
  (filter #(= editor (:face/editor %)) user-faces))

(defn inject-bg-color-ident [faces-by-name]
  "Injects the bg color ident from the background face into the
  default face/colo-rbg property"
  (let [bg-color-ident (get-in faces-by-name ["background" :face/color-bg])]
    (assoc-in faces-by-name ["default" :face/color-bg] bg-color-ident)))

(defmulti build-theme
  "Build the current theme file for a given editor"
  (fn [editor] editor))

;;; EMACS

(defn face-to-emacs [face-name]
  (cond (= face-name "default")
        "default"
        :else
        (str "font-lock-" face-name "-face")))

(defn emacs-theme [face-specs]
  (let [rec           @reconciler
        name           (:theme/name rec)
        name-sym       (reader/read-string name)
        name-sym-quote (reader/read-string (str "'" name))
        doc      "A theme created with Koeeoadi"]
    `(~'progn
      (~'deftheme ~name-sym ~doc)
      (~'put ~name-sym-quote (~'quote ~'theme-immediate) ~'t)
      (~'custom-theme-set-faces ~name-sym-quote ~@face-specs)
      (~'provide-theme ~name-sym-quote))))

(defn font-lock-faceify [[face-name props :as pair]]
  (let [face-name' (str "font-lock-" face-name "-face")]
    (if (= face-name "default")
      pair
      (vector face-name' (assoc props :face/name face-name')))))

(defn xform-prop-emacs [[k v]]
  (when v
    (let [rec @reconciler]
      (case (name k)
        "color-fg"  `(:foreground ~(:color/hex (get-in rec v)))
        "color-bg"  `(:background ~(:color/hex (get-in rec v)))
        "bold"      `(:weight     ~'bold)
        "italic"    `(:italic     ~'t)
        "underline" `(:underline  ~'t)
        nil))))

(defn xform-face-emacs [{:keys [face/name] :as face}]
  ;; TODO could use transducers here to optimize
  (let [plist (filter identity (map xform-prop-emacs face))]
    (reader/read-string (str "'" (pr-str `(~(reader/read-string name) ((~'t ~(flatten plist)))))))))

(defn xform-faces-emacs [default-faces-map user-faces-map]
  (let [default-faces-map' (into {} (map font-lock-faceify default-faces-map))
        bg-color           (get-in default-faces-map ["background" :face/color-bg])]
    (map xform-face-emacs (-> default-faces-map'
                            ;; remove background face
                            (dissoc "background")
                            ;; inject original bg color into default face (emacs sets its background through the default face)
                            (assoc-in ["default" :face/color-bg] bg-color)
                            ;; to list
                            vals
                            ;; combine with the user defined emacs faces
                            (concat (filter #(= :emacs (:face/editor %)) (vals user-faces-map)))))))

(defmethod build-theme :emacs
  [_]
  (let [{current-theme      :theme/name
         faces-by-name      :faces/by-name
         user-faces-by-name :user-faces/by-name} @reconciler
        face-specs   (xform-faces-emacs faces-by-name user-faces-by-name)]
    (emacs-theme face-specs)))

;;; VIM
(defn vim-set-bg [hex]
  (str "set background=" (if (dark? hex) "dark" "light")))

(def vim-highlight-init
  ["if version > 580"
   "  hi clear"
   "  if exists(\"syntax_on\")"
   "    syntax reset"
   "  endif"
   "endif"
   ""])

(def vim-face-map
  {"Comment"     "comment-delimiter"
   "Conditional" "keyword"
   "Constant"    "constant"
   "Define"      "preprocessor"
   "Exception"   "keyword"
   "Function"    "function-name"
   "Identifier"  "variable-name"
   "Include"     "preprocessor"
   "Keyword"     "keyword"
   "Label"       "keyword"
   "Macro"       "preprocessor"
   "Normal"      "default"
   "PreCondit"   "preprocessor"
   "PreProc"     "preprocessor"
   "Repeat"      "keyword"
   "String"      "string"
   "Type"        "type"})

(defn vim-position-normal [face-names]
  "Moves the Normal syntax name to the beginning.  Needed for VIM
   to set colors properly"
  (sort-by #(not= "Normal" %) face-names))

(defn vim-build-style [style-type prop-separator styles]
  (let [styles' (filter identity styles)]
    (if (empty? styles')
      ""
      (str style-type prop-separator (clojure.string/join "," styles')))))

(defn vim-build-syntax-config-line
  [{:keys [face/name face/color-bg face/color-fg
           face/bold face/italic face/underline]}]
  (clojure.string/join " "
    [(vim-build-style "hi"    " " [name])
     (vim-build-style "gui"   "=" [(if bold "bold" nil)
                                   (if italic "italic" nil)
                                   (if underline "underline" nil)])
     (vim-build-style "guifg" "=" [color-fg])
     (vim-build-style "guibg" "=" [color-bg])]))

(defn vim-build-face [vim-face-name faces-by-name]
  (let [face (get faces-by-name (get vim-face-map vim-face-name))]
    (assoc face :face/name vim-face-name)))

(defn vim-theme-title []
  (let [name (get @reconciler :theme/name)]
    ;; TODO insert version number here and in emacs/st themes
    (str "\"" name " - Created with Koeeoadi")))

(defn vim-xform-faces []
  (let [rec            @reconciler
        faces-by-name  (:faces/by-name rec)
        faces-by-name' (inject-bg-color-ident faces-by-name)
        faces          (map #(vim-build-face % faces-by-name') (vim-position-normal (keys vim-face-map)))
        user-faces     (filter-by-editor :vim (vals (:user-faces/by-name rec)))
        all-faces      (sub-colors (concat faces user-faces))]
    (map vim-build-syntax-config-line all-faces)))

(defmethod build-theme :vim
  [_]
  (let [rec        @reconciler
        set-bg     (->> (get-in rec [:faces/by-name "background" :face/color-bg])
                     (get-in rec)
                     :color/hex
                     vim-set-bg)
        face-specs (vim-xform-faces)]
    (clojure.string/join "%0A"
      (concat
        [(vim-theme-title)
         ""
         set-bg
         ""]
        vim-highlight-init
        face-specs))))

(ns koeeoadi.themebuilder
  (:require [koeeoadi.reconciler :refer [reconciler]]
            [koeeoadi.util :refer [dark?]]
            [cljs.reader :as reader]))

;;; General
(defn sub-color [{:keys [:face/color-bg :face/color-fg] :as face}]
  (let [rec @reconciler]
    (assoc face
      :face/color-bg (:color/hex (get-in rec color-bg))
      :face/color-fg (:color/hex (get-in rec color-fg)))))

(defn sub-colors [faces]
  (map sub-color faces))

(defn filter-by-editor [editor user-faces]
  (filter #(= editor (:face/editor %)) user-faces))

(defn inject-bg-color-ident [faces-by-name]
  "Injects the bg color ident from the background face into the
  default face/colo-rbg property"
  (let [bg-color-ident (get-in faces-by-name ["background" :face/color-bg])]
    (assoc-in faces-by-name ["default" :face/color-bg] bg-color-ident)))

(defmulti build-theme
  "Build the current theme file for a given editor"
  (fn [editor] editor))

;;; EMACS

(defn face-to-emacs [face-name]
  (cond (= face-name "default")
        "default"
        :else
        (str "font-lock-" face-name "-face")))

(defn emacs-theme [face-specs]
  (let [rec           @reconciler
        name           (:theme/name rec)
        name-sym       (reader/read-string name)
        name-sym-quote (reader/read-string (str "'" name))
        doc      "A theme created with Koeeoadi"]
    `(~'progn
      (~'deftheme ~name-sym ~doc)
      (~'put ~name-sym-quote (~'quote ~'theme-immediate) ~'t)
      (~'custom-theme-set-faces ~name-sym-quote ~@face-specs)
      (~'provide-theme ~name-sym-quote))))

(defn font-lock-faceify [[face-name props :as pair]]
  (let [face-name' (str "font-lock-" face-name "-face")]
    (if (= face-name "default")
      pair
      (vector face-name' (assoc props :face/name face-name')))))

(defn xform-prop-emacs [[k v]]
  (when v
    (let [rec @reconciler]
      (case (name k)
        "color-fg"  `(:foreground ~(:color/hex (get-in rec v)))
        "color-bg"  `(:background ~(:color/hex (get-in rec v)))
        "bold"      `(:weight     ~'bold)
        "italic"    `(:italic     ~'t)
        "underline" `(:underline  ~'t)
        nil))))

(defn xform-face-emacs [{:keys [face/name] :as face}]
  ;; TODO could use transducers here to optimize
  (let [plist (filter identity (map xform-prop-emacs face))]
    (reader/read-string (str "'" (pr-str `(~(reader/read-string name) ((~'t ~(flatten plist)))))))))

(defn xform-faces-emacs [default-faces-map user-faces-map]
  (let [default-faces-map' (into {} (map font-lock-faceify default-faces-map))
        bg-color           (get-in default-faces-map ["background" :face/color-bg])]
    (map xform-face-emacs (-> default-faces-map'
                            ;; remove background face
                            (dissoc "background")
                            ;; inject original bg color into default face (emacs sets its background through the default face)
                            (assoc-in ["default" :face/color-bg] bg-color)
                            ;; to list
                            vals
                            ;; combine with the user defined emacs faces
                            (concat (filter #(= :emacs (:face/editor %)) (vals user-faces-map)))))))

(defmethod build-theme :emacs
  [_]
  (let [{current-theme      :theme/name
         faces-by-name      :faces/by-name
         user-faces-by-name :user-faces/by-name} @reconciler
        face-specs   (xform-faces-emacs faces-by-name user-faces-by-name)]
    (emacs-theme face-specs)))

;;; VIM
(defn vim-set-bg [hex]
  (str "set background=" (if (dark? hex) "dark" "light")))

(def vim-highlight-init
  ["if version > 580"
   "  hi clear"
   "  if exists(\"syntax_on\")"
   "    syntax reset"
   "  endif"
   "endif"
   ""])

(def vim-face-map
  {"Comment"     "comment-delimiter"
   "Conditional" "keyword"
   "Constant"    "constant"
   "Define"      "keyword"
   "Exception"   "keyword"
   "Float"       "constant"
   "Function"    "function-name"
   "Identifier"  "variable-name"
   "Include"     "preprocessor"
   "Keyword"     "keyword"
   "Label"       "variable-name"
   "Macro"       "preprocessor"
   "Normal"      "default"
   "Operater"    "keyword"
   "PreCondit"   "preprocessor"
   "PreProc"     "preprocessor"
   "Repeat"      "keyword"
   "Tag"         "keyword"
   "Statement"   "keyword"
   "String"      "string"
   "Type"        "type"})

(defn vim-position-normal [face-names]
  "Moves the Normal syntax name to the beginning.  Needed for VIM
   to set colors properly"
  (sort-by #(not= "Normal" %) face-names))

(defn vim-build-style [style-type prop-separator styles]
  (let [styles' (filter identity styles)]
    (if (empty? styles')
      ""
      (str style-type prop-separator (clojure.string/join "," styles')))))

(defn vim-build-syntax-config-line
  [{:keys [face/name face/color-bg face/color-fg
           face/bold face/italic face/underline]}]
  (clojure.string/join " "
    [(vim-build-style "hi"    " " [name])
     (vim-build-style "gui"   "=" [(if bold "bold" nil)
                                   (if italic "italic" nil)
                                   (if underline "underline" nil)])
     (vim-build-style "guifg" "=" [color-fg])
     (vim-build-style "guibg" "=" [color-bg])]))

(defn vim-build-face [vim-face-name faces-by-name]
  (let [face (get faces-by-name (get vim-face-map vim-face-name))]
    (assoc face :face/name vim-face-name)))

(defn vim-theme-title []
  (let [name (get @reconciler :theme/name)]
    ;; TODO insert version number here and in emacs/st themes
    (str "\"" name " - Created with Koeeoadi")))

(defn vim-xform-faces []
  (let [rec            @reconciler
        faces-by-name  (:faces/by-name rec)
        faces-by-name' (inject-bg-color-ident faces-by-name)
        faces          (map #(vim-build-face % faces-by-name') (vim-position-normal (keys vim-face-map)))
        user-faces     (filter-by-editor :vim (vals (:user-faces/by-name rec)))
        all-faces      (sub-colors (concat faces user-faces))]
    (map vim-build-syntax-config-line all-faces)))

(defmethod build-theme :vim
  [_]
  (let [rec        @reconciler
        set-bg     (->> (get-in rec [:faces/by-name "background" :face/color-bg])
                     (get-in rec)
                     :color/hex
                     vim-set-bg)
        face-specs (vim-xform-faces)]
    (clojure.string/join "%0A"
      (concat
        [(vim-theme-title)
         ""
         set-bg
         ""]
        vim-highlight-init
        face-specs))))

Add more VIM mappings

Add more VIM mappings


(ns braid.base.api
  (:require
    [braid.core.common.util :as util]
    #?@(:cljs
         [[braid.base.client.events]
          [braid.base.client.subs]
          [braid.base.client.pages]
          [braid.base.client.styles]
          [braid.base.client.state]
          [braid.base.client.remote-handlers]
          [braid.base.client.root-view]]
         :clj
         [[braid.base.conf]
          [braid.base.server.jobs]
          [braid.base.server.seed]
          [braid.base.server.cqrs]
          [braid.base.server.http-api-routes]
          [braid.base.server.initial-data]
          [braid.base.server.spa]
          [braid.base.server.schema]
          [braid.base.server.ws-handler]])))

#?(:cljs
   (do
     (defn register-initial-user-data-handler!
       "Add a handler that will run with the initial db & user-info recieved from the server. See `:register-initial-user-data` under `:clj`"
       [f]
       {:pre [(fn? f)]}
       (swap! braid.base.client.events/initial-user-data-handlers conj f))

     (defn register-state!
       "Add a key and initial value to the default app state, plus an associated spec."
       [state spec]
       {:pre [(map? state)
              (map? spec)]}
       (braid.base.client.state/register-state! state spec))

     (defn register-incoming-socket-message-handlers!
       "Registers multiple client-side socket message handlers.

       Expects map of event-keys and handler-fns.
       Handler fn will be called with user-id and data arguments"
       [handler-map]
       {:pre [(map? handler-map)
              (every? keyword? (keys handler-map))
              (every? fn? (vals handler-map))]}
       (swap! braid.base.client.remote-handlers/incoming-socket-message-handlers merge handler-map))

     (defn register-events!
       "Registers multiple re-frame event handlers, as if passed to reg-event-fx.

       Expects a map of event-keys to event-handler-fns."
       [event-map]
       {:pre [(map? event-map)
              (every? keyword? (keys event-map))
              (every? fn? (vals event-map))]}
       (braid.base.client.events/register-events! event-map))

     (defn register-event-listener!
       "Register a function to intercept re-frame events."
       [f]
       {:pre [(fn? f)]}
       (swap! braid.base.client.events/event-listeners conj f))

     (defn register-subs!
       "Registers multiple re-frame subscription handlers, as if passed to reg-sub.

       Expects a map of sub-keys to sub-handler-fns."
       [sub-map]
       {:pre [(map? sub-map)
              (every? keyword? (keys sub-map))
              (every? fn? (vals sub-map))]}
       (braid.base.client.subs/register-subs! sub-map))

     (defn register-subs-raw!
       "Registers multiple re-frame subscription handlers, as if passed to reg-sub-raw.

       Expects a map of sub-keys to sub-handler-fns."
       [sub-map]
       {:pre [(map? sub-map)
              (every? keyword? (keys sub-map))
              (every? fn? (vals sub-map))]}
       (braid.base.client.subs/register-subs-raw! sub-map))

     (defn register-root-view!
       "Add a new view to the app (when user is logged in).
       Will be put under body > #app > .app > .main >"
       [view]
       {:pre [(fn? view)]}
       (swap! braid.base.client.root-view/root-views conj view))

     (defn register-styles!
       "Add Garden CSS styles to the page styles"
       [styles]
       {:pre [(util/valid? braid.base.client.styles/style-dataspec styles)]}
       (swap! braid.base.client.styles/module-styles conj styles))

     (defn register-system-page!
       "Registers a system page with its own URL.

       Expects a map with the following keys:
         :key      keyword
         :on-load  (optional) function to call
                   when page is navigated to
         :on-exit  (optional) function to call
                   when page is navigated away from
         :view   reagent view fn
         :styles  (optional) garden styles for the page

       Link for page can be generated using:
        (braid.core.client.routes/system-page-path
             {:page-id __})"
       [page]
       {:pre [(util/valid? braid.base.client.pages/page-dataspec page)]}
       (swap! braid.base.client.pages/pages assoc (page :key) page)
       (when (page :styles)
         (register-styles!
           [:#app>.app>.main
            (page :styles)]))))

   :clj
   (do

     (defn register-initial-user-data!
       "Add a map of key -> fn for getting the initial user data to be sent to the client. `fn` will recieve the user-id as its argument. See `:register-initial-user-data-handler` under `:cljs`"
       [f]
       {:pre [(fn? f)]}
       (swap! braid.base.server.initial-data/initial-user-data conj f))

     (defn register-additional-script!
       "Add a javascript script tag to client html. Values can be a map with a `:src` or `:body` key or a function with no arguments, returing the same."
       [tag]
       {:pre [(util/valid? braid.base.server.spa/additional-script-dataspec tag)]}
       (swap! braid.base.server.spa/additional-scripts conj tag))

     (defn register-db-schema!
       "Add new datoms to the db schema"
       [schema]
       {:pre [(vector? schema)
              (every? (partial util/valid? braid.base.server.schema/rule-dataspec) schema)]}
       (swap! braid.base.server.schema/schema into schema))

     (defn register-db-seed-fn!
       "Will register function to call when base.server.seed/seed! is called"
       [f]
       {:pre [(fn? f)]}
       (swap! braid.base.server.seed/seed-fns conj f))

     (defn register-config-var!
       "Add a keyword to be read from `env` and added to the `config` state"
         [k required-or-optional schema]
       {:pre [(keyword? k)
              (#{:required :optional} required-or-optional)
              ;; TODO use malli internals to check schema
              ]}
       (swap! braid.base.conf/config-vars conj
              {:key k
               :required? (case required-or-optional
                            :required true
                            :optional false)
               :schema (if (= :optional required-or-optional)
                         [:or schema nil?]
                         schema)}))

     (defn register-server-message-handlers!
       "Add a map of websocket-event-name -> event-handler-fn to handle events from the client"
       [handler-defs]
       {:pre [(map? handler-defs)
              (every? keyword? (keys handler-defs))
              (every? fn? (vals handler-defs))]}
       (swap! braid.base.server.ws-handler/message-handlers merge handler-defs))

     (defn register-commands!
       "Add a command, which also exposes a websocket server-handler for a message of the same name."
       [commands]
       (swap! braid.base.server.cqrs/commands
              concat commands)

       (braid.base.server.cqrs/update-registry!)

       (register-server-message-handlers!
         (->> commands
              (map (fn [command]
                     [(:id command)
                      (braid.base.server.cqrs/->ws-handler command)]))
              (into {}))))

    (defn register-public-http-route!
       "Add a public HTTP route.
        Expects a route defined as:
        [:method \"pattern\" handler-fn]

        handler-fn will be passed a ring request object (with query-params and body-params in :params key)
        handler-fn should return a ring-compatible response (if it is a clojure data structure, it will be converted to edn or transit-json, based on the accepts header)
        ex.
        [:get \"/foo/:bar\" (fn [request]
                              {:status 200
                               :body (get-in request [:params :bar])})]"
       [route]
       {:pre [(util/valid? braid.base.server.http-api-routes/route? route)]}
       (swap! braid.base.server.http-api-routes/module-public-http-routes conj route))

     (defn register-private-http-route!
       "Add a private HTTP route (one that requires a user to be logged in).
        Expects a route defined as:
        [:method \"pattern\" handler-fn]

        handler-fn will be passed a ring request object (with query-params and body-params in :params key)
        handler-fn should return a ring-compatible response (if it is a clojure data structure, it will be converted to edn or transit-json, based on the accepts header)
        ex.
        [:get \"/foo/:bar\" (fn [request]
                              {:status 200
                               :body (get-in request [:params :bar])})]"
       [route]
       {:pre [(util/valid? braid.base.server.http-api-routes/route? route)]}
       (swap! braid.base.server.http-api-routes/module-private-http-routes conj route))

     (defn register-raw-http-handler!
       "Add an HTTP handler that expects to handle all its own middleware
        Expects a ring handler function

        handler-fn will be passed a ring request object (with query-params and body-params in :params key)
        handler-fn should return a ring-compatible response "
       [handler]
       (swap! braid.base.server.http-api-routes/module-raw-http-routes conj handler))

     (defn register-daily-job!
       "Add a recurring job that will run once a day. Expects a zero-arity function."
       [job-fn]
       {:pre [(fn? job-fn)]}
       (braid.base.server.jobs/register-daily-job! job-fn))))

(ns braid.base.api
  (:require
    [braid.core.common.util :as util]
    #?@(:cljs
         [[braid.base.client.events]
          [braid.base.client.subs]
          [braid.base.client.pages]
          [braid.base.client.styles]
          [braid.base.client.state]
          [braid.base.client.remote-handlers]
          [braid.base.client.root-view]]
         :clj
         [[braid.base.conf]
          [braid.base.server.jobs]
          [braid.base.server.seed]
          [braid.base.server.cqrs]
          [braid.base.server.http-api-routes]
          [braid.base.server.initial-data]
          [braid.base.server.spa]
          [braid.base.server.schema]
          [braid.base.server.ws-handler]])))

#?(:cljs
   (do
     (defn register-initial-user-data-handler!
       "Add a handler that will run with the initial db & user-info recieved from the server. See `:register-initial-user-data` under `:clj`"
       [f]
       {:pre [(fn? f)]}
       (swap! braid.base.client.events/initial-user-data-handlers conj f))

     (defn register-state!
       "Add a key and initial value to the default app state, plus an associated spec."
       [state spec]
       {:pre [(map? state)
              (map? spec)]}
       (braid.base.client.state/register-state! state spec))

     (defn register-incoming-socket-message-handlers!
       "Registers multiple client-side socket message handlers.

       Expects map of event-keys and handler-fns.
       Handler fn will be called with user-id and data arguments"
       [handler-map]
       {:pre [(map? handler-map)
              (every? keyword? (keys handler-map))
              (every? fn? (vals handler-map))]}
       (swap! braid.base.client.remote-handlers/incoming-socket-message-handlers merge handler-map))

     (defn register-events!
       "Registers multiple re-frame event handlers, as if passed to reg-event-fx.

       Expects a map of event-keys to event-handler-fns."
       [event-map]
       {:pre [(map? event-map)
              (every? keyword? (keys event-map))
              (every? fn? (vals event-map))]}
       (braid.base.client.events/register-events! event-map))

     (defn register-event-listener!
       "Register a function to intercept re-frame events."
       [f]
       {:pre [(fn? f)]}
       (swap! braid.base.client.events/event-listeners conj f))

     (defn register-subs!
       "Registers multiple re-frame subscription handlers, as if passed to reg-sub.

       Expects a map of sub-keys to sub-handler-fns."
       [sub-map]
       {:pre [(map? sub-map)
              (every? keyword? (keys sub-map))
              (every? fn? (vals sub-map))]}
       (braid.base.client.subs/register-subs! sub-map))

     (defn register-subs-raw!
       "Registers multiple re-frame subscription handlers, as if passed to reg-sub-raw.

       Expects a map of sub-keys to sub-handler-fns."
       [sub-map]
       {:pre [(map? sub-map)
              (every? keyword? (keys sub-map))
              (every? fn? (vals sub-map))]}
       (braid.base.client.subs/register-subs-raw! sub-map))

     (defn register-root-view!
       "Add a new view to the app (when user is logged in).
       Will be put under body > #app > .app > .main >"
       [view]
       {:pre [(fn? view)]}
       (swap! braid.base.client.root-view/root-views conj view))

     (defn register-styles!
       "Add Garden CSS styles to the page styles"
       [styles]
       {:pre [(util/valid? braid.base.client.styles/style-dataspec styles)]}
       (swap! braid.base.client.styles/module-styles conj styles))

     (defn register-system-page!
       "Registers a system page with its own URL.

       Expects a map with the following keys:
         :key      keyword
         :on-load  (optional) function to call
                   when page is navigated to
         :on-exit  (optional) function to call
                   when page is navigated away from
         :view   reagent view fn
         :styles  (optional) garden styles for the page

       Link for page can be generated using:
        (braid.core.client.routes/system-page-path
             {:page-id __})"
       [page]
       {:pre [(util/valid? braid.base.client.pages/page-dataspec page)]}
       (swap! braid.base.client.pages/pages assoc (page :key) page)
       (when (page :styles)
         (register-styles!
           [:#app>.app>.main
            (page :styles)]))))

   :clj
   (do

     (defn register-initial-user-data!
       "Add a map of key -> fn for getting the initial user data to be sent to the client. `fn` will recieve the user-id as its argument. See `:register-initial-user-data-handler` under `:cljs`"
       [f]
       {:pre [(fn? f)]}
       (swap! braid.base.server.initial-data/initial-user-data conj f))

     (defn register-additional-script!
       "Add a javascript script tag to client html. Values can be a map with a `:src` or `:body` key or a function with no arguments, returing the same."
       [tag]
       {:pre [(util/valid? braid.base.server.spa/additional-script-dataspec tag)]}
       (swap! braid.base.server.spa/additional-scripts conj tag))

     (defn register-db-schema!
       "Add new datoms to the db schema"
       [schema]
       {:pre [(vector? schema)
              (every? (partial util/valid? braid.base.server.schema/rule-dataspec) schema)]}
       (swap! braid.base.server.schema/schema into schema))

     (defn register-db-seed-fn!
       "Will register function to call when base.server.seed/seed! is called"
       [f]
       {:pre [(fn? f)]}
       (swap! braid.base.server.seed/seed-fns conj f))

     (defn register-config-var!
       "Add a keyword to be read from `env` and added to the `config` state"
         [k required-or-optional schema]
       {:pre [(keyword? k)
              (#{:required :optional} required-or-optional)
              ;; TODO use malli internals to check schema
              ]}
       (swap! braid.base.conf/config-vars conj
              {:key k
               :required? (case required-or-optional
                            :required true
                            :optional false)
               :schema (if (= :optional required-or-optional)
                         [:maybe schema]
                         schema)}))

     (defn register-server-message-handlers!
       "Add a map of websocket-event-name -> event-handler-fn to handle events from the client"
       [handler-defs]
       {:pre [(map? handler-defs)
              (every? keyword? (keys handler-defs))
              (every? fn? (vals handler-defs))]}
       (swap! braid.base.server.ws-handler/message-handlers merge handler-defs))

     (defn register-commands!
       "Add a command, which also exposes a websocket server-handler for a message of the same name."
       [commands]
       (swap! braid.base.server.cqrs/commands
              concat commands)

       (braid.base.server.cqrs/update-registry!)

       (register-server-message-handlers!
         (->> commands
              (map (fn [command]
                     [(:id command)
                      (braid.base.server.cqrs/->ws-handler command)]))
              (into {}))))

    (defn register-public-http-route!
       "Add a public HTTP route.
        Expects a route defined as:
        [:method \"pattern\" handler-fn]

        handler-fn will be passed a ring request object (with query-params and body-params in :params key)
        handler-fn should return a ring-compatible response (if it is a clojure data structure, it will be converted to edn or transit-json, based on the accepts header)
        ex.
        [:get \"/foo/:bar\" (fn [request]
                              {:status 200
                               :body (get-in request [:params :bar])})]"
       [route]
       {:pre [(util/valid? braid.base.server.http-api-routes/route? route)]}
       (swap! braid.base.server.http-api-routes/module-public-http-routes conj route))

     (defn register-private-http-route!
       "Add a private HTTP route (one that requires a user to be logged in).
        Expects a route defined as:
        [:method \"pattern\" handler-fn]

        handler-fn will be passed a ring request object (with query-params and body-params in :params key)
        handler-fn should return a ring-compatible response (if it is a clojure data structure, it will be converted to edn or transit-json, based on the accepts header)
        ex.
        [:get \"/foo/:bar\" (fn [request]
                              {:status 200
                               :body (get-in request [:params :bar])})]"
       [route]
       {:pre [(util/valid? braid.base.server.http-api-routes/route? route)]}
       (swap! braid.base.server.http-api-routes/module-private-http-routes conj route))

     (defn register-raw-http-handler!
       "Add an HTTP handler that expects to handle all its own middleware
        Expects a ring handler function

        handler-fn will be passed a ring request object (with query-params and body-params in :params key)
        handler-fn should return a ring-compatible response "
       [handler]
       (swap! braid.base.server.http-api-routes/module-raw-http-routes conj handler))

     (defn register-daily-job!
       "Add a recurring job that will run once a day. Expects a zero-arity function."
       [job-fn]
       {:pre [(fn? job-fn)]}
       (braid.base.server.jobs/register-daily-job! job-fn))))

[base] Use :maybe instead of :or ... nil? for optional schema


(ns ring.middleware.incise
  (:require [clojure.java.io :refer [file]]
            [ns-tracker.core :refer [ns-tracker]]
            (incise [utils :refer [delete-recursively]]
                    [load :refer [load-parsers-and-layouts]]
                    [config :as conf])
            [incise.parsers.core :refer [parse]])
  (:import [java.io File]))

(def ^:private file-modification-times (atom {}))

(defn- modified?
  "If file is not in atom or it's modification date has advanced."
  [^File a-file]
  (let [previous-modification-time (@file-modification-times a-file)
        last-modification-time (.lastModified a-file)]
    (swap! file-modification-times assoc a-file (.lastModified a-file))
    (or (nil? previous-modification-time)
        (< previous-modification-time last-modification-time))))

(defn wrap-incise-parse
  "Call parse on each modified file in the given dir with each request."
  [handler]
  (let [orig-out *out*
        orig-err *err*]
    (delete-recursively (file (conf/get :out-dir)))
    (fn [request]
      (binding [*out* orig-out
                *err* orig-err]
        (->> (conf/get :in-dir)
             (file)
             (file-seq)
             (filter modified?)
             (pmap parse)
             (dorun)))
      (handler request))))

(defn wrap-reset-modified-files-with-source-change
  "An almost copy of wrap-reload, but instead of reloading modified files this
   ensurs that the next time parse is called all content files are reparsed.

   Takes the following options:
     :dirs - A list of directories that contain the source files.
             Defaults to [\"src\"]."
  [handler & [options]]
  (let [source-dirs (:dirs options ["src"])
        modified-namespaces (ns-tracker source-dirs)]
    (fn [request]
      (when-not (empty? (modified-namespaces))
        (reset! file-modification-times {}))
      (handler request))))

(defn wrap-parsers-reload
  "Reload all parsers and layouts with each request."
  [handler]
  (fn [request]
    (load-parsers-and-layouts)
    (handler request)))

(defn wrap-incise
  [handler]
  (conf/load)
  (-> handler
      (wrap-incise-parse)
      (wrap-reset-modified-files-with-source-change)
      (wrap-parsers-reload)))

(ns ring.middleware.incise
  (:require [clojure.java.io :refer [file]]
            [ns-tracker.core :refer [ns-tracker]]
            (incise [utils :refer [delete-recursively]]
                    [load :refer [load-parsers-and-layouts]]
                    [config :as conf])
            [incise.parsers.core :refer [parse]])
  (:import [java.io File]))

(defonce ^:private file-modification-times (atom {}))

(defn- modified?
  "If file is not in atom or it's modification date has advanced."
  [^File a-file]
  (let [previous-modification-time (@file-modification-times a-file)
        last-modification-time (.lastModified a-file)]
    (swap! file-modification-times assoc a-file (.lastModified a-file))
    (or (nil? previous-modification-time)
        (< previous-modification-time last-modification-time))))

(defn wrap-incise-parse
  "Call parse on each modified file in the given dir with each request."
  [handler]
  (reset! file-modification-times {})
  (let [orig-out *out*
        orig-err *err*]
    (delete-recursively (file (conf/get :out-dir)))
    (fn [request]
      (binding [*out* orig-out
                *err* orig-err]
        (->> (conf/get :in-dir)
             (file)
             (file-seq)
             (filter modified?)
             (pmap parse)
             (dorun)))
      (handler request))))

(defn wrap-reset-modified-files-with-source-change
  "An almost copy of wrap-reload, but instead of reloading modified files this
   ensurs that the next time parse is called all content files are reparsed.

   Takes the following options:
     :dirs - A list of directories that contain the source files.
             Defaults to [\"src\"]."
  [handler & [options]]
  (let [source-dirs (:dirs options ["src"])
        modified-namespaces (ns-tracker source-dirs)]
    (fn [request]
      (when-not (empty? (modified-namespaces))
        (reset! file-modification-times {}))
      (handler request))))

(defn wrap-parsers-reload
  "Reload all parsers and layouts with each request."
  [handler]
  (fn [request]
    (load-parsers-and-layouts)
    (handler request)))

(defn wrap-incise
  [handler]
  (conf/load)
  (-> handler
      (wrap-incise-parse)
      (wrap-reset-modified-files-with-source-change)
      (wrap-parsers-reload)))

Reset file-modifcation-times with each invocation of wrap-incise-parse.


(ns portal.core
  (:use gloss.core lamina.core
        [clojure.string :only [join split]]))

(defn read-seq [string]
  (with-in-str string
    (loop [forms []]
      (let [form (read *in* false ::EOF)]
        (if (= ::EOF form)
          forms
          (recur (conj forms form)))))))

(def message
  (compile-frame
   (string :utf-8 :length (prefix (string-integer :ascii :delimiters [":"]) inc dec))
   #(str (join " " %) ",")
   #(split (apply str (butlast %)) #" " 3)))

(ns portal.core
  (:use gloss.core lamina.core
        [clojure.string :only [join split]]))

(def message
  (compile-frame
   (string :utf-8 :length (prefix (string-integer :ascii :delimiters [":"]) inc dec))
   #(str (join " " %) ",")
   #(split (apply str (butlast %)) #" " 3)))

remove unused code

remove unused code


;; Copyright (c) Andrew A. Raines
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use,
;; copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following
;; conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;; OTHER DEALINGS IN THE SOFTWARE.

(ns postal.core
  (:use [postal.sendmail :only [sendmail-send]]
        [postal.smtp :only [smtp-send]]
        [postal.stress :only [spam]]))

(defn send-message
  ([{:keys [host] :as server}
    {:keys [from to subject body] :or {to "" subject ""} :as msg}]
     (when-not (and from to)
       (throw (Exception. "message needs at least :from and :to")))
     (if host
       (smtp-send server msg)
       (sendmail-send msg)))
  ([msg]
     (send-message (meta msg) msg)))

(defn stress [profile]
  (let [defaults #^{:host "localhost"
                    :port 25
                    :num 1
                    :delay 100
                    :threads 1}
        {:from "foo@lolz.dom"
         :to "bar@lolz.dom"}
        {:keys [host port from to num delay threads]}
        (merge (meta defaults) defaults (meta profile) profile)]
    (println (format "sent %s msgs to %s:%s"
                     (spam host port from to num delay threads)
                     host port))))

;; Copyright (c) Andrew A. Raines
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use,
;; copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following
;; conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;; OTHER DEALINGS IN THE SOFTWARE.

(ns postal.core
  (:use [postal.sendmail :only [sendmail-send]]
        [postal.smtp :only [smtp-send]]
        [postal.stress :only [spam]]))

(defn send-message
  ([{:keys [host] :as server}
    {:keys [from to bcc subject body] :or {to "" subject ""} :as msg}]
     (when-not (or (and from to)
                   (and from bcc))
       (throw (Exception. "message needs at least :from and :to or :from and :bcc")))
     (if host
       (smtp-send server msg)
       (sendmail-send msg)))
  ([msg]
     (send-message (meta msg) msg)))

(defn stress [profile]
  (let [defaults #^{:host "localhost"
                    :port 25
                    :num 1
                    :delay 100
                    :threads 1}
        {:from "foo@lolz.dom"
         :to "bar@lolz.dom"}
        {:keys [host port from to num delay threads]}
        (merge (meta defaults) defaults (meta profile) profile)]
    (println (format "sent %s msgs to %s:%s"
                     (spam host port from to num delay threads)
                     host port))))

Allow bcc only messages through

Allow bcc only messages through

This updates the test in `core.clj` to allow `:bcc` only emails, which should be valid.


(ns asciinema-player.core
  (:require [reagent.core :as reagent :refer [atom]]
            [asciinema-player.view :as view]
            [asciinema-player.util :as util]
            [cljs.core.async :refer [chan >! <! timeout close!]]
            [clojure.walk :as walk]
            [ajax.core :refer [GET]])
  (:require-macros [cljs.core.async.macros :refer [go go-loop]]))

(defn make-player-state [snapshot]
  (atom {:width 80
   :height 24
   :current-time 23
   :duration 148.297910690308
   :frames-url "/frames.json"
   :font-size "small"
   :theme "solarized-dark"
   :lines snapshot }))

(defn apply-changes [state changes]
  (if-let [line-changes (seq (:lines changes))]
    (update-in state [:lines] #(apply assoc % (apply concat line-changes)))
    state))

(defn coll->chan [coll stop-chan]
  (let [ch (chan)]
    (go
      (loop [coll coll]
        (when-let [[delay data] (first coll)]
          (let [timeout-chan (timeout (* 1000 delay))
               [val c] (alts! [timeout-chan stop-chan])]
            (when (= c timeout-chan)
              (>! ch data)
              (recur (rest coll))))))
      (print "finished sending data")
      (close! ch))
    ch))

(defn prev-changes [frames seconds]
  (loop [frames frames
        seconds seconds
        candidate nil]
    (let [[delay changes :as frame] (first frames)]
      (if (or (nil? frame) (< seconds delay))
        candidate
        (recur (rest frames) (- seconds delay) (merge-with merge candidate changes))))))

(defn next-frames [frames seconds]
  (if (seq frames)
    (let [[delay changes] (first frames)]
      (if (<= delay seconds)
        (recur (rest frames) (- seconds delay))
        (cons [(- delay seconds) changes] (rest frames))))
    frames))

(defn start-playback [state dispatch]
  (print "starting")
  (let [start (js/Date.)
        start-at (rand 120)
        frames (next-frames (:frames state) start-at)
        stop-playback-chan (chan)
        changes-chan (coll->chan frames stop-playback-chan)
        timer-chan (coll->chan (repeat [0.3 true]) stop-playback-chan)]
    (go-loop []
      (when-let [changes (<! changes-chan)]
        (dispatch [:frame-changes changes])
        (recur)))
    (go-loop []
      (when (<! timer-chan)
        (let [t (+ start-at (/ (- (.getTime (js/Date.)) (.getTime start)) 1000))]
          (dispatch [:current-time t]))
        (recur)))
    (go
      (<! stop-playback-chan)
      (print (str "finished in " (- (.getTime (js/Date.)) (.getTime start)))))
    (assoc state :stop-playback-chan stop-playback-chan)))

(defn stop-playback [state]
  (print "stopping")
  (close! (:stop-playback-chan state))
  (dissoc state :stop-playback-chan))

(defn fix-line-changes-keys [frame]
  (update-in frame [1 :lines] #(into {} (map (fn [[k v]] [(js/parseInt (name k) 10) v]) %))))

(defn frames-json->clj [frames]
  (map fix-line-changes-keys (walk/keywordize-keys frames)))

(defn fetch-frames [state dispatch]
  (let [url (:frames-url state)]
    (GET
      url
      {:format :json
      :handler #(dispatch [:frames-response %])
      :error-handler #(dispatch [:bad-response %])})
    (assoc state :loading true)))

(defn new-position [current-time total-time offset]
  (/ (util/adjust-to-range (+ current-time offset) 0 total-time) total-time))

(defn handle-toggle-play [state dispatch]
  (if (contains? state :frames)
    (if (contains? state :stop-playback-chan)
      (stop-playback state)
      (start-playback state dispatch))
    (fetch-frames state dispatch)))

(defn handle-seek [state _ [position]]
  (let [new-time (* position (:duration state))
        changes (prev-changes (:frames state) new-time)]
    (-> state
        (assoc :current-time new-time)
        (apply-changes changes))))

(defn handle-rewind [state dispatch]
  (let [position (new-position (:current-time state) (:duration state) -5)]
    (handle-seek state dispatch [position])))

(defn handle-fast-forward [state dispatch]
  (let [position (new-position (:current-time state) (:duration state) 5)]
    (handle-seek state dispatch [position])))

(defn handle-frames-response [state dispatch [frames-json]]
  (dispatch [:toggle-play])
  (assoc state :loading false
               :frames (frames-json->clj frames-json)))

(defn handle-frame-changes [state _ [changes]]
  (apply-changes state changes))

(defn handle-current-time [state _ [current-time]]
  (assoc state :current-time current-time))

(def event-handlers {:toggle-play handle-toggle-play
                     :seek handle-seek
                     :rewind handle-rewind
                     :fast-forward handle-fast-forward
                     :frames-response handle-frames-response
                     :frame-changes handle-frame-changes
                     :current-time handle-current-time})

(defn process-event [state dispatch [event-name & args]]
  (if-let [handler (get event-handlers event-name)]
    (reset! state (handler @state dispatch args))
    (print (str "unhandled event: " event-name))))

(defn create-player-with-state [state dom-node]
  (let [events (chan)
        dispatch (fn [event] (go (>! events event)))]
    (go-loop []
      (when-let [event (<! events)]
        (process-event state dispatch event)
        (recur)))
    (reagent/render-component [view/player state dispatch] dom-node)
    (clj->js {:toggle (fn [] true)})))

(ns asciinema-player.core
  (:require [reagent.core :as reagent :refer [atom]]
            [asciinema-player.view :as view]
            [asciinema-player.util :as util]
            [cljs.core.async :refer [chan >! <! timeout close!]]
            [clojure.walk :as walk]
            [ajax.core :refer [GET]])
  (:require-macros [cljs.core.async.macros :refer [go go-loop]]))

(defn make-player-state [snapshot]
  (atom {:width 80
   :height 24
   :current-time 23
   :duration 148.297910690308
   :frames-url "/frames.json"
   :font-size "small"
   :theme "solarized-dark"
   :lines snapshot }))

(defn apply-changes [state changes]
  (if-let [line-changes (seq (:lines changes))]
    (update-in state [:lines] #(apply assoc % (apply concat line-changes)))
    state))

(defn coll->chan [coll stop-chan]
  (let [ch (chan)]
    (go
      (loop [coll coll]
        (when-let [[delay data] (first coll)]
          (let [timeout-chan (timeout (* 1000 delay))
               [_ c] (alts! [timeout-chan stop-chan])]
            (when (= c timeout-chan)
              (>! ch data)
              (recur (rest coll))))))
      (print "finished sending data")
      (close! ch))
    ch))

(defn prev-changes [frames seconds]
  (loop [frames frames
        seconds seconds
        candidate nil]
    (let [[delay changes :as frame] (first frames)]
      (if (or (nil? frame) (< seconds delay))
        candidate
        (recur (rest frames) (- seconds delay) (merge-with merge candidate changes))))))

(defn next-frames [frames seconds]
  (if (seq frames)
    (let [[delay changes] (first frames)]
      (if (<= delay seconds)
        (recur (rest frames) (- seconds delay))
        (cons [(- delay seconds) changes] (rest frames))))
    frames))

(defn start-playback [state dispatch]
  (print "starting")
  (let [start (js/Date.)
        start-at (rand 120)
        frames (next-frames (:frames state) start-at)
        stop-playback-chan (chan)
        changes-chan (coll->chan frames stop-playback-chan)
        timer-chan (coll->chan (repeat [0.3 true]) stop-playback-chan)]
    (go-loop []
      (when-let [changes (<! changes-chan)]
        (dispatch [:frame-changes changes])
        (recur)))
    (go-loop []
      (when (<! timer-chan)
        (let [t (+ start-at (/ (- (.getTime (js/Date.)) (.getTime start)) 1000))]
          (dispatch [:current-time t]))
        (recur)))
    (go
      (<! stop-playback-chan)
      (print (str "finished in " (- (.getTime (js/Date.)) (.getTime start)))))
    (assoc state :stop-playback-chan stop-playback-chan)))

(defn stop-playback [state]
  (print "stopping")
  (close! (:stop-playback-chan state))
  (dissoc state :stop-playback-chan))

(defn fix-line-changes-keys [frame]
  (update-in frame [1 :lines] #(into {} (map (fn [[k v]] [(js/parseInt (name k) 10) v]) %))))

(defn frames-json->clj [frames]
  (map fix-line-changes-keys (walk/keywordize-keys frames)))

(defn fetch-frames [state dispatch]
  (let [url (:frames-url state)]
    (GET
      url
      {:format :json
      :handler #(dispatch [:frames-response %])
      :error-handler #(dispatch [:bad-response %])})
    (assoc state :loading true)))

(defn new-position [current-time total-time offset]
  (/ (util/adjust-to-range (+ current-time offset) 0 total-time) total-time))

(defn handle-toggle-play [state dispatch]
  (if (contains? state :frames)
    (if (contains? state :stop-playback-chan)
      (stop-playback state)
      (start-playback state dispatch))
    (fetch-frames state dispatch)))

(defn handle-seek [state _ [position]]
  (let [new-time (* position (:duration state))
        changes (prev-changes (:frames state) new-time)]
    (-> state
        (assoc :current-time new-time)
        (apply-changes changes))))

(defn handle-rewind [state dispatch]
  (let [position (new-position (:current-time state) (:duration state) -5)]
    (handle-seek state dispatch [position])))

(defn handle-fast-forward [state dispatch]
  (let [position (new-position (:current-time state) (:duration state) 5)]
    (handle-seek state dispatch [position])))

(defn handle-frames-response [state dispatch [frames-json]]
  (dispatch [:toggle-play])
  (assoc state :loading false
               :frames (frames-json->clj frames-json)))

(defn handle-frame-changes [state _ [changes]]
  (apply-changes state changes))

(defn handle-current-time [state _ [current-time]]
  (assoc state :current-time current-time))

(def event-handlers {:toggle-play handle-toggle-play
                     :seek handle-seek
                     :rewind handle-rewind
                     :fast-forward handle-fast-forward
                     :frames-response handle-frames-response
                     :frame-changes handle-frame-changes
                     :current-time handle-current-time})

(defn process-event [state dispatch [event-name & args]]
  (if-let [handler (get event-handlers event-name)]
    (reset! state (handler @state dispatch args))
    (print (str "unhandled event: " event-name))))

(defn create-player-with-state [state dom-node]
  (let [events (chan)
        dispatch (fn [event] (go (>! events event)))]
    (go-loop []
      (when-let [event (<! events)]
        (process-event state dispatch event)
        (recur)))
    (reagent/render-component [view/player state dispatch] dom-node)
    (clj->js {:toggle (fn [] true)})))

Remove unused var

Remove unused var