(ns com.frereth.common.async-zmq
  "Communicate among 0mq sockets and async channels.

Strongly inspired by lynaghk's zmq-async"
  (:require [cljeromq.core :as mq]
            [clojure.core.async :as async :refer (>! >!!)]
            [clojure.edn :as edn]
            #_[com.frereth.common.communication :as comm]
            [com.frereth.common.schema :as fr-sch]
            [com.frereth.common.util :as util]
            [com.frereth.common.zmq-socket :as zmq-socket]
            [com.stuartsierra.component :as component]
            [full.async :refer (<? <?? alts? go-try)]
            [ribol.core :refer (raise)]
            [schema.core :as s]
            [taoensso.timbre :as log])
  (:import [com.frereth.common.zmq_socket
            ContextWrapper
            SocketDescription]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema

(declare run-async-loop! run-zmq-loop!)
(s/defrecord EventPair
  [_name :- s/Str  ; Because trying to figure out which is what is driving me crazy
   ;; Important for public API
   ;; send messages to this to get them to 0mq. Supplied by caller
   ;; (that's where the messages come from, so that's what's responsible
   ;; for opening/closing)
   in-chan :- fr-sch/async-channel
   ;; faces outside world.
   ;; Caller provides, because binding/connecting is really not in scope here
   ex-sock :- SocketDescription
   ;; 0mq puts messages onto here when they come in from outside
   ;; Owned by this.
   ;; This is the part that you read
   ex-chan :- fr-sch/async-channel

   ;; external-reader and -writer should be simple for
   ;; everything except router/dealer (which is what
   ;; I'll be using, of course).
   ;; dealer really just needs to cope with an empty address
   ;; separator frame
   ;; reader has to handle things like socket registration,
   ;; reconnecting dropped sessions, etc.
   ;; Luckily (?) these are the server writer's problems.
   external-reader :- (s/=> fr-sch/java-byte-array mq/Socket)
   ;; I *think* this returns bool, but, honestly,
   ;; it should return nil
   external-writer :- (s/=> s/Any mq/Socket fr-sch/java-byte-array)

   ;; Really, these are implementation details

   ;; feed this into loops to stop them. Very important  when everything hangs
   ;; Unless you just enjoy sitting around waiting for the JVM to
   ;; restart, of course
   stopper :- s/Symbol
   in<->ex-sock :- mq/InternalPair     ; messages from in-chan to ex-sock flow across these
   ;; It's tempting to make these zmq-socket/Socket instances
   ;; instead.
   ;; But mq/InternalPair was pretty much custom-written for this
   ;; scenario.
   async->sock :- mq/Socket  ; async half of in<->ex-sock
   ->zmq-sock :- mq/Socket ; 0mq half of in<->ex-sock
   async-loop :- fr-sch/async-channel  ; thread where the async event loop is running
   zmq-loop :- fr-sch/async-channel  ; thread where the 0mq event loop is running
   ]
  component/Lifecycle
  (start [this]
    "Set up two entertwined event loops running in background threads.

Their entire purpose in life, really, is to shuffle messages between
0mq and core.async"
         (assert ex-sock "Missing exterior socket")

         ;; I'm torn about in-chan. It seems like it would
         ;; make perfect sense to create it here.
         ;; I shouldn't be, because it wouldn't.
         ;; The thing that writes to it is responsible for
         ;; closing it.
         ;; Something on the inside writes to this channel
         ;; when it wants us to forward the message along to
         ;; the outside world.
         ;; It can close this channel to signal that it's time
         ;; to quit.
         ;; It only makes sense that that's where it gets created
         (assert in-chan "Missing internal async channel")

         ;; Set up default readers/writers
         (let [this (as-> (if external-reader
                            this
                            (assoc this
                                   :external-reader
                                   (fn [sock]
                                     ;; It's tempting to default
                                     ;; to :dont-wait
                                     ;; But we shouldn't ever
                                     ;; try reading this unless
                                     ;; a Poller just verified
                                     ;; that messages are waiting.
                                     (mq/raw-recv! sock :wait))))
                        this
                      (if external-writer
                        this
                        (assoc this
                               :external-writer
                               (fn [sock array-of-bytes]
                                 (mq/send! sock array-of-bytes)))))]
           ;; TODO: Need channel(s) to write to for handling incoming
           ;; messages.
           ;; These can't be in-chan: the entire point to this
           ;; architecture is to do the heavy lifting of both reading
           ;; and writing.
           (let [stopper (gensym)
                 in<->ex-sock (mq/build-internal-pair!
                               (-> ex-sock :ctx :ctx))
                 ex-chan (async/chan)
                 almost-started (assoc this
                                       :stopper stopper
                                       :in<->ex-sock in<->ex-sock
                                       :->zmq-sock (:rhs in<->ex-sock)
                                       :async->sock (:lhs in<->ex-sock)
                                       :ex-chan ex-chan)
                 ;; The choice between lhs and rhs for who gets
                 ;; which of the internal pairs is completely
                 ;; and deliberately arbitrary.
                 ;; Well, I'm thinking in terms of writing left
                 ;; to right and messages originating from the
                 ;; interior more often, but that isn't even
                 ;; vaguely realistic.
                 zmq-loop (run-zmq-loop! almost-started)
                 async-loop (run-async-loop! almost-started)]
             (assoc almost-started
                    :async-loop async-loop
                    :zmq-loop zmq-loop))))
  (stop [this]
        ;; signal the async half of the event loop to exit
        (when async-loop
          (if in-chan
            (let [[v c] (async/alts!! [[in-chan stopper] (async/timeout 750)])]
              (when-not v
                (log/error _name ": Failed to deliver stop message to async channel. Attempting brute force")
                ;; Q: What does this even do?
                (async/close! async-loop)))
            (do
              (log/error _name ": No channel for stopping async loop. Attempting brute force")
              (async/close! async-loop))))

        (if ex-chan
          (async/close! ex-chan)
          (log/info _name ": No ex-chan. Assume this means we weren't actually started"))

        ;; N.B. These status updates are really pretty vital
        ;; and should be logged at the warning level, at the very least
        (comment) (log/debug _name "-- async-zmq Component: Waiting for Asynchronous Event Loop to exit")
        ;; Q: Why is this commented out?
        (comment (let [[async-result c] (async/alts!! [async-loop (async/timeout 1500)])]
                   (if (= c async-loop)
                     (log/debug _name ": Asynchronous event loop exited with a status:\n"
                                (util/pretty async-result))
                     (do
                       (log/warn "Asynchronous event loop failed to exit.
Assume that it failed to signal 0mq loop to exit.
Send a duplicate stopper ("
                                 stopper
                                 ")\nto" async->sock ", a"
                                 (class async->sock))
                       (if stopper
                         (mq/send! async->sock (name stopper) :dont-wait)
                         (log/info _name
                                   ": Missing stopper. Hopefully this means we've already shut down"))))))

        (comment) (log/debug _name ": Waiting for 0mq Event Loop to exit")
        (when zmq-loop
          (let [[zmq-result c] (async/alts!! [zmq-loop (async/timeout 150)])]
            (if (= c zmq-loop)
              (log/debug _name ": 0mq Event Loop exited with status:\n"
                                 (util/pretty zmq-result))
              (log/warn "zmq-loop didn't exit"))))
        (when in<->ex-sock
          (comment) (log/debug _name ": Final cleanup")
          (mq/close-internal-pair! in<->ex-sock))
        (assoc this
               :stopper nil
               :in<->ex-sock nil
               :ex-chan nil
               :async-loop nil
               :zmq-loop nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal

(s/defn serialize :- fr-sch/java-byte-array
  "TODO: This absolutely does not belong in here"
  [o :- s/Any]
  (-> o pr-str .getBytes))

(s/defn deserialize :- s/Any
  "Neither does this"
  [bs :- fr-sch/java-byte-array]
  (let [s (String. bs)]
    (try
      (edn/read-string s)
      (catch RuntimeException ex
        (log/error ex "Failed reading incoming string:\n"
                   (util/pretty s))))))

(s/defn run-async-loop! :- fr-sch/async-channel
  [{:keys [async->sock in-chan _name stopper]} :- EventPair]
  (let [internal-> async->sock]
    (async/go
     (comment) (log/debug "Entering "
                          _name
                          " Async event thread, based on:"
                          in-chan)
     (loop [val (async/<! in-chan)]
       (try
         (if (-> val nil? not)
           (do
             (log/debug _name " Incoming async message:\n"
                        (util/pretty val) "a" (class val)
                        "\nFrom internal. Forwarding to 0mq")
             ;; Have to serialize it here: can't
             ;; send arbitrary data across 0mq sockets
             (mq/send! internal-> (serialize val))
             (log/debug _name ": Message forwarded"))
           (log/info _name ": in-chan closed -- this will end loop"))
         (catch RuntimeException ex
           (log/error ex "Unexpected error in async loop"))
         (catch Exception ex
           (log/error ex "Unexpected bad error in async loop"))
         (catch Throwable ex
           (log/error ex "Things have gotten really bad in the async loop")))
       (when (and val (not= val stopper))
         (recur (<? in-chan)))))
    (log/debug "We either received the stop signal or the internal channel closed")
    :exited-successfully))

(s/defn possibly-recv-internal!
  "Really just refactored to make data flow more clear"
  [{:keys [->zmq-sock external-writer ex-sock]
    :as component} :- EventPair
   poller :- mq/Poller]
  ;; Message over internal notifier socket?
  (if (mq/in-available? poller 1)
    ;; Should almost definitely be using raw-recv! for
    ;; performance.
    ;; Which means the edn/read at the end needs to
    ;; deserialize instead.
    ;; Which probably kills whatever performance gain
    ;; I might hope for.
    ;; TODO: Find a profiler!
    (let [msg (mq/recv! ->zmq-sock)]
      (comment) (log/debug "Forwarding internal message\n"
                           (util/pretty msg)
                           "a" (class msg)
                           "\nfrom 0mq through\n"
                           (util/pretty external-writer))
      ;; Forward it
      ;; TODO: Probably shouldn't forward the
      ;; exit signal, but consider this a test
      ;; of the robustness on the other side,
      ;; for now.
      ;; After all, both sides really have to be
      ;; able to cope with gibberish
      ;; Handling this in here breaks separation
      ;; of concerns and leaves a recv! function
      ;; doing both recv and send.
      ;; TODO: Rename this to proxy and split the
      ;; two halves.
      (try
        (external-writer (:socket ex-sock) msg)
        (catch RuntimeException ex
          (log/error ex)
          (throw)))
      (comment) (log/debug "Message forwarded")
      ;; Do we continue?
      (edn/read-string msg))))

(s/defn possibly-forward-msg-from-outside!
  [{:keys [external-reader ex-sock ex-chan _name]
    :as component} :- EventPair
   poller :- mq/Poller]
  ;; Message coming in from outside?
  (when (mq/in-available? poller 0)
    ;; TODO: Would arguably be more
    ;; efficient to loop over all available
    ;; messages in case several arrive at once.
    ;; The most obvious downside to that approach
    ;; is a DDoS that locks us into that forever
    (let [raw (external-reader (:socket ex-sock))
          msg (deserialize raw)]
      ;; Forward it along
      (log/debug _name " 0mq Loop: Forwarding\n"
                 (util/pretty msg)
                 "a" (class msg)
                 "from outside to async")
      ;; This is actually inside a go block,
      ;; but this is where macros < special
      ;; forms. That go block is structurally
      ;; inside the function that calls this one,
      ;; so there's no way for this one to know
      ;; that we're in it.
      ;; N.B. This blocks the entire message loop
      ;; TODO: Switch to using alts!! and some sort
      ;; of timeout for scenarios where the other
      ;; end can't keep up
      (>!! ex-chan msg)
      (log/debug _name "0mq loop: Message forwarded"))))

(defn actual-zmq-loop
  [component poller]
  (let [stopper (:stopper component)]
    (loop [available-sockets (mq/poll poller -1)]
      (let [received-internal? (possibly-recv-internal! component poller)]
        (log/error "Top of actual-zmq-loop for" (:_name component))
        (log/debug (if received-internal?
                     (str (:_name component) " 0mq: Received Internal:\n"
                          (util/pretty received-internal?))
                     (str (:_name component)
                          " 0mq: must have been a message from external")))
        (if-not (= received-internal? stopper)
          (do
            (log/debug (:_name component) "Wasn't the kill message. Continuing.")
            (possibly-forward-msg-from-outside! component poller)
            (recur (mq/poll poller -1)))
          (log/info (:_name component) "Killed by" received-internal?))))))

(s/defn run-zmq-loop! :- fr-sch/async-channel
  [{:keys [ex-sock ->zmq-sock ex-chan external-reader externalwriter]
    :as component} :- EventPair]
  (let [poller (mq/poller 2)]
    (mq/register-socket-in-poller! poller (:socket ex-sock))
    (mq/register-socket-in-poller! poller ->zmq-sock)
    (go-try
     (comment (log/debug "Entering 0mq event thread"))
     (try
       ;; Move the actual functionality into its own function
       ;; so that it isn't buried here
       (actual-zmq-loop component poller)
       (comment (log/debug "Cleaning up 0mq Event Loop"))
       :exited-successfully
       (catch NullPointerException ex
         (let [tb (->> ex .getStackTrace vec (map #(str % "\n")))
               msg (.getMessage ex)]
           (log/error ex msg "\n" tb))
         :null-pointer-exception)
       (catch RuntimeException ex
         (let [tb (->> ex .getStackTrace vec (map #(str % "\n")))
               msg (.getMessage ex)]
           (log/error ex "0mq Loop: Unhandled Runtime Exception\n" msg "\n" tb)))
       (catch Exception ex
         (let [tb (->> ex .getStackTrace vec (map #(str % "\n")))
               msg (.getMessage ex)]
           (log/error ex "0mq Loop: Unhandled Base Exception\n" msg "\n" tb)))
       (catch Throwable ex
         (let [tb (->> ex .getStackTrace vec (map #(str % "\n")))
               msg (.getMessage ex)]
           (log/error ex "0mq Loop: Unhandled Throwable\n" msg "\n" tb)))
       (finally
         ;; This is probably pointless, but might
         ;; as well do whatever cleanup I can
         (mq/unregister-socket-in-poller! poller (:socket ex-sock))
         (mq/unregister-socket-in-poller! poller ->zmq-sock)
         (comment (log/debug "Exiting 0mq Event Loop")))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Public

(s/defn ctor :- EventPair
  [cfg]
  (map->EventPair cfg))

(ns com.frereth.common.async-zmq
  "Communicate among 0mq sockets and async channels.

Strongly inspired by lynaghk's zmq-async"
  (:require [cljeromq.core :as mq]
            [clojure.core.async :as async :refer (>! >!!)]
            [clojure.edn :as edn]
            #_[com.frereth.common.communication :as comm]
            [com.frereth.common.schema :as fr-sch]
            [com.frereth.common.util :as util]
            [com.frereth.common.zmq-socket :as zmq-socket]
            [com.stuartsierra.component :as component]
            [full.async :refer (<? <?? alts? go-try)]
            [ribol.core :refer (raise)]
            [schema.core :as s]
            [taoensso.timbre :as log])
  (:import [com.frereth.common.zmq_socket
            ContextWrapper
            SocketDescription]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema

(declare run-async-loop! run-zmq-loop!)
(s/defrecord EventPair
  [_name :- s/Str  ; Because trying to figure out which is what is driving me crazy
   ;; Important for public API
   ;; send messages to this to get them to 0mq. Supplied by caller
   ;; (that's where the messages come from, so that's what's responsible
   ;; for opening/closing)
   in-chan :- fr-sch/async-channel
   ;; faces outside world.
   ;; Caller provides, because binding/connecting is really not in scope here
   ex-sock :- SocketDescription
   ;; 0mq puts messages onto here when they come in from outside
   ;; Owned by this.
   ;; This is the part that you read
   ex-chan :- fr-sch/async-channel

   ;; external-reader and -writer should be simple for
   ;; everything except router/dealer (which is what
   ;; I'll be using, of course).
   ;; dealer really just needs to cope with an empty address
   ;; separator frame
   ;; reader has to handle things like socket registration,
   ;; reconnecting dropped sessions, etc.
   ;; Luckily (?) these are the server writer's problems.
   external-reader :- (s/=> fr-sch/java-byte-array mq/Socket)
   ;; I *think* this returns bool, but, honestly,
   ;; it should return nil
   external-writer :- (s/=> s/Any mq/Socket fr-sch/java-byte-array)

   ;; Really, these are implementation details

   ;; feed this into loops to stop them. Very important  when everything hangs
   ;; Unless you just enjoy sitting around waiting for the JVM to
   ;; restart, of course
   stopper :- s/Symbol
   in<->ex-sock :- mq/InternalPair     ; messages from in-chan to ex-sock flow across these
   ;; It's tempting to make these zmq-socket/Socket instances
   ;; instead.
   ;; But mq/InternalPair was pretty much custom-written for this
   ;; scenario.
   async->sock :- mq/Socket  ; async half of in<->ex-sock
   ->zmq-sock :- mq/Socket ; 0mq half of in<->ex-sock
   async-loop :- fr-sch/async-channel  ; thread where the async event loop is running
   zmq-loop :- fr-sch/async-channel  ; thread where the 0mq event loop is running
   ]
  component/Lifecycle
  (start [this]
    "Set up two entertwined event loops running in background threads.

Their entire purpose in life, really, is to shuffle messages between
0mq and core.async"
         (assert ex-sock "Missing exterior socket")

         ;; I'm torn about in-chan. It seems like it would
         ;; make perfect sense to create it here.
         ;; I shouldn't be, because it wouldn't.
         ;; The thing that writes to it is responsible for
         ;; closing it.
         ;; Something on the inside writes to this channel
         ;; when it wants us to forward the message along to
         ;; the outside world.
         ;; It can close this channel to signal that it's time
         ;; to quit.
         ;; It only makes sense that that's where it gets created
         (assert in-chan "Missing internal async channel")

         ;; Set up default readers/writers
         (let [this (as-> (if external-reader
                            this
                            (assoc this
                                   :external-reader
                                   (fn [sock]
                                     ;; It's tempting to default
                                     ;; to :dont-wait
                                     ;; But we shouldn't ever
                                     ;; try reading this unless
                                     ;; a Poller just verified
                                     ;; that messages are waiting.
                                     (mq/raw-recv! sock :wait))))
                        this
                      (if external-writer
                        this
                        (assoc this
                               :external-writer
                               (fn [sock array-of-bytes]
                                 (mq/send! sock array-of-bytes)))))]
           ;; TODO: Need channel(s) to write to for handling incoming
           ;; messages.
           ;; These can't be in-chan: the entire point to this
           ;; architecture is to do the heavy lifting of both reading
           ;; and writing.
           (let [stopper (gensym)
                 in<->ex-sock (mq/build-internal-pair!
                               (-> ex-sock :ctx :ctx))
                 ex-chan (async/chan)
                 almost-started (assoc this
                                       :stopper stopper
                                       :in<->ex-sock in<->ex-sock
                                       :->zmq-sock (:rhs in<->ex-sock)
                                       :async->sock (:lhs in<->ex-sock)
                                       :ex-chan ex-chan)
                 ;; The choice between lhs and rhs for who gets
                 ;; which of the internal pairs is completely
                 ;; and deliberately arbitrary.
                 ;; Well, I'm thinking in terms of writing left
                 ;; to right and messages originating from the
                 ;; interior more often, but that isn't even
                 ;; vaguely realistic.
                 zmq-loop (run-zmq-loop! almost-started)
                 async-loop (run-async-loop! almost-started)]
             (assoc almost-started
                    :async-loop async-loop
                    :zmq-loop zmq-loop))))
  (stop [this]
        ;; signal the async half of the event loop to exit
        (when async-loop
          (if in-chan
            (let [[v c] (async/alts!! [[in-chan stopper] (async/timeout 750)])]
              (when-not v
                (log/error _name ": Failed to deliver stop message to async channel. Attempting brute force")
                ;; Q: What does this even do?
                (async/close! async-loop)))
            (do
              (log/error _name ": No channel for stopping async loop. Attempting brute force")
              (async/close! async-loop))))

        (if ex-chan
          (async/close! ex-chan)
          (log/info _name ": No ex-chan. Assume this means we weren't actually started"))

        ;; N.B. These status updates are really pretty vital
        ;; and should be logged at the warning level, at the very least
        (comment) (log/debug _name "-- async-zmq Component: Waiting for Asynchronous Event Loop to exit")
        ;; Q: Why is this commented out?
        (comment (let [[async-result c] (async/alts!! [async-loop (async/timeout 1500)])]
                   (if (= c async-loop)
                     (log/debug _name ": Asynchronous event loop exited with a status:\n"
                                (util/pretty async-result))
                     (do
                       (log/warn "Asynchronous event loop failed to exit.
Assume that it failed to signal 0mq loop to exit.
Send a duplicate stopper ("
                                 stopper
                                 ")\nto" async->sock ", a"
                                 (class async->sock))
                       (if stopper
                         (mq/send! async->sock (name stopper) :dont-wait)
                         (log/info _name
                                   ": Missing stopper. Hopefully this means we've already shut down"))))))

        (comment) (log/debug _name ": Waiting for 0mq Event Loop to exit")
        (when zmq-loop
          (let [[zmq-result c] (async/alts!! [zmq-loop (async/timeout 150)])]
            (if (= c zmq-loop)
              (log/debug _name ": 0mq Event Loop exited with status:\n"
                                 (util/pretty zmq-result))
              (log/warn "zmq-loop didn't exit"))))
        (when in<->ex-sock
          (comment) (log/debug _name ": Final cleanup")
          (mq/close-internal-pair! in<->ex-sock))
        (assoc this
               :stopper nil
               :in<->ex-sock nil
               :ex-chan nil
               :async-loop nil
               :zmq-loop nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal

(s/defn serialize :- fr-sch/java-byte-array
  "TODO: This absolutely does not belong in here"
  [o :- s/Any]
  (-> o pr-str .getBytes))

(s/defn deserialize :- s/Any
  "Neither does this"
  [bs :- fr-sch/java-byte-array]
  (let [s (String. bs)]
    (try
      (edn/read-string s)
      (catch RuntimeException ex
        (log/error ex "Failed reading incoming string:\n"
                   (util/pretty s))))))

(s/defn run-async-loop! :- fr-sch/async-channel
  [{:keys [async->sock in-chan _name stopper]} :- EventPair]
  (let [internal-> async->sock]
    (async/go
      (log/debug "Entering "
                 _name
                 " Async event thread, based on:"
                 in-chan)
      (loop [val (async/<! in-chan)]
        (try
          (if (-> val nil? not)
            (do
              (log/debug _name " Incoming async message:\n"
                         (util/pretty val) "a" (class val)
                         "\nFrom internal. Forwarding to 0mq")
              ;; Have to serialize it here: can't
              ;; send arbitrary data across 0mq sockets
              (mq/send! internal-> (serialize val))
              (log/debug _name ": Message forwarded"))
            (log/info _name ": in-chan closed -- this will end loop"))
          (catch RuntimeException ex
            (log/error ex "Unexpected error in async loop"))
          (catch Exception ex
            (log/error ex "Unexpected bad error in async loop"))
          (catch Throwable ex
            (log/error ex "Things have gotten really bad in the async loop")))
        (when (and val (not= val stopper))
          (recur (<? in-chan))))
      (log/debug "We either received the stop signal or the internal channel closed"))
    :exited-successfully))

(s/defn possibly-recv-internal!
  "Really just refactored to make data flow more clear"
  [{:keys [->zmq-sock external-writer ex-sock]
    :as component} :- EventPair
   poller :- mq/Poller]
  ;; Message over internal notifier socket?
  (if (mq/in-available? poller 1)
    ;; Should almost definitely be using raw-recv! for
    ;; performance.
    ;; Which means the edn/read at the end needs to
    ;; deserialize instead.
    ;; Which probably kills whatever performance gain
    ;; I might hope for.
    ;; TODO: Find a profiler!
    (let [msg (mq/recv! ->zmq-sock)]
      (comment) (log/debug "Forwarding internal message\n"
                           (util/pretty msg)
                           "a" (class msg)
                           "\nfrom 0mq through\n"
                           (util/pretty external-writer))
      ;; Forward it
      ;; TODO: Probably shouldn't forward the
      ;; exit signal, but consider this a test
      ;; of the robustness on the other side,
      ;; for now.
      ;; After all, both sides really have to be
      ;; able to cope with gibberish
      ;; Handling this in here breaks separation
      ;; of concerns and leaves a recv! function
      ;; doing both recv and send.
      ;; TODO: Rename this to proxy and split the
      ;; two halves.
      (try
        (external-writer (:socket ex-sock) msg)
        (catch RuntimeException ex
          (log/error ex)
          (throw)))
      (comment) (log/debug "Message forwarded")
      ;; Do we continue?
      (edn/read-string msg))))

(s/defn possibly-forward-msg-from-outside!
  [{:keys [external-reader ex-sock ex-chan _name]
    :as component} :- EventPair
   poller :- mq/Poller]
  ;; Message coming in from outside?
  (when (mq/in-available? poller 0)
    ;; TODO: Would arguably be more
    ;; efficient to loop over all available
    ;; messages in case several arrive at once.
    ;; The most obvious downside to that approach
    ;; is a DDoS that locks us into that forever
    (let [raw (external-reader (:socket ex-sock))
          msg (deserialize raw)]
      ;; Forward it along
      (log/debug _name " 0mq Loop: Forwarding\n"
                 (util/pretty msg)
                 "a" (class msg)
                 "from outside to async")
      ;; This is actually inside a go block,
      ;; but this is where macros < special
      ;; forms. That go block is structurally
      ;; inside the function that calls this one,
      ;; so there's no way for this one to know
      ;; that we're in it.
      ;; N.B. This blocks the entire message loop
      ;; TODO: Switch to using alts!! and some sort
      ;; of timeout for scenarios where the other
      ;; end can't keep up
      (>!! ex-chan msg)
      (log/debug _name "0mq loop: Message forwarded"))))

(defn actual-zmq-loop
  [component poller]
  (let [stopper (:stopper component)]
    (loop [available-sockets (mq/poll poller -1)]
      (let [received-internal? (possibly-recv-internal! component poller)]
        (log/error "Top of actual-zmq-loop for" (:_name component))
        (log/debug (if received-internal?
                     (str (:_name component) " 0mq: Received Internal:\n"
                          (util/pretty received-internal?))
                     (str (:_name component)
                          " 0mq: must have been a message from external")))
        (if-not (= received-internal? stopper)
          (do
            (log/debug (:_name component) "Wasn't the kill message. Continuing.")
            (possibly-forward-msg-from-outside! component poller)
            (recur (mq/poll poller -1)))
          (log/info (:_name component) "Killed by" received-internal?))))))

(s/defn run-zmq-loop! :- fr-sch/async-channel
  [{:keys [ex-sock ->zmq-sock ex-chan external-reader externalwriter]
    :as component} :- EventPair]
  (let [poller (mq/poller 2)]
    (mq/register-socket-in-poller! poller (:socket ex-sock))
    (mq/register-socket-in-poller! poller ->zmq-sock)
    (go-try
     (comment (log/debug "Entering 0mq event thread"))
     (try
       ;; Move the actual functionality into its own function
       ;; so that it isn't buried here
       (actual-zmq-loop component poller)
       (comment (log/debug "Cleaning up 0mq Event Loop"))
       :exited-successfully
       (catch NullPointerException ex
         (let [tb (->> ex .getStackTrace vec (map #(str % "\n")))
               msg (.getMessage ex)]
           (log/error ex msg "\n" tb))
         :null-pointer-exception)
       (catch RuntimeException ex
         (let [tb (->> ex .getStackTrace vec (map #(str % "\n")))
               msg (.getMessage ex)]
           (log/error ex "0mq Loop: Unhandled Runtime Exception\n" msg "\n" tb)))
       (catch Exception ex
         (let [tb (->> ex .getStackTrace vec (map #(str % "\n")))
               msg (.getMessage ex)]
           (log/error ex "0mq Loop: Unhandled Base Exception\n" msg "\n" tb)))
       (catch Throwable ex
         (let [tb (->> ex .getStackTrace vec (map #(str % "\n")))
               msg (.getMessage ex)]
           (log/error ex "0mq Loop: Unhandled Throwable\n" msg "\n" tb)))
       (finally
         ;; This is probably pointless, but might
         ;; as well do whatever cleanup I can
         (mq/unregister-socket-in-poller! poller (:socket ex-sock))
         (mq/unregister-socket-in-poller! poller ->zmq-sock)
         (comment (log/debug "Exiting 0mq Event Loop")))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Public

(s/defn ctor :- EventPair
  [cfg]
  (map->EventPair cfg))

Move the async loop exit log message

Move the async loop exit log message

It needs to happen after the actual loop ends, but still inside the go
block. Otherwise it claims to exit long before it actually does.


(defproject org.example/sample "1.0.0-SNAPSHOT" ; version "1.0.0-SNAPSHOT"
  :description "A sample project"
  :url "http://example.org/sample-clojure-project"
  :min-lein-version "2.0.0"
  :profiles {:dev {:dependencies [[junit/junit "4.11"]]}}
  :dependencies [[org.clojure/clojure "1.6.0"] [junit/junit "4.11"]]
  :pedantic? :abort
  :plugins [[lein-junit "1.1.8"]]
  :repositories [["java.net" "http://download.java.net/maven/2"]]
  :update :never
  :checksum :fail
  :source-paths ["src" "src/main/clojure"]
  ;; not sure how to
  :java-source-paths ["src/main/java" "src/test/java"]  ; Java source is stored separately.
  :test-paths ["test" "src/test/clojure"]
  :junit ["src/test/java"]
  :resource-paths ["src/main/resource"] ; Non-code files included in classpath/jar.
  :target-path "target/%s/"
  :clean-targets [:target-path :compile-path "out"]
  ;;; Jar Output
  ;; Name of the jar file produced. Will be placed inside :target-path.
  ;; Including %s will splice the project version into the filename.
  :jar-name "example.jar"
  :auto-clean false)

(defproject org.example/sample "1.0.0-SNAPSHOT" ; version "1.0.0-SNAPSHOT"
  :description "A sample project"
  :url "http://example.org/sample-clojure-project"
  :min-lein-version "2.0.0"
  :profiles {:dev {:dependencies [[junit/junit "4.11"]]}}
  :dependencies [[org.clojure/clojure "1.6.0"] [junit/junit "4.11"]]
  :pedantic? :abort
  :plugins [[lein-junit "1.1.8"]]
  :repositories [["java.net" "http://download.java.net/maven/2"]]
  :update :never
  :checksum :fail
  :source-paths ["src/main/clojure"]
  :java-source-paths ["src/main/java"]  ; Java source is stored separately.
  :test-paths ["src/test/clojure"]
  :junit ["src/test/java"]
  ;; regex magic to include all *Test.java, but no *AbstractTest.java
  :junit-test-file-pattern #"^((?!Abstract).)*Test.java$"
  :resource-paths ["src/test/resources" "src/main/resources"] ; Non-code files included in classpath/jar.
  :target-path "target/%s/"
  :clean-targets [:target-path :compile-path "out"]
  ;;; Jar Output
  ;; Name of the jar file produced. Will be placed inside :target-path.
  ;; Including %s will splice the project version into the filename.
  :jar-name "example.jar"
  :auto-clean false)

fix leiningen

fix leiningen


(ns braid.core.server.middleware
  (:require
   [braid.base.conf :refer [config]]
   [mount.core :as mount :refer [defstate]]
   [ring.middleware.cors :refer [wrap-cors]]
   [ring.middleware.session :refer [wrap-session]]
   [taoensso.timbre :as timbre]))

(def session-max-age (* 60 60 24 365))

(def session-store
  (delay
    (if (config :redis-uri)
      (do
        (require 'taoensso.carmine.ring)
        (let [carmine-store (ns-resolve 'taoensso.carmine.ring 'carmine-store)
              redis-conf {:pool {}
                          :spec {:uri (config :redis-uri)}} ]
          (carmine-store redis-conf {:expiration-secs session-max-age
                                     :key-prefix "braid"})))
      (do
        (require 'ring.middleware.session.cookie)
        (let [cookie-store (ns-resolve 'ring.middleware.session.cookie
                                       'cookie-store)]
          (cookie-store))))))

(def session-config
  (delay {:cookie-name "braid",
          :cookie-attrs {:secure (cond
                                   (config :http-only) false
                                   (= (config :environment) "prod") true
                                   :else false)
                         :max-age session-max-age},
          :store @session-store}))

(defn- wrap-log-requests
  [handler]
  (fn [{uri :uri method :request-method :as request}]
    (let [t0 (System/currentTimeMillis)
          {:keys [status] :as response} (handler request)]
      (timbre/debugf "[%s +%4dms] %8.8s %s"
                     status (- (System/currentTimeMillis) t0) method uri)
      response)))

;; Here we define the universal (as opposed to route-specific) middleware stack.
(defn wrap-universal-middleware
  "Wrap the handler with middleware that is universally applicable across the site."
  [handler {:keys [session]}]
  (-> handler
      (wrap-cors :access-control-allow-origin
                 (->>
                   [(when-let [site (config :site-url)]
                      (re-pattern (java.util.regex.Pattern/quote site)))
                    (when-let [mobile-site (config :mobile-site-url)]
                      (re-pattern (java.util.regex.Pattern/quote mobile-site)))
                    #"http://localhost:\d+"]
                   (remove nil?))
                 :access-control-allow-credentials true
                 :access-control-allow-methods [:get :put :post :delete])
      (wrap-session (or session @session-config))
      wrap-log-requests))

(ns braid.core.server.middleware
  (:require
   [braid.base.conf :refer [config]]
   [ring.middleware.cors :refer [wrap-cors]]
   [ring.middleware.session :refer [wrap-session]]
   [taoensso.timbre :as timbre]))

(def session-max-age (* 60 60 24 365))

(def session-store
  (delay
    (if (config :redis-uri)
      (do
        (require 'taoensso.carmine.ring)
        (let [carmine-store (ns-resolve 'taoensso.carmine.ring 'carmine-store)
              redis-conf {:pool {}
                          :spec {:uri (config :redis-uri)}} ]
          (carmine-store redis-conf {:expiration-secs session-max-age
                                     :key-prefix "braid"})))
      (do
        (require 'ring.middleware.session.cookie)
        (let [cookie-store (ns-resolve 'ring.middleware.session.cookie
                                       'cookie-store)]
          (cookie-store))))))

(def session-config
  (delay {:cookie-name "braid",
          :cookie-attrs {:secure (cond
                                   (config :http-only) false
                                   (= (config :environment) "prod") true
                                   :else false)
                         :max-age session-max-age},
          :store @session-store}))

(defn- wrap-log-requests
  [handler]
  (fn [{uri :uri method :request-method :as request}]
    (let [t0 (System/currentTimeMillis)
          {:keys [status] :as response} (handler request)]
      (timbre/debugf "[%s +%4dms] %8.8s %s"
                     status (- (System/currentTimeMillis) t0) method uri)
      response)))

;; Here we define the universal (as opposed to route-specific) middleware stack.
(defn wrap-universal-middleware
  "Wrap the handler with middleware that is universally applicable across the site."
  [handler {:keys [session]}]
  (-> handler
      (wrap-cors :access-control-allow-origin
                 (->>
                   [(when-let [site (config :site-url)]
                      (re-pattern (java.util.regex.Pattern/quote site)))
                    (when-let [mobile-site (config :mobile-site-url)]
                      (re-pattern (java.util.regex.Pattern/quote mobile-site)))
                    #"http://localhost:\d+"]
                   (remove nil?))
                 :access-control-allow-credentials true
                 :access-control-allow-methods [:get :put :post :delete])
      (wrap-session (or session @session-config))
      wrap-log-requests))

Remove unused require

Remove unused require


(ns caesium.magicnonce.secretbox
  "\"Magic\" nonce schemes for secretbox.

  There are two kinds of schemes in this namespace:

   * schemes that take a nonce, but do something with it to make the
     resulting system safer or easier to use,
   * schemes that produce the nonce for you automatically.

  See individual function docstrings for details, but the most
  interesting function in this namespace is [[secretbox-nmr]]. If you
  just want a random nonce and do not care about nonce-misuse
  resistance, use [[secretbox-rnd]]. The other functions are fairly
  limited use.")

(defn secretbox-pfx
  "secretbox, with the given nonce embedded in the ciphertext as a prefix.

  This is only useful if there is an obvious nonce in your protocol
  that can not repeat, you have ways of detecting when your peer
  epeats nonces, your nonce is not implicitly part of your protocol so
  you have to specify it as part of the ciphertext, and you can not
  afford to use a nonce-misuse resistant scheme. As you can see,
  that's a fairly rare circumstance; this function is mainly used
  internally by other, easier to use schemes in this namespace. Check
  out [[secretbox-nmr]] instead.

  The resulting layout will be 24 bytes of nonce, followed by the
  secretbox ciphertext (which itself consists of the encryption of the
  plaintext, followed by a 16 byte MAC).

  To decrypt, use [[decrypt]] or [[open]], depending on which argument order
  you prefer."
  [msg nonce key])
(defn ^:private random-nonce!
  "Creates a random nonce suitable for use in secretbox.

  This function is not pure: it will request a different random nonce from
  the CSPRNG every time."
  [])

(defn secretbox-rnd
  "secretbox, with randomized prefix nonce.

  This is useful if you don't have an obvious nonce in your protocol
  you can use. However, it does rely on having a cryptographically
  secure CSPRNG available during encryption. It is *not* nonce-misuse
  resistant. Unless you can't afford the minor performance penalty for
  a nonce-misuse resistant scheme, consider using [[secretbox-nmr]].

  To decrypt, use [[decrypt]] or [[open]], depending on which argument
  order you prefer."
  [msg key])

(defn ^:private synthetic-nonce
  "Creates a synthetic nonce from the given plaintext.

  This function is pure in the sense that it is deterministic and has
  no visible side effects: the same plaintext will always generate the
  same byte array. However, note that the returned nonce will be a
  mutable byte array."
  [plaintext])

(defn ^:private xor!
  "Populates `out` with the XOR of matching elements in `a`, `b`.

  All three arrays should be of identical length. Returns `out`."
  [^bytes out ^bytes a ^bytes b]
  (dotimes [i (alength a)]
    (aset-byte out i (bit-xor (aget a i) (aget b i))))
  out)

(defn ^:private xor-inplace!
  "XORs elements of array `a` in-place with the matching elem from `b`."
  [^bytes a ^bytes b]
  (xor! a a b))

(defn secretbox-det
  "secretbox, with deterministic nonce.

  This means the encryption operation requires no new randomness; it
  is a fully deterministic cryptosystem. This means identical
  plaintexts will map to identical ciphertexts. That has to be
  acceptable for your protocol!

  Because the nonce is determined from the plaintext, adding any
  non-determinism to your message will make the nonce not repeat and
  hence hide repeated messages from the attacker. A high-resolution
  timestamp will do that effectively in most cases.

  This scheme does not change the requirements for the key: the key
  must still be a cryptographically random byte array of appropriate
  size ([[caesium.crypto.secretbox/keybytes]]).

  Unless you know for sure that repeat messages are OK or that your
  messages will not repeat or you can't rely on encryption-time
  randomness, consider [[secrebox-nmr]].

  To decrypt, use [[decrypt]] or [[open]], depending on which argument order
  you prefer."
  [msg key])

(defn secretbox-nmr
  "Encrypt a message like secretbox, but nonce-misuse resistant.

  This still optionally takes a nonce, but that nonce will be combined
  with a synthetic nonce. This means that if the nonce incidentally
  repeats, an attacker will only be able to tell that a message
  repeated, instead of the usual plaintext disclosure that happens.

  If no nonce argument is specified, a random nonce is automatically
  selected for you, and the NMR scheme is applied on top of that."
  ([msg nonce key])
  ([msg key]
   (secretbox-nmr msg (random-nonce!) key)))

(defn decrypt-to-buf!
  "Decrypts any secretbox message with a prefix nonce into the given buffer."
  [out key ctext])

(defn decrypt
  "Decrypts any secretbox message with a prefix nonce."
  [key ctext])

(defn open-to-buf!
  "Open (decrypt and verify) a nonce-prefixed secretbox message."
  [out ctext key])

(defn open
  "Like [[decrypt]], but with different argument order; analogous to
  [[caesium.crypto.secretbox/secretbox-open-easy]]."
  [ctext key])

(ns caesium.magicnonce.secretbox
  "\"Magic\" nonce schemes for secretbox.

  There are two kinds of schemes in this namespace:

   * schemes that take a nonce, but do something with it to make the
     resulting system safer or easier to use,
   * schemes that produce the nonce for you automatically.

  See individual function docstrings for details, but the most
  interesting function in this namespace is [[secretbox-nmr]]. If you
  just want a random nonce and do not care about nonce-misuse
  resistance, use [[secretbox-rnd]]. The other functions are fairly
  limited use."
  (:require [caesium.crypto.secretbox :as s])
  (:import [java.nio ByteBuffer]))

(defn secretbox-pfx
  "secretbox, with the given nonce embedded in the ciphertext as a prefix.

  This is only useful if there is an obvious nonce in your protocol
  that can not repeat, you have ways of detecting when your peer
  epeats nonces, your nonce is not implicitly part of your protocol so
  you have to specify it as part of the ciphertext, and you can not
  afford to use a nonce-misuse resistant scheme. As you can see,
  that's a fairly rare circumstance; this function is mainly used
  internally by other, easier to use schemes in this namespace. Check
  out [[secretbox-nmr]] instead.

  The resulting layout will be 24 bytes of nonce, followed by the
  secretbox ciphertext (which itself consists of the encryption of the
  plaintext, followed by a 16 byte MAC).

  To decrypt, use [[decrypt]] or [[open]], depending on which argument order
  you prefer."
  [msg nonce key]
  (let [msglen (alength ^bytes msg)
        ctextlen (+ msglen s/macbytes)
        outlen (+ s/noncebytes ctextlen)
        out (byte-array outlen)
        ctextbuf (ByteBuffer/wrap out s/noncebytes ctextlen)]
    (System/arraycopy nonce 0 out 0 s/noncebytes)
    (s/secretbox-easy-to-byte-buf! ctextbuf msg nonce key)
    out))

(defn ^:private random-nonce!
  "Creates a random nonce suitable for use in secretbox.

  This function is not pure: it will request a different random nonce from
  the CSPRNG every time."
  [])

(defn secretbox-rnd
  "secretbox, with randomized prefix nonce.

  This is useful if you don't have an obvious nonce in your protocol
  you can use. However, it does rely on having a cryptographically
  secure CSPRNG available during encryption. It is *not* nonce-misuse
  resistant. Unless you can't afford the minor performance penalty for
  a nonce-misuse resistant scheme, consider using [[secretbox-nmr]].

  To decrypt, use [[decrypt]] or [[open]], depending on which argument
  order you prefer."
  [msg key])

(defn ^:private synthetic-nonce
  "Creates a synthetic nonce from the given plaintext.

  This function is pure in the sense that it is deterministic and has
  no visible side effects: the same plaintext will always generate the
  same byte array. However, note that the returned nonce will be a
  mutable byte array."
  [plaintext])

(defn ^:private xor!
  "Populates `out` with the XOR of matching elements in `a`, `b`.

  All three arrays should be of identical length. Returns `out`."
  [^bytes out ^bytes a ^bytes b]
  (dotimes [i (alength a)]
    (aset-byte out i (bit-xor (aget a i) (aget b i))))
  out)

(defn ^:private xor-inplace!
  "XORs elements of array `a` in-place with the matching elem from `b`."
  [^bytes a ^bytes b]
  (xor! a a b))

(defn secretbox-det
  "secretbox, with deterministic nonce.

  This means the encryption operation requires no new randomness; it
  is a fully deterministic cryptosystem. This means identical
  plaintexts will map to identical ciphertexts. That has to be
  acceptable for your protocol!

  Because the nonce is determined from the plaintext, adding any
  non-determinism to your message will make the nonce not repeat and
  hence hide repeated messages from the attacker. A high-resolution
  timestamp will do that effectively in most cases.

  This scheme does not change the requirements for the key: the key
  must still be a cryptographically random byte array of appropriate
  size ([[caesium.crypto.secretbox/keybytes]]).

  Unless you know for sure that repeat messages are OK or that your
  messages will not repeat or you can't rely on encryption-time
  randomness, consider [[secrebox-nmr]].

  To decrypt, use [[decrypt]] or [[open]], depending on which argument order
  you prefer."
  [msg key])

(defn secretbox-nmr
  "Encrypt a message like secretbox, but nonce-misuse resistant.

  This still optionally takes a nonce, but that nonce will be combined
  with a synthetic nonce. This means that if the nonce incidentally
  repeats, an attacker will only be able to tell that a message
  repeated, instead of the usual plaintext disclosure that happens.

  If no nonce argument is specified, a random nonce is automatically
  selected for you, and the NMR scheme is applied on top of that."
  ([msg nonce key])
  ([msg key]
   (secretbox-nmr msg (random-nonce!) key)))

(defn decrypt-to-buf!
  "Decrypts any secretbox message with a prefix nonce into the given buffer."
  [out key ctext])

(defn decrypt
  "Decrypts any secretbox message with a prefix nonce."
  [key ctext])

(defn open-to-buf!
  "Open (decrypt and verify) a nonce-prefixed secretbox message."
  [out ctext key])

(defn open
  "Like [[decrypt]], but with different argument order; analogous to
  [[caesium.crypto.secretbox/secretbox-open-easy]]."
  [ctext key])

Add an impl for secretbox-pfx

Add an impl for secretbox-pfx


; Copyright (C) 2013, 2014, 2015 Dr. Thomas Schank  (DrTom@schank.ch, Thomas.Schank@algocon.ch)
; Licensed under the terms of the GNU Affero General Public License v3.
; See the "LICENSE.txt" file provided with this software.

(ns cider-ci.dispatcher.dispatch
  (:require
    [cider-ci.dispatcher.executor :as executor-utils]
    [cider-ci.dispatcher.task :as task]
    [cider-ci.dispatcher.trial :as trial-utils]
    [cider-ci.utils.config :refer [get-config]]
    [cider-ci.utils.daemon :as daemon]
    [drtom.logbug.debug :as debug]
    [cider-ci.utils.http :as http]
    [cider-ci.utils.rdbms :as rdbms]
    [drtom.logbug.catcher :as catcher]
    [clj-http.client :as http-client]
    [clj-logging-config.log4j :as logging-config]
    [clojure.data.json :as json]
    [clojure.java.jdbc :as jdbc]
    [clojure.tools.logging :as logging]
    [honeysql.core :as hc]
    [honeysql.helpers :as hh]
    [robert.hooke :as hooke]
    ))

;### build urls ###############################################################

(defn- git-path [repository-id]
  (http/build-service-path :repository (str "/" repository-id "/git")))

(defn- git-url [repository-id]
  ( ->
    (jdbc/query
      (rdbms/get-ds)
      ["SELECT origin_uri FROM repositories WHERE id = ?" repository-id])
    first
    :origin_uri))

(defn- trial-attachments-path [trial-id]
  (http/build-service-path :storage  (str "/trial-attachments/" trial-id "/")))

(defn- tree-attachments-path [tree-id]
  (http/build-service-path :storage  (str "/tree-attachments/" tree-id "/")))

(defn- patch-path [executor trial-id]
  (http/build-service-path :dispatcher (str "/trials/" trial-id )))

;### dispatch data ############################################################
(defn get-branch-and-commit [job-id]
  (first (jdbc/query (rdbms/get-ds)
           ["SELECT branches.name, branches.repository_id,
              commits.tree_id as tree_id,
              commits.id as git_commit_id FROM branches
            INNER JOIN branches_commits ON branches.id = branches_commits.branch_id
            INNER JOIN commits ON branches_commits.commit_id = commits.id
            INNER JOIN jobs ON commits.tree_id = jobs.tree_id
            WHERE jobs.id = ?
            ORDER BY branches.updated_at DESC" job-id])))

(defn add-git-url [data repository-id]
  (conj data
        {:git_path (git-path repository-id)
         :git_url (git-url repository-id) }))

(defn build-dispatch-data [trial executor]
  (let [task (first (jdbc/query (rdbms/get-ds)
                                ["SELECT * FROM tasks WHERE tasks.id = ?" (:task_id trial)]))
        task-spec (task/get-task-spec (:id task))
        job-id (:job_id task)
        branch-and-commit (get-branch-and-commit job-id)
        tree-id (:tree_id branch-and-commit)
        repository-id (:repository_id branch-and-commit)
        trial-id (:id trial)
        environment-variables (conj (or (:environment_variables task-spec) {})
                                    {:CIDER_CI_EXECUTION_ID job-id
                                     :CIDER_CI_TASK_ID (:task_id trial)
                                     :CIDER_CI_TRIAL_ID trial-id
                                     :CIDER_CI_TREE_ID (:tree_id branch-and-commit)})
        data {
              :environment_variables environment-variables
              :job_id job-id
              :git_branch_name (:name branch-and-commit)
              :git_commit_id (:git_commit_id branch-and-commit)
              :git_options (or (:git_options task-spec) {})
              :git_tree_id (:tree_id branch-and-commit)
              :patch_path (patch-path executor trial-id)
              :ports (:ports task-spec)
              :repository_id repository-id
              :scripts (:scripts trial)
              :task_id (:task_id trial)
              :tree_attachments (:tree_attachments task-spec)
              :tree_attachments_path (tree-attachments-path tree-id)
              :trial_attachments (:trial_attachments task-spec)
              :trial_attachments_path (trial-attachments-path trial-id)
              :trial_id trial-id
              }]
    (-> data
        (add-git-url repository-id))))

;### dispatch #################################################################

(defn choose-executor-to-dispatch-to [trial]
  (->> (-> (hh/select :executors_with_load.*)
           (hh/from :trials)
           (hh/where [:= :trials.id (:id trial)])
           (hh/merge-join :tasks [:= :tasks.id :trials.task_id])
           (hh/merge-join :executors_with_load (hc/raw "(tasks.traits <@ executors_with_load.traits)"))
           (hh/merge-where (hc/raw "(last_ping_at > (now() - interval '1 Minutes'))"))
           (hh/merge-where [:= :enabled true])
           (hh/merge-where [:< :relative_load 1])
           hc/format)
       (jdbc/query (rdbms/get-ds))
       (map (fn [e] (repeat (- (:max_load e) (:current_load e)) e)))
       flatten rand-nth))

(defn get-next-trial-to-be-dispatched []
  (-> (-> (hh/select :trials.*)
          (hh/from :trials)
          (hh/merge-where [:= :trials.state "pending"])
          (hh/merge-where [:exists  (-> (hh/select 1 )
                                        (hh/from :executors_with_load)
                                        (hh/merge-where [:< :relative_load 1])
                                        (hh/merge-where [:= :enabled true])
                                        (hh/merge-where (hc/raw "(tasks.traits <@ executors_with_load.traits)"))
                                        (hh/merge-where (hc/raw "(last_ping_at > (now() - interval '1 Minutes'))"))
                                        )])
          (hh/merge-where [ "NOT EXISTS" (-> (hh/select 1)
                                             (hh/from [:trials :active_trials])
                                             (hh/merge-join [:tasks :active_tasks] [:= :active_tasks.id :active_trials.task_id])
                                             (hh/merge-where [:in :active_trials.state  ["executing","dispatching"]])
                                             (hh/merge-where (hc/raw "active_tasks.exclusive_resources && tasks.exclusive_resources")))])
          (hh/merge-join :tasks [:= :tasks.id :trials.task_id])
          (hh/merge-join :jobs [:= :jobs.id :tasks.job_id])
          (hh/order-by [:jobs.priority :desc]
                       [:jobs.created_at :asc]
                       [:tasks.priority :desc]
                       [:tasks.created_at :asc]
                       [:trials.created_at :asc])
          (hh/limit 1)
          hc/format)
      (#(jdbc/query (rdbms/get-ds) %))
      first))

(defn- issues-count [trial]
  (-> (jdbc/query (rdbms/get-ds)
                  ["SELECT count(*) FROM trial_issues WHERE trial_id = ? " (:id trial)] )
      first :count))

(defn dispatch [trial executor]
  (try
    (trial-utils/wrap-trial-with-issue-and-throw-again
      trial  "Error during dispatch"
      (let [data (build-dispatch-data trial executor)
            protocol (if (:ssl executor) "https" "http")
            url (str (:base_url executor)  "/execute")]

        (jdbc/update! (rdbms/get-ds) :trials
                      {:state "dispatching" :executor_id (:id executor)}
                      ["id = ?" (:id trial)])
        (http-client/post url
                          {:content-type :json
                           :body (json/write-str data)
                           :insecure? true
                           :basic-auth ["dispatcher"
                                        (executor-utils/http-basic-password executor)]})))
    (catch Exception e
      (let  [row (if (<= 3 (issues-count trial))
                   {:state "failed" :error "Too many issues, giving up to dispatch this trial "
                    :executor_id nil}
                   {:state "pending" :executor_id nil})]
        (trial-utils/update (conj trial row))
        false))))

(defn dispatch-trials []
  (when-let [next-trial  (get-next-trial-to-be-dispatched)]
    (loop [trial next-trial
           executor (choose-executor-to-dispatch-to trial)]
      (jdbc/update! (rdbms/get-ds) :trials
                    {:state "dispatching"
                     :executor_id (:id executor)}
                    ["id = ?" (:id trial)])
      (future (dispatch trial executor))
      (when-let [trial (get-next-trial-to-be-dispatched)]
        (recur trial (choose-executor-to-dispatch-to trial))))))

;#### dispatch service ########################################################
(daemon/define "dispatch-service"
  start-dispatch-service
  stop-dispatch-service
  0.2
  (logging/debug "dispatch-service")
  (dispatch-trials))

;### initialize ##############################################################
(defn initialize []
  (start-dispatch-service))

;#### debug ###################################################################
;(logging-config/set-logger! :level :debug)
;(logging-config/set-logger! :level :info)
;(debug/debug-ns 'cider-ci.utils.http)
;(debug/debug-ns *ns*)

; Copyright (C) 2013, 2014, 2015 Dr. Thomas Schank  (DrTom@schank.ch, Thomas.Schank@algocon.ch)
; Licensed under the terms of the GNU Affero General Public License v3.
; See the "LICENSE.txt" file provided with this software.

(ns cider-ci.dispatcher.dispatch
  (:require
    [cider-ci.dispatcher.executor :as executor-utils]
    [cider-ci.dispatcher.task :as task]
    [cider-ci.dispatcher.trial :as trial-utils]
    [cider-ci.utils.config :refer [get-config]]
    [cider-ci.utils.daemon :as daemon]
    [drtom.logbug.debug :as debug]
    [cider-ci.utils.http :as http]
    [cider-ci.utils.rdbms :as rdbms]
    [drtom.logbug.catcher :as catcher]
    [clj-http.client :as http-client]
    [clj-logging-config.log4j :as logging-config]
    [clojure.data.json :as json]
    [clojure.java.jdbc :as jdbc]
    [clojure.tools.logging :as logging]
    [honeysql.core :as hc]
    [honeysql.helpers :as hh]
    [robert.hooke :as hooke]
    ))

;### build urls ###############################################################

(defn- git-path [repository-id]
  (http/build-service-path :repository (str "/" repository-id "/git")))

(defn- git-url [repository-id]
  ( ->
    (jdbc/query
      (rdbms/get-ds)
      ["SELECT origin_uri FROM repositories WHERE id = ?" repository-id])
    first
    :origin_uri))

(defn- trial-attachments-path [trial-id]
  (http/build-service-path :storage  (str "/trial-attachments/" trial-id "/")))

(defn- tree-attachments-path [tree-id]
  (http/build-service-path :storage  (str "/tree-attachments/" tree-id "/")))

(defn- patch-path [executor trial-id]
  (http/build-service-path :dispatcher (str "/trials/" trial-id )))

;### dispatch data ############################################################
(defn get-branch-and-commit [job-id]
  (first (jdbc/query (rdbms/get-ds)
           ["SELECT branches.name, branches.repository_id,
              commits.tree_id as tree_id,
              commits.id as git_commit_id FROM branches
            INNER JOIN branches_commits ON branches.id = branches_commits.branch_id
            INNER JOIN commits ON branches_commits.commit_id = commits.id
            INNER JOIN jobs ON commits.tree_id = jobs.tree_id
            WHERE jobs.id = ?
            ORDER BY branches.updated_at DESC" job-id])))

(defn add-git-url [data repository-id]
  (conj data
        {:git_path (git-path repository-id)
         :git_url (git-url repository-id) }))

(defn build-dispatch-data [trial executor]
  (let [task (first (jdbc/query (rdbms/get-ds)
                                ["SELECT * FROM tasks WHERE tasks.id = ?" (:task_id trial)]))
        task-spec (task/get-task-spec (:id task))
        job-id (:job_id task)
        branch-and-commit (get-branch-and-commit job-id)
        tree-id (:tree_id branch-and-commit)
        repository-id (:repository_id branch-and-commit)
        trial-id (:id trial)
        environment-variables (conj (or (:environment_variables task-spec) {})
                                    {:CIDER_CI_JOB_ID job-id
                                     :CIDER_CI_TASK_ID (:task_id trial)
                                     :CIDER_CI_TRIAL_ID trial-id
                                     :CIDER_CI_TREE_ID (:tree_id branch-and-commit)})
        data {
              :environment_variables environment-variables
              :job_id job-id
              :git_branch_name (:name branch-and-commit)
              :git_commit_id (:git_commit_id branch-and-commit)
              :git_options (or (:git_options task-spec) {})
              :git_tree_id (:tree_id branch-and-commit)
              :patch_path (patch-path executor trial-id)
              :ports (:ports task-spec)
              :repository_id repository-id
              :scripts (:scripts trial)
              :task_id (:task_id trial)
              :tree_attachments (:tree_attachments task-spec)
              :tree_attachments_path (tree-attachments-path tree-id)
              :trial_attachments (:trial_attachments task-spec)
              :trial_attachments_path (trial-attachments-path trial-id)
              :trial_id trial-id
              }]
    (-> data
        (add-git-url repository-id))))

;### dispatch #################################################################

(defn choose-executor-to-dispatch-to [trial]
  (->> (-> (hh/select :executors_with_load.*)
           (hh/from :trials)
           (hh/where [:= :trials.id (:id trial)])
           (hh/merge-join :tasks [:= :tasks.id :trials.task_id])
           (hh/merge-join :executors_with_load (hc/raw "(tasks.traits <@ executors_with_load.traits)"))
           (hh/merge-where (hc/raw "(last_ping_at > (now() - interval '1 Minutes'))"))
           (hh/merge-where [:= :enabled true])
           (hh/merge-where [:< :relative_load 1])
           hc/format)
       (jdbc/query (rdbms/get-ds))
       (map (fn [e] (repeat (- (:max_load e) (:current_load e)) e)))
       flatten rand-nth))

(defn get-next-trial-to-be-dispatched []
  (-> (-> (hh/select :trials.*)
          (hh/from :trials)
          (hh/merge-where [:= :trials.state "pending"])
          (hh/merge-where [:exists  (-> (hh/select 1 )
                                        (hh/from :executors_with_load)
                                        (hh/merge-where [:< :relative_load 1])
                                        (hh/merge-where [:= :enabled true])
                                        (hh/merge-where (hc/raw "(tasks.traits <@ executors_with_load.traits)"))
                                        (hh/merge-where (hc/raw "(last_ping_at > (now() - interval '1 Minutes'))"))
                                        )])
          (hh/merge-where [ "NOT EXISTS" (-> (hh/select 1)
                                             (hh/from [:trials :active_trials])
                                             (hh/merge-join [:tasks :active_tasks] [:= :active_tasks.id :active_trials.task_id])
                                             (hh/merge-where [:in :active_trials.state  ["executing","dispatching"]])
                                             (hh/merge-where (hc/raw "active_tasks.exclusive_resources && tasks.exclusive_resources")))])
          (hh/merge-join :tasks [:= :tasks.id :trials.task_id])
          (hh/merge-join :jobs [:= :jobs.id :tasks.job_id])
          (hh/order-by [:jobs.priority :desc]
                       [:jobs.created_at :asc]
                       [:tasks.priority :desc]
                       [:tasks.created_at :asc]
                       [:trials.created_at :asc])
          (hh/limit 1)
          hc/format)
      (#(jdbc/query (rdbms/get-ds) %))
      first))

(defn- issues-count [trial]
  (-> (jdbc/query (rdbms/get-ds)
                  ["SELECT count(*) FROM trial_issues WHERE trial_id = ? " (:id trial)] )
      first :count))

(defn dispatch [trial executor]
  (try
    (trial-utils/wrap-trial-with-issue-and-throw-again
      trial  "Error during dispatch"
      (let [data (build-dispatch-data trial executor)
            protocol (if (:ssl executor) "https" "http")
            url (str (:base_url executor)  "/execute")]

        (jdbc/update! (rdbms/get-ds) :trials
                      {:state "dispatching" :executor_id (:id executor)}
                      ["id = ?" (:id trial)])
        (http-client/post url
                          {:content-type :json
                           :body (json/write-str data)
                           :insecure? true
                           :basic-auth ["dispatcher"
                                        (executor-utils/http-basic-password executor)]})))
    (catch Exception e
      (let  [row (if (<= 3 (issues-count trial))
                   {:state "failed" :error "Too many issues, giving up to dispatch this trial "
                    :executor_id nil}
                   {:state "pending" :executor_id nil})]
        (trial-utils/update (conj trial row))
        false))))

(defn dispatch-trials []
  (when-let [next-trial  (get-next-trial-to-be-dispatched)]
    (loop [trial next-trial
           executor (choose-executor-to-dispatch-to trial)]
      (jdbc/update! (rdbms/get-ds) :trials
                    {:state "dispatching"
                     :executor_id (:id executor)}
                    ["id = ?" (:id trial)])
      (future (dispatch trial executor))
      (when-let [trial (get-next-trial-to-be-dispatched)]
        (recur trial (choose-executor-to-dispatch-to trial))))))

;#### dispatch service ########################################################
(daemon/define "dispatch-service"
  start-dispatch-service
  stop-dispatch-service
  0.2
  (logging/debug "dispatch-service")
  (dispatch-trials))

;### initialize ##############################################################
(defn initialize []
  (start-dispatch-service))

;#### debug ###################################################################
;(logging-config/set-logger! :level :debug)
;(logging-config/set-logger! :level :info)
;(debug/debug-ns 'cider-ci.utils.http)
;(debug/debug-ns *ns*)

Send JOB_ID instead of EXECUTION_ID env var


(ns conference-rating.server
  (:require [conference-rating.handler :refer [app]]
            [clojure.java.io :as io]
            [environ.core :refer [env]]
            [conference-rating.db-handler :as db-handler]
            [ring.adapter.jetty :refer [run-jetty]]
            [ring.middleware.logger :as ring-logger]
            [ring.middleware.session :as session]
            [ring.middleware.session.cookie :as cookie]
            [ring.middleware.okta :refer [wrap-okta okta-routes]])
  (:gen-class))

(defn do-wrap-okta [handler okta-active]
  (if okta-active
    (wrap-okta handler {:okta-home "https://dev-133267-admin.oktapreview.com/" :okta-config-location (io/resource "okta-ci-config.xml")})
    handler))

 (defn -main [& args]
   (let [port (Integer/parseInt (or (env :port) "3000"))
         okta-active (= "--okta-active" (first args))
         app (-> (app (db-handler/connect))
                 (do-wrap-okta okta-active)
                 (ring-logger/wrap-with-logger)
                 (session/wrap-session)
                 )]
     (run-jetty app {:port port :join? false})))

(ns conference-rating.server
  (:require [conference-rating.handler :refer [app]]
            [clojure.java.io :as io]
            [environ.core :refer [env]]
            [conference-rating.db-handler :as db-handler]
            [ring.adapter.jetty :refer [run-jetty]]
            [ring.middleware.logger :as ring-logger]
            [ring.middleware.session :as session]
            [ring.middleware.session.cookie :as cookie]
            [ring.middleware.okta :refer [wrap-okta okta-routes]])
  (:gen-class))

(defn do-wrap-okta [handler okta-active]
  (let [config-res (io/resource "okta-ci-config.xml")]
    (println "initialize okta?" okta-active " config location: " config-res)
    (if okta-active
      (wrap-okta handler {:okta-home "https://dev-133267-admin.oktapreview.com/" :okta-config config-res})
      handler)))

 (defn -main [& args]
   (let [port (Integer/parseInt (or (env :port) "3000"))
         okta-active (= "--okta-active" (first args))
         app (-> (app (db-handler/connect))
                 (do-wrap-okta okta-active)
                 (ring-logger/wrap-with-logger)
                 (session/wrap-session)
                 )]
     (run-jetty app {:port port :join? false})))

fix okta-config.xml config | sg/fs | #35


(ns phonecat-re-frame.core
    (:require [reagent.core :as reagent :refer [atom]]
              [reagent.session :as session]
              [secretary.core :as secretary :include-macros true]
              [goog.events :as events]
              [goog.history.EventType :as EventType]
              [cljsjs.react :as react]
              [re-frame.core :as re-frame])
    (:require-macros [reagent.ratom  :refer [reaction]])
    (:import goog.History))

;; -------------------------
;; Re-frame data

(re-frame/register-sub
 :search-input
 (fn [db]
   (reaction (:search-input @db))))

(re-frame/register-sub        ;; a new subscription handler
 :phones             ;; usage (subscribe [:phones])
 (fn [db]
   (reaction (:phones @db))))  ;; pulls out :phones

(re-frame/register-handler
   :initialise-db             ;; usage: (dispatch [:initialise-db])
   (fn
     [_ _]                   ;; Ignore both params (db and v).
     {:phones [{:name "Nexus S" :snippet "Fast just got faster with Nexus S."}
               {:name "Motorola XOOM™ with Wi-Fi" :snippet "The Next, Next Generation tablet."}
               {:name "Motoral Xoom" :snippet "The Next, Next Generation tablet."}]
      :search-input ""}))

(defn handle-search-input-entered
  [app-state [_ search-input]]
  (assoc-in app-state [:search-input] search-input))

(re-frame/register-handler
 :search-input-entered
 handle-search-input-entered)
;; -------------------------
;; Views

(defn phone-component
  [phone]
  [:li
   [:span (:name phone)]
   [:p (:snippet phone)]])

(defn matches-query?
  [search-input phone]
  (if (= "" search-input)
    true
    (= (:name phone) search-input)))

(defn phones-component
  []
  (let [phones (re-frame/subscribe [:phones])
        search-input (re-frame/subscribe [:search-input])]
    (fn []

      [:ul {:class= "phones"}
       (for [phone (filter (partial matches-query? @search-input) @phones)]
         ^{:key (:name phone)} [phone-component phone])])))

(defn search-component
  []
  (let [search-input (re-frame/subscribe [:search-input])])
  (fn []
    [:input {:on-change #(re-frame/dispatch [:search-input-entered (-> % .-target .-value)])}]))

(defn phones-component
  []
  (let [phones (re-frame/subscribe [:phones])]
    (fn []
      [:ul (doall  (map (fn [phone] ^{:key phone} [phone-component (:name phone) (:snippet phone)]) @phones))])))

(defn home-page []
  [phones-component])
  [:div {:class "container-fluid"}
   [:div {:class "row"}
    [:div {:class "col-md-2"}
     [search-component]]]
   [:div {:class "row"}
    [:div {:class "col-md-6"}
     [order-by-component]]]
   [:div {:class "row"}
    [:div {:class "col-md-10"}
     [phones-component]]]])

(defn current-page []
  [:div [(session/get :current-page)]])

;; -------------------------
;; Routes
(secretary/set-config! :prefix "#")

(secretary/defroute "/" []
  (session/put! :current-page #'home-page))

;; -------------------------
;; History
;; must be called after routes have been defined
(defn hook-browser-navigation! []
  (doto (History.)
    (events/listen
     EventType/NAVIGATE
     (fn [event]
       (secretary/dispatch! (.-token event))))
    (.setEnabled true)))

;; -------------------------
;; Initialize app
(defn init! []
  (hook-browser-navigation!)
  (re-frame/dispatch [:initialise-db])
  (reagent/render-component [current-page] (.getElementById js/document "app")))

(ns phonecat-re-frame.core
    (:require [reagent.core :as reagent :refer [atom]]
              [reagent.session :as session]
              [secretary.core :as secretary :include-macros true]
              [goog.events :as events]
              [goog.history.EventType :as EventType]
              [cljsjs.react :as react]
              [re-frame.core :as re-frame])
    (:require-macros [reagent.ratom  :refer [reaction]])
    (:import goog.History))

;; -------------------------
;; Re-frame data

(re-frame/register-sub
 :search-input
 (fn [db]
   (reaction (:search-input @db))))

(re-frame/register-sub        ;; a new subscription handler
 :phones             ;; usage (subscribe [:phones])
 (fn [db]
   (reaction (:phones @db))))  ;; pulls out :phones

(re-frame/register-handler
   :initialise-db             ;; usage: (dispatch [:initialise-db])
   (fn
     [_ _]                   ;; Ignore both params (db and v).
     {:phones [{:name "Nexus S" :snippet "Fast just got faster with Nexus S."}
               {:name "Motorola XOOM™ with Wi-Fi" :snippet "The Next, Next Generation tablet."}
               {:name "Motoral Xoom" :snippet "The Next, Next Generation tablet."}]
      :search-input ""}))

(defn handle-search-input-entered
  [app-state [_ search-input]]
  (assoc-in app-state [:search-input] search-input))

(re-frame/register-handler
 :search-input-entered
 handle-search-input-entered)
;; -------------------------
;; Views

(defn phone-component
  [phone]
  [:li
   [:span (:name phone)]
   [:p (:snippet phone)]])

(defn matches-query?
  [search-input phone]
  (if (= "" search-input)
    true
    (= (:name phone) search-input)))

(defn phones-component
  []
  (let [phones (re-frame/subscribe [:phones])
        search-input (re-frame/subscribe [:search-input])]
    (fn []

      [:ul {:class= "phones"}
       (for [phone (filter (partial matches-query? @search-input) @phones)]
         ^{:key (:name phone)} [phone-component phone])])))

(defn search-component
  []
  (let [search-input (re-frame/subscribe [:search-input])])
  (fn []
    [:input {:on-change #(re-frame/dispatch [:search-input-entered (-> % .-target .-value)])}]))

(defn home-page []
  [:div {:class "container-fluid"}
   [:div {:class "row"}
    [:div {:class "col-md-2"}
     [search-component]]]
   [:div {:class "row"}
    [:div {:class "col-md-6"}
     [order-by-component]]]
   [:div {:class "row"}
    [:div {:class "col-md-10"}
     [phones-component]]]])

(defn current-page []
  (session/get :current-page))

;; -------------------------
;; Routes
(secretary/set-config! :prefix "#")

(secretary/defroute "/" []
  (session/put! :current-page #'home-page))

;; -------------------------
;; History
;; must be called after routes have been defined
(defn hook-browser-navigation! []
  (doto (History.)
    (events/listen
     EventType/NAVIGATE
     (fn [event]
       (secretary/dispatch! (.-token event))))
    (.setEnabled true)))

;; -------------------------
;; Initialize app
(defn init! []
  (hook-browser-navigation!)
  (re-frame/dispatch [:initialise-db])
  (reagent/render-component [current-page] (.getElementById js/document "app")))

fix issues with merge - all working

fix issues with merge - all working


(ns
  ^{:doc "

  The idea is the access TCP client connections like any other product driver code would e.g the cassandra or mondodb driver.
  There are allot of situations where software in the past (my own experience) became unstable because the TCP connections
  were not written or treated with the equivalent importance as server connections.
  Writing the TCP connection as if it were a product driver sets a certain design mindset.

  This is the main entry point namespace for this project, the other namespaces are:

   tcp-driver.io.conn   -> TCP connection abstractions
   tcp-driver.io-pool   -> Connection pooling and creating object pools
   tcp-driver.io-stream -> reading and writing from TCP Connections

   The main idea is that a driver can point at 1,2 or more servers, for each server a Pool of Connections are maintained
   using a KeyedObjectPool  from the commons pool2 library.

   Pooling connections is done not only for performance but also make connection error handling easier, the connection
   is tested and retried before given to the application user, and if you have a connection at least at the moment
   of handoff you know that it is connection and ready to go.

  "}
  tcp-driver.driver

  (:require
    [schema.core :as s]
    [clojure.tools.logging :refer [error]]
    [tcp-driver.io.pool :as tcp-pool]
    [tcp-driver.io.conn :as tcp-conn]
    [tcp-driver.routing.policy :as routing]
    [tcp-driver.routing.retry :as retry]) (:import (java.io IOException)))

;;;;;;;;;;;;;;
;;;;;; Schemas and Protocols

(def IRouteSchema (s/pred #(satisfies? routing/IRoute %)))

(def IRetrySchema (s/pred #(satisfies? retry/IRetry %)))

(def IPoolSchema (s/pred #(satisfies? tcp-pool/IPool %)))

(def DriverRetSchema {:pool           tcp-pool/IPoolSchema
                      :routing-policy IRouteSchema
                      :retry-policy   IRetrySchema})

;;;;;;;;;;;;;;
;;;;;; Private functions

(defn throw-no-connection! []
      (throw (RuntimeException. "No connection is available to perform the send")))

(defn select-send!
      "ctx - DriverRetSchema
       io-f - function that takes a connection and on error throws an exception
       timeout-ms - connection timeout"
      [ctx io-f timeout-ms]
      {:pre [ctx io-f timeout-ms]}
      (loop [i 0]
            (if-let [host (routing/-select-host (:routing-policy ctx))]

                    (let [pool (:pool ctx)]

                         ;;;try the io-f, if an exception then only if we haven't tried (count hosts) already
                         ;;;loop and retry, its expected that the routing policy blacklist or remove the host on error

                         (let [res (try

                                     (if-let [conn (tcp-pool/borrow pool host timeout-ms)]

                                             (try
                                               (io-f conn)
                                               (catch IOException e
                                                 ;;any io exception will cause invalidation of the connection.
                                                 (tcp-pool/invalidate pool host conn)
                                                 (throw e))
                                               (finally
                                                 (tcp-pool/return pool host conn)))

                                             (throw-no-connection!))

                                     (catch Exception t
                                       (routing/-on-error! (:routing-policy ctx) host t)
                                       (ex-info (str "Error while connecting to " host) {:throwable t :host host :retries i :hosts (routing/-hosts (:routing-policy ctx))})))]

                              (if (instance? Throwable res)
                                (do
                                  (error res)
                                  (if (< i (count (routing/-hosts (:routing-policy ctx))))
                                    (recur (inc i))
                                    (throw res)))
                                res)))

                    (throw-no-connection!))))

(defn retry-select-send!
      "Send with the retry-policy, select-send! will be retried depending on the retry policy"
      [{:keys [retry-policy] :as ctx} io-f timeout-ms]
      {:pre [retry-policy]}
      (retry/with-retry retry-policy #(select-send! ctx io-f timeout-ms)))

;; routing-policy is a function to which we pass the routing-env atom, which contains {:hosts (set [tcp-conn/HostAddressSchema]) } by default
(s/defn create [pool :- IPoolSchema
                routing-policy :- IRouteSchema
                retry-policy :- IRetrySchema
                ] :- DriverRetSchema
        {:pool           pool
         :routing-policy routing-policy
         :retry-policy   retry-policy})

;;;;;;;;;;;;;;;;
;;;;;; Public API

(defn send-f
      "
       Apply the io-f with a connection from the connection pool selected based on
         the retry policy, and retried if exceptions in the io-f based on the retry policy
       ctx - returned from create
       io-f - function that should accept the tcp-driver.io.conn/ITCPConn
       timeout-ms - the timeout for connection borrow"
      [ctx io-f timeout-ms]
      (retry-select-send! ctx io-f timeout-ms))

(defn create-default
      "Create a driver with the default settings for tcp-pool, routing and retry-policy
       hosts: a vector or seq of {:host :port} maps
       return: DriverRetSchema

       Routing policy: The default routing policy will select hosts at random and on any exception blacklist a particular host.
                       To add/remove/blacklist a node use the public functions add-host, remove-host and blacklist-host in this namespace.
      "
      ^{:arg-lists [routing-conf pool-conf retry-limit]}
      [hosts & {:keys [routing-conf pool-conf retry-limit] :or {retry-limit 10 routing-conf {} pool-conf {}}}]
      {:pre [
             (s/validate tcp-pool/PoolConfSchema pool-conf)
             (s/validate [tcp-conn/HostAddressSchema] hosts)
             (number? retry-limit)
             ]}
      (create
        (tcp-pool/create-tcp-pool pool-conf)
        (apply routing/create-default-routing-policy hosts (mapcat identity routing-conf))
        (retry/retry-policy retry-limit)))

(defn close
      "Close the driver connection pool"
      ^{:arg-lists [pool]}
      [{:keys [pool]}]
      (tcp-pool/close pool))

(defn add-host [{:keys [routing-policy]} host]
      {:pre [(s/validate tcp-conn/HostAddressSchema host)]}
      (routing/-add-host! routing-policy host))

(defn remove-host [{:keys [routing-policy]} host]
      {:pre [(s/validate tcp-conn/HostAddressSchema host)]}
      (routing/-remove-host! routing-policy host))

(defn blacklist-host [{:keys [routing-policy]} host]
      {:pre [(s/validate tcp-conn/HostAddressSchema host)]}
      (routing/-blacklist! routing-policy host))

(ns
  ^{:doc "

  The idea is the access TCP client connections like any other product driver code would e.g the cassandra or mondodb driver.
  There are allot of situations where software in the past (my own experience) became unstable because the TCP connections
  were not written or treated with the equivalent importance as server connections.
  Writing the TCP connection as if it were a product driver sets a certain design mindset.

  This is the main entry point namespace for this project, the other namespaces are:

   tcp-driver.io.conn   -> TCP connection abstractions
   tcp-driver.io-pool   -> Connection pooling and creating object pools
   tcp-driver.io-stream -> reading and writing from TCP Connections

   The main idea is that a driver can point at 1,2 or more servers, for each server a Pool of Connections are maintained
   using a KeyedObjectPool  from the commons pool2 library.

   Pooling connections is done not only for performance but also make connection error handling easier, the connection
   is tested and retried before given to the application user, and if you have a connection at least at the moment
   of handoff you know that it is connection and ready to go.

  "}
  tcp-driver.driver

  (:require
    [schema.core :as s]
    [clojure.tools.logging :refer [error]]
    [tcp-driver.io.pool :as tcp-pool]
    [tcp-driver.io.conn :as tcp-conn]
    [tcp-driver.routing.policy :as routing]
    [tcp-driver.routing.retry :as retry]) (:import (java.io IOException)))

;;;;;;;;;;;;;;
;;;;;; Schemas and Protocols

(def IRouteSchema (s/pred #(satisfies? routing/IRoute %)))

(def IRetrySchema (s/pred #(satisfies? retry/IRetry %)))

(def IPoolSchema (s/pred #(satisfies? tcp-pool/IPool %)))

(def DriverRetSchema {:pool           tcp-pool/IPoolSchema
                      :routing-policy IRouteSchema
                      :retry-policy   IRetrySchema})

;;;;;;;;;;;;;;
;;;;;; Private functions

(defn throw-no-connection! []
      (throw (RuntimeException. "No connection is available to perform the send")))

(defn select-send!
      "ctx - DriverRetSchema
       host-address if specified this host is used, otherwise the routing policy is asked for a host
       io-f - function that takes a connection and on error throws an exception
       timeout-ms - connection timeout"
      ([ctx io-f timeout-ms]
        (select-send! ctx nil io-f timeout-ms))
      ([ctx host-address io-f timeout-ms]
        {:pre [ctx io-f timeout-ms]}
        (loop [i 0]
              (if-let [host (if host-address host-address (routing/-select-host (:routing-policy ctx)))]

                      (let [pool (:pool ctx)]

                           ;;;try the io-f, if an exception then only if we haven't tried (count hosts) already
                           ;;;loop and retry, its expected that the routing policy blacklist or remove the host on error

                           (let [res (try

                                       (if-let [conn (tcp-pool/borrow pool host timeout-ms)]

                                               (try
                                                 (io-f conn)
                                                 (catch IOException e
                                                   ;;any io exception will cause invalidation of the connection.
                                                   (tcp-pool/invalidate pool host conn)
                                                   (throw e))
                                                 (finally
                                                   (tcp-pool/return pool host conn)))

                                               (throw-no-connection!))

                                       (catch Exception t
                                         (routing/-on-error! (:routing-policy ctx) host t)
                                         (ex-info (str "Error while connecting to " host) {:throwable t :host host :retries i :hosts (routing/-hosts (:routing-policy ctx))})))]

                                (if (instance? Throwable res)
                                  (do
                                    (error res)
                                    (if (< i (count (routing/-hosts (:routing-policy ctx))))
                                      (recur (inc i))
                                      (throw res)))
                                  res)))

                      (throw-no-connection!)))))

(defn retry-select-send!
      "Send with the retry-policy, select-send! will be retried depending on the retry policy"
      ([{:keys [retry-policy] :as ctx} host-address io-f timeout-ms]
        {:pre [retry-policy]}
        (retry/with-retry retry-policy #(select-send! ctx host-address io-f timeout-ms)))
      ([{:keys [retry-policy] :as ctx} io-f timeout-ms]
        {:pre [retry-policy]}
        (retry/with-retry retry-policy #(select-send! ctx io-f timeout-ms))))

;; routing-policy is a function to which we pass the routing-env atom, which contains {:hosts (set [tcp-conn/HostAddressSchema]) } by default
(s/defn create [pool :- IPoolSchema
                routing-policy :- IRouteSchema
                retry-policy :- IRetrySchema
                ] :- DriverRetSchema
        {:pool           pool
         :routing-policy routing-policy
         :retry-policy   retry-policy})

;;;;;;;;;;;;;;;;
;;;;;; Public API

(defn send-f
      "
       Apply the io-f with a connection from the connection pool selected based on
         the retry policy, and retried if exceptions in the io-f based on the retry policy
       ctx - returned from create
       io-f - function that should accept the tcp-driver.io.conn/ITCPConn
       timeout-ms - the timeout for connection borrow"
      ([ctx host-address io-f timeout-ms]
        (retry-select-send! ctx host-address io-f timeout-ms))
      ([ctx io-f timeout-ms]
        (retry-select-send! ctx io-f timeout-ms)))

(defn create-default
      "Create a driver with the default settings for tcp-pool, routing and retry-policy
       hosts: a vector or seq of {:host :port} maps
       return: DriverRetSchema

       Routing policy: The default routing policy will select hosts at random and on any exception blacklist a particular host.
                       To add/remove/blacklist a node use the public functions add-host, remove-host and blacklist-host in this namespace.
      "
      ^{:arg-lists [routing-conf pool-conf retry-limit]}
      [hosts & {:keys [routing-conf pool-conf retry-limit] :or {retry-limit 10 routing-conf {} pool-conf {}}}]
      {:pre [
             (s/validate tcp-pool/PoolConfSchema pool-conf)
             (s/validate [tcp-conn/HostAddressSchema] hosts)
             (number? retry-limit)
             ]}
      (create
        (tcp-pool/create-tcp-pool pool-conf)
        (apply routing/create-default-routing-policy hosts (mapcat identity routing-conf))
        (retry/retry-policy retry-limit)))

(defn close
      "Close the driver connection pool"
      ^{:arg-lists [pool]}
      [{:keys [pool]}]
      (tcp-pool/close pool))

(defn add-host [{:keys [routing-policy]} host]
      {:pre [(s/validate tcp-conn/HostAddressSchema host)]}
      (routing/-add-host! routing-policy host))

(defn remove-host [{:keys [routing-policy]} host]
      {:pre [(s/validate tcp-conn/HostAddressSchema host)]}
      (routing/-remove-host! routing-policy host))

(defn blacklist-host [{:keys [routing-policy]} host]
      {:pre [(s/validate tcp-conn/HostAddressSchema host)]}
      (routing/-blacklist! routing-policy host))

add specifying host

add specifying host