(ns onyx.log.commands.common
  (:require [clojure.core.async :refer [chan]]
            [clojure.data :refer [diff]]
            [clojure.set :refer [map-invert]]
            [com.stuartsierra.component :as component]
            [onyx.extensions :as extensions]
            [taoensso.timbre :refer [info]]))

(defn job->peers [replica]
  (reduce-kv
   (fn [all job tasks]
     (assoc all job (apply concat (vals tasks))))
   {} (:allocations replica)))

(defn peer->allocated-job [allocations id]
  (get
   (reduce-kv
    (fn [all job tasks]
      (->> tasks
           (mapcat (fn [[t ps]] (map (fn [p] {p {:job job :task t}}) ps)))
           (into {})
           (merge all)))
    {} allocations)
   id))

(defn allocations->peers [allocations]
  (reduce-kv
   (fn [all job tasks]
     (merge all
            (reduce-kv
             (fn [all task allocations]
               (->> allocations
                    (map (fn [peer] {peer {:job job :task task}}))
                    (into {})
                    (merge all)))
             {}
             tasks)))
   {}
   allocations))

(defn remove-peers [replica args]
  (let [prev (get (allocations->peers (:allocations replica)) (:id args))]
    (if (and (:job prev) (:task prev))
      (let [remove-f #(vec (remove (partial = (:id args)) %))]
        (update-in replica [:allocations (:job prev) (:task prev)] remove-f))
      replica)))

(defn all-inputs-exhausted? [replica job]
  (let [all (get-in replica [:input-tasks job])
        exhausted (get-in replica [:exhausted-inputs job])]
    (= (into #{} all) (into #{} exhausted))))

(defn executing-output-task? [replica id]
  (let [{:keys [job task]} (peer->allocated-job (:allocations replica) id)]
    (some #{task} (get-in replica [:output-tasks job]))))

(defn elected-sealer? [replica message-id id]
  (let [{:keys [job task]} (peer->allocated-job (:allocations replica) id)
        peers (get-in replica [:allocations job task])]
    (when (pos? (count peers))
      (let [n (mod message-id (count peers))]
        (= (nth peers n) id)))))

(defn should-seal? [replica args state message-id]
  (and (all-inputs-exhausted? replica (:job args))
       (executing-output-task? replica (:id state))
       (elected-sealer? replica message-id (:id state))))

(defn start-new-lifecycle [old new diff state]
  (let [old-allocation (peer->allocated-job (:allocations old) (:id state))
        new-allocation (peer->allocated-job (:allocations new) (:id state))]
    (if-not (not old-allocation new-allocation)
      (do (when (:lifecycle state)
            (component/stop @(:lifecycle state)))
          (let [seal-ch (chan)
                new-state (assoc state :job (:job diff) :task (:task diff) :seal-ch seal-ch)
                new-lifecycle (future (component/start ((:task-lifecycle-fn state) diff new-state)))]
            (assoc new-state :lifecycle new-lifecycle :seal-response-ch seal-ch)))
      state)))

(ns onyx.log.commands.common
  (:require [clojure.core.async :refer [chan]]
            [clojure.data :refer [diff]]
            [clojure.set :refer [map-invert]]
            [com.stuartsierra.component :as component]
            [onyx.extensions :as extensions]
            [taoensso.timbre :refer [info]]))

(defn job->peers [replica]
  (reduce-kv
   (fn [all job tasks]
     (assoc all job (apply concat (vals tasks))))
   {} (:allocations replica)))

(defn peer->allocated-job [allocations id]
  (get
   (reduce-kv
    (fn [all job tasks]
      (->> tasks
           (mapcat (fn [[t ps]] (map (fn [p] {p {:job job :task t}}) ps)))
           (into {})
           (merge all)))
    {} allocations)
   id))

(defn allocations->peers [allocations]
  (reduce-kv
   (fn [all job tasks]
     (merge all
            (reduce-kv
             (fn [all task allocations]
               (->> allocations
                    (map (fn [peer] {peer {:job job :task task}}))
                    (into {})
                    (merge all)))
             {}
             tasks)))
   {}
   allocations))

(defn remove-peers [replica args]
  (let [prev (get (allocations->peers (:allocations replica)) (:id args))]
    (if (and (:job prev) (:task prev))
      (let [remove-f #(vec (remove (partial = (:id args)) %))]
        (update-in replica [:allocations (:job prev) (:task prev)] remove-f))
      replica)))

(defn all-inputs-exhausted? [replica job]
  (let [all (get-in replica [:input-tasks job])
        exhausted (get-in replica [:exhausted-inputs job])]
    (= (into #{} all) (into #{} exhausted))))

(defn executing-output-task? [replica id]
  (let [{:keys [job task]} (peer->allocated-job (:allocations replica) id)]
    (some #{task} (get-in replica [:output-tasks job]))))

(defn elected-sealer? [replica message-id id]
  (let [{:keys [job task]} (peer->allocated-job (:allocations replica) id)
        peers (get-in replica [:allocations job task])]
    (when (pos? (count peers))
      (let [n (mod message-id (count peers))]
        (= (nth peers n) id)))))

(defn should-seal? [replica args state message-id]
  (and (all-inputs-exhausted? replica (:job args))
       (executing-output-task? replica (:id state))
       (elected-sealer? replica message-id (:id state))))

(defn start-new-lifecycle [old new diff state]
  (let [old-allocation (peer->allocated-job (:allocations old) (:id state))
        new-allocation (peer->allocated-job (:allocations new) (:id state))]
    (if-not (= old-allocation new-allocation)
      (do (when (:lifecycle state)
            (component/stop @(:lifecycle state)))
          (let [seal-ch (chan)
                new-state (assoc state :job (:job diff) :task (:task diff) :seal-ch seal-ch)
                new-lifecycle (future (component/start ((:task-lifecycle-fn state) diff new-state)))]
            (assoc new-state :lifecycle new-lifecycle :seal-response-ch seal-ch)))
      state)))

Fix not =

Fix not =


(ns refactor-nrepl.ns.pprint
  (:require [clojure.pprint :refer [pprint]]
            [clojure.string :as str]
            [refactor-nrepl.ns.helpers :refer [prefix-form?]]))

(defn- libspec-vectors-last [libspecs]
  (vec (concat (remove sequential? libspecs)
               (filter sequential? libspecs))))

(defn- pprint-prefix-form [[name & libspecs]]
  (printf "[%s" name)
  (let [ordered-libspecs (libspec-vectors-last libspecs)]
    (dorun
     (map-indexed (fn [idx libspec]
                    ;; insert newline after all non-libspec vectors
                    (when (and (vector? libspec)
                               (or (zero? idx)
                                   (symbol? (get ordered-libspecs (dec idx)))))
                      (println))
                    (if (= idx (dec (count ordered-libspecs)))
                      (printf "%s]\n" libspec)
                      (if (vector? libspec)
                        (pprint libspec)
                        (if (zero? idx)
                          (printf " %s " libspec)
                          (if (vector? (get ordered-libspecs (inc idx)))
                            (printf "%s" libspec)
                            (printf "%s " libspec))))))
                  ordered-libspecs))))

(defn pprint-require-form
  [[_ & libspecs]]
  (print "(:require ")
  (dorun
   (map-indexed
    (fn [idx libspec]
      (if (= idx (dec (count libspecs)))
        (printf "%s)\n" (str/trim-newline
                         (with-out-str (pprint libspec))))
        (if (prefix-form? libspec)
          (pprint-prefix-form libspec)
          (pprint libspec))))
    libspecs)))

(defn- form-is? [form type]
  (and (sequential? form)
       (= (first form) type)))

(defn- pprint-gen-class-form
  [[_ & elems]]
  (if (empty? elems)
    (println "(:gen-class)")
    (println "(:gen-class"))
  (dorun
   (map-indexed
    (fn [idx [key val]]
      (if (= idx (dec (count (partition 2 elems))))
        (printf "%s %s)\n" key val)
        (println key val)))
    (partition 2 elems))))

(defn- pprint-import-form
  [[_ & imports]]
  (printf "(:import ")
  (dorun
   (map-indexed
    (fn [idx import]
      (if (= idx (dec (count imports)))
        (printf "%s)\n" import)
        (println import)))
    imports)))

(defn pprint-ns
  [[_ name & more :as ns-form]]
  (let [docstring? (when (string? (first more)) (first more))
        attrs? (when (map? (second more)) (second more))
        forms (cond (and docstring? attrs?) (nthrest more 2)
                    (not (or docstring? attrs?)) more
                    :else (rest more))]
    (-> (with-out-str
          (printf "(ns %s" name)
          (if (or docstring? attrs? forms)
            (println)
            (print ")"))
          (when docstring? (printf "\"%s\"\n" docstring? ))
          (when attrs? (pprint attrs?))
          (dorun
           (map-indexed
            (fn [idx form]
              (if (= idx (dec (count forms)))
                (printf "%s)\n"
                        (str/trim-newline
                         (with-out-str
                           (cond (form-is? form :require) (pprint-require-form form)
                                 (form-is? form :gen-class) (pprint-gen-class-form form)
                                 (form-is? form :import) (pprint-import-form form)
                                 :else (pprint form)))))
                (cond (form-is? form :require) (pprint-require-form form)
                      (form-is? form :gen-class) (pprint-gen-class-form form)
                      (form-is? form :import) (pprint-import-form form)
                      :else (pprint form))))
            forms)))
        (.replaceAll "\r" ""))))

(ns refactor-nrepl.ns.pprint
  (:require [clojure.pprint :refer [pprint]]
            [clojure.string :as str]
            [refactor-nrepl.ns.helpers :refer [prefix-form?]]))

(defn- libspec-vectors-last [libspecs]
  (vec (concat (remove sequential? libspecs)
               (filter sequential? libspecs))))

(defn- pprint-prefix-form [[name & libspecs]]
  (printf "[%s" name)
  (let [ordered-libspecs (libspec-vectors-last libspecs)]
    (dorun
     (map-indexed (fn [idx libspec]
                    ;; insert newline after all non-libspec vectors
                    (when (and (vector? libspec)
                               (or (zero? idx)
                                   (symbol? (get ordered-libspecs (dec idx)))))
                      (println))
                    (if (= idx (dec (count ordered-libspecs)))
                      (printf "%s]\n" libspec)
                      (if (vector? libspec)
                        (pprint libspec)
                        (if (zero? idx)
                          (printf " %s " libspec)
                          (if (vector? (get ordered-libspecs (inc idx)))
                            (printf "%s" libspec)
                            (printf "%s " libspec))))))
                  ordered-libspecs))))

(defn pprint-require-form
  [[_ & libspecs]]
  (print "(:require ")
  (dorun
   (map-indexed
    (fn [idx libspec]
      (if (= idx (dec (count libspecs)))
        (printf "%s)\n" (str/trim-newline
                         (with-out-str (if (prefix-form? libspec)
                                         (pprint-prefix-form libspec)
                                         (pprint libspec)))))
        (if (prefix-form? libspec)
          (pprint-prefix-form libspec)
          (pprint libspec))))
    libspecs)))

(defn- form-is? [form type]
  (and (sequential? form)
       (= (first form) type)))

(defn- pprint-gen-class-form
  [[_ & elems]]
  (if (empty? elems)
    (println "(:gen-class)")
    (println "(:gen-class"))
  (dorun
   (map-indexed
    (fn [idx [key val]]
      (if (= idx (dec (count (partition 2 elems))))
        (printf "%s %s)\n" key val)
        (println key val)))
    (partition 2 elems))))

(defn- pprint-import-form
  [[_ & imports]]
  (printf "(:import ")
  (dorun
   (map-indexed
    (fn [idx import]
      (if (= idx (dec (count imports)))
        (printf "%s)\n" import)
        (println import)))
    imports)))

(defn pprint-ns
  [[_ name & more :as ns-form]]
  (let [docstring? (when (string? (first more)) (first more))
        attrs? (when (map? (second more)) (second more))
        forms (cond (and docstring? attrs?) (nthrest more 2)
                    (not (or docstring? attrs?)) more
                    :else (rest more))]
    (-> (with-out-str
          (printf "(ns %s" name)
          (if (or docstring? attrs? forms)
            (println)
            (print ")"))
          (when docstring? (printf "\"%s\"\n" docstring? ))
          (when attrs? (pprint attrs?))
          (dorun
           (map-indexed
            (fn [idx form]
              (if (= idx (dec (count forms)))
                (printf "%s)\n"
                        (str/trim-newline
                         (with-out-str
                           (cond (form-is? form :require) (pprint-require-form form)
                                 (form-is? form :gen-class) (pprint-gen-class-form form)
                                 (form-is? form :import) (pprint-import-form form)
                                 :else (pprint form)))))
                (cond (form-is? form :require) (pprint-require-form form)
                      (form-is? form :gen-class) (pprint-gen-class-form form)
                      (form-is? form :import) (pprint-import-form form)
                      :else (pprint form))))
            forms)))
        (.replaceAll "\r" ""))))

Fix prefix libspec edgecase

Fix prefix libspec edgecase

When a prefix entry appeared as the last entry if the :require form it
would print as a regular libspec


;; Copyright (c) 2007-2013 Basho Technologies, Inc.  All Rights Reserved.
;;
;; This file is provided to you under the Apache License,
;; Version 2.0 (the "License"); you may not use this file
;; except in compliance with the License.  You may obtain
;; a copy of the License at
;;
;;   http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing,
;; software distributed under the License is distributed on an
;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
;; KIND, either express or implied.  See the License for the
;; specific language governing permissions and limitations
;; under the License.

(ns java-s3-tests.test.client
  (:import java.security.MessageDigest
           org.apache.commons.codec.binary.Hex
           com.amazonaws.services.s3.model.AmazonS3Exception)

  (:require [aws.sdk.s3 :as s3])
  (:require [java-s3-tests.user-creation :as user-creation])
  (:require [clojure.tools.logging :as log])
  (:use midje.sweet))

(def ^:internal riak-cs-host-with-protocol "http://localhost")
(def ^:internal riak-cs-host "localhost")

(defn input-stream-from-string
  [s]
  (java.io.ByteArrayInputStream. (.getBytes s "UTF-8")))

(defn get-riak-cs-port-str
  "Try to get a TCP port number from the OS environment"
  []
  (let [port-str (get (System/getenv) "CS_HTTP_PORT")]
       (cond (nil? port-str) "8080"
             :else           port-str)))

(defn get-riak-cs-port []
  (Integer/parseInt (get-riak-cs-port-str) 10))

(defn md5-byte-array [input-byte-array]
  (let [instance (MessageDigest/getInstance "MD5")]
    (.digest instance input-byte-array)))

(defn md5-string
  [input-byte-array]
  (let [b (md5-byte-array input-byte-array)]
    (String. (Hex/encodeHex b))))

(defn user-to-cred
  [user]
  {:endpoint "http://s3.amazonaws.com"
   :access-key (:key_id user)
   :secret-key (:key_secret user)
   :proxy {:host riak-cs-host
           :port (get-riak-cs-port)}})

(defn random-cred
  []
  (let [new-cred (user-creation/create-random-user
                   riak-cs-host-with-protocol
                   (get-riak-cs-port))]
    (user-to-cred new-cred)))

(defmacro with-random-cred
  "Execute `form` with a random-cred
  bound to `var-name`"
  [var-name form]
  `(let [~var-name (random-cred)]
     ~form))

(defn random-string []
  (str (java.util.UUID/randomUUID)))

(defn write-file [filename content]
  (with-open [w (clojure.java.io/writer  filename :append false)]
    (.write w content)))

(defn etag-suffix [etag]
  (subs etag (- (count etag) 2)))

(defn upload-file [cred bucket key file-name part-size]
  (let [f (clojure.java.io/file file-name)]
    (s3/put-multipart-object cred bucket key f {:part-size part-size :threads 2})
    (.delete f)))

(fact "bogus creds raises an exception"
      (let [bogus-user {:key_id "foo"
                        :key_secret "bar"}]
        (s3/list-buckets (user-to-cred bogus-user)))
      => (throws AmazonS3Exception))

(fact "new users have no buckets"
      (with-random-cred c
        (s3/list-buckets c))
      => [])

(let [bucket-name (random-string)]
  (fact "creating a bucket should list
        one bucket in list buckets"
        (with-random-cred c
          (do (s3/create-bucket c bucket-name)
              ((comp :name first) (s3/list-buckets c))))
        => bucket-name))

(let [bucket-name (random-string)
      object-name (random-string)]
  (fact "simple put works"
        (with-random-cred cred
          (do (s3/create-bucket cred bucket-name)
              (s3/put-object cred bucket-name object-name
                             "contents")))
        => truthy))

(let [bucket-name (random-string)
      object-name (random-string)
      value "this is the value!"]
  (fact "the value received during GET is the same
        as the object that was PUT"
        (with-random-cred c
          (do (s3/create-bucket c bucket-name)
              (s3/put-object c bucket-name object-name
                             value)
              ((comp slurp :content) (s3/get-object c bucket-name object-name))))
        => value))

(let [bucket-name (random-string)
      object-name (random-string)
      value "this is the value!"
      as-bytes (.getBytes value "UTF-8")
      md5-sum (md5-string as-bytes)]
  (fact "check that the etag of the response
        is the same as the md5 of the original
        object"
        (with-random-cred c
          (do (s3/create-bucket c bucket-name)
            (s3/put-object c bucket-name object-name
                           value)
            ((comp :etag :metadata)
               (s3/get-object
                 c bucket-name object-name))))
        => md5-sum))

(let [bucket-name (random-string)
      object-name (random-string)
      value (str "aaaaaaaaaa" "bbbbbbbbbb")
      file-name "./clj-mp-test.txt"]
  (fact "multipart upload works"
        (with-random-cred c
          (do
            (s3/create-bucket c bucket-name)
            (write-file file-name value)
            (upload-file c bucket-name object-name file-name 10)
            (let [fetched-object (s3/get-object
                                  c bucket-name object-name)]
              [((comp slurp :content) fetched-object)
               ((comp etag-suffix :etag :metadata) fetched-object)])))
        => [value, "-2"]))

(let [bucket-name (random-string)
      object-name (random-string)
      value "this is the real value"
      wrong-md5 "2945d7de2f70de5b8c0cb3fbcba4fe92"]
  (fact "Bad content md5 throws an exception"
        (with-random-cred c
          (do
            (s3/create-bucket c bucket-name)
            (s3/put-object c bucket-name object-name value
                           {:content-md5 wrong-md5})))
        => (throws AmazonS3Exception)))

(def bad-canonical-id
  "0f80b2d002a3d018faaa4a956ce8aa243332a30e878f5dc94f82749984ebb30b")

(let [bucket-name (random-string)
      object-name (random-string)
      value-string "this is the real value"]
  (fact "Nonexistent canonical-id grant header returns HTTP 400 on
        a put object request (not just an ACL subresource request)"
        (with-random-cred c
          (do
            ;; create a bucket
            (s3/create-bucket c bucket-name)
            (s3/put-object c bucket-name object-name value-string {}
                           (s3/grant {:id bad-canonical-id} :full-control))))
        => (throws AmazonS3Exception)))

(let [bucket-name (random-string)
      object-name (random-string)
      value-string "this is the real value"
      public-read-grant {:grantee :all-users, :permission :read}]
  (fact "Creating an object with an ACL returns the same ACL when you read
        the ACL"
        (with-random-cred c
          (do
            ;; create a bucket
            (s3/create-bucket c bucket-name)
            (s3/put-object c bucket-name object-name value-string {}
                           (s3/grant :all-users :read))
            (contains?
             (:grants (s3/get-object-acl c bucket-name object-name))
             public-read-grant)))
        => truthy))

(let [bucket-name (random-string)
      object-name (random-string)
      value-string "this is the real value"
      public-read-grant {:grantee :all-users, :permission :read}]
  (fact "Creating an object with an ACL returns the same ACL when you read
        the ACL"
        (with-random-cred c
          (do
            ;; create a bucket
            (s3/create-bucket c bucket-name)
            (s3/put-object c bucket-name object-name value-string {}
                           (s3/grant :all-users :read))
            (contains?
             (:grants (s3/get-object-acl c bucket-name object-name))
             public-read-grant)))
        => truthy))

(let [bucket-name (random-string)
      object-name (random-string)
      value-string "this is the real value"]
  (fact "Creating an object with an (non-canned) ACL returns the same ACL
        when you read the ACL"
        (with-random-cred c
          (do
            (s3/create-bucket c bucket-name)
            (let [user-two (user-creation/create-random-user
                            riak-cs-host-with-protocol
                            (get-riak-cs-port))
                  user-two-id (:id user-two)
                  user-two-name (:display_name user-two)
                  acl-grant {:grantee {:id user-two-id, :display-name user-two-name},
                             :permission :read}]
              (s3/put-object c bucket-name object-name value-string {}
                             (s3/grant {:id user-two-id} :read))
              (contains?
                (:grants (s3/get-object-acl c bucket-name object-name))
                acl-grant))))
        => truthy))

(let [bucket-name (random-string)
      object-name (random-string)
      public-read-grant {:grantee :all-users, :permission :read}]
  (fact "Creating a bucket with an ACL returns the same ACL when you read
        the ACL"
        (with-random-cred c
          (do
            (s3/create-bucket c bucket-name {}
                              (s3/grant :all-users :read))
            (contains?
             (:grants (s3/get-bucket-acl c bucket-name))
             public-read-grant)))
        => truthy))

(let [bucket-name (random-string)
      object-name (random-string)]
  (fact "Creating a bucket with an (non-canned) ACL returns the same ACL
        when you read the ACL"
        (with-random-cred c
          (do
            (let [user-two (user-creation/create-random-user
                            riak-cs-host-with-protocol
                            (get-riak-cs-port))
                  user-two-id (:id user-two)
                  user-two-name (:display_name user-two)
                  acl-grant {:grantee {:id user-two-id, :display-name user-two-name},
                             :permission :write}]
              (s3/create-bucket c bucket-name {}
                                (s3/grant {:id user-two-id} :write))
              (contains?
               (:grants (s3/get-bucket-acl c bucket-name))
               acl-grant))))
        => truthy))

;; Copyright (c) 2007-2015 Basho Technologies, Inc.  All Rights Reserved.
;;
;; This file is provided to you under the Apache License,
;; Version 2.0 (the "License"); you may not use this file
;; except in compliance with the License.  You may obtain
;; a copy of the License at
;;
;;   http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing,
;; software distributed under the License is distributed on an
;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
;; KIND, either express or implied.  See the License for the
;; specific language governing permissions and limitations
;; under the License.

(ns java-s3-tests.test.client
  (:import java.security.MessageDigest
           org.apache.commons.codec.binary.Hex
           com.amazonaws.services.s3.model.AmazonS3Exception)

  (:require [aws.sdk.s3 :as s3])
  (:require [java-s3-tests.user-creation :as user-creation])
  (:require [clojure.tools.logging :as log])
  (:use midje.sweet))

(def ^:internal riak-cs-host "127.0.0.1")
(def ^:internal riak-cs-host-with-protocol (str "http://" riak-cs-host))

(defn get-riak-cs-port-str
  "Try to get a TCP port number from the OS environment"
  []
  (let [port-str (get (System/getenv) "CS_HTTP_PORT")]
       (cond (nil? port-str) "8080"
             :else           port-str)))

(defn get-riak-cs-port []
  (Integer/parseInt (get-riak-cs-port-str) 10))

(defn md5-byte-array [input-byte-array]
  (let [instance (MessageDigest/getInstance "MD5")]
    (.digest instance input-byte-array)))

(defn md5-string
  [input-byte-array]
  (let [b (md5-byte-array input-byte-array)]
    (String. (Hex/encodeHex b))))

(defn user-to-cred
  [user]
  {:endpoint "http://s3.amazonaws.com"
   :access-key (:key_id user)
   :secret-key (:key_secret user)
   :proxy {:host riak-cs-host
           :port (get-riak-cs-port)}})

(defn random-user
  []
  (user-creation/create-random-user riak-cs-host-with-protocol (get-riak-cs-port)))

(defmacro with-random-user
  "Execute `body` in implicit do with a random-user bound to `var-name`"
  [var-name & body]
  `(let [~var-name (random-user)]
     (do ~@body)))

(defn random-cred
  []
  (user-to-cred (random-user)))

(defmacro with-random-cred
  "Execute `body` in implicit do with a random-cred bound to `var-name`"
  [var-name & body]
  `(let [~var-name (random-cred)]
     (do ~@body)))

(defn random-string []
  (str (java.util.UUID/randomUUID)))

(defn write-file [filename content]
  (with-open [w (clojure.java.io/writer filename :append false)]
    (.write w content)))

(defn etag-suffix [etag]
  (subs etag (- (count etag) 2)))

(defn upload-file [cred bucket key file-name part-size]
  (let [f (clojure.java.io/file file-name)]
    (s3/put-multipart-object cred bucket key f {:part-size part-size :threads 2})
    (.delete f)))

(fact "bogus creds raises an exception"
      (let [bogus-user {:key_id "foo"
                        :key_secret "bar"}]
        (s3/list-buckets (user-to-cred bogus-user)))
      => (throws AmazonS3Exception))

(fact "new users have no buckets"
      (with-random-cred c
        (s3/list-buckets c))
      => [])

(let [bucket-name (random-string)]
  (fact "creating a bucket should list one bucket in list buckets"
        (with-random-cred c
          (s3/create-bucket c bucket-name)
          (map :name (s3/list-buckets c))
        => [bucket-name])))

(let [bucket-name (random-string)
      object-name (random-string)]
  (fact "simple put works"
        (with-random-cred cred
          (s3/create-bucket cred bucket-name)
          (s3/put-object cred bucket-name object-name
                         "contents"))
        => truthy))

(let [bucket-name (random-string)
      object-name (random-string)
      value "this is the value!"]
  (fact "the value received during GET is the same
         as the object that was PUT"
        (with-random-cred c
          (s3/create-bucket c bucket-name)
          (s3/put-object c bucket-name object-name value)
          ((comp slurp :content) (s3/get-object c bucket-name object-name)))
        => value))

(let [bucket-name (random-string)
      object-name (random-string)
      value "this is the value!"
      as-bytes (.getBytes value "UTF-8")
      md5-sum (md5-string as-bytes)]
  (fact "check that the etag of the response is the same as the md5
         of the original object"
        (with-random-cred c
          (s3/create-bucket c bucket-name)
          (s3/put-object c bucket-name object-name value)
          ((comp :etag :metadata)
           (s3/get-object
            c bucket-name object-name)))
        => md5-sum))

(let [bucket-name (random-string)
      object-name (random-string)
      value "aaaaaaaaaabbbbbbbbbb"
      file-name "./clj-mp-test.txt"]
  (fact "multipart upload works"
        (with-random-cred c
          (s3/create-bucket c bucket-name)
          (write-file file-name value)
          (upload-file c bucket-name object-name file-name 10)
          (let [fetched-object (s3/get-object
                                c bucket-name object-name)]
            ((comp slurp :content) fetched-object)
            => value
            ((comp etag-suffix :etag :metadata) fetched-object)
            => "-2"))))

(let [bucket-name (random-string)
      object-name (random-string)
      value "this is the real value"
      wrong-md5 "2945d7de2f70de5b8c0cb3fbcba4fe92"]
  (fact "Bad content md5 throws an exception"
        (with-random-cred c
          (s3/create-bucket c bucket-name)
          (s3/put-object c bucket-name object-name value
                         {:content-md5 wrong-md5}))
        => (throws AmazonS3Exception)))

(def bad-canonical-id
  "0f80b2d002a3d018faaa4a956ce8aa243332a30e878f5dc94f82749984ebb30b")

(let [bucket-name (random-string)
      object-name (random-string)
      value-string "this is the real value"]
  (fact "Nonexistent canonical-id grant header returns HTTP 400 on
        a put object request (not just an ACL subresource request)"
        (with-random-cred c
          (s3/create-bucket c bucket-name)
          (s3/put-object c bucket-name object-name value-string {}
                         (s3/grant {:id bad-canonical-id} :full-control)))
        => (throws AmazonS3Exception)))

(let [bucket-name (random-string)
      object-name (random-string)
      value-string "this is the real value"
      public-read-grant {:grantee :all-users, :permission :read}]
  (fact "Creating an object with an ACL returns the same ACL when you read
        the ACL"
        (with-random-cred c
          (s3/create-bucket c bucket-name)
          (s3/put-object c bucket-name object-name value-string {}
                         (s3/grant :all-users :read))
          (:grants (s3/get-object-acl c bucket-name object-name)))
        => (contains (just public-read-grant))))

(let [bucket-name (random-string)
      object-name (random-string)
      value-string "this is the real value"
      public-read-grant {:grantee :all-users, :permission :read}]
  (fact "Creating an object with an ACL returns the same ACL when you read
        the ACL"
        (with-random-cred c
          (s3/create-bucket c bucket-name)
          (s3/put-object c bucket-name object-name value-string {}
                         (s3/grant :all-users :read))
          (:grants (s3/get-object-acl c bucket-name object-name)))
        => (contains (just public-read-grant))))

(let [bucket-name (random-string)
      object-name (random-string)
      value-string "this is the real value"]
  (with-random-cred c
    (with-random-user u2
      (fact "Creating an object with an (non-canned) ACL returns the same ACL
             when you read the ACL"
            (s3/create-bucket c bucket-name)
            (s3/put-object c bucket-name object-name value-string {}
                           (s3/grant {:id (:id u2)} :read))
            (:grants (s3/get-object-acl c bucket-name object-name))
            => (contains (just {:grantee {:id (:id u2),
                                          :display-name (:display_name u2)},
                                :permission :read}))))))

(let [bucket-name (random-string)
      object-name (random-string)]
  (fact "Creating a bucket with an ACL returns the same ACL when you read
        the ACL"
        (with-random-cred c
          (do
            (s3/create-bucket c bucket-name {}
                              (s3/grant :all-users :read))
            (:grants (s3/get-bucket-acl c bucket-name))))
        => (contains (just {:grantee :all-users, :permission :read}))))

(let [bucket-name (random-string)
      object-name (random-string)]
  (with-random-cred c
    (with-random-user u2
        (fact "Creating a bucket with an (non-canned) ACL returns the same ACL
               when you read the ACL"
               (s3/create-bucket c bucket-name {}
                                 (s3/grant {:id (:id u2)} :write))
               (:grants (s3/get-bucket-acl c bucket-name))
               => (contains (just {:grantee {:id (:id u2),
                                             :display-name (:display_name u2)},
                                   :permission :write}))))))

Refactor clojure test code

Refactor clojure test code


(ns photon.api
  (:require [photon.streams :as streams]
            [clojure.tools.logging :as log]
            [clojure.core.async :as async]))

(defn post-projection! [stm request]
  (let [body request
        projection-name (:projection-name body)
        stream-name (:stream-name body)
        language (:language body)
        code (:reduction body)
        initial-value (:initial-value body)]
    (streams/register-query! stm (keyword projection-name)
                             stream-name
                             (keyword language)
                             code
                             (read-string initial-value))
    "Ok"))

(defn projections []
  (map
    (fn [v] (assoc v :fn (pr-str (:fn v))))
    (map #(apply dissoc (deref %) [:_id])
         (vals @streams/queries))))

(defn projection [projection-name]
  (log/info "Querying" projection-name)
  (let [res (first (filter #(= (name (:projection-name %)) projection-name)
                           (map deref (vals @streams/queries))))]
    (log/info "Result:" (pr-str res))
    (log/info "Result:" (pr-str (muon-clojure.common/dekeywordize res)))
    res))

(defn proper-map [m]
  (java.util.HashMap. (clojure.walk/stringify-keys m)))

(defn projection-keys []
  (proper-map
    {:projection-keys
     (map :projection-name
          (map
            (fn [v] (assoc v :fn (pr-str (:fn v))))
            (map #(apply dissoc (deref %) [:_id])
                 (vals @streams/queries))))}))

(defn stream [stm stream-name]
  {:results
   (async/<!!
     (async/reduce (fn [prev n] (concat prev [n])) []
                   (streams/stream stm {"from" "0"
                                        "stream-name" stream-name
                                        "stream-type" "cold"})))})

(ns photon.api
  (:require [photon.streams :as streams]
            [clojure.tools.logging :as log]
            [clojure.core.async :as async]))

(defn post-projection! [stm request]
  (let [body request
        projection-name (:projection-name body)
        stream-name (:stream-name body)
        language (:language body)
        code (:reduction body)
        initial-value (:initial-value body)]
    (streams/register-query! stm (keyword projection-name)
                             stream-name
                             (keyword language)
                             code
                             (read-string initial-value))
    "Ok"))

(defn projections []
  (map
    (fn [v] (assoc v :fn (pr-str (:fn v))))
    (map #(apply dissoc (deref %) [:_id])
         (vals @streams/queries))))

(defn projection [projection-name]
  (log/info "Querying" projection-name)
  (let [res (first (filter #(= (name (:projection-name %)) projection-name)
                           (map deref (vals @streams/queries))))]
    (log/info "Result:" (pr-str res))
    (log/info "Result:" (pr-str (muon-clojure.utils/dekeywordize res)))
    res))

(defn proper-map [m]
  (java.util.HashMap. (clojure.walk/stringify-keys m)))

(defn projection-keys []
  (proper-map
    {:projection-keys
     (map :projection-name
          (map
            (fn [v] (assoc v :fn (pr-str (:fn v))))
            (map #(apply dissoc (deref %) [:_id])
                 (vals @streams/queries))))}))

(defn stream [stm stream-name]
  {:results
   (async/<!!
     (async/reduce (fn [prev n] (concat prev [n])) []
                   (streams/stream stm {"from" "0"
                                        "stream-name" stream-name
                                        "stream-type" "cold"})))})

Update to fix compilation

Update to fix compilation


(ns qttt.game
  "Logic relating to game state"
  (:require [clojure.set :as set]))

(def num-cells 9)
(def num-players 2)

(def ^:dynamic *speculative* false)

(comment
  ;; Game Data Structures

  ;; Game
  {:turn   0
   :player 0
   :pair [4 2]
   :board board
   :base game
   }

  ;; The board
  {0 cell 1 cell}

   ;; A cell
  {:entanglements {0 {:player 0
                      :turn 0
                      :pair [4 2]
                      :focus false
                      :collapsing true}
                   1 {:player 1
                      :pair [4 2]
                      :turn 1
                      :focus true}}
   :classical {:player 0
               :turn 0
               :speculative true}})

(defn next-player
  [player]
  (mod (inc player) num-players))

(defn get-entanglements
  "Return information regarding cells entangled with the given cell.

   Return value is a seq of [cell turn] tuples, where turn
   is the turn the spooky mark was placed. Exclude
   entanglements which have a classical value already."

  [game cell]
  (->> (get-in game [:board cell :entanglements])
    (vals)
    (keep (fn [e] (when-let [[pair-cell pair-subcell] (:pair e)]
                    (when-not (get-in game [:board pair-cell :classical])
                      [pair-cell (:turn e)]))))))

(defn index-of
  "Return the index of an item in a vector, if present. If not present return nil"
  [v item]
  (first (keep-indexed (fn [i val]
                         (when (= val item) i))
           v)))

(defn cycle-search
  "Return a seq of cell cycles discovered.

   Tracks the turn of the entanglement just
   followed, to avoid backtracking immediately."
  [game cell visited from-turn]
  (set (mapcat (fn [[edge turn]]
                 (when-not (= turn from-turn)
                   (if-let [idx (index-of visited edge)]
                     [(set (conj (subvec visited idx) cell))]
                     (cycle-search game edge (conj visited cell) turn))))
         (get-entanglements game cell))))

(defn detect-cycles
  "Return a sequence of all entanglement cycles present in the given board"
  [game]
  ;; Not 100% efficient, but we need some way of detecting multiple disjoint graphs.
  ;; Should be fine for small N. Using sets removes redundancies. If we run into perf
  ;; trouble we can track which nodes we've visited *at all* and never revisit them.
  (apply set/union (map #(cycle-search game % [] -1) (keys (:board game)))))

(defn check-collapses
  "Given a game, check if there are any collapses happening
   and return an updated game accordingly"
  [game]
  (let [cycles (detect-cycles game)]
    (if (empty? cycles)
      (assoc game :collapsing false)
      (let [collapsing-cells (apply set/union cycles)]
        (reduce (fn [g cell]
                  (let [collapsing-subcells
                        (keep
                          (fn [[sub e]] (when (contains? collapsing-cells (first (:pair e))) sub))
                          (get-in g [:board cell :entanglements]))]
                    (reduce #(assoc-in %1 [:board cell :entanglements %2 :collapsing] true) g collapsing-subcells)))
          (assoc game :collapsing true)
          collapsing-cells)))))

(defn legal-spooky-mark?
  "Return true if a spooky mark can be placed on the given cell and subcell"
  [game cell subcell]
  (and
    (not= cell (first (:pair game)))
    (nil? (get-in game [:board cell :entanglements subcell]))))

(defn entangle
  "Given a cell, a subcell and the entangled cell and subcell, create an entanglement"
  [game cell subcell pair-cell pair-subcell]
  (if-not (legal-spooky-mark? game cell subcell)
    game
    (-> game
      ;; add the new spooky mark
      (assoc-in [:board cell :entanglements subcell]
        {:player (:player game)
         :turn (:turn game)
         :pair [pair-cell pair-subcell]
         :focus *speculative*})
      ;; update the entangled spooky mark
      (update-in [:board pair-cell :entanglements pair-subcell] assoc
        :focus *speculative*
        :pair [cell subcell])
      ;; remove the pair tracker
      (dissoc :pair)
      ;; change the player
      (update-in [:player] next-player)
      ;; update the turn
      (update-in [:turn] inc)
      ;; check for collapses
      (check-collapses))))

(defn valid-collapse?
  "Return true if the given cell and subcell represent
   a valid choice to collapse"
  [game cell subcell]
  (get-in game [:board cell :entanglements subcell :collapsing]))

;; will this work with the new data model? Or need refactoring?
(defn observe
  "Define an observation as a tuple of [accepted-cell accepted-subcell],
   where the accepted subcell is that which will be observed and become classical.

  Given an observation, return a set of observations implied based
  on the accepted cell's entanglements."
  [game [accepted-cell accepted-subcell]]
  (map :pair
    (vals (dissoc (get-in game [:board accepted-cell :entanglements])
            accepted-subcell))))

(defn observe-all
  "Given a set of observations, recursively calculate *all* observations inferred from entangled cells"
  [game observations]
  (loop [os observations]
    (let [next-os (apply set/union os (map #(observe game %) os))]
      (if (= next-os os)
        next-os
        (recur next-os)))))

(defn resolve-collapse
  "Given a cell and subcell, resolve any collapse present in the game"
  [game cell subcell]
  (if-not (valid-collapse? game cell subcell)
    game
    (let [observations (observe-all game #{[cell subcell]})
          observations (if *speculative* (disj observations [cell subcell])
                                         observations)]
      (reduce (fn [game [cell subcell]]
                (let [e (get-in game [:board cell :entanglements subcell])]
                  (assoc-in game [:board cell :classical]
                    {:player (:player e)
                     :turn (:turn e)
                     :focus *speculative*})))
        (if *speculative*
          (assoc-in game [:board cell :entanglements subcell :focus] true)
          (assoc game :collapsing false))
        observations))))

(defn spooky-mark
  "Place a spooky mark at the given cell and subcell"
  [game cell subcell]
  (if-let [[pair-cell pair-subcell] (:pair game)]
    (entangle game cell subcell pair-cell pair-subcell)
    (if-not (legal-spooky-mark? game cell subcell)
      game
      (-> game
        (assoc :pair [cell subcell])
        (assoc-in  [:board cell :entanglements subcell]
          {:player (:player game)
           :turn (:turn game)
           :focus true})))))

(defn highlight
  "Focus the subcell and its entanglement"
  [game cell subcell]
  (-> (if-let [[pair-cell pair-subcell]
               (get-in game [:board cell :entanglements subcell :pair])]
        (assoc-in game [:board pair-cell :entanglements pair-subcell :focus] true)
        game)
    (assoc-in [:board cell :entanglements subcell :focus] true)))

(defn play
  "Play an action at the given cell and subcell.
   What the action is depends on the game context."
  [game cell subcell]
  (if (:collapsing game)
    (resolve-collapse game cell subcell)
    (if (and *speculative* (get-in game [:board cell :entanglements subcell]))
      (highlight game cell subcell)
      (spooky-mark game cell subcell))))

(defn speculate
  "Make a play, but store the previous game state so the 'play' can be easily reverted"
  [game cell subcell]
  (binding [*speculative* true]
    (-> game
      (play cell subcell)
      (assoc :base game))))

(defn unspeculate
  "Restore the previous game state (if there was one)."
  [game]
  (if (:base game) (:base game) game))

(def new-game
  {:turn 0
   :player 0
   :board (zipmap (range num-cells)
                  (repeat {:entanglements {}}))})

(ns qttt.game
  "Logic relating to game state"
  (:require [clojure.set :as set]))

(def num-cells 9)
(def num-players 2)

(def ^:dynamic *speculative* false)

(comment
  ;; Game Data Structures

  ;; Game
  {:turn   0
   :player 0
   :pair [4 2]
   :board board
   :base game
   }

  ;; The board
  {0 cell 1 cell}

   ;; A cell
  {:entanglements {0 {:player 0
                      :turn 0
                      :pair [4 2]
                      :focus false
                      :collapsing true}
                   1 {:player 1
                      :pair [4 2]
                      :turn 1
                      :focus true}}
   :classical {:player 0
               :turn 0
               :speculative true}})

(defn next-player
  [player]
  (mod (inc player) num-players))

(defn get-entanglements
  "Return information regarding cells entangled with the given cell.

   Return value is a seq of [cell turn] tuples, where turn
   is the turn the spooky mark was placed. Exclude
   entanglements which have a classical value already."

  [game cell]
  (->> (get-in game [:board cell :entanglements])
    (vals)
    (keep (fn [e] (when-let [[pair-cell pair-subcell] (:pair e)]
                    (when-not (get-in game [:board pair-cell :classical])
                      [pair-cell (:turn e)]))))))

(defn index-of
  "Return the index of an item in a vector, if present. If not present return nil"
  [v item]
  (first (keep-indexed (fn [i val]
                         (when (= val item) i))
           v)))

(defn cycle-search
  "Return a seq of cell cycles discovered.

   Tracks the turn of the entanglement just
   followed, to avoid backtracking immediately."
  [game cell visited from-turn]
  (set (mapcat (fn [[edge turn]]
                 (when-not (= turn from-turn)
                   (if-let [idx (index-of visited edge)]
                     [(set (conj (subvec visited idx) cell))]
                     (cycle-search game edge (conj visited cell) turn))))
         (get-entanglements game cell))))

(defn detect-cycles
  "Return a sequence of all entanglement cycles present in the given board"
  [game]
  ;; Not 100% efficient, but we need some way of detecting multiple disjoint graphs.
  ;; Should be fine for small N. Using sets removes redundancies. If we run into perf
  ;; trouble we can track which nodes we've visited *at all* and never revisit them.
  (apply set/union (map #(cycle-search game % [] -1) (keys (:board game)))))

(defn check-collapses
  "Given a game, check if there are any collapses happening
   and return an updated game accordingly"
  [game]
  (let [cycles (detect-cycles game)]
    (if (empty? cycles)
      (assoc game :collapsing false)
      (let [collapsing-cells (apply set/union cycles)]
        (reduce (fn [g cell]
                  (let [collapsing-subcells
                        (keep
                          (fn [[sub e]] (when (contains? collapsing-cells (first (:pair e))) sub))
                          (get-in g [:board cell :entanglements]))]
                    (reduce #(assoc-in %1 [:board cell :entanglements %2 :collapsing] true) g collapsing-subcells)))
          (assoc game :collapsing true)
          collapsing-cells)))))

(defn legal-spooky-mark?
  "Return true if a spooky mark can be placed on the given cell and subcell"
  [game cell subcell]
  (and
    (not= cell (first (:pair game)))
    (nil? (get-in game [:board cell :entanglements subcell]))))

(defn entangle
  "Given a cell, a subcell and the entangled cell and subcell, create an entanglement"
  [game cell subcell pair-cell pair-subcell]
  (if-not (legal-spooky-mark? game cell subcell)
    game
    (-> game
      ;; add the new spooky mark
      (assoc-in [:board cell :entanglements subcell]
        {:player (:player game)
         :turn (:turn game)
         :pair [pair-cell pair-subcell]
         :focus *speculative*})
      ;; update the entangled spooky mark
      (update-in [:board pair-cell :entanglements pair-subcell] assoc
        :focus *speculative*
        :pair [cell subcell])
      ;; remove the pair tracker
      (dissoc :pair)
      ;; change the player
      (update-in [:player] next-player)
      ;; update the turn
      (update-in [:turn] inc)
      ;; check for collapses
      (check-collapses))))

(defn valid-collapse?
  "Return true if the given cell and subcell represent
   a valid choice to collapse"
  [game cell subcell]
  (get-in game [:board cell :entanglements subcell :collapsing]))

;; will this work with the new data model? Or need refactoring?
(defn observe
  "Define an observation as a tuple of [accepted-cell accepted-subcell],
   where the accepted subcell is that which will be observed and become classical.

  Given an observation, return a set of observations implied based
  on the accepted cell's entanglements."
  [game [accepted-cell accepted-subcell]]
  (set (map :pair
         (vals (dissoc (get-in game [:board accepted-cell :entanglements])
                 accepted-subcell)))))

(defn observe-all
  "Given a set of observations, recursively calculate *all* observations inferred from entangled cells"
  [game observations]
  (loop [os observations]
    (let [next-os (apply set/union os (map #(observe game %) os))]
      (if (= next-os os)
        next-os
        (recur next-os)))))

(defn resolve-collapse
  "Given a cell and subcell, resolve any collapse present in the game"
  [game cell subcell]
  (if-not (valid-collapse? game cell subcell)
    game
    (let [observations (observe-all game #{[cell subcell]})
          observations (if *speculative* (disj observations [cell subcell])
                                         observations)]
      (reduce (fn [game [cell subcell]]
                (let [e (get-in game [:board cell :entanglements subcell])]
                  (assoc-in game [:board cell :classical]
                    {:player (:player e)
                     :turn (:turn e)
                     :focus *speculative*})))
        (if *speculative*
          (assoc-in game [:board cell :entanglements subcell :focus] true)
          (assoc game :collapsing false))
        observations))))

(defn spooky-mark
  "Place a spooky mark at the given cell and subcell"
  [game cell subcell]
  (if-let [[pair-cell pair-subcell] (:pair game)]
    (entangle game cell subcell pair-cell pair-subcell)
    (if-not (legal-spooky-mark? game cell subcell)
      game
      (-> game
        (assoc :pair [cell subcell])
        (assoc-in  [:board cell :entanglements subcell]
          {:player (:player game)
           :turn (:turn game)
           :focus true})))))

(defn highlight
  "Focus the subcell and its entanglement"
  [game cell subcell]
  (-> (if-let [[pair-cell pair-subcell]
               (get-in game [:board cell :entanglements subcell :pair])]
        (assoc-in game [:board pair-cell :entanglements pair-subcell :focus] true)
        game)
    (assoc-in [:board cell :entanglements subcell :focus] true)))

(defn play
  "Play an action at the given cell and subcell.
   What the action is depends on the game context."
  [game cell subcell]
  (if (:collapsing game)
    (resolve-collapse game cell subcell)
    (if (and *speculative* (get-in game [:board cell :entanglements subcell]))
      (highlight game cell subcell)
      (spooky-mark game cell subcell))))

(defn speculate
  "Make a play, but store the previous game state so the 'play' can be easily reverted"
  [game cell subcell]
  (binding [*speculative* true]
    (-> game
      (play cell subcell)
      (assoc :base game))))

(defn unspeculate
  "Restore the previous game state (if there was one)."
  [game]
  (if (:base game) (:base game) game))

(def new-game
  {:turn 0
   :player 0
   :board (zipmap (range num-cells)
                  (repeat {:entanglements {}}))})

fix observation bug

fix observation bug


(ns vault.blob
  (:refer-clojure :exclude [list ref])
  (:require [clojure.string :as string]
            digest))

(def ^:private digest-functions
  "Map of content hashing algorithms to functional implementations."
  {:md5    digest/md5
   :sha1   digest/sha-1
   :sha256 digest/sha-256})

(def digest-algorithms
  "Set of available content hashing algorithms."
  (into #{} (keys digest-functions)))

(defn- assert-valid-digest
  [algorithm]
  (when-not (digest-functions algorithm)
    (throw (IllegalArgumentException.
             (str "Unsupported digest algorithm: " algorithm
                  ", must be one of: " (string/join ", " digest-algorithms))))))

;; BLOB REFERENCE

(defrecord BlobRef
  [algorithm digest]

  Comparable

  (compareTo [this that]
    (if (= this that)
      0
      (->> [this that]
           (map (juxt :algorithm :digest))
           (apply compare))))

  Object

  (toString [this]
    (str (name algorithm) ":" digest)))

; FIXME: this doesn't need to be here, could be declared later to remove dependency on vault.data
;(data/extend-tagged-str BlobRef vault/ref)

(defn parse-identifier
  "Parses a hash identifier string into a blobref. Accepts either a hash URN
  or the shorter \"algo:digest\" format."
  [id]
  (let [id (if (re-find #"^urn:" id) (subs id 4) id)
        id (if (re-find #"^hash:" id) (subs id 5) id)
        [algorithm digest] (string/split id #":" 2)
        algorithm (keyword algorithm)]
    (assert-valid-digest algorithm)
    (BlobRef. algorithm digest)))

(defn ref
  "Constructs a BlobRef out of the arguments."
  ([x]
   (if (instance? BlobRef x) x
     (parse-identifier (str x))))
  ([algorithm digest]
   (let [algorithm (keyword algorithm)]
     (assert-valid-digest algorithm)
     (BlobRef. algorithm digest))))

;; BLOB STORE PROTOCOL

(defprotocol BlobStore
  (algorithm
    [this]
    "Returns the algorithm in use by the blob store.")

  (enumerate
    [this opts]
    "Enumerates the stored blobs, returning a sequence of BlobRefs.
    Options should be keyword/value pairs from the following:
    * :start - start enumerating blobrefs lexically following this string
    * :prefix - only return blobrefs matching the given string
    * :count - limit the number of results returned")

  (stat
    [this blobref]
    "Returns a map of metadata about the blob, if it is stored. Properties are
    implementation-specific, but should include:
    * :size - blob size in bytes
    * :since - date blob was added to store
    Optionally, other attributes may also be included:
    * :content-type - a guess at the type of content stored in the blob
    * :location - a resource location for the blob")

  (open
    ^java.io.InputStream
    [this blobref]
    "Opens a stream of byte content for the referenced blob, if it is stored.")

  (store!
    [this content]
    "Stores the given byte stream and returns the blob reference.")

  (remove!
    [this blobref]
    "Remove the referenced blob from this store. Returns true if the store
    contained the blob when this method was called."))

(defn list
  "Enumerates the stored blobs, returning a sequence of BlobRefs.
  Options should be keyword/value pairs from the following:
  * :start - start enumerating blobrefs lexically following this string
  * :prefix - only return blobrefs matching the given string
  * :count - limit the number of results returned"
  ([store]
   (enumerate store nil))
  ([store opts]
   (enumerate store opts))
  ([store first-opt & opts]
   (->> (cons first-opt opts)
        (partition 2)
        (into {})
        (enumerate store))))

(defn contains-blob?
  "Determines whether the store contains the referenced blob."
  [store blobref]
  (not (nil? (stat store blobref))))

(defn select-refs
  "Selects blobrefs from a lazy sequence based on input criteria."
  [opts blobrefs]
  (let [{:keys [start prefix]} opts
        blobrefs (if-let [start (or start prefix)]
                   (drop-while #(< 0 (compare start (str %))) blobrefs)
                   blobrefs)
        blobrefs (if prefix
                   (take-while #(.startsWith (str %) prefix) blobrefs)
                   blobrefs)
        blobrefs (if-let [n (:count opts)]
                   (take n blobrefs)
                   blobrefs)]
    blobrefs))

;; CONTENT HASHING

(defn digest
  "Calculates the blob reference for the given content."
  [algorithm content]
  (assert-valid-digest algorithm)
  (let [hashfn (digest-functions algorithm)
        digest ^String (hashfn content)]
    (BlobRef. algorithm (.toLowerCase digest))))

(ns vault.blob
  (:refer-clojure :exclude [list ref])
  (:require [clojure.string :as string]
            digest))

(def ^:private digest-functions
  "Map of content hashing algorithms to functional implementations."
  {:md5    digest/md5
   :sha1   digest/sha-1
   :sha256 digest/sha-256})

(def digest-algorithms
  "Set of available content hashing algorithms."
  (into #{} (keys digest-functions)))

(defn- assert-valid-digest
  [algorithm]
  (when-not (digest-functions algorithm)
    (throw (IllegalArgumentException.
             (str "Unsupported digest algorithm: " algorithm
                  ", must be one of: " (string/join ", " digest-algorithms))))))

;; BLOB REFERENCE

(defrecord BlobRef
  [algorithm digest]

  Comparable

  (compareTo [this that]
    (if (= this that)
      0
      (->> [this that]
           (map (juxt :algorithm :digest))
           (apply compare))))

  Object

  (toString [this]
    (str (name algorithm) ":" digest)))

; FIXME: this doesn't need to be here, could be declared later to remove dependency on vault.data
;(data/extend-tagged-str BlobRef vault/ref)

(defn parse-identifier
  "Parses a hash identifier string into a blobref. Accepts either a hash URN
  or the shorter \"algo:digest\" format."
  [id]
  (let [id (if (re-find #"^urn:" id) (subs id 4) id)
        id (if (re-find #"^hash:" id) (subs id 5) id)
        [algorithm digest] (string/split id #":" 2)
        algorithm (keyword algorithm)]
    (assert-valid-digest algorithm)
    (BlobRef. algorithm digest)))

(defn ref
  "Constructs a BlobRef out of the arguments."
  ([x]
   (if (instance? BlobRef x) x
     (parse-identifier (str x))))
  ([algorithm digest]
   (let [algorithm (keyword algorithm)]
     (assert-valid-digest algorithm)
     (BlobRef. algorithm digest))))

;; BLOB STORE PROTOCOL

(defprotocol BlobStore
  (algorithm
    [this]
    "Returns the algorithm in use by the blob store.")

  (enumerate
    [this opts]
    "Enumerates the stored blobs, returning a sequence of BlobRefs.
    Options should be keyword/value pairs from the following:
    * :start - start enumerating blobrefs lexically following this string
    * :prefix - only return blobrefs matching the given string
    * :count - limit the number of results returned")

  (stat
    [this blobref]
    "Returns a map of metadata about the blob, if it is stored. Properties are
    implementation-specific, but should include:
    * :size - blob size in bytes
    * :since - date blob was added to store
    Optionally, other attributes may also be included:
    * :content-type - a guess at the type of content stored in the blob
    * :location - a resource location for the blob")

  (open
    ^java.io.InputStream
    [this blobref]
    "Opens a stream of byte content for the referenced blob, if it is stored.")

  (store!
    [this content]
    "Stores the given byte stream and returns the blob reference.")

  (remove!
    [this blobref]
    "Remove the referenced blob from this store. Returns true if the store
    contained the blob when this method was called."))

(defn list
  "Enumerates the stored blobs, returning a sequence of BlobRefs.
  Options should be keyword/value pairs from the following:
  * :start - start enumerating blobrefs lexically following this string
  * :prefix - only return blobrefs matching the given string
  * :count - limit the number of results returned"
  ([store]
   (enumerate store nil))
  ([store opts]
   (enumerate store opts))
  ([store opt-key opt-val & opts]
   (->> opts
        (partition 2)
        (cons [opt-key opt-val])
        (into {})
        (enumerate store))))

(defn contains-blob?
  "Determines whether the store contains the referenced blob."
  [store blobref]
  (not (nil? (stat store blobref))))

(defn select-refs
  "Selects blobrefs from a lazy sequence based on input criteria."
  [opts blobrefs]
  (let [{:keys [start prefix]} opts
        blobrefs (if-let [start (or start prefix)]
                   (drop-while #(< 0 (compare start (str %))) blobrefs)
                   blobrefs)
        blobrefs (if prefix
                   (take-while #(.startsWith (str %) prefix) blobrefs)
                   blobrefs)
        blobrefs (if-let [n (:count opts)]
                   (take n blobrefs)
                   blobrefs)]
    blobrefs))

;; CONTENT HASHING

(defn digest
  "Calculates the blob reference for the given content."
  [algorithm content]
  (assert-valid-digest algorithm)
  (let [hashfn (digest-functions algorithm)
        digest ^String (hashfn content)]
    (BlobRef. algorithm (.toLowerCase digest))))

Fix bug when statting blobs.

Fix bug when statting blobs.


(ns adzerk.boot-cljs.impl
  (:require [boot.file :as file]
            [boot.kahnsort :as kahn]
            [boot.pod :as pod]
            [boot.util :as butil]
            [cljs.analyzer :as ana]
            [cljs.analyzer.api :as ana-api :refer [empty-state default-warning-handler warning-enabled?]]
            [cljs.build.api :as build-api :refer [build inputs target-file-for-cljs-ns]]
            [clojure.java.io :as io]
            [adzerk.boot-cljs.util :as util]
            [ns-tracker.core :refer [ns-tracker]]))

; Because this ns is loaded in pod, it's private to one cljs task.
; Compiler env is a atom.
(def ^:private stored-env (empty-state))

(defn ns-dependencies
  "Given a namespace as a symbol return list of namespaces required by the namespace."
  ; ([ns] (ns-dependencies env/*compiler* ns))
  ([state ns]
   (vals (:requires (ana-api/find-ns state ns)))))

(defn cljs-depdendency-graph [state]
  (let [all-ns (ana-api/all-ns state)
        all-ns-set (set all-ns)]
    (->> all-ns
         (reduce (fn [acc n]
                   (assoc acc n (->> (ns-dependencies state n)
                                     (keep all-ns-set)
                                     (set))))
                 {}))))

(defn dep-order [env opts]
  (->> (cljs-depdendency-graph env)
       (kahn/topo-sort)
       reverse
       (map #(.getPath (target-file-for-cljs-ns % (:output-dir opts))))))

(defn handle-ex [e dirs report-atom]
  (let [{:keys [type] :as ex} (ex-data (.getCause e))]
    (cond
      (= :reader-exception type)
      (let [{:keys [file line column]} ex
            msg  (some-> e (.getCause) (.getMessage))
            path (util/find-relative-path dirs file)
            exs  (format "ERROR: %s on file %s, line %d, column %d\n" msg path line column)]
        (swap! report-atom assoc :exception exs)
        (butil/fail exs))

      :default (throw e))))

(defn compile-cljs
  "Given a seq of directories containing CLJS source files and compiler options
  opts, compiles the CLJS to produce JS files."
  [input-path {:keys [optimizations] :as opts}]
  ;; So directories need to be passed to cljs compiler when compiling in dev
  ;; or there are stale namespace problems with tests. However, if compiling
  ;; with optimizations other than :none adding directories will break the
  ;; build and defeat tree shaking and :main option.
  (let [directories (when (#{nil :none} optimizations) (:directories pod/env))
        messages (atom {:exception nil
                        :warnings []})
        handler (fn [warning-type env extra]
                  (let [s (ana/error-message warning-type extra)]
                    (when (warning-enabled? warning-type)
                      (swap! messages update :warnings conj (ana/message env s)))))]
    (try
      (build
        (apply inputs input-path directories)
        (assoc opts :warning-handlers [default-warning-handler handler])
        stored-env)
      (catch Exception e
        (handle-ex e directories messages)))
    {:messages  @messages
     :dep-order (dep-order stored-env opts)}))

(def tracker (atom nil))

(defn reload-macros! []
  (let [dirs (:directories pod/env)]
    (when (nil? @tracker)
      (reset! tracker (ns-tracker (vec dirs))))
    ; Reload only namespaces which are already loaded
    ; As opposed to :reload-all, ns-tracker only reloads namespaces which are really changed.
    (doseq [s (filter find-ns (@tracker))]
      (butil/dbug "Reload macro ns: %s\n" s)
      (require s :reload))))

(defn backdate-macro-dependants!
  [output-dir changed-files]
  (doseq [cljs-ns (->> changed-files
                       (map (comp symbol util/path->ns))
                       (build-api/cljs-dependents-for-macro-namespaces stored-env))]
    ; broken
    ; (build-api/mark-cljs-ns-for-recompile! cljs-ns output-dir)
    (let [f (build-api/target-file-for-cljs-ns cljs-ns output-dir)]
      (when (.exists f)
        (butil/dbug "Backdate macro dependant cljs ns: %s\n" cljs-ns)
        (.setLastModified f 5000)))))

(ns adzerk.boot-cljs.impl
  (:require [boot.file :as file]
            [boot.kahnsort :as kahn]
            [boot.pod :as pod]
            [boot.util :as butil]
            [cljs.analyzer :as ana]
            [cljs.analyzer.api :as ana-api :refer [empty-state default-warning-handler warning-enabled?]]
            [cljs.build.api :as build-api :refer [build inputs target-file-for-cljs-ns]]
            [clojure.java.io :as io]
            [adzerk.boot-cljs.util :as util]
            [ns-tracker.core :refer [ns-tracker]]))

; Because this ns is loaded in pod, it's private to one cljs task.
; Compiler env is a atom.
(def ^:private stored-env (empty-state))

(defn ns-dependencies
  "Given a namespace as a symbol return list of namespaces required by the namespace."
  ; ([ns] (ns-dependencies env/*compiler* ns))
  ([state ns]
   (vals (:requires (ana-api/find-ns state ns)))))

(defn cljs-depdendency-graph [state]
  (let [all-ns (ana-api/all-ns state)
        all-ns-set (set all-ns)]
    (->> all-ns
         (reduce (fn [acc n]
                   (assoc acc n (->> (ns-dependencies state n)
                                     (keep all-ns-set)
                                     (set))))
                 {}))))

(defn dep-order [env opts]
  (->> (cljs-depdendency-graph env)
       (kahn/topo-sort)
       reverse
       (map #(.getPath (target-file-for-cljs-ns % (:output-dir opts))))))

(defn handle-ex [e dirs report-atom]
  (let [{:keys [type] :as ex} (ex-data (.getCause e))]
    (cond
      (= :reader-exception type)
      (let [{:keys [file line column]} ex
            msg  (some-> e (.getCause) (.getMessage))
            path (util/find-relative-path dirs file)
            exs  (format "ERROR: %s on file %s, line %d, column %d\n" msg path line column)]
        (swap! report-atom assoc :exception {:message exs
                                             :type type
                                             :file file
                                             :line line
                                             :column column})
        (butil/fail exs))

      :default (throw e))))

(defn compile-cljs
  "Given a seq of directories containing CLJS source files and compiler options
  opts, compiles the CLJS to produce JS files."
  [input-path {:keys [optimizations] :as opts}]
  ;; So directories need to be passed to cljs compiler when compiling in dev
  ;; or there are stale namespace problems with tests. However, if compiling
  ;; with optimizations other than :none adding directories will break the
  ;; build and defeat tree shaking and :main option.
  (let [directories (when (#{nil :none} optimizations) (:directories pod/env))
        messages (atom {:exception nil
                        :warnings []})
        handler (fn [warning-type env extra]
                  (when (warning-enabled? warning-type)
                    (let [s (ana/error-message warning-type extra)]
                      (swap! messages update :warnings conj {:message s
                                                             :file ana/*cljs-file*
                                                             :line (:line env)
                                                             :type warning-type}))))]
    (try
      (build
        (apply inputs input-path directories)
        (assoc opts :warning-handlers [default-warning-handler handler])
        stored-env)
      (catch Exception e
        (handle-ex e directories messages)))
    {:messages  @messages
     :dep-order (dep-order stored-env opts)}))

(def tracker (atom nil))

(defn reload-macros! []
  (let [dirs (:directories pod/env)]
    (when (nil? @tracker)
      (reset! tracker (ns-tracker (vec dirs))))
    ; Reload only namespaces which are already loaded
    ; As opposed to :reload-all, ns-tracker only reloads namespaces which are really changed.
    (doseq [s (filter find-ns (@tracker))]
      (butil/dbug "Reload macro ns: %s\n" s)
      (require s :reload))))

(defn backdate-macro-dependants!
  [output-dir changed-files]
  (doseq [cljs-ns (->> changed-files
                       (map (comp symbol util/path->ns))
                       (build-api/cljs-dependents-for-macro-namespaces stored-env))]
    ; broken
    ; (build-api/mark-cljs-ns-for-recompile! cljs-ns output-dir)
    (let [f (build-api/target-file-for-cljs-ns cljs-ns output-dir)]
      (when (.exists f)
        (butil/dbug "Backdate macro dependant cljs ns: %s\n" cljs-ns)
        (.setLastModified f 5000)))))

Add metadata to exceptions and warnings

Add metadata to exceptions and warnings


; Copyright © 2013 - 2016 Dr. Thomas Schank <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.utils.system
  (:require
    [cider-ci.utils.duration :as duration]
    [logbug.debug :as debug]
    [clj-commons-exec :as commons-exec]
    [clj-logging-config.log4j :as logging-config]
    [clojure.tools.logging :as logging]
    [clj-time.core :as time]
    )
  (:import
    [java.io File]
    [org.apache.commons.exec ExecuteWatchdog]
    [org.apache.commons.lang3 SystemUtils]
    ))

(defn create-watchdog
  ([]
   (create-watchdog (ExecuteWatchdog/INFINITE_TIMEOUT)))
  ([timeout-ms]
   (ExecuteWatchdog. timeout-ms )))

(defn normalized-timeout-ms [opts]
  (let [timeout (or (:timeout opts)
                    (:watchdog opts))]
    (cond
      (string? timeout)  (-> timeout
                             duration/parse-string-to-seconds
                             (* 1000.0))
      (integer? timeout) (* timeout 1.0)
      :else (* 10 1000.0))))

(defn exec
  ([command]
   (exec command {}))
  ([command opts]
   (logging/warn "exec is deprecated, use exec! or async-exec")
   (when (:watchdog opts)
     (logging/warn (str "`" (clojure.string/join " " command) "`  "
                        "The :watchdog option is deprecated, use :timeout instead."
                        {:opts opts})))
   (let [timeout-ms (normalized-timeout-ms opts)
         expires-at (time/plus (time/now) (time/millis (+ timeout-ms 100)))
         watchdog (create-watchdog)
         options (conj opts {:watchdog watchdog})
         exec-future (commons-exec/sh command options) ]
     (while (and (not (realized? exec-future))
                 (time/before? (time/now) expires-at))
       (Thread/sleep 50))
     (if (realized? exec-future)
       @exec-future
       (do
         (.destroyProcess watchdog)
         (throw (ex-info (str "Execution `"
                              (clojure.string/join " " command)
                              "` expired.") opts)))))))
(defn exec-with-success-or-throw [& args]
   (logging/warn "exec-with-success-or-throw is deprecated, use exec! or async-exec")
  (let [res (apply exec args)]
    (if (= 0 (:exit res))
      res
      (throw (ex-info
               (str "Execution `"
                    (clojure.string/join " " (first args))
                    "` exited with non zero exit status.")
               {:opts (second args)
                :res res})))))

(defn exec-with-success? [& args]
  (= 0 (:exit (apply exec args))))

;### NEW #######################################################################

(defn cancle-async-exec [wrapped-exec]
  (when (not (realized? (:exec @wrapped-exec)))
    (swap! wrapped-exec (fn [r]
                          (assoc r :exception
                                 (ex-info (str "Execution `"
                                               (clojure.string/join " " (:command r))
                                               "` has been canceled!") {}))))
    (.destroyProcess (-> @wrapped-exec :opts :watchdog))))

(defn async-exec
  ([command]
   (async-exec command {}))
  ([command opts]
   (let [timeout-ms (normalized-timeout-ms opts)
         expires-at (time/plus (time/now) (time/millis timeout-ms))
         options (conj opts {:watchdog (create-watchdog)})
         wrapped-exec (atom {:command command
                             :opts options
                             :exec (commons-exec/sh command options)})]
     (future (while (and (not (realized? (-> @wrapped-exec :exec)))
                         (time/before? (time/now) expires-at))
               (Thread/sleep 50))
             (when (not (realized? (:exec @wrapped-exec)))
               (swap! wrapped-exec (fn [r]
                                     (assoc r :exception
                                            (ex-info (str "Execution `"
                                                          (clojure.string/join " " (:command r))
                                                          "` timed out!") r))))
               (.destroyProcess (-> @wrapped-exec :opts :watchdog))))
     wrapped-exec)))

(defn exec!
  ([command]
   (exec! command {}))
  ([command opts]
   (let [wrapped-exec (async-exec command opts)
         realized-exec (-> wrapped-exec deref :exec deref)]
     (logging/warn 'wrapped-exec wrapped-exec)
     (logging/warn 'realized-exec realized-exec)
     (when-let [ex (-> wrapped-exec deref :exception)] (throw ex))
     (when-not (= 0 (:exit realized-exec))
       (throw  (ex-info (str "Execution `"
                             (clojure.string/join " " (-> @wrapped-exec :command))
                             "` exited with non zero status!")
                        @wrapped-exec)))
     realized-exec)))

;(exec! ["exit" "1"])

;(exec! ["sleep" "10"] {:timeout "3 Seconds"})

;(exec! ["echo" "Hello World!"])

;(def ^:dynamic *P* (async-exec ["sleep" "50"] {:timeout "3 Seconds"}))

;### Debug #####################################################################
;(debug/debug-ns *ns*)
;(logging-config/set-logger! :level :debug)
;(logging-config/set-logger! :level :info)

; Copyright © 2013 - 2016 Dr. Thomas Schank <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.utils.system
  (:require
    [cider-ci.utils.duration :as duration]
    [logbug.debug :as debug]
    [clj-commons-exec :as commons-exec]
    [clj-logging-config.log4j :as logging-config]
    [clojure.tools.logging :as logging]
    [clj-time.core :as time]
    )
  (:import
    [java.io File]
    [org.apache.commons.exec ExecuteWatchdog]
    [org.apache.commons.lang3 SystemUtils]
    ))

;### helpers ###################################################################

(defn create-watchdog
  ([]
   (create-watchdog (ExecuteWatchdog/INFINITE_TIMEOUT)))
  ([timeout-ms]
   (ExecuteWatchdog. timeout-ms )))

(defn normalized-timeout-ms [opts]
  (let [timeout (or (:timeout opts)
                    (:watchdog opts))]
    (cond
      (string? timeout)  (-> timeout
                             duration/parse-string-to-seconds
                             (* 1000.0))
      (integer? timeout) (* timeout 1.0)
      :else (* 10 1000.0))))

;### OLD #######################################################################

(defn exec
  ([command]
   (exec command {}))
  ([command opts]
   (logging/warn "exec is deprecated, use exec! or async-exec")
   (when (:watchdog opts)
     (logging/warn (str "`" (clojure.string/join " " command) "`  "
                        "The :watchdog option is deprecated, use :timeout instead."
                        {:opts opts})))
   (let [timeout-ms (normalized-timeout-ms opts)
         expires-at (time/plus (time/now) (time/millis (+ timeout-ms 100)))
         watchdog (create-watchdog)
         options (conj opts {:watchdog watchdog})
         exec-future (commons-exec/sh command options) ]
     (while (and (not (realized? exec-future))
                 (time/before? (time/now) expires-at))
       (Thread/sleep 50))
     (if (realized? exec-future)
       @exec-future
       (do
         (.destroyProcess watchdog)
         (throw (ex-info (str "Execution `"
                              (clojure.string/join " " command)
                              "` expired.") opts)))))))

(defn exec-with-success-or-throw [& args]
   (logging/warn "exec-with-success-or-throw is deprecated, use exec! or async-exec")
  (let [res (apply exec args)]
    (if (= 0 (:exit res))
      res
      (throw (ex-info
               (str "Execution `"
                    (clojure.string/join " " (first args))
                    "` exited with non zero exit status.")
               {:opts (second args)
                :res res})))))

(defn exec-with-success? [& args]
  (= 0 (:exit (apply exec args))))

;### NEW #######################################################################

(defn cancle-async-exec [wrapped-exec]
  (when (not (realized? (:exec @wrapped-exec)))
    (swap! wrapped-exec (fn [r]
                          (assoc r :exception
                                 (ex-info (str "Execution `"
                                               (clojure.string/join " " (:command r))
                                               "` has been canceled!") {}))))
    (.destroyProcess (-> @wrapped-exec :opts :watchdog))))

(defn async-exec
  ([command]
   (async-exec command {}))
  ([command opts]
   (let [timeout-ms (normalized-timeout-ms opts)
         expires-at (time/plus (time/now) (time/millis timeout-ms))
         options (conj opts {:watchdog (create-watchdog)})
         wrapped-exec (atom {:command command
                             :opts options
                             :exec (commons-exec/sh command options)})]
     (future (while (and (not (realized? (-> @wrapped-exec :exec)))
                         (time/before? (time/now) expires-at))
               (Thread/sleep 50))
             (when (not (realized? (:exec @wrapped-exec)))
               (swap! wrapped-exec (fn [r]
                                     (assoc r :exception
                                            (ex-info (str "Execution `"
                                                          (clojure.string/join " " (:command r))
                                                          "` timed out!") r))))
               (.destroyProcess (-> @wrapped-exec :opts :watchdog))))
     wrapped-exec)))

(defn exec!
  ([command]
   (exec! command {}))
  ([command opts]
   (let [wrapped-exec (async-exec command opts)
         realized-exec (-> wrapped-exec deref :exec deref)]
     (when-let [ex (-> wrapped-exec deref :exception)] (throw ex))
     (when-not (= 0 (:exit realized-exec))
       (throw  (ex-info (str "Execution `"
                             (clojure.string/join " " (-> @wrapped-exec :command))
                             "` exited with non zero status!")
                        @wrapped-exec)))
     realized-exec)))

;### Debug #####################################################################
;(debug/debug-ns *ns*)
;(logging-config/set-logger! :level :debug)
;(logging-config/set-logger! :level :info)

Remove some logging stuff

Remove some logging stuff


(ns clj-applenewsapi.core
  (:require [clj-http.client :as client]
            [clj-applenewsapi.crypto :refer [signature now canonical]]
            [clj-applenewsapi.multipart :as multipart]
            [clj-applenewsapi.config :as cfg]))

(def default-opts
  {
   ; :debug true
   :throw-exceptions false
   :accept :json
   :socket-timeout 10000
   :conn-timeout 10000
   :headers {}})

(defn post-opts [boundary payload]
  (-> default-opts
      (assoc :body payload)
      (assoc :content-type (str "multipart/form-data; boundary=" boundary))))

(defn authorize [opts concatenated ts channel-name]
  (let [secret (cfg/api-key-secret channel-name)
        keyid (cfg/api-key-id channel-name)
        digest (signature concatenated secret)
        auth (str "HHMAC; key=" keyid "; signature=" digest "; date=" ts)]
    (update-in opts [:headers] #(assoc % "Authorization" auth))))

(defn get-article
  ([id] (get-article id :sandbox))
  ([id channel-name]
   (let [url (str (cfg/host) "/articles/" id)
         ts (now)
         concatenated (canonical "GET" url ts)]
     (client/get url (authorize default-opts concatenated ts channel-name)))))

(defn get-channel
  ([] (get-channel :sandbox))
  ([channel-name]
   (let [url (str (cfg/host) "/channels/" (cfg/channel-id channel-name))
         ts (now)
         concatenated (canonical "GET" url ts)]
     (client/get url (authorize default-opts concatenated ts channel-name)))))

(defn get-section
  ([id] (get-section id :sandbox))
  ([id channel-name]
   (let [url (str (cfg/host) "/sections/" id)
         ts (now)
         concatenated (canonical "GET" url ts)]
     (client/get url (authorize default-opts concatenated ts channel-name)))))

(defn get-sections
  ([] (get-sections :sandbox))
  ([channel-name]
   (let [url (str (cfg/host) "/channels/" (cfg/channel-id channel-name) "/sections/")
         ts (now)
         concatenated (canonical "GET" url ts)]
     (client/get url (authorize default-opts concatenated ts channel-name)))))

(defn create-article
  ([bundle] (create-article bundle :sandbox))
  ([bundle channel-name]
   (let [url (str (cfg/host) "/channels/" (cfg/channel-id channel-name) "/articles")
         ts (now)
         boundary (multipart/random)
         payload (multipart/payload boundary bundle)
         content-type (str "multipart/form-data; boundary=" boundary)
         concatenated (canonical "POST" url ts content-type payload)
         opts (authorize (post-opts boundary payload) concatenated ts channel-name)]
     (client/post url opts))))

; test with
; (require '[clj-applenewsapi.core :as c]) (def bundle (read-string (slurp "test/bundle.edn")))  (c/create-article bundle :sandbox))

(ns clj-applenewsapi.core
  (:require [clj-http.client :as client]
            [clj-applenewsapi.crypto :refer [signature now canonical]]
            [clj-applenewsapi.multipart :as multipart]
            [clj-applenewsapi.config :as cfg]))

(def default-opts
  {
   ; :debug true
   :throw-exceptions false
   :accept :json
   :socket-timeout 30000
   :conn-timeout 10000
   :headers {}})

(defn post-opts [boundary payload]
  (-> default-opts
      (assoc :body payload)
      (assoc :content-type (str "multipart/form-data; boundary=" boundary))))

(defn authorize [opts concatenated ts channel-name]
  (let [secret (cfg/api-key-secret channel-name)
        keyid (cfg/api-key-id channel-name)
        digest (signature concatenated secret)
        auth (str "HHMAC; key=" keyid "; signature=" digest "; date=" ts)]
    (update-in opts [:headers] #(assoc % "Authorization" auth))))

(defn get-article
  ([id] (get-article id :sandbox))
  ([id channel-name]
   (let [url (str (cfg/host) "/articles/" id)
         ts (now)
         concatenated (canonical "GET" url ts)]
     (client/get url (authorize default-opts concatenated ts channel-name)))))

(defn get-channel
  ([] (get-channel :sandbox))
  ([channel-name]
   (let [url (str (cfg/host) "/channels/" (cfg/channel-id channel-name))
         ts (now)
         concatenated (canonical "GET" url ts)]
     (client/get url (authorize default-opts concatenated ts channel-name)))))

(defn get-section
  ([id] (get-section id :sandbox))
  ([id channel-name]
   (let [url (str (cfg/host) "/sections/" id)
         ts (now)
         concatenated (canonical "GET" url ts)]
     (client/get url (authorize default-opts concatenated ts channel-name)))))

(defn get-sections
  ([] (get-sections :sandbox))
  ([channel-name]
   (let [url (str (cfg/host) "/channels/" (cfg/channel-id channel-name) "/sections/")
         ts (now)
         concatenated (canonical "GET" url ts)]
     (client/get url (authorize default-opts concatenated ts channel-name)))))

(defn create-article
  ([bundle] (create-article bundle :sandbox))
  ([bundle channel-name]
   (let [url (str (cfg/host) "/channels/" (cfg/channel-id channel-name) "/articles")
         ts (now)
         boundary (multipart/random)
         payload (multipart/payload boundary bundle)
         content-type (str "multipart/form-data; boundary=" boundary)
         concatenated (canonical "POST" url ts content-type payload)
         opts (authorize (post-opts boundary payload) concatenated ts channel-name)]
     (client/post url opts))))

; test with
; (require '[clj-applenewsapi.core :as c]) (def bundle (read-string (slurp "test/bundle.edn")))  (c/create-article bundle :sandbox))

Increase timeout for publishing to 30s

Increase timeout for publishing to 30s