;;Collection of helpers for dealing with scalable vector graphics.
;;
;;Coordinates to any fn can be 2-vector `[x y]` or map `{:x x :y y}`.
^:clj (ns c2.svg
        (:use [c2.maths :only [Pi Tau radians-per-degree
                               sin cos mean]]
              [clojure.core.match :only [match]]))

^:cljs (ns c2.svg
         (:use-macros [clojure.core.match.js :only [match]])
         (:use [c2.maths :only [Pi Tau radians-per-degree
                                sin cos mean]])
         (:require [c2.dom :as dom]))

(defn ->xy
  "Convert coordinates (potentially map of `{:x :y}`) to 2-vector."
  [coordinates]
  (match [coordinates]
         [[x y]] [x y]
         [{:x x :y y}] [x y]))

(defn translate [coordinates]
  (let [[x y] (->xy coordinates)]
    (str "translate(" x "," y ")")))

(defn scale [coordinates]
  (match [coordinates]
         [[x y]] (str "scale(" x "," y ")")
         [{:x x :y y}] (recur [x y])
         [s] (str "scale(" s ")")))

(defn rotate
  ([angle] (rotate angle [0 0]))
  ([angle coordinates]
     (let [[x y] (->xy coordinates)]
       (str "rotate(" angle "," x "," y ")"))))

(defn ^:cljs get-bounds
  "Returns map of `{:x :y :width :height}` containing SVG element bounding box.
   All coordinates are in userspace. Ref [SVG spec](http://www.w3.org/TR/SVG/types.html#InterfaceSVGLocatable)"
  [$svg-el]
  (let [b (.getBBox $svg-el)]
    {:x (.-x b)
     :y (.-y b)
     :width (.-width b)
     :height (.-height b)}))

(defn transform-to-center
  "Returns a transform string that will scale and center provided element `{:width :height :x :y}` within container `{:width :height}`."
  [element container]
  (let [{ew :width eh :height x :x y :y} element
        {w :width h :height} container
        s (min (/ h eh) (/ w ew))]
    (str (translate [(- (/ w 2) (* s (/ ew 2)))
                     (- (/ h 2) (* s (/ eh 2)))]);;translate scaled to center
         " " (scale s) ;;scale
         " " (translate [(- x) (- y)]) ;;translate to origin
         )))

(defn ^:cljs transform-to-center!
  "Scales and centers `$svg-el` within its parent SVG container.
   Uses parent's width and height attributes only."
  [$svg-el]
  (let [$svg (.-ownerSVGElement $svg-el)
        t (transform-to-center (get-bounds $svg-el)
                               {:width (js/parseFloat (dom/attr $svg :width))
                                :height (js/parseFloat (dom/attr $svg :height))})]
    (dom/attr $svg-el :transform t)))

(defn axis
  "Returns axis <g> hiccup vector for provided input `scale` and collection of `ticks` (numbers).
   Direction away from the data frame is defined to be positive; use negative margins and widths to render axis inside of data frame.

   Kwargs:

   > *:orientation* ∈ (`:top`, `:bottom`, `:left`, `:right`), where the axis should be relative to the data frame, defaults to `:left`

   > *:formatter* fn run on tick values, defaults to `str`

   > *:major-tick-width* width of ticks (minor ticks not yet implemented), defaults to 6

   > *:text-margin* distance between axis and start of text, defaults to 9

   > *:label* axis label, centered on axis; :left and :right orientation labels are rotated by +/- pi/2, respectively

   > *:label-margin* distance between axis and label, defaults to 28"
  [scale ticks & {:keys [orientation
                         formatter
                         major-tick-width
                         text-margin
                         label
                         label-margin]
                  :or {orientation :left
                       formatter str
                       major-tick-width 6
                       text-margin 9
                       label-margin 28}}]

  (let [[x y x1 x2 y1 y2] (match [orientation]
                                 [(:or :left :right)] [:x :y :x1 :x2 :y1 :y2]
                                 [(:or :top :bottom)] [:y :x :y1 :y2 :x1 :x2])

        parity (match [orientation]
                      [(:or :left :top)] -1
                      [(:or :right :bottom)] 1)]

    [:g {:class (str "axis " (name orientation))}
     [:line.rule (apply hash-map (interleave [y1 y2] (:range scale)))]

     (map (fn [d]
            [:g.tick.major-tick {:transform (translate {x 0 y (scale d)})}
             [:text {x (* parity text-margin)} (formatter d)]
             [:line {x1 0 x2 (* parity major-tick-width)}]])
          ticks)

     (when label
       [:text.label {:transform (str (translate {x (* parity label-margin)
                                                 y (mean (:range scale))})
                                     " "
                                     (match [orientation]
                                            [:left] (rotate -90)
                                            [:right] (rotate 90)
                                            :else ""))}
        label])
     ]))

(def ArcMax (- Tau 0.0000001))

(defn circle
  "Calculate SVG path data for a circle of `radius` starting at 3 o'clock and sweeping in positive y."
  ([radius] (circle [0 0] radius))
  ([coordinates radius]
     (let [[x y] (->xy coordinates)]
       (str "M"  (+ x radius) "," y
            "A" (+ x radius) "," (+ y radius) " 0 1,1" (- (+ x radius)) "," y
            "A" (+ x radius) "," (+ y radius) " 0 1,1" (+ x radius) "," y))))

(defn arc
  "Calculate SVG path data for an arc."
  [& {:keys [inner-radius, outer-radius
             start-angle, end-angle, angle-offset]
      :or {inner-radius 0, outer-radius 1
           start-angle 0, end-angle Pi, angle-offset 0}}]
  (let [r0 inner-radius
        r1 outer-radius
        [a0 a1]  (sort [(+ angle-offset start-angle)
                        (+ angle-offset end-angle)])
        da (- a1 a0)
        large-arc-flag (if (< da Pi) "0" "1")

        s0 (sin a0), c0 (cos a0)
        s1 (sin a1), c1 (cos a1)]

    ;;SVG "A" parameters: (rx ry x-axis-rotation large-arc-flag sweep-flag x y)
    ;;see http://www.w3.org/TR/SVG/paths.html#PathData
    (if (>= da ArcMax)
      ;;Then just draw a full annulus
      (str "M0," r1
           "A" r1 "," r1 " 0 1,1 0," (- r1)
           "A" r1 "," r1 " 0 1,1 0," r1
           (if (not= 0 r0) ;;draw inner arc
             (str "M0," r0
                  "A" r0 "," r0 " 0 1,0 0," (- r0)
                  "A" r0 "," r0 " 0 1,0 0," r0))
           "Z")

      ;;Otherwise, draw the wedge
      (str "M" (* r1 c0) "," (* r1 s0)
           "A" r1 "," r1 " 0 " large-arc-flag ",1 " (* r1 c1) "," (* r1 s1)
           (if (not= 0 r0) ;;draw inner arc
             (str "L" (* r0 c1) "," (* r0 s1)
                  "A" r0 "," r0 " 0 " large-arc-flag ",0 " (* r0 c0) "," (* r0 s0))
             "L0,0")
           "Z"))))

;;Collection of helpers for dealing with scalable vector graphics.
;;
;;Coordinates to any fn can be 2-vector `[x y]` or map `{:x x :y y}`.
^:clj (ns c2.svg
        (:use [c2.maths :only [Pi Tau radians-per-degree
                               sin cos mean]]
              [clojure.core.match :only [match]]))

^:cljs (ns c2.svg
         (:use-macros [clojure.core.match.js :only [match]])
         (:use [c2.maths :only [Pi Tau radians-per-degree
                                sin cos mean]])
         (:require [c2.dom :as dom]))

(defn ->xy
  "Convert coordinates (potentially map of `{:x :y}`) to 2-vector."
  [coordinates]
  (match [coordinates]
         [[x y]] [x y]
         [{:x x :y y}] [x y]))

(defn translate [coordinates]
  (let [[x y] (->xy coordinates)]
    (str "translate(" x "," y ")")))

(defn scale [coordinates]
  (match [coordinates]
         [[x y]] (str "scale(" x "," y ")")
         [{:x x :y y}] (recur [x y])
         [s] (str "scale(" s ")")))

(defn rotate
  ([angle] (rotate angle [0 0]))
  ([angle coordinates]
     (let [[x y] (->xy coordinates)]
       (str "rotate(" angle "," x "," y ")"))))

(defn ^:cljs get-bounds
  "Returns map of `{:x :y :width :height}` containing SVG element bounding box.
   All coordinates are in userspace. Ref [SVG spec](http://www.w3.org/TR/SVG/types.html#InterfaceSVGLocatable)"
  [$svg-el]
  (let [b (.getBBox $svg-el)]
    {:x (.-x b)
     :y (.-y b)
     :width (.-width b)
     :height (.-height b)}))

(defn transform-to-center
  "Returns a transform string that will scale and center provided element `{:width :height :x :y}` within container `{:width :height}`."
  [element container]
  (let [{ew :width eh :height x :x y :y} element
        {w :width h :height} container
        s (min (/ h eh) (/ w ew))]
    (str (translate [(- (/ w 2) (* s (/ ew 2)))
                     (- (/ h 2) (* s (/ eh 2)))]);;translate scaled to center
         " " (scale s) ;;scale
         " " (translate [(- x) (- y)]) ;;translate to origin
         )))

(defn ^:cljs transform-to-center!
  "Scales and centers `$svg-el` within its parent SVG container.
   Uses parent's width and height attributes only."
  [$svg-el]
  (let [$svg (.-ownerSVGElement $svg-el)
        t (transform-to-center (get-bounds $svg-el)
                               {:width (js/parseFloat (dom/attr $svg :width))
                                :height (js/parseFloat (dom/attr $svg :height))})]
    (dom/attr $svg-el :transform t)))

(defn axis
  "Returns axis <g> hiccup vector for provided input `scale` and collection of `ticks` (numbers).
   Direction away from the data frame is defined to be positive; use negative margins and widths to render axis inside of data frame.

   Kwargs:

   > *:orientation* ∈ (`:top`, `:bottom`, `:left`, `:right`), where the axis should be relative to the data frame, defaults to `:left`

   > *:formatter* fn run on tick values, defaults to `str`

   > *:major-tick-width* width of ticks (minor ticks not yet implemented), defaults to 6

   > *:text-margin* distance between axis and start of text, defaults to 9

   > *:label* axis label, centered on axis; :left and :right orientation labels are rotated by +/- pi/2, respectively

   > *:label-margin* distance between axis and label, defaults to 28"
  [scale ticks & {:keys [orientation
                         formatter
                         major-tick-width
                         text-margin
                         label
                         label-margin]
                  :or {orientation :left
                       formatter str
                       major-tick-width 6
                       text-margin 9
                       label-margin 28}}]

  (let [[x y x1 x2 y1 y2] (match [orientation]
                                 [(:or :left :right)] [:x :y :x1 :x2 :y1 :y2]
                                 [(:or :top :bottom)] [:y :x :y1 :y2 :x1 :x2])

        parity (match [orientation]
                      [(:or :left :top)] -1
                      [(:or :right :bottom)] 1)]

    [:g {:class (str "axis " (name orientation))}
     [:line.rule (apply hash-map (interleave [y1 y2] (:range scale)))]
     [:g.ticks
      (map (fn [d]
             [:g.tick.major-tick {:transform (translate {x 0 y (scale d)})}
              [:text {x (* parity text-margin)} (formatter d)]
              [:line {x1 0 x2 (* parity major-tick-width)}]])
           ticks)]

     (when label
       [:text.label {:transform (str (translate {x (* parity label-margin)
                                                 y (mean (:range scale))})
                                     " "
                                     (match [orientation]
                                            [:left] (rotate -90)
                                            [:right] (rotate 90)
                                            :else ""))}
        label])
     ]))

(def ArcMax (- Tau 0.0000001))

(defn circle
  "Calculate SVG path data for a circle of `radius` starting at 3 o'clock and sweeping in positive y."
  ([radius] (circle [0 0] radius))
  ([coordinates radius]
     (let [[x y] (->xy coordinates)]
       (str "M"  (+ x radius) "," y
            "A" (+ x radius) "," (+ y radius) " 0 1,1" (- (+ x radius)) "," y
            "A" (+ x radius) "," (+ y radius) " 0 1,1" (+ x radius) "," y))))

(defn arc
  "Calculate SVG path data for an arc."
  [& {:keys [inner-radius, outer-radius
             start-angle, end-angle, angle-offset]
      :or {inner-radius 0, outer-radius 1
           start-angle 0, end-angle Pi, angle-offset 0}}]
  (let [r0 inner-radius
        r1 outer-radius
        [a0 a1]  (sort [(+ angle-offset start-angle)
                        (+ angle-offset end-angle)])
        da (- a1 a0)
        large-arc-flag (if (< da Pi) "0" "1")

        s0 (sin a0), c0 (cos a0)
        s1 (sin a1), c1 (cos a1)]

    ;;SVG "A" parameters: (rx ry x-axis-rotation large-arc-flag sweep-flag x y)
    ;;see http://www.w3.org/TR/SVG/paths.html#PathData
    (if (>= da ArcMax)
      ;;Then just draw a full annulus
      (str "M0," r1
           "A" r1 "," r1 " 0 1,1 0," (- r1)
           "A" r1 "," r1 " 0 1,1 0," r1
           (if (not= 0 r0) ;;draw inner arc
             (str "M0," r0
                  "A" r0 "," r0 " 0 1,0 0," (- r0)
                  "A" r0 "," r0 " 0 1,0 0," r0))
           "Z")

      ;;Otherwise, draw the wedge
      (str "M" (* r1 c0) "," (* r1 s0)
           "A" r1 "," r1 " 0 " large-arc-flag ",1 " (* r1 c1) "," (* r1 s1)
           (if (not= 0 r0) ;;draw inner arc
             (str "L" (* r0 c1) "," (* r0 s1)
                  "A" r0 "," r0 " 0 " large-arc-flag ",0 " (* r0 c0) "," (* r0 s0))
             "L0,0")
           "Z"))))

Put SVG axis helper ticks in their own g element. This makes it easier to select first/last ticks using CSS.


(ns onyx.plugin.input-log
  (:require [onyx.plugin.kafka-log :as kl]
            [midje.sweet :refer :all]))

(fact "Allocate from scratch"
      (kl/allocate-partition {:allocations {:task-a [:peer-3]}}
                             {:n-partitions 5
                              :task-id :task-a
                              :peer-id :peer-3})
      =>
      {:task-metadata {:task-a {:peer-3 0}}
       :allocations {:task-a [:peer-3]}})

(fact "Allocate, however peer is no longer allocated to task"
      (kl/allocate-partition {:allocations {:task-a []}}
                             {:n-partitions 5
                              :task-id :task-a
                              :peer-id :peer-3})
      =>
      {:allocations {:task-a []}})

(fact "Allocate a new peer, deallocate dropped peer"
      (kl/allocate-partition {:task-metadata {:task-a {:peer-0 1
                                                       :peer-1 0
                                                       :peer-2 3}}
                              :allocations {:task-a [:peer-1
                                                     :peer-2
                                                     :peer-3]}}
                             {:n-partitions 5
                              :task-id :task-a
                              :peer-id :peer-3})
      =>
      {:task-metadata {:task-a {:peer-1 0
                                :peer-2 3
                                :peer-3 1}}
       :allocations {:task-a [:peer-1 :peer-2 :peer-3]}})

(ns onyx.plugin.input-log
  (:require [onyx.plugin.kafka-log :as kl]
            [midje.sweet :refer :all]))

(fact "Allocate from scratch"
      (kl/allocate-partition {:allocations {:job-1 {:task-a [:peer-3]}}}
                             {:n-partitions 5
                              :job-id :job-1
                              :task-id :task-a
                              :peer-id :peer-3})
      =>
      {:task-metadata {:job-1 {:task-a {:peer-3 0}}}
       :allocations {:job-1 {:task-a [:peer-3]}}})

(fact "Allocate, however peer is no longer allocated to task"
      (kl/allocate-partition {:allocations {:job-1 {:task-a []}}}
                             {:n-partitions 5
                              :job-id :job-1
                              :task-id :task-a
                              :peer-id :peer-3})
      =>
      {:allocations {:job-1 {:task-a []}}})

(fact "Allocate a new peer, deallocate dropped peer"
      (kl/allocate-partition {:task-metadata {:job-1 {:task-a {:peer-0 1
                                                               :peer-1 0
                                                               :peer-2 3}}}
                              :allocations {:job-1 {:task-a [:peer-1
                                                             :peer-2
                                                             :peer-3]}}}
                             {:n-partitions 5
                              :job-id :job-1
                              :task-id :task-a
                              :peer-id :peer-3})
      =>
      {:task-metadata {:job-1 {:task-a {:peer-1 0
                                        :peer-2 3
                                        :peer-3 1}}}
       :allocations {:job-1 {:task-a [:peer-1 :peer-2 :peer-3]}}})

Fix expected replicas in tests

Fix expected replicas in tests


(ns memento.routes.api
  (:require [buddy.auth :refer [authenticated? throw-unauthorized]]
            [buddy.auth.accessrules :refer [restrict]]
            [buddy.auth.backends.token :refer [token-backend]]
            [buddy.auth.middleware :refer [wrap-authentication wrap-authorization]]
            [compojure.api.meta :refer [restructure-param]]
            [compojure.api.sweet :refer [defapi context PATCH POST GET PUT DELETE]]
            [memento.middleware :refer [token-auth-mw]]
            [memento.routes.api.auth :as auth]
            [memento.routes.api.common :refer [read-content]]
            [memento.routes.api.memory :as memory]
            [memento.routes.api.reminder :as reminder]
            [numergent.utils :as utils]
            [ring.util.http-response :refer :all]
            [schema.core :as s])
  (:import (java.util UUID Date)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Access handlers and wrappers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn access-error [_ _]
  (unauthorized {:error "unauthorized"}))

(defn wrap-restricted [handler rule]
  (restrict handler {:handler  rule
                     :on-error access-error}))

(defmethod restructure-param :auth-rules
  [_ rule acc]
  (update-in acc [:middleware] conj [wrap-restricted rule]))

(defmethod restructure-param :auth-data
  [_ binding acc]
  (update-in acc [:letks] into [binding `(:identity ~'+compojure-api-request+)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Services
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(s/defschema Reminder
  {:id                        s/Uuid
   :type_id                   s/Str
   :thought_id                s/Uuid
   :created                   s/Inst
   :next_date                 (s/maybe s/Inst)
   :properties                s/Any
   (s/optional-key :username) s/Str
   (s/optional-key :thought)  s/Str                         ; Returned when querying for pending reminders
   })

(s/defschema Thought
  {:id                         s/Uuid
   :username                   s/Str
   :thought                    s/Str
   :created                    s/Inst
   (s/optional-key :root_id)   (s/maybe s/Uuid)
   (s/optional-key :refine_id) (s/maybe s/Uuid)
   (s/optional-key :status)    s/Keyword
   (s/optional-key :reminders) [Reminder]
   })

(s/defschema ThoughtSearchResult
  {:total        s/Int
   :pages        s/Int
   :current-page s/Int
   :results      [Thought]})

(s/defschema ThreadResult
  {:id      s/Uuid
   :results [Thought]})

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Services
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defapi service-routes
  {:swagger {:ui   "/swagger-ui"
             :spec "/swagger.json"
             :data {:info {:version     "1.0.0"
                           :title       "Memento API"
                           :description "Signup and data access"}}}}

  (context "/api/auth" []
    :tags ["AUTH"]

    (POST "/login" []
      :return s/Str
      :body-params [username :- s/Str
                    password :- s/Str]
      :summary "Attempts to validate a username and password, and returns a token"
      (auth/login username password))

    (GET "/validate" []
      :return s/Str
      :header-params [authorization :- String]
      :middleware [token-auth-mw]
      :auth-rules authenticated?
      :auth-data auth-data
      :summary "Attempts to validate a token, and echoes it if valid"
      ;; You'll notice I don't actually do any validation here. This is
      ;; because the validation and the authentication verification are
      ;; the same. If we got this far, the token is valid.
      (ok (:token auth-data)))

    (POST "/signup" []
      :return s/Str
      :body-params [username :- s/Str
                    password :- s/Str
                    {password2 :- s/Str ""}]
      :summary "Creates a new user"
      ;; Returns an authentication token
      (auth/signup! username password)))

  (context "/api" []
    :tags ["THOUGHTS"]

    ;; You'll need to be authenticated for these
    :middleware [token-auth-mw]
    :auth-rules authenticated?
    :header-params [authorization :- s/Str]

    (GET "/search" []
      :summary "Searches the thoughts"
      :query-params [{q :- s/Str ""}
                     {page :- s/Int 0}]
      :auth-data auth-data
      (memory/query-thoughts (:username auth-data) q page))

    (GET "/thoughts" []
      :summary "Gets the first page of thoughts"
      :return ThoughtSearchResult
      :query-params [{page :- s/Int 0}]
      :auth-data auth-data
      (memory/query-thoughts (:username auth-data) nil page))

    (POST "/thoughts" []
      :summary "Creates a new thought"
      :return Thought
      :body-params [thought :- s/Str
                    {refine_id :- (s/maybe s/Uuid) nil}]
      :auth-data auth-data
      (memory/save-thought (:username auth-data) thought refine_id))

    (PATCH "/thoughts/:id" []
      :summary "Updates an existing thought. Needs to be open."
      ;; I'm not 100% sure if patch should return a value, according to the standard, but
      ;; doing so here because it simplifies things if we have the full thought as it comes
      ;; from the server.
      :return Thought
      :path-params [id :- s/Uuid]
      :body-params [thought :- s/Str]
      :auth-data auth-data
      (memory/update-thought (:username auth-data) id thought))

    (DELETE "/thoughts/:id" []
      :summary "Deletes an existing thought. Needs to be open."
      :path-params [id :- s/Uuid]
      :auth-data auth-data
      (memory/delete-thought (:username auth-data) id))

    (GET "/threads/:id" []
      :summary "Gets a thread"
      :return ThreadResult
      :path-params [id :- s/Uuid]
      :auth-data auth-data
      (memory/get-thread (:username auth-data) id))
    )

  (context "/api" []
    :tags ["REMINDERS"]

    ;; You'll need to be authenticated for these
    :middleware [token-auth-mw]
    :auth-rules authenticated?
    :header-params [authorization :- s/Str]

    (POST "/reminders" []
      :summary "Creates a new reminder for a thought"
      :return Reminder
      :body-params [thought-id :- s/Uuid
                    type-id :- s/Str]
      :auth-data auth-data
      (reminder/create-new (:username auth-data) thought-id type-id))

    (GET "/reminders/:id" []
      :summary "Retrieves a specific reminder by id"
      :return Reminder
      :path-params [id :- s/Uuid]
      :auth-data auth-data
      (reminder/get-reminder (:username auth-data) id))

    (PATCH "/reminders/:id" []
      :summary "Patches a reminder's next-date"
      :path-params [id :- s/Uuid]
      :body-params [next-date :- (s/maybe s/Inst)]
      :auth-data auth-data
      (reminder/set-next-date (:username auth-data) id next-date))

    (GET "/reminders" []
      :summary "Retrieves all pending reminders"
      :return [Reminder]
      :auth-data auth-data
      (reminder/get-pending-reminders (:username auth-data)))

    (POST "/reminders/viewed/:id" []
      :summary "Marks a reminder as viewed"
      :path-params [id :- s/Uuid]
      :return s/Int
      :auth-data auth-data
      (reminder/mark-as-viewed! (:username auth-data) id))
    )

  )

(ns memento.routes.api
  (:require [buddy.auth :refer [authenticated? throw-unauthorized]]
            [buddy.auth.accessrules :refer [restrict]]
            [buddy.auth.backends.token :refer [token-backend]]
            [buddy.auth.middleware :refer [wrap-authentication wrap-authorization]]
            [compojure.api.meta :refer [restructure-param]]
            [compojure.api.sweet :refer [defapi context PATCH POST GET PUT DELETE]]
            [memento.middleware :refer [token-auth-mw]]
            [memento.routes.api.auth :as auth]
            [memento.routes.api.common :refer [read-content]]
            [memento.routes.api.memory :as memory]
            [memento.routes.api.reminder :as reminder]
            [numergent.utils :as utils]
            [ring.util.http-response :refer :all]
            [schema.core :as s])
  (:import (java.util UUID Date)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Access handlers and wrappers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn access-error [_ _]
  (unauthorized {:error "unauthorized"}))

(defn wrap-restricted [handler rule]
  (restrict handler {:handler  rule
                     :on-error access-error}))

(defmethod restructure-param :auth-rules
  [_ rule acc]
  (update-in acc [:middleware] conj [`wrap-restricted rule]))

(defmethod restructure-param :auth-data
  [_ binding acc]
  (update-in acc [:letks] into [binding `(:identity ~'+compojure-api-request+)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Services
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(s/defschema Reminder
  {:id                        s/Uuid
   :type_id                   s/Str
   :thought_id                s/Uuid
   :created                   s/Inst
   :next_date                 (s/maybe s/Inst)
   :properties                s/Any
   (s/optional-key :username) s/Str
   (s/optional-key :thought)  s/Str                         ; Returned when querying for pending reminders
   })

(s/defschema Thought
  {:id                         s/Uuid
   :username                   s/Str
   :thought                    s/Str
   :created                    s/Inst
   (s/optional-key :root_id)   (s/maybe s/Uuid)
   (s/optional-key :refine_id) (s/maybe s/Uuid)
   (s/optional-key :status)    s/Keyword
   (s/optional-key :reminders) [Reminder]
   })

(s/defschema ThoughtSearchResult
  {:total        s/Int
   :pages        s/Int
   :current-page s/Int
   :results      [Thought]})

(s/defschema ThreadResult
  {:id      s/Uuid
   :results [Thought]})

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Services
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defapi service-routes
  {:swagger {:ui   "/swagger-ui"
             :spec "/swagger.json"
             :data {:info {:version     "1.0.0"
                           :title       "Memento API"
                           :description "Signup and data access"}}}}

  (context "/api/auth" []
    :tags ["AUTH"]

    (POST "/login" []
      :return s/Str
      :body-params [username :- s/Str
                    password :- s/Str]
      :summary "Attempts to validate a username and password, and returns a token"
      (auth/login username password))

    (GET "/validate" []
      :return s/Str
      :header-params [authorization :- String]
      :middleware [token-auth-mw]
      :auth-rules authenticated?
      :auth-data auth-data
      :summary "Attempts to validate a token, and echoes it if valid"
      ;; You'll notice I don't actually do any validation here. This is
      ;; because the validation and the authentication verification are
      ;; the same. If we got this far, the token is valid.
      (ok (:token auth-data)))

    (POST "/signup" []
      :return s/Str
      :body-params [username :- s/Str
                    password :- s/Str
                    {password2 :- s/Str ""}]
      :summary "Creates a new user"
      ;; Returns an authentication token
      (auth/signup! username password)))

  (context "/api" []
    :tags ["THOUGHTS"]

    ;; You'll need to be authenticated for these
    :middleware [token-auth-mw]
    :auth-rules authenticated?
    :header-params [authorization :- s/Str]

    (GET "/search" []
      :summary "Searches the thoughts"
      :query-params [{q :- s/Str ""}
                     {page :- s/Int 0}]
      :auth-data auth-data
      (memory/query-thoughts (:username auth-data) q page))

    (GET "/thoughts" []
      :summary "Gets the first page of thoughts"
      :return ThoughtSearchResult
      :query-params [{page :- s/Int 0}]
      :auth-data auth-data
      (memory/query-thoughts (:username auth-data) nil page))

    (POST "/thoughts" []
      :summary "Creates a new thought"
      :return Thought
      :body-params [thought :- s/Str
                    {refine_id :- (s/maybe s/Uuid) nil}]
      :auth-data auth-data
      (memory/save-thought (:username auth-data) thought refine_id))

    (PATCH "/thoughts/:id" []
      :summary "Updates an existing thought. Needs to be open."
      ;; I'm not 100% sure if patch should return a value, according to the standard, but
      ;; doing so here because it simplifies things if we have the full thought as it comes
      ;; from the server.
      :return Thought
      :path-params [id :- s/Uuid]
      :body-params [thought :- s/Str]
      :auth-data auth-data
      (memory/update-thought (:username auth-data) id thought))

    (DELETE "/thoughts/:id" []
      :summary "Deletes an existing thought. Needs to be open."
      :path-params [id :- s/Uuid]
      :auth-data auth-data
      (memory/delete-thought (:username auth-data) id))

    (GET "/threads/:id" []
      :summary "Gets a thread"
      :return ThreadResult
      :path-params [id :- s/Uuid]
      :auth-data auth-data
      (memory/get-thread (:username auth-data) id))
    )

  (context "/api" []
    :tags ["REMINDERS"]

    ;; You'll need to be authenticated for these
    :middleware [token-auth-mw]
    :auth-rules authenticated?
    :header-params [authorization :- s/Str]

    (POST "/reminders" []
      :summary "Creates a new reminder for a thought"
      :return Reminder
      :body-params [thought-id :- s/Uuid
                    type-id :- s/Str]
      :auth-data auth-data
      (reminder/create-new (:username auth-data) thought-id type-id))

    (GET "/reminders/:id" []
      :summary "Retrieves a specific reminder by id"
      :return Reminder
      :path-params [id :- s/Uuid]
      :auth-data auth-data
      (reminder/get-reminder (:username auth-data) id))

    (PATCH "/reminders/:id" []
      :summary "Patches a reminder's next-date"
      :path-params [id :- s/Uuid]
      :body-params [next-date :- (s/maybe s/Inst)]
      :auth-data auth-data
      (reminder/set-next-date (:username auth-data) id next-date))

    (GET "/reminders" []
      :summary "Retrieves all pending reminders"
      :return [Reminder]
      :auth-data auth-data
      (reminder/get-pending-reminders (:username auth-data)))

    (POST "/reminders/viewed/:id" []
      :summary "Marks a reminder as viewed"
      :path-params [id :- s/Uuid]
      :return s/Int
      :auth-data auth-data
      (reminder/mark-as-viewed! (:username auth-data) id))
    )

  )

Fix for using Cloverage (see #77)

Fix for using Cloverage (see #77)

More at
https://github.com/cloverage/cloverage/issues/164#issuecomment-281673566


(ns xl.snake-or-ladder
  "On an N x N board, the numbers from 1 to N*N are written boustrophedonically starting from the bottom left of the board, and alternating direction each row.
    For example, for a 6 x 6 board, the numbers are written as follows:

You start on square 1 of the board (which is always in the last row and first column).  Each move, starting from square x, consists of the following:

You choose a destination square S with number x+1, x+2, x+3, x+4, x+5, or x+6, provided this number is <= N*N.
(This choice simulates the result of a standard 6-sided die roll: ie., there are always at most 6 destinations.)
If S has a snake or ladder, you move to the destination of that snake or ladder.  Otherwise, you move to S.
A board square on row r and column c has a 'snake or ladder' if board[r][c] != -1.  The destination of that snake or ladder is board[r][c].

Note that you only take a snake or ladder at most once per move: if the destination to a snake or ladder is the start of another snake or ladder,
you do not continue moving.  (For example, if the board is `[[4,-1],[-1,3]]`, and on the first move your destination square is `2`,
then you finish your first move at `3`, because you do not continue moving to `4`.)

Return the least number of moves required to reach square N*N.  If it is not possible, return -1.

Example 1:

Input: [
[-1,-1,-1,-1,-1,-1],
[-1,-1,-1,-1,-1,-1],
[-1,-1,-1,-1,-1,-1],
[-1,35,-1,-1,13,-1],
[-1,-1,-1,-1,-1,-1],
[-1,15,-1,-1,-1,-1]]
Output: 4
Explanation:
At the beginning, you start at square 1 [at row 5, column 0].
You decide to move to square 2, and must take the ladder to square 15.
You then decide to move to square 17 (row 3, column 5), and must take the snake to square 13.
You then decide to move to square 14, and must take the ladder to square 35.
You then decide to move to square 36, ending the game.
It can be shown that you need at least 4 moves to reach the N*N-th square, so the answer is 4.
Note:

2 <= board.length = board[0].length <= 20
board[i][j] is between 1 and N*N or is equal to -1.
The board square with number 1 has no snake or ladder.
The board square with number N*N has no snake or ladder.

Solution:
Idea:
1. starting from square 1
2. Each iteration, construct S(i): squares which can be reached for at least i steps.
S(0) = [1]. S[i] = { dests of x for each x in S[i-1] - union(S[0..i1]).
Space is O(n^2). Time: O(n^2).

Potential optimization:

"
  (:require [clojure.set :as set])
  )

(defn steps [table]
  (let [n (count table)
        n2 (* n n)
        to-rc (fn [k]
                (let [k1 (dec k)
                      r (int (/ k1 n))
                      c1 (int (mod k1 n))
                      c (if (even? r) c1 (- n 1 c1))]
                  [r c]))
        dest (fn [k]
               (let [[r c] (to-rc k)
                     _ (println "n: " n ", k: " k ", r: " r ", c: " c)
                     v (nth (nth table r) c)]
                 (if (= v -1) k v)
                 )
               )
        ]
    (loop [steps 0 visited #{1} si #{1}]
      (let [si1* (set (mapcat (fn [i] (map dest (filter #(<= % n2) (range (inc i) (+ i 7))))) si))
            si1 (set/difference si1* visited)
            new-steps (inc steps)
            ]
        (if (si1 n2) new-steps (recur new-steps (set/union visited si1) si1))
        )
      )
    )
  )

(defn do-samples []
  (let [table  [
                [-1,-1,-1,-1,-1,-1],
                [-1,-1,-1,-1,-1,-1],
                [-1,-1,-1,-1,-1,-1],
                [-1,35,-1,-1,13,-1],
                [-1,-1,-1,-1,-1,-1],
                [-1,15,-1,-1,-1,-1]]
        ]
    (println "steps is " (steps table) " for")
    (println "table: " table)
    )
)

(do-samples)

(ns xl.snake-or-ladder
  "On an N x N board, the numbers from 1 to N*N are written boustrophedonically starting from the bottom left of the board, and alternating direction each row.
    For example, for a 6 x 6 board, the numbers are written as follows:

You start on square 1 of the board (which is always in the last row and first column).  Each move, starting from square x, consists of the following:

You choose a destination square S with number x+1, x+2, x+3, x+4, x+5, or x+6, provided this number is <= N*N.
(This choice simulates the result of a standard 6-sided die roll: ie., there are always at most 6 destinations.)
If S has a snake or ladder, you move to the destination of that snake or ladder.  Otherwise, you move to S.
A board square on row r and column c has a 'snake or ladder' if board[r][c] != -1.  The destination of that snake or ladder is board[r][c].

Note that you only take a snake or ladder at most once per move: if the destination to a snake or ladder is the start of another snake or ladder,
you do not continue moving.  (For example, if the board is `[[4,-1],[-1,3]]`, and on the first move your destination square is `2`,
then you finish your first move at `3`, because you do not continue moving to `4`.)

Return the least number of moves required to reach square N*N.  If it is not possible, return -1.

Example 1:

Input: [
[-1,-1,-1,-1,-1,-1],
[-1,-1,-1,-1,-1,-1],
[-1,-1,-1,-1,-1,-1],
[-1,35,-1,-1,13,-1],
[-1,-1,-1,-1,-1,-1],
[-1,15,-1,-1,-1,-1]]
Output: 4
Explanation:
At the beginning, you start at square 1 [at row 5, column 0].
You decide to move to square 2, and must take the ladder to square 15.
You then decide to move to square 17 (row 3, column 5), and must take the snake to square 13.
You then decide to move to square 14, and must take the ladder to square 35.
You then decide to move to square 36, ending the game.
It can be shown that you need at least 4 moves to reach the N*N-th square, so the answer is 4.
Note:

2 <= board.length = board[0].length <= 20
board[i][j] is between 1 and N*N or is equal to -1.
The board square with number 1 has no snake or ladder.
The board square with number N*N has no snake or ladder.

Solution:
Idea:
1. starting from square 1
2. Each iteration, construct S(i): squares which can be reached for at least i steps.
S(0) = [1]. S[i] = { dests of x for each x in S[i-1] - union(S[0..i1]).
Space is O(n^2). Time: O(n^2).

Potential optimization:

"
  (:require [clojure.set :as set])
  )

(defn steps [table]
  (let [n (count table)
        n2 (* n n)
        to-rc (fn [k]
                (let [k1 (dec k)
                      r (int (/ k1 n))
                      r (- n 1 r)
                      c1 (int (mod k1 n))
                      c (if (even? (- n 1 r)) c1 (- n 1 c1))
                      ;                      _ (println "to-rc [k, r, c]: " [k, r, c])
                      ]
                  [r c]))
        dest (fn [k]
               (let [[r c] (to-rc k)
                     v (nth (nth table r) c)
                     ;                     _ (println "k: " k ", r: " r ", c: " c ", v: " v)
                     ]
                 (if (= v -1) k v)
                 )
               )
        ]
    (loop [steps 0 visited #{1} si #{1}]
      (println "step: " steps ", visited: " visited)
      (let [si1* (set (mapcat (fn [i] (map dest (filter #(<= % n2) (range (inc i) (+ i 7))))) si))
            si1 (set/difference si1* visited)
            new-steps (inc steps)
            ]
        (if (si1 n2) new-steps (recur new-steps (set/union visited si1) si1))
        )
      )
    )
  )

(defn do-samples []
  (let [table  [
                [-1,-1,-1,-1,-1,-1],
                [-1,-1,-1,-1,-1,-1],
                [-1,-1,-1,-1,-1,-1],
                [-1,35,-1,-1,13,-1],
                [-1,-1,-1,-1,-1,-1],
                [-1,15,-1,-1,-1,-1]]
        ]
    (println "steps is " (steps table) " for")
    (println "table: ")
    (doseq [r (range (count table))]
            (println (nth table r))
            )
    )
)

(do-samples)

fix snake ladder

fix snake ladder


(ns clojuredocs.util
  (:require [clojure.string :as str]
            [clojuredocs.md5 :as md5]
            #+clj  [cheshire.core :as json]
            #+clj  [clojure.pprint :refer [pprint]]
            #+cljs [goog.string :as gstring]
            #+cljs [cljs.reader :as reader])
  #+clj
  (:import [org.pegdown PegDownProcessor]
           [org.pegdown Parser]
           [org.pegdown Extensions]))

#+clj
(defn url-encode [s]
  (when s
    (java.net.URLEncoder/encode s)))

#+clj
(defn url-decode [s]
  (when s
    (java.net.URLDecoder/decode s)))

#+cljs
(defn url-encode
  [string]
  (some-> string
    str
    (js/encodeURIComponent)
    (.replace "+" "%20")))

#+cljs
(defn url-decode [s]
  (some-> s
    str
    js/decodeURIComponent))

#+clj
(defn html-encode [s]
  (when s
    (-> s
        (str/replace #"<" "<")
        (str/replace #">" ">"))))

(defn cd-decode [s]
  (when s
    (cond
      (= "_dot" s) "."
      (= "_." s) "."
      (= "_.." s) ".."
      :else (-> s
                (str/replace #"_fs" "/")
                (str/replace #"_bs" "\\")
                (str/replace #"_q" "?")

                ;; legacy
                (str/replace #"_dot" ".")))))

(defn cd-encode [s]
  (when s
    (cond
      (= "." s) "_."
      (= ".." s) "_.."
      :else (-> s
                (str/replace #"/" "_fs")
                (str/replace #"\\" "_bs")
                (str/replace #"\?" "_q")))))

(defn var-path [ns name]
  (str "/" ns "/" (cd-encode name)))

(defn $var-link [ns name & contents]
  (vec
    (concat
      [:a {:href (var-path ns name)}]
      contents)))

#+cljs
(defn navigate-to [url]
  (aset (.-location js/window) "href" url))

(def md5 md5/md5-hex)

#+cljs
(defn markdown [s]
  (when s
    (js/marked s)))

#+clj
(defn markdown [s]
  (when s
    (let [pd (PegDownProcessor. (int (bit-or
                                       Extensions/AUTOLINKS
                                       Extensions/FENCED_CODE_BLOCKS
                                       Extensions/TABLES)))]
      (.markdownToHtml pd s))))

(defn pluralize [n single plural]
  (str n " " (if (= 1 n) single plural)))

(defn now []
  #+clj  (System/currentTimeMillis)
  #+cljs (.now js/Date))

(defn $avatar [{:keys [email login avatar-url account-source] :as user} & [{:keys [size]}]]
  (let [size (str (or size 32))]
    [:a.avatar-link
     {:href (str (if (= "github" account-source)
                   "/u/"
                   "/uc/")
                 login)}
     [:img.avatar
      {:src (or (str avatar-url "&s=" size)
                (str "https://www.gravatar.com/avatar/"
                     (md5 email)
                     "?r=PG&s=" size "&default=identicon")) }]]))

(defn sformat [& args]
  #+cljs
  (apply gstring/format args)
  #+clj
  (apply format args))

(defn timeago [millis]
  (when millis
    (let [ms (- (now) millis)
          s (/ ms 1000)
          m (/ s 60)
          h (/ m 60)
          d (/ h 24)
          y (/ d 365.0)]
      (cond
        (< s 60) "less than a minute"
        (< m 2) "1 minute"
        (< h 1) (str (int m) " minutes")
        (< h 2) "1 hour"
        (< d 1) (str (int h) " hours")
        (< d 2) "1 day"
        (< y 1) (str (int d) " days")
        :else (str (sformat "%.1f" y) " years")))))

(defn to-json [o]
  #+clj  (json/generate-string o)
  #+cljs (.stringify js/JSON o))

(defn from-json [s]
  #+clj  (json/parse-string s true)
  #+cljs (.parse js/JSON s))

#+clj
(defn bson-id
  ([]
     (org.bson.types.ObjectId.))
  ([id-or-str]
     (org.bson.types.ObjectId/massageToObjectId id-or-str)))

#+clj
(defn uuid []
  (-> (java.util.UUID/randomUUID)
      str
      (str/replace #"-" "")))

#+clj
(defn pp-str [o]
  (let [w (java.io.StringWriter.)]
    (pprint o w)
    (str/trim (.toString w))))

#+cljs
(defn page-data! []
  (reader/read-string (aget js/window "PAGE_DATA")))

(defn is-author? [user o]
  (= (select-keys user [:login :account-source])
     (select-keys (:author o) [:login :account-source])))

(ns clojuredocs.util
  (:require [clojure.string :as str]
            [clojuredocs.md5 :as md5]
            #+clj  [cheshire.core :as json]
            #+clj  [clojure.pprint :refer [pprint]]
            #+cljs [goog.string :as gstring]
            #+cljs [cljs.reader :as reader])
  #+clj
  (:import [org.pegdown PegDownProcessor]
           [org.pegdown Parser]
           [org.pegdown Extensions]))

#+clj
(defn url-encode [s]
  (when s
    (java.net.URLEncoder/encode s)))

#+clj
(defn url-decode [s]
  (when s
    (java.net.URLDecoder/decode s)))

#+cljs
(defn url-encode
  [string]
  (some-> string
    str
    (js/encodeURIComponent)
    (.replace "+" "%20")))

#+cljs
(defn url-decode [s]
  (some-> s
    str
    js/decodeURIComponent))

#+clj
(defn html-encode [s]
  (when s
    (-> s
        (str/replace #"<" "<")
        (str/replace #">" ">"))))

(defn cd-decode [s]
  (when s
    (cond
      (= "_dot" s) "."
      (= "_." s) "."
      (= "_.." s) ".."
      :else (-> s
                (str/replace #"_fs" "/")
                (str/replace #"_bs" "\\\\")
                (str/replace #"_q" "?")

                ;; legacy
                (str/replace #"_dot" ".")))))

(defn cd-encode [s]
  (when s
    (cond
      (= "." s) "_."
      (= ".." s) "_.."
      :else (-> s
                (str/replace #"/" "_fs")
                (str/replace #"\\" "_bs")
                (str/replace #"\?" "_q")))))

(defn var-path [ns name]
  (str "/" ns "/" (cd-encode name)))

(defn $var-link [ns name & contents]
  (vec
    (concat
      [:a {:href (var-path ns name)}]
      contents)))

#+cljs
(defn navigate-to [url]
  (aset (.-location js/window) "href" url))

(def md5 md5/md5-hex)

#+cljs
(defn markdown [s]
  (when s
    (js/marked s)))

#+clj
(defn markdown [s]
  (when s
    (let [pd (PegDownProcessor. (int (bit-or
                                       Extensions/AUTOLINKS
                                       Extensions/FENCED_CODE_BLOCKS
                                       Extensions/TABLES)))]
      (.markdownToHtml pd s))))

(defn pluralize [n single plural]
  (str n " " (if (= 1 n) single plural)))

(defn now []
  #+clj  (System/currentTimeMillis)
  #+cljs (.now js/Date))

(defn $avatar [{:keys [email login avatar-url account-source] :as user} & [{:keys [size]}]]
  (let [size (str (or size 32))]
    [:a.avatar-link
     {:href (str (if (= "github" account-source)
                   "/u/"
                   "/uc/")
                 login)}
     [:img.avatar
      {:src (or (str avatar-url "&s=" size)
                (str "https://www.gravatar.com/avatar/"
                     (md5 email)
                     "?r=PG&s=" size "&default=identicon")) }]]))

(defn sformat [& args]
  #+cljs
  (apply gstring/format args)
  #+clj
  (apply format args))

(defn timeago [millis]
  (when millis
    (let [ms (- (now) millis)
          s (/ ms 1000)
          m (/ s 60)
          h (/ m 60)
          d (/ h 24)
          y (/ d 365.0)]
      (cond
        (< s 60) "less than a minute"
        (< m 2) "1 minute"
        (< h 1) (str (int m) " minutes")
        (< h 2) "1 hour"
        (< d 1) (str (int h) " hours")
        (< d 2) "1 day"
        (< y 1) (str (int d) " days")
        :else (str (sformat "%.1f" y) " years")))))

(defn to-json [o]
  #+clj  (json/generate-string o)
  #+cljs (.stringify js/JSON o))

(defn from-json [s]
  #+clj  (json/parse-string s true)
  #+cljs (.parse js/JSON s))

#+clj
(defn bson-id
  ([]
     (org.bson.types.ObjectId.))
  ([id-or-str]
     (org.bson.types.ObjectId/massageToObjectId id-or-str)))

#+clj
(defn uuid []
  (-> (java.util.UUID/randomUUID)
      str
      (str/replace #"-" "")))

#+clj
(defn pp-str [o]
  (let [w (java.io.StringWriter.)]
    (pprint o w)
    (str/trim (.toString w))))

#+cljs
(defn page-data! []
  (reader/read-string (aget js/window "PAGE_DATA")))

(defn is-author? [user o]
  (= (select-keys user [:login :account-source])
     (select-keys (:author o) [:login :account-source])))

Fix escaping backslash in cd-decode. Fixes #94.


(ns fault.patterns
  (:require [fault.service :as service]
            [fault.future :as future])
  (:import (fault ServiceExecutor
                  MultipleWriterResilientPromise
                  ResilientPromise
                  ResilientAction)))

(set! *warn-on-reflection* true)

(defprotocol ComposedService
  (submit-action [this action-fn timeout-millis])
  (submit-action-map [this key->fn timeout-millis])
  (perform-action [this action-fn])
  (perform-action-map [this key->fn]))

(deftype LoadBalancer [context load-balancer-fn]
  ComposedService
  (submit-action [this action-fn timeout-millis]
    (some (fn [[key service]]
            (let [f (service/submit-action service
                                        (partial action-fn (get context key))
                                        timeout-millis)]
              (if (identical? :rejected (:status f)) nil f)))
          (load-balancer-fn)))
  (submit-action-map [this key->fn timeout-millis]
    (some (fn [[key service]]
            (let [f (service/submit-action service (get key->fn key) timeout-millis)]
              (if (identical? :rejected (:status f)) nil f)))
          (load-balancer-fn)))
  (perform-action [this action-fn]
    (some (fn [[key service]]
            (let [f (service/perform-action
                      service (partial action-fn (get context key)))]
              (if (identical? :rejected (:status f)) nil f)))
          (load-balancer-fn)))
  (perform-action-map [this key->fn]
    (some (fn [[key service]]
            (let [f (service/perform-action service (get key->fn key))]
              (if (identical? :rejected (:status f)) nil f)))
          (load-balancer-fn))))

(defn- next-idx [last-idx current]
  (if (<= last-idx current)
    0
    (inc current)))

(defn load-balancer [key->service context]
  (let [service-count (count key->service)
        next-fn (partial next-idx (dec service-count))
        state (atom -1)
        key-service-tuples (vec key->service)]
    (->LoadBalancer
      context
      (fn []
        (let [start-idx (swap! state next-fn)]
          (map #(nth key-service-tuples %)
               (take service-count (iterate next-fn start-idx))))))))

(deftype Shotgun [context shotgun-fn]
  ComposedService
  (submit-action [this action-fn timeout-millis]
    (let [^ResilientPromise promise (MultipleWriterResilientPromise.)]
      (doseq [[key service] (shotgun-fn)
              :let [svc-context (get context key)]]
        (.submitAction ^ServiceExecutor (:service-executor service)
                       (reify ResilientAction (run [_] (action-fn svc-context)))
                       promise
                       timeout-millis))
      (future/->CLJResilientFuture promise)))
  (submit-action-map [this key->fn timeout-millis]
    (let [^ResilientPromise promise (MultipleWriterResilientPromise.)]
      (doseq [[key service] (shotgun-fn)
              :let [fn (get key->fn key)]]
        (.submitAction ^ServiceExecutor (:service-executor service)
                       (reify ResilientAction (run [_] (fn)))
                       promise
                       timeout-millis))
      (future/->CLJResilientFuture promise)))
  (perform-action [this action-fn]
    (throw (UnsupportedOperationException. "Cannot perform action with Shotgun")))
  (perform-action-map [this key->fn]
    (throw (UnsupportedOperationException. "Cannot perform action with Shotgun"))))

(defn shotgun [key->service action-count context]
  (let [key-service-tuples (vec key->service)
        service-count (count key->service)
        rand-fn (fn [] (rand-int service-count))]
    (assert (>= service-count action-count))
    (->Shotgun context
               (if (= service-count action-count)
                 (fn []
                   key-service-tuples)
                 (fn []
                   (map #(nth key-service-tuples %)
                        (reduce (fn [acc i]
                                  (let [acc1 (conj! acc i)]
                                    (if (= action-count (count acc1))
                                      (reduced (persistent! acc1))
                                      acc1)))
                                (transient #{})
                                (repeatedly rand-fn))))))))

(ns fault.patterns
  (:require [fault.service :as service]
            [fault.future :as future])
  (:import (fault ServiceExecutor
                  MultipleWriterResilientPromise
                  ResilientPromise
                  ResilientAction RejectedActionException)
           (java.util ArrayList)))

(set! *warn-on-reflection* true)

(defprotocol ComposedService
  (submit-action [this action-fn timeout-millis])
  (submit-action-map [this key->fn timeout-millis])
  (perform-action [this action-fn])
  (perform-action-map [this key->fn]))

(deftype LoadBalancer [context load-balancer-fn]
  ComposedService
  (submit-action [this action-fn timeout-millis]
    (some (fn [[key service]]
            (let [f (service/submit-action service
                                           (partial action-fn (get context key))
                                           timeout-millis)]
              (if (identical? :rejected (:status f)) nil f)))
          (load-balancer-fn)))
  (submit-action-map [this key->fn timeout-millis]
    (some (fn [[key service]]
            (let [f (service/submit-action service (get key->fn key) timeout-millis)]
              (if (identical? :rejected (:status f)) nil f)))
          (load-balancer-fn)))
  (perform-action [this action-fn]
    (some (fn [[key service]]
            (let [f (service/perform-action
                      service (partial action-fn (get context key)))]
              (if (identical? :rejected (:status f)) nil f)))
          (load-balancer-fn)))
  (perform-action-map [this key->fn]
    (some (fn [[key service]]
            (let [f (service/perform-action service (get key->fn key))]
              (if (identical? :rejected (:status f)) nil f)))
          (load-balancer-fn))))

(defn- next-idx [last-idx current]
  (if (<= last-idx current)
    0
    (inc current)))

(defn load-balancer [key->service context]
  (let [service-count (count key->service)
        next-fn (partial next-idx (dec service-count))
        state (atom -1)
        key-service-tuples (vec key->service)]
    (->LoadBalancer
      context
      (fn []
        (let [start-idx (swap! state next-fn)]
          (map #(nth key-service-tuples %)
               (take service-count (iterate next-fn start-idx))))))))

(deftype Shotgun [action-count context shotgun-fn]
  ComposedService
  (submit-action [this action-fn timeout-millis]
    (let [^ResilientPromise promise (MultipleWriterResilientPromise.)
          rejects (ArrayList. ^long action-count)]
      (doseq [[key service] (shotgun-fn)
              :let [svc-context (get context key)]]
        (try
          (.submitAction ^ServiceExecutor (:service-executor service)
                         (reify ResilientAction (run [_] (action-fn svc-context)))
                         promise
                         timeout-millis)
          (catch RejectedActionException e (.add rejects (.reason e)))))
      (when (not= (count rejects) action-count)
        (future/->CLJResilientFuture promise))))
  (submit-action-map [this key->fn timeout-millis]
    (let [^ResilientPromise promise (MultipleWriterResilientPromise.)
          rejects (ArrayList. ^long action-count)]
      (doseq [[key service] (shotgun-fn)
              :let [fn (get key->fn key)]]
        (try
          (.submitAction ^ServiceExecutor (:service-executor service)
                         (reify ResilientAction (run [_] (fn)))
                         promise
                         timeout-millis)
          (catch RejectedActionException e (.add rejects (.reason e)))))
      (when (not= (count rejects) action-count)
        (future/->CLJResilientFuture promise))))
  (perform-action [this action-fn]
    (throw (UnsupportedOperationException. "Cannot perform action with Shotgun")))
  (perform-action-map [this key->fn]
    (throw (UnsupportedOperationException. "Cannot perform action with Shotgun"))))

(defn shotgun [key->service action-count context]
  (let [key-service-tuples (vec key->service)
        service-count (count key->service)
        rand-fn (fn [] (rand-int service-count))]
    (assert (>= service-count action-count))
    (->Shotgun action-count
               context
               (if (= service-count action-count)
                 (fn []
                   key-service-tuples)
                 (fn []
                   (map #(nth key-service-tuples %)
                        (reduce (fn [acc i]
                                  (let [acc1 (conj! acc i)]
                                    (if (= action-count (count acc1))
                                      (reduced (persistent! acc1))
                                      acc1)))
                                (transient #{})
                                (repeatedly rand-fn))))))))

Add functionality in patterns to handle rejected actions


;   Copyright (c) Shantanu Kumar. All rights reserved.
;   The use and distribution terms for this software are covered by the
;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;   which can be found in the file LICENSE at the root of this distribution.
;   By using this software in any fashion, you are agreeing to be bound by
;   the terms of this license.
;   You must not remove this notice, or any other, from this software.

(ns keypin.store
  (:require
    [clojure.stacktrace :as cs]
    [keypin.internal :as i]
    [keypin.type     :as t])
  (:import
    [java.util Date]
    [java.text SimpleDateFormat]
    [java.util.concurrent TimeoutException]
    [clojure.lang Associative IDeref ILookup IPersistentCollection IPersistentMap Named Seqable]))

(defrecord DynamicStore
  [^IPersistentMap kvdata
   ^String         name
   ^long           tstamp])

(defn fetch-every?
  "Given duration in milliseconds, return a fetch decider (fn fetch? [last-fetch-time-millis]) that returns true if
  it is time to fetch data, false otherwise."
  [^long duration-millis]
  (fn [^DynamicStore dynamic-store]
    (>= (i/now-millis (.-tstamp dynamic-store))
      duration-millis)))

(defn fetch-if-error?
  [err-ts-key ^long millis-since-error]
  (fn [^DynamicStore dynamic-store]
    (if-let [err-ts (get dynamic-store err-ts-key)]
      (>= (i/now-millis (long err-ts))
        millis-since-error)
      true)))

(defn wait-if-stale
  [^long stale-millis ^long timeout-millis]
  (fn [container]
    (let [^DynamicStore dynamic-store @container
          tstamp (.-tstamp dynamic-store)]
      (when (>= (i/now-millis tstamp) stale-millis)  ; stale data?
        (let [until-millis (unchecked-add (i/now-millis) timeout-millis)]
          (loop []
            (if (< (i/now-millis) until-millis)  ; not timed out yet waiting for stale->refresh
              (when (= tstamp (.-tstamp ^DynamicStore @container))  ; not updated?
                (try (-> until-millis
                       (unchecked-subtract (i/now-millis))
                       (min 10) ; max 10ms sleep window
                       (max 0)  ; guard against negative duration
                       (Thread/sleep))
                  (catch InterruptedException _))
                (recur))
              (throw (TimeoutException. (format "Timed out waiting for stale dynamic store %s to be refreshed"
                                          (.-name dynamic-store)))))))))))

(defn make-dynamic-store
  "Given a fetch function (fn [old-data])->new-data that fetches a map instance, and initial data (`nil`: initialized
  asynchronously in another thread), create a dynamic store that refreshes itself.

  ### Options

  | Kwarg          | Type/format                   | Description                 | Default |
  |----------------|-------------------------------|-----------------------------|---------|
  | :name          | stringable                    | Name of the config store    | Auto generated |
  | :fetch?        | (fn [^DynamicStore ds])->bool | Return true for to re-fetch | Fetch at 1 sec interval |
  | :verify-sanity | (fn [DynamicStore-holder])    | Verify store sanity         | Wait max 1 sec for 5+ sec old data |
  | :error-handler | (fn [DynamicStore-holder ex]) | respond to async fetch error| Prints the error |

  You may deref DynamicStore-holder to access its contents.

  ### Examples

  (make-dynamic-store f nil)  ; async initialization, refresh interval 1 second
  (make-dynamic-store f (f))  ; upfront initialization, refresh interval 1 second"
  ([f init]
    (make-dynamic-store f init {}))
  ([f init {:keys [name
                   fetch?
                   verify-sanity
                   error-handler]
            :or {name   (gensym "dynamic-store:")
                 fetch? (let [f? (fetch-every? 1000)  ; fetch every 1 second
                              e? (fetch-if-error?     ; fetch after minimum 1 second if error happened
                                   :err-ts 1000)]
                          (fn [db] (and (f? db) (e? db))))
                 verify-sanity (wait-if-stale 5000 1000)
                 error-handler (fn [data-holder ^Throwable ex]
                                 (let [err-ts (i/now-millis)]
                                   (binding [*out* *err*]
                                     (printf "Error refreshing dynamic store %s at %s\n"
                                       (i/as-str name)
                                       (.format (SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss.SSSXXX") (Date. err-ts)))
                                     (cs/print-stack-trace ex)
                                     (flush))
                                   (send data-holder update :err-ts (fn [old-err-ts]
                                                                      (max (long (or old-err-ts 0)) err-ts)))))}
                              :as options}]
    (let [name-string (i/as-str name)
          data-holder (agent (map->DynamicStore {:kvdata init
                                                 :name   name-string
                                                 :tstamp (if (nil? init)
                                                           0
                                                           (i/now-millis))})
                        :error-handler error-handler)
          start-fetch (fn [] (send-off data-holder (fn [^DynamicStore dynamic-store]
                                                     (if (fetch? dynamic-store)
                                                       (map->DynamicStore {:kvdata (f (.-kvdata dynamic-store))
                                                                           :name   name-string
                                                                           :tstamp (i/now-millis)})
                                                       dynamic-store))))
          update-data (fn []
                        (let [^DynamicStore dynamic-store @data-holder
                              kvdata (.-kvdata dynamic-store)]
                          (when (fetch? dynamic-store)
                            (start-fetch))
                          (verify-sanity data-holder)
                          (when (nil? kvdata)
                            (throw (IllegalStateException. (format "Dynamic store %s is not yet initialized"
                                                             name-string))))
                          kvdata))]
      (when (nil? init)
        (start-fetch))
      (reify
        IDeref
        (deref [_]      (update-data))
        t/IStore
        (lookup [_ kd]  (t/lookup (update-data) kd))
        ILookup
        (valAt [_ k]    (get (update-data) k))
        (valAt [_ k nf] (get (update-data) k nf))
        Seqable
        (seq   [_]      (seq (update-data)))
        IPersistentCollection
        (count [_]      (count (update-data)))
        (cons  [_ _]    (throw (UnsupportedOperationException. "cons is not supported on this type")))
        (empty [_]      (make-dynamic-store (constantly false) {}))
        (equiv [_ obj]  (.equiv ^IPersistentMap (update-data) obj))
        Associative
        (containsKey  [_ k]   (contains? (update-data) k))
        (entryAt      [_ k]   (.entryAt ^IPersistentMap (update-data) k))
        (assoc        [_ _ _] (throw (UnsupportedOperationException. "assoc is not supported on this type")))
        Named
        (getNamespace [_]  (when (instance? Named name) (namespace name)))
        (getName      [_]  (if (instance? Named name)
                             (clojure.core/name name)
                             name-string))))))

;; ----- caching store -----

(defn make-caching-store
  [store]
  (i/expected #(satisfies? t/IStore %) "an instance of keypin.type/IStore protocol" store)
  (let [state (agent {:kvdata nil
                      :cache  {}})
        fetch (if (instance? IDeref store)
                (fn []
                  (let [store-data @store
                        state-data @state]
                    (if (identical? store-data (:kvdata state-data))
                      state-data
                      (let [new-state {:kvdata store-data
                                       :cache {}}]
                        (send state conj new-state)
                        new-state))))
                (do
                  (send state assoc :kvdata store)
                  (fn []
                    @state)))
        sdata (fn []
                (:kvdata (fetch)))]
    (reify
      IDeref
      (deref [_]      (sdata))
      t/IStore
      (lookup [_ kd]  (let [{:keys [kvdata cache]} (fetch)
                            l-key (:the-key kd)]
                        (if (contains? cache l-key)
                          (get cache l-key)
                          (let [v (t/lookup kvdata kd)]
                            (send state assoc-in [:cache l-key] v)
                            v))))
      ILookup
      (valAt [_ k]    (get (sdata) k))
      (valAt [_ k nf] (get (sdata) k nf))
      Seqable
      (seq   [_]      (seq (sdata)))
      IPersistentCollection
      (count [_]      (count (sdata)))
      (cons  [_ _]    (throw (UnsupportedOperationException. "cons is not supported on this type")))
      (empty [_]      (make-caching-store {}))
      (equiv [_ obj]  (.equiv ^IPersistentMap (sdata) obj))
      Associative
      (containsKey  [_ k]   (contains? (sdata) k))
      (entryAt      [_ k]   (.entryAt ^IPersistentMap (sdata) k))
      (assoc        [_ _ _] (throw (UnsupportedOperationException. "assoc is not supported on this type"))))))

;   Copyright (c) Shantanu Kumar. All rights reserved.
;   The use and distribution terms for this software are covered by the
;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;   which can be found in the file LICENSE at the root of this distribution.
;   By using this software in any fashion, you are agreeing to be bound by
;   the terms of this license.
;   You must not remove this notice, or any other, from this software.

(ns keypin.store
  (:require
    [clojure.stacktrace :as cs]
    [keypin.internal :as i]
    [keypin.type     :as t])
  (:import
    [java.util Date]
    [java.text SimpleDateFormat]
    [java.util.concurrent TimeoutException]
    [clojure.lang Associative IDeref ILookup IPersistentCollection IPersistentMap Named Seqable]))

(defrecord DynamicStore
  [^IPersistentMap kvdata
   ^String         name
   ^long           tstamp])

(defn fetch-every?
  "Given duration in milliseconds, return a fetch decider (fn fetch? [last-fetch-time-millis]) that returns true if
  it is time to fetch data, false otherwise."
  [^long duration-millis]
  (fn [^DynamicStore dynamic-store]
    (>= (i/now-millis (.-tstamp dynamic-store))
      duration-millis)))

(defn fetch-if-error?
  [err-ts-key ^long millis-since-error]
  (fn [^DynamicStore dynamic-store]
    (if-let [err-ts (get dynamic-store err-ts-key)]
      (>= (i/now-millis (long err-ts))
        millis-since-error)
      true)))

(defn wait-if-stale
  [^long stale-millis ^long timeout-millis]
  (fn [container]
    (let [^DynamicStore dynamic-store @container
          tstamp (.-tstamp dynamic-store)]
      (when (>= (i/now-millis tstamp) stale-millis)  ; stale data?
        (let [until-millis (unchecked-add (i/now-millis) timeout-millis)]
          (loop []
            (if (< (i/now-millis) until-millis)  ; not timed out yet waiting for stale->refresh
              (when (= tstamp (.-tstamp ^DynamicStore @container))  ; not updated?
                (try (-> until-millis
                       (unchecked-subtract (i/now-millis))
                       (min 10) ; max 10ms sleep window
                       (max 0)  ; guard against negative duration
                       (Thread/sleep))
                  (catch InterruptedException _))
                (recur))
              (throw (TimeoutException. (format "Timed out waiting for stale dynamic store %s to be refreshed"
                                          (.-name dynamic-store)))))))))))

(defn make-dynamic-store
  "Given a fetch function (fn [old-data])->new-data that fetches a map instance, and initial data (`nil`: initialized
  asynchronously in another thread), create a dynamic store that refreshes itself.

  ### Options

  | Kwarg          | Type/format                   | Description                 | Default |
  |----------------|-------------------------------|-----------------------------|---------|
  | :name          | stringable                    | Name of the config store    | Auto generated |
  | :fetch?        | (fn [^DynamicStore ds])->bool | Return true for to re-fetch | Fetch at 1 sec interval |
  | :verify-sanity | (fn [DynamicStore-holder])    | Verify store sanity         | Wait max 1 sec for 5+ sec old data |
  | :error-handler | (fn [DynamicStore-holder ex]) | respond to async fetch error| Prints the error |

  You may deref DynamicStore-holder to access its contents.

  ### Examples

  (make-dynamic-store f nil)  ; async initialization, refresh interval 1 second
  (make-dynamic-store f (f))  ; upfront initialization, refresh interval 1 second"
  ([f init]
    (make-dynamic-store f init {}))
  ([f init {:keys [name
                   fetch?
                   verify-sanity
                   error-handler]
            :or {name   (gensym "dynamic-store:")
                 fetch? (let [f? (fetch-every? 1000)  ; fetch every 1 second
                              e? (fetch-if-error?     ; fetch after minimum 1 second if error happened
                                   :err-ts 1000)]
                          (fn [db] (and (f? db) (e? db))))
                 verify-sanity (wait-if-stale 5000 1000)
                 error-handler (fn [data-holder ^Throwable ex]
                                 (let [err-ts (i/now-millis)]
                                   (binding [*out* *err*]
                                     (printf "Error refreshing dynamic store %s at %s\n"
                                       (i/as-str name)
                                       (.format (SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss.SSSXXX") (Date. err-ts)))
                                     (cs/print-stack-trace ex)
                                     (flush))
                                   (send data-holder update :err-ts (fn [old-err-ts]
                                                                      (max (long (or old-err-ts 0)) err-ts)))))}
                              :as options}]
    (let [name-string (i/as-str name)
          data-holder (agent (map->DynamicStore {:kvdata init
                                                 :name   name-string
                                                 :tstamp (if (nil? init)
                                                           0
                                                           (i/now-millis))})
                        :error-handler error-handler)
          start-fetch (fn [] (send-off data-holder (fn [^DynamicStore dynamic-store]
                                                     (if (fetch? dynamic-store)
                                                       (map->DynamicStore {:kvdata (f (.-kvdata dynamic-store))
                                                                           :name   name-string
                                                                           :tstamp (i/now-millis)})
                                                       dynamic-store))))
          update-data (fn []
                        (let [^DynamicStore dynamic-store @data-holder
                              kvdata (.-kvdata dynamic-store)]
                          (when (fetch? dynamic-store)
                            (start-fetch))
                          (verify-sanity data-holder)
                          (when (nil? kvdata)
                            (throw (IllegalStateException. (format "Dynamic store %s is not yet initialized"
                                                             name-string))))
                          kvdata))]
      (when (nil? init)
        (start-fetch))
      (reify
        IDeref
        (deref [_]      (update-data))
        t/IStore
        (lookup [_ kd]  (t/lookup (update-data) kd))
        ILookup
        (valAt [_ k]    (get (update-data) k))
        (valAt [_ k nf] (get (update-data) k nf))
        Seqable
        (seq   [_]      (seq (update-data)))
        IPersistentCollection
        (count [_]      (count (update-data)))
        (cons  [_ _]    (throw (UnsupportedOperationException. "cons is not supported on this type")))
        (empty [_]      (make-dynamic-store (constantly false) {}))
        (equiv [_ obj]  (.equiv ^IPersistentMap (update-data) obj))
        Associative
        (containsKey  [_ k]   (contains? (update-data) k))
        (entryAt      [_ k]   (.entryAt ^IPersistentMap (update-data) k))
        (assoc        [_ _ _] (throw (UnsupportedOperationException. "assoc is not supported on this type")))
        Named
        (getNamespace [_]  (when (instance? Named name) (namespace name)))
        (getName      [_]  (if (instance? Named name)
                             (clojure.core/name name)
                             name-string))))))

;; ----- caching store -----

(defn make-caching-store
  "Wrap a given a store such that the key lookups are cached as long as the store doesn't change."
  [store]
  (i/expected #(satisfies? t/IStore %) "an instance of keypin.type/IStore protocol" store)
  (let [data? (not (instance? IDeref store))
        state (agent {:kvdata (when data?
                                store)
                      :cache  {}})
        fetch (if data?
                (fn []
                  @state)
                (fn []
                  (let [store-data @store
                        state-data @state]
                    (if (identical? store-data (:kvdata state-data))
                      state-data
                      (let [new-state {:kvdata store-data
                                       :cache {}}]
                        (send state conj new-state)
                        new-state)))))
        sdata (fn []
                (:kvdata (fetch)))]
    (reify
      IDeref
      (deref [_]      (sdata))
      t/IStore
      (lookup [_ kd]  (let [{:keys [kvdata cache]} (fetch)
                            l-key (:the-key kd)]
                        (if (contains? cache l-key)
                          (get cache l-key)
                          (let [v (t/lookup kvdata kd)]
                            (send state assoc-in [:cache l-key] v)
                            v))))
      ILookup
      (valAt [_ k]    (get (sdata) k))
      (valAt [_ k nf] (get (sdata) k nf))
      Seqable
      (seq   [_]      (seq (sdata)))
      IPersistentCollection
      (count [_]      (count (sdata)))
      (cons  [_ _]    (throw (UnsupportedOperationException. "cons is not supported on this type")))
      (empty [_]      (make-caching-store {}))
      (equiv [_ obj]  (.equiv ^IPersistentMap (sdata) obj))
      Associative
      (containsKey  [_ k]   (contains? (sdata) k))
      (entryAt      [_ k]   (.entryAt ^IPersistentMap (sdata) k))
      (assoc        [_ _ _] (throw (UnsupportedOperationException. "assoc is not supported on this type"))))))

initialize store state with data when not dynamic


(ns revdiff.core
  (:gen-class)
  (:import [java.io.StringBufferInputStream])
  (:require [clojure.tools.cli :as cli])
  (:use [clojure.xml :only [parse]])
  (:use [clojure.java.shell :only [sh]])
  (:use [clojure.string :only [join split split-lines trim]]))

(declare matching-files log squeeze svndiff uri? vpaths)

;; defs

(def shhh "--non-interactive")

(def show-cmd #(println (str "Command: " (squeeze (join " " %)))))

(def squeeze #(clojure.string/replace % #"\s\s+" " "))

;; defns

;; Strip peg revision, if present.

(defn baseobject [object]
  (clojure.string/replace object #"@[0-9]+$" ""))

;; Command-line interface options.

(def cliopts
  [["-h" "--help" "Show usage information"]
   ["-i" "--case-insensitive" "Treat regexp as case-insensitive"]
   ["-d" "--diff-opts options" "Quoted list of options to pass to svn diff"]
   ["-l" "--log-opts options" "Quoted list of options to pass to svn log"]
   ["-s" "--show-cmds" "Show svn commands as they are issued"]])

;; A string containing the output of "diff" on the two svn revision of object.

(defn diff [r1 r2 object show]
  (let [object (baseobject object)
        v (vpaths r1 r2 object object)
        o1 (first v)
        o2 (second v)
        cmd-components ["svn" "diff" "--diff-cmd" "diff" "-x" "-U 0" shhh o1 o2]]
    (if show (show-cmd cmd-components))
    (apply sh cmd-components)))

;; Show diffs for files that changed (modulo the optional filtering regexp)
;; between each revision pair in the given list.

(defn diff-revpairs [object filt revpairs show insens]
  (loop [x revpairs]
    (let [r1 (first x)
          r2 (second x)
          mf (matching-files r1 r2 object filt show insens)]
      (println (str "Checking: r" r1 " vs r" r2))
      (doseq [filename mf] (svndiff r1 r2 filename object show))
      (recur (drop 2 x)))))

;; Try to explain why this has failed.

(defn errmsg []
  (println "\nError retrieving repository information. Perhaps:\n")
  (println "- The supplied filename or URI is invalid, or")
  (println "- Your valid svn authentication credentials are not cached.")
  (println)
  (System/exit 1))

;; Return a newest-first sequence of revision numbers in which the object
;; changed.

(defn get-revlist [opts show object]
  (let [x (java.io.ByteArrayInputStream. (.getBytes (log opts show object)))]
    (for [e (try
              (xml-seq (parse x))
              (catch Exception e (errmsg)))
          :when (seq (:attrs e))]
    (:revision (:attrs e)))))

;; Return a sequence of revision pairs for potential comparison -- e.g. for the
;; revlist (9 8 6 4 1), return (8 9 6 8 4 6 1 4).

(defn get-revpairs [revlist object]
  (interleave (rest revlist) (butlast revlist)))

;; Return a string containing the xml-formatted svn log for the requested
;; object.

(defn log [opts show object]
  (let [cmd-components (if opts ["svn" "log" shhh "--xml" opts object]
                                ["svn" "log" shhh "--xml"      object])]
    (if show (show-cmd cmd-components))
    (print "Fetching log... ")
    (flush)
    (let [result (:out (apply sh cmd-components))]
      (println)
      result)))

;; Obtain a diff from svn for the given object between the specified revisions.
;; Break each diff into blocks (delineated by the text "Index: "), where each
;; block describes one file. The block's first line is the filename, and lines
;; beginning with a single '+' or '-' are the changes. Construct and return a
;; vector of the names of files where the filter term appears on a changed line.
;; If no filter term is given, a changed file automatically matches.

(defn matching-files [r1 r2 object filt show insens]
  (let [raw (:out (diff r1 r2 object show))
        blocks (rest (split raw #"^Index: |\nIndex: "))
        filt (if insens (str "(?i)" filt) filt)]
    (remove nil?
            (into []
                  (for [block blocks]
                    (let [matching-line-in? #(re-matches (re-pattern filt) %)
                          diff-line? #(re-matches #"^[+-][^+-].*" %)
                          strip+- #(clojure.string/replace % #"^[+-]" "")
                          all-lines (split-lines block)
                          diff-lines (filter diff-line? all-lines)
                          changes (map strip+- diff-lines)
                          filename (trim (first all-lines))]
                      (if (some matching-line-in? changes) filename)))))))

;; If the object under investigation is a uri, and if it already ends with the
;; given filename (e.g. when the object names a file) as the absolute pathname.
;; Otherwise (e.g. when the object names a directory), append the filename to
;; the object to form the absolute pathname. If the object is a filesystem name,
;; just use the filename. Construct versioned pathnames and svn diff them.

(defn svndiff [r1 r2 filename object show]
  (let [object (baseobject object)
        re (re-pattern (str "^.*/" filename "$"))
        abs-path (if (uri? object)
            (if (re-matches re object) object (str object "/" filename))
            filename)
        v (vpaths r1 r2 abs-path object)
        cmd-components ["svn" "diff" (first v) (second v)]]
    (if show (show-cmd cmd-components))
    (apply sh cmd-components)))

;; Is path a uri? If it contains :// assume it is.

(defn uri? [path] (re-matches #".*://.*" path))

;; Print usage information.

(defn usage [summary code]
  (println (str "\nUsage: revdiff [options] object [regexp]\n\n  Options:\n"))
  (println (str summary "\n"))
  (println "  object: svn URI or name of versioned object in working-copy")
  (println "  regexp: only show diffs where a changed line matches regexp\n")
  (println "  See https://github.com/maddenp/revdiff for notes on options.\n")
  (System/exit code))

;; If object is a uri, the "-rn:m" revision-range format will not work if object
;; is no longer present in the head revision, in which case we have to use the
;; "object@n object@m" revision-specification format. Return the correctly
;; formatted versioned-path(s) string for use by a diff command.

(defn vpaths [r1 r2 path object]
  (if (uri? object)
    (list (str path "@" r1) (str path "@" r2))
    (list (str "-r" r1 ":" r2) path)))

;; Entry point from command line.

(defn -main [& args]
  (let [{:keys [options arguments summary]} (cli/parse-opts args cliopts)
        object (first arguments)
        filt (or (second arguments) ".*")
        insens (:case-insensitive options)
        optsd (:diff-opts options)
        optsl (:log-opts options)
        show (:show-cmds options)]
    (if (:help options) (usage summary 0))
    (if (not object)
      (usage summary 1)
      (let [revlist (get-revlist optsl show object)
            revpairs (get-revpairs revlist object)]
        (diff-revpairs object filt revpairs show insens)
        (shutdown-agents)))))

(ns revdiff.core
  (:gen-class)
  (:import [java.io.StringBufferInputStream])
  (:require [clojure.tools.cli :as cli])
  (:use [clojure.xml :only [parse]])
  (:use [clojure.java.shell :only [sh]])
  (:use [clojure.string :only [join split split-lines trim]]))

(declare matching-files log squeeze svndiff uri? vpaths)

;; defs

(def shhh "--non-interactive")

(def show-cmd #(println (str "Command: " (squeeze (join " " %)))))

(def squeeze #(clojure.string/replace % #"\s\s+" " "))

;; defns

;; Strip peg revision, if present.

(defn baseobject [object]
  (clojure.string/replace object #"@[0-9]+$" ""))

;; Command-line interface options.

(def cliopts
  [["-h" "--help" "Show usage information"]
   ["-i" "--case-insensitive" "Treat regexp as case-insensitive"]
   ["-d" "--diff-opts options" "Quoted list of options to pass to svn diff"]
   ["-l" "--log-opts options" "Quoted list of options to pass to svn log"]
   ["-s" "--show-cmds" "Show svn commands as they are issued"]])

;; A string containing the output of "diff" on the two svn revision of object.

(defn diff [r1 r2 object show]
  (let [object (baseobject object)
        v (vpaths r1 r2 object object)
        o1 (first v)
        o2 (second v)
        cmd-components ["svn" "diff" "--diff-cmd" "diff" "-x" "-U 0" shhh o1 o2]]
    (if show (show-cmd cmd-components))
    (apply sh cmd-components)))

;; Show diffs for files that changed (modulo the optional filtering regexp)
;; between each revision pair in the given list.

(defn diff-revpairs [object filt revpairs show insens]
  (loop [x revpairs]
    (if (not-empty x)
      (let [r1 (first x)
            r2 (second x)
            mf (matching-files r1 r2 object filt show insens)]
        (println (str "Checking: r" r1 " vs r" r2))
        (doseq [filename mf] (svndiff r1 r2 filename object show))
        (recur (drop 2 x))))))

;; Try to explain why this has failed.

(defn errmsg []
  (println "\nError retrieving repository information. Perhaps:\n")
  (println "- The supplied filename or URI is invalid, or")
  (println "- Your valid svn authentication credentials are not cached.")
  (println)
  (System/exit 1))

;; Return a newest-first sequence of revision numbers in which the object
;; changed.

(defn get-revlist [opts show object]
  (let [x (java.io.ByteArrayInputStream. (.getBytes (log opts show object)))]
    (for [e (try
              (xml-seq (parse x))
              (catch Exception e (errmsg)))
          :when (seq (:attrs e))]
    (:revision (:attrs e)))))

;; Return a sequence of revision pairs for potential comparison -- e.g. for the
;; revlist (9 8 6 4 1), return (8 9 6 8 4 6 1 4).

(defn get-revpairs [revlist object]
  (interleave (rest revlist) (butlast revlist)))

;; Return a string containing the xml-formatted svn log for the requested
;; object.

(defn log [opts show object]
  (let [cmd-components (if opts ["svn" "log" shhh "--xml" opts object]
                                ["svn" "log" shhh "--xml"      object])]
    (if show (show-cmd cmd-components))
    (print "Fetching log... ")
    (flush)
    (let [result (:out (apply sh cmd-components))]
      (println)
      result)))

;; Obtain a diff from svn for the given object between the specified revisions.
;; Break each diff into blocks (delineated by the text "Index: "), where each
;; block describes one file. The block's first line is the filename, and lines
;; beginning with a single '+' or '-' are the changes. Construct and return a
;; vector of the names of files where the filter term appears on a changed line.
;; If no filter term is given, a changed file automatically matches.

(defn matching-files [r1 r2 object filt show insens]
  (let [raw (:out (diff r1 r2 object show))
        blocks (rest (split raw #"^Index: |\nIndex: "))
        filt (if insens (str "(?i)" filt) filt)]
    (remove nil?
            (into []
                  (for [block blocks]
                    (let [matching-line-in? #(re-matches (re-pattern filt) %)
                          diff-line? #(re-matches #"^[+-][^+-].*" %)
                          strip+- #(clojure.string/replace % #"^[+-]" "")
                          all-lines (split-lines block)
                          diff-lines (filter diff-line? all-lines)
                          changes (map strip+- diff-lines)
                          filename (trim (first all-lines))]
                      (if (some matching-line-in? changes) filename)))))))

;; If the object under investigation is a uri, and if it already ends with the
;; given filename (e.g. when the object names a file) as the absolute pathname.
;; Otherwise (e.g. when the object names a directory), append the filename to
;; the object to form the absolute pathname. If the object is a filesystem name,
;; just use the filename. Construct versioned pathnames and svn diff them.

(defn svndiff [r1 r2 filename object show]
  (let [object (baseobject object)
        re (re-pattern (str "^.*/" filename "$"))
        abs-path (if (uri? object)
            (if (re-matches re object) object (str object "/" filename))
            filename)
        v (vpaths r1 r2 abs-path object)
        cmd-components ["svn" "diff" (first v) (second v)]]
    (if show (show-cmd cmd-components))
    (apply sh cmd-components)))

;; Is path a uri? If it contains :// assume it is.

(defn uri? [path] (re-matches #".*://.*" path))

;; Print usage information.

(defn usage [summary code]
  (println (str "\nUsage: revdiff [options] object [regexp]\n\n  Options:\n"))
  (println (str summary "\n"))
  (println "  object: svn URI or name of versioned object in working-copy")
  (println "  regexp: only show diffs where a changed line matches regexp\n")
  (println "  See https://github.com/maddenp/revdiff for notes on options.\n")
  (System/exit code))

;; If object is a uri, the "-rn:m" revision-range format will not work if object
;; is no longer present in the head revision, in which case we have to use the
;; "object@n object@m" revision-specification format. Return the correctly
;; formatted versioned-path(s) string for use by a diff command.

(defn vpaths [r1 r2 path object]
  (if (uri? object)
    (list (str path "@" r1) (str path "@" r2))
    (list (str "-r" r1 ":" r2) path)))

;; Entry point from command line.

(defn -main [& args]
  (let [{:keys [options arguments summary]} (cli/parse-opts args cliopts)
        object (first arguments)
        filt (or (second arguments) ".*")
        insens (:case-insensitive options)
        optsd (:diff-opts options)
        optsl (:log-opts options)
        show (:show-cmds options)]
    (if (:help options) (usage summary 0))
    (if (not object)
      (usage summary 1)
      (let [revlist (get-revlist optsl show object)
            revpairs (get-revpairs revlist object)]
        (diff-revpairs object filt revpairs show insens)
        (shutdown-agents)))))

fix non-termination bug

fix non-termination bug