(ns bide.tests.core-tests
  (:require [cljs.test :as t]
            [bide.core :as r]))

(t/deftest match-tests
  (let [r (r/router [["/a/b" :r1]
                     ["/b/:c" :r2]
                     ["/d/:e/f" :r3]])]
    (t/is (= [:r1 nil] (r/match r "/a/b")))
    (t/is (= [:r2 {:c "1"}] (r/match r "/b/1")))
    (t/is (= [:r3 {:e "2"}] (r/match r "/d/2/f")))
    (t/is (= nil (r/match r "/foo/bar")))))

(t/deftest resolve-tests
  (let [r (r/router [["/a/b" :r1]
                     ["/b/:c" :r2]
                     ["/d/:e/f" :r3]])]
    (t/is (= "/a/b" (r/resolve r :r1)))
    (t/is (= "/b/4" (r/resolve r :r2 {:c 4})))
    (t/is (= "/d/5/f" (r/resolve r :r3 {:e 5})))))

(enable-console-print!)
(set! *main-cli-fn* #(t/run-tests))

(defmethod t/report [:cljs.test/default :end-run-tests]
  [m]
  (if (t/successful? m)
    (set! (.-exitCode js/process) 0)
    (set! (.-exitCode js/process) 1)))

(ns bide.tests.core-tests
  (:require [cljs.test :as t]
            [bide.core :as r]))

(t/deftest match-tests
  (let [r (r/router [["/a/b" :r1]
                     ["/b/:c" :r2]
                     ["/d/:e/f" :r3]
                     ["/g/:h-i" :r4]])]
    (t/is (= [:r1 nil] (r/match r "/a/b")))
    (t/is (= [:r2 {:c "1"}] (r/match r "/b/1")))
    (t/is (= [:r3 {:e "2"}] (r/match r "/d/2/f")))
    (t/is (= [:r4 {:h-i "foo"}] (r/match r "/g/foo")))
    (t/is (= nil (r/match r "/foo/bar")))))

(t/deftest resolve-tests
  (let [r (r/router [["/a/b" :r1]
                     ["/b/:c" :r2]
                     ["/d/:e/f" :r3]])]
    (t/is (= "/a/b" (r/resolve r :r1)))
    (t/is (= "/b/4" (r/resolve r :r2 {:c 4})))
    (t/is (= "/d/5/f" (r/resolve r :r3 {:e 5})))))

(enable-console-print!)
(set! *main-cli-fn* #(t/run-tests))

(defmethod t/report [:cljs.test/default :end-run-tests]
  [m]
  (if (t/successful? m)
    (set! (.-exitCode js/process) 0)
    (set! (.-exitCode js/process) 1)))

Add more tests.

Add more tests.


(ns lambdacd.util-test
  (:use [lambdacd.util])
  (:require [clojure.test :refer :all]
            [me.raynes.fs :as fs]
            [clojure.java.io :as io]))

(deftest range-test
  (testing "that range produces a range from a value+1 with a defined length"
    ; TODO: the plus-one is like that because the user wants it, probably shouldn't be like this..
    (is (= '(6 7 8) (range-from 5 3)))))

(defn some-function [] {})

(deftest map-if-test
  (testing "that is applies a function to all elements that match a predicate"
    (is (= []      (map-if (identity true) inc [])))
    (is (= [4 3 5] (map-if #(< % 5) inc [3 2 4])))
    (is (= [3 2 5] (map-if #(= 4 %) inc [3 2 4])))))

(deftest put-if-not-present-test
  (testing "that it adds a value to a map only of no value exists for this key"
    (is (= {:foo :bar}       (put-if-not-present {:foo :bar} :foo :baz)))
    (is (= {:foo :baz}       (put-if-not-present {} :foo :baz)))
    (is (= {:a :b :foo :baz} (put-if-not-present {:a :b} :foo :baz)))))

(deftest create-temp-dir-test
  (testing "creating in default tmp folder"
    (testing "that we can create a temp-directory"
      (is (fs/exists? (io/file (create-temp-dir)))))
    (testing "that it is writable"
      (is (fs/mkdir (io/file (create-temp-dir) "hello")))))
  (testing "creating in a defined parent directory"
    (testing "that it is a child of the parent directory"
      (let [parent (create-temp-dir)]
        (is (= parent (.getParent (io/file (create-temp-dir parent)))))))))

(defn- throw-if-not-exists [f]
  (if (not (fs/exists? f))
    (throw (IllegalStateException. (str f " does not exist")))
    "some-value-from-function"))

(deftest with-temp-test
  (testing "that a tempfile is deleted after use"
    (let [f (create-temp-file)]
      (is (= "some-value-from-function" (with-temp f (throw-if-not-exists f))))
      (is (not (fs/exists? f)))))
  (testing "that a tempfile is deleted when body throws"
    (let [f (create-temp-file)]
      (is (thrown? Exception (with-temp f (throw (Exception. "oh no!")))))
      (is (not (fs/exists? f)))))
  (testing "that a temp-dir is deleted after use"
    (let [d (create-temp-dir)]
      (fs/touch (fs/file d "somefile"))

      (is (= "some-value-from-function" (with-temp d (throw-if-not-exists d))))

      (is (not (fs/exists? (fs/file d "somefile"))))
      (is (not (fs/exists? d))))))

(deftest json-test
  (testing "that a proper ring-json-response is returned"
    (is (= {:body    "{\"hello\":\"world\"}"
            :headers {"Content-Type" "application/json;charset=UTF-8"}
            :status  200} (json { :hello :world })))))

(deftest parse-int-test
  (testing "that we can parse integers"
    (is (= 42 (parse-int "42")))
    (is (= -1 (parse-int "-1")))
    (is (thrown? NumberFormatException (parse-int "foo")))))

(deftest fill-test
  (testing "that we can fill up a sequence to a certain length"
    (is (= [1 2 3 -1 -1] (fill [1 2 3] 5 -1))))
  (testing "that a collection is left just as it was if it is already longer than the desired length"
    (is (= [1 2 3] (fill [1 2 3] 2 -1)))
    (is (= [1 2 3] (fill [1 2 3] 3 -1)))))

(ns lambdacd.util-test
  (:use [lambdacd.util])
  (:require [clojure.test :refer :all]
            [me.raynes.fs :as fs]
            [clojure.java.io :as io]))

(deftest range-test
  (testing "that range produces a range from a value+1 with a defined length"
    ; TODO: the plus-one is like that because the user wants it, probably shouldn't be like this..
    (is (= '(6 7 8) (range-from 5 3)))))

(defn some-function [] {})

(deftest map-if-test
  (testing "that is applies a function to all elements that match a predicate"
    (is (= []      (map-if (identity true) inc [])))
    (is (= [4 3 5] (map-if #(< % 5) inc [3 2 4])))
    (is (= [3 2 5] (map-if #(= 4 %) inc [3 2 4])))))

(deftest put-if-not-present-test
  (testing "that it adds a value to a map only of no value exists for this key"
    (is (= {:foo :bar}       (put-if-not-present {:foo :bar} :foo :baz)))
    (is (= {:foo :baz}       (put-if-not-present {} :foo :baz)))
    (is (= {:a :b :foo :baz} (put-if-not-present {:a :b} :foo :baz)))))

(deftest create-temp-dir-test
  (testing "creating in default tmp folder"
    (testing "that we can create a temp-directory"
      (is (fs/exists? (io/file (create-temp-dir)))))
    (testing "that it is writable"
      (is (fs/mkdir (io/file (create-temp-dir) "hello")))))
  (testing "creating in a defined parent directory"
    (testing "that it is a child of the parent directory"
      (let [parent (create-temp-dir)]
        (is (= parent (.getParent (io/file (create-temp-dir parent)))))))))

(defn- throw-if-not-exists [f]
  (if (not (fs/exists? f))
    (throw (IllegalStateException. (str f " does not exist")))
    "some-value-from-function"))

(deftest with-temp-test
  (testing "that a tempfile is deleted after use"
    (let [f (create-temp-file)]
      (is (= "some-value-from-function" (with-temp f (throw-if-not-exists f))))
      (is (not (fs/exists? f)))))
  (testing "that a tempfile is deleted when body throws"
    (let [f (create-temp-file)]
      (is (thrown? Exception (with-temp f (throw (Exception. "oh no!")))))
      (is (not (fs/exists? f)))))
  (testing "that a temp-dir is deleted after use"
    (let [d (create-temp-dir)]
      (fs/touch (fs/file d "somefile"))

      (is (= "some-value-from-function" (with-temp d (throw-if-not-exists d))))

      (is (not (fs/exists? (fs/file d "somefile"))))
      (is (not (fs/exists? d)))))
  (testing "that it can deal with circular symlinks"
    (let [f (create-temp-dir)]
      (is (= "some-value-from-function"
             (with-temp f (let [link-parent (io/file f "foo" "bar")]
                            (fs/mkdirs link-parent)
                            (fs/sym-link (io/file link-parent "link-to-the-start") f)
                            "some-value-from-function"
                            ))))
      (is (not (fs/exists? f))))))

(deftest json-test
  (testing "that a proper ring-json-response is returned"
    (is (= {:body    "{\"hello\":\"world\"}"
            :headers {"Content-Type" "application/json;charset=UTF-8"}
            :status  200} (json { :hello :world })))))

(deftest parse-int-test
  (testing "that we can parse integers"
    (is (= 42 (parse-int "42")))
    (is (= -1 (parse-int "-1")))
    (is (thrown? NumberFormatException (parse-int "foo")))))

(deftest fill-test
  (testing "that we can fill up a sequence to a certain length"
    (is (= [1 2 3 -1 -1] (fill [1 2 3] 5 -1))))
  (testing "that a collection is left just as it was if it is already longer than the desired length"
    (is (= [1 2 3] (fill [1 2 3] 2 -1)))
    (is (= [1 2 3] (fill [1 2 3] 3 -1)))))

Add test to reproduce #112 (seems not to occur on OS X so I want to make sure at least travis catches it)


(ns discuss.clipboard
  (:require [om.core :as om :include-macros true]
            [om.dom :as dom :include-macros true]
            [discuss.utils.common :as lib]))

(def counter (atom 0))

(defn get-stored-selections
  "Return all stored selections."
  []
  (let [selections (get-in @lib/app-state [:clipboard :selections])]
    (or selections [])))

(defn add-selection
  "Store current selection in clipboard."
  []
  (let [selections (get-stored-selections)
        current (lib/get-selection)
        with-current (distinct (conj selections current))]
    (lib/update-state-item! :clipboard :selections (fn [_] with-current))))

;;;; Drag n Drop stuff
; http://www.w3schools.com/html/html5_draganddrop.asp

(defn update-reference-drop
  "Use text from clipboard item as reference for own statement."
  [_ev]
  (let [clipboard-item (get-in @lib/app-state [:clipboard :current])]
    (lib/remove-class clipboard-item "bs-callout-info")
    (lib/add-class clipboard-item "bs-callout-success")
    (lib/update-state-item! :user :selection (fn [_] (.. clipboard-item -innerText)))))

(defn allow-drop [ev]
  (println "fn: allow-drop")
  (.preventDefault ev))

(defn drag-event [ev]
  (let [target (.. ev -target)]
    (lib/update-state-item! :clipboard :current (fn [_] target))))

;;;; Views
(defn clipboard-item [data owner]
  (reify
    om/IInitState
    (init-state [_]
      {:selected? false})
    om/IRenderState
    (render-state [_ {:keys [selected?]}]
      (dom/div #js {:id          (swap! counter inc)
                    :className   "bs-callout bs-callout-info"
                    :draggable   true
                    :onDragStart drag-event}
               (dom/div nil data)
               #_(dom/button #js {:className "btn btn-sm btn-default"
                                :onClick   #(discuss.communication/ajax-get "api/cat-or-dog")
                                :title     "Select this reference for your statement"}
                           (vlib/fa-icon "fa-check"))))))

(defn view [data owner]
  (reify om/IRender
    (render [_]
      (when (pos? (count (get-stored-selections)))
        (dom/div nil
                 (dom/h5 nil "Clipboard")
                 (apply dom/div nil
                        (map #(om/build clipboard-item (lib/merge-react-key %)) (get-stored-selections))))))))

(ns discuss.clipboard
  (:require [om.core :as om :include-macros true]
            [om.dom :as dom :include-macros true]
            [discuss.utils.common :as lib]))

(def counter (atom 0))

(defn get-stored-selections
  "Return all stored selections."
  []
  (let [selections (get-in @lib/app-state [:clipboard :selections])]
    (or selections [])))

(defn add-selection
  "Store current selection in clipboard."
  []
  (let [selections (get-stored-selections)
        current (lib/get-selection)
        with-current (distinct (merge selections {:title current}))]
    (lib/update-state-item! :clipboard :selections (fn [_] with-current))))

;;;; Drag n Drop stuff
; http://www.w3schools.com/html/html5_draganddrop.asp

(defn update-reference-drop
  "Use text from clipboard item as reference for own statement."
  [_ev]
  (let [clipboard-item (get-in @lib/app-state [:clipboard :current])]
    (lib/remove-class clipboard-item "bs-callout-info")
    (lib/add-class clipboard-item "bs-callout-success")
    (lib/update-state-item! :user :selection (fn [_] (.. clipboard-item -innerText)))))

(defn allow-drop [ev]
  (println "fn: allow-drop")
  (.preventDefault ev))

(defn drag-event [ev]
  (let [target (.. ev -target)]
    (lib/update-state-item! :clipboard :current (fn [_] target))))

;;;; Views
(defn clipboard-item [data]
  (reify
    om/IInitState
    (init-state [_]
      {:selected? false})
    om/IRenderState
    (render-state [_ {:keys [selected?]}]
      (dom/div #js {:id          (swap! counter inc)
                    :className   "bs-callout bs-callout-info"
                    :draggable   true
                    :onDragStart drag-event}
               (dom/div nil (:title data))
               #_(dom/button #js {:className "btn btn-sm btn-default"
                                :onClick   #(discuss.communication/ajax-get "api/cat-or-dog")
                                :title     "Select this reference for your statement"}
                           (vlib/fa-icon "fa-check"))))))

(defn view []
  (when (pos? (count (get-stored-selections)))
    (dom/div nil
             (dom/h5 nil "Clipboard")
             (apply dom/div nil
                    (map #(om/build clipboard-item (lib/merge-react-key %)) (get-stored-selections))))))

Fix clipboard

Fix clipboard


(ns env-logger.handler
  "The main namespace of the application"
  (:gen-class)
  (:require [buddy
             [auth :refer [authenticated?]]
             [hashers :as h]]
            [buddy.auth.backends.session :refer [session-backend]]
            [buddy.auth.backends.token :refer [jwe-backend]]
            [buddy.auth.middleware :refer [wrap-authentication
                                           wrap-authorization]]
            [buddy.core.nonce :as nonce]
            [buddy.sign.jwt :as jwt]
            [cheshire.core :refer [generate-string parse-string]]
            [java-time :as t]
            [clojure set
             [string :as s]]
            [clojure.tools.logging :as log]
            [compojure
             [core :refer [defroutes DELETE GET POST]]
             [route :as route]]
            [env-logger
             [config :refer [get-conf-value]]
             [db :as db]
             [grabber :refer [calculate-start-time
                              get-fmi-weather-data
                              weather-query-ok?]]
             [user :as u]]
            [ring.adapter.jetty :refer [run-jetty]]
            [ring.middleware.defaults :refer :all]
            [ring.middleware.reload :refer [wrap-reload]]
            [ring.middleware.json :refer [wrap-json-params wrap-json-response]]
            [ring.util.response :as resp]
            [selmer.parser :refer [render-file]])
  (:import java.time.Instant
           com.yubico.client.v2.YubicoClient))

(defn otp-value-valid?
  "Checks whether the provided Yubico OTP value is valid. Returns true
  on success and false otherwise."
  [otp-value]
  (let [client (YubicoClient/getClient
                (Integer/parseInt (get-conf-value :yubico-client-id))
                (get-conf-value :yubico-secret-key))]
    (if-not (YubicoClient/isValidOTPFormat otp-value)
      false
      (.isOk (.verify client otp-value)))))

(defn check-auth-code
  "Checks whether the authentication code is valid."
  [code-to-check]
  (= (get-conf-value :auth-code) code-to-check))

(defn login-authenticate
  "Check request username and password against user data in the database.
  On successful authentication, set appropriate user into the session and
  redirect to the value of (:query-params (:next request)).
  On failed authentication, renders the login page."
  [request]
  (let [username (get-in request [:form-params "username"])
        password (get-in request [:form-params "password"])
        otp (get-in request [:form-params "otp"])
        session (:session request)
        use-ldap? (get-conf-value :use-ldap)
        user-data (if use-ldap?
                    (when-let [password (u/get-password-from-ldap username)]
                      {:pw-hash password})
                    (u/get-user-data db/postgres username))]
    (if (:error user-data)
      (render-file "templates/error.html"
                   {})
      (if (or (and user-data (h/check password (:pw-hash user-data)))
              (and (seq otp)
                   (otp-value-valid? otp)
                   (contains? (u/get-yubikey-id db/postgres username)
                              (YubicoClient/getPublicId otp))))
        (let [next-url (get-in request [:query-params :next]
                               (str (get-conf-value :url-path) "/"))
              updated-session (assoc session :identity (keyword username))]
          (assoc (resp/redirect next-url) :session updated-session))
        (render-file "templates/login.html"
                     {:error "Error: an invalid credential was provided"})))))

(defn unauthorized-handler
  "Handles unauthorized requests."
  [request metadata]
  (if (authenticated? request)
    ;; If request is authenticated, raise 403 instead of 401 as the user
    ;; is authenticated but permission denied is raised.
    (assoc (resp/response "403 Forbidden") :status 403)
    ;; In other cases, redirect it user to login
    (resp/redirect (format (str (get-conf-value :url-path) "/login?next=%s")
                           (:uri request)))))

(def response-unauthorized {:status 401
                            :headers {"Content-Type" "text/plain"}
                            :body "Unauthorized"})
(def response-invalid-request {:status 400
                               :headers {"Content-Type" "text/plain"}
                               :body "Invalid request"})
(def response-server-error {:status 500
                            :headers {"Content-Type" "text/plain"}
                            :body "Internal Server Error"})

(def jwe-secret (nonce/random-bytes 32))

(def jwe-auth-backend (jwe-backend {:secret jwe-secret
                                    :options {:alg :a256kw :enc :a128gcm}}))

(def auth-backend (session-backend
                   {:unauthorized-handler unauthorized-handler}))

(defn token-login
  "Login method for getting an token for data access."
  [request]
  (let [auth-data (get-conf-value :data-user-auth-data)
        username (get-in request [:params :username])
        password (get-in request [:params :password])
        valid? (and (and username
                         (= username (:username auth-data)))
                    (and password
                         (h/check password (:password auth-data))))]
    (if valid?
      (let [claims {:user (keyword username)
                    :exp (. (. (. Instant now) plusSeconds
                               (get-conf-value :jwt-token-timeout))
                            getEpochSecond)}
            token (jwt/encrypt claims jwe-secret {:alg :a256kw :enc :a128gcm})]
        (generate-string token))
      response-unauthorized)))

(defn get-last-obs-data
  "Get data for observation with a non-null FMI temperature value."
  [request]
  (if-not (authenticated? request)
    response-unauthorized
    {:status 200
     :body {:data (first (filter #(not (nil? (:fmi_temperature %)))
                                 (reverse (db/get-obs-days db/postgres 1))))
            :rt-data (take (count (get-conf-value :ruuvitag-locations))
                           (reverse (db/get-ruuvitag-obs
                                     db/postgres
                                     (t/minus (t/local-date-time)
                                              (t/minutes 45))
                                     (t/local-date-time)
                                     (get-conf-value :ruuvitag-locations))))}}))

(defn yc-image-validity-check
  "Checks whether the yardcam image has the right format and is not too old.
  Returns true when the image name is valid and false otherwise."
  [image-name]
  (boolean (and image-name
                (re-find db/yc-image-pattern image-name)
                (<= (t/as (t/interval (t/zoned-date-time
                                       (t/formatter :iso-offset-date-time)
                                       (nth (re-find db/yc-image-pattern
                                                     image-name)
                                            1))
                                      (t/zoned-date-time))
                          :minutes)
                    (get-conf-value :yc-max-time-diff)))))

(defn get-plot-page-data
  "Returns data needed for rendering the plot page."
  [request]
  (let [start-date (when (seq (:startDate (:params request)))
                     (:startDate (:params request)))
        end-date (when (seq (:endDate (:params request)))
                   (:endDate (:params request)))
        obs-dates (db/get-obs-date-interval db/postgres)
        logged-in? (authenticated? request)
        initial-days (get-conf-value :initial-show-days)
        common-values {:obs-dates obs-dates
                       :logged-in? logged-in?
                       :yc-image-basepath (get-conf-value
                                           :yc-image-basepath)
                       :tb-image-basepath (get-conf-value
                                           :tb-image-basepath)
                       :rt-names (generate-string
                                  (get-conf-value :ruuvitag-locations))
                       :hide-rt (generate-string (get-conf-value
                                                  :hide-ruuvitag-data))}]
    (merge common-values
           (if (or start-date end-date)
             {:data (generate-string
                     (if logged-in?
                       (db/get-obs-interval db/postgres
                                            {:start start-date
                                             :end end-date})
                       (db/get-weather-obs-interval db/postgres
                                                    {:start start-date
                                                     :end end-date})))
              :rt-data (generate-string
                        (when logged-in?
                          (db/get-ruuvitag-obs
                           db/postgres
                           (db/make-local-dt start-date "start")
                           (db/make-local-dt end-date "end")
                           (get-conf-value :ruuvitag-locations))))
              :start-date start-date
              :end-date end-date}
             {:data (generate-string
                     (if logged-in?
                       (db/get-obs-days db/postgres
                                        initial-days)
                       (db/get-weather-obs-days db/postgres
                                                initial-days)))
              :rt-data (generate-string
                        (when logged-in?
                          (db/get-ruuvitag-obs
                           db/postgres
                           (t/minus (t/local-date-time)
                                    (t/days initial-days))
                           (t/local-date-time)
                           (get-conf-value :ruuvitag-locations))))
              :start-date (t/format (t/formatter :iso-local-date)
                                    (t/minus (t/local-date (t/formatter
                                                            :iso-local-date)
                                                           (:end obs-dates))
                                             (t/days initial-days)))
              :end-date (:end obs-dates)}))))

(defn handle-observation-insert
  "Handles the insertion of an observation to the database."
  [obs-string]
  (let [start-time (calculate-start-time)
        start-time-int (t/interval (t/plus start-time (t/minutes 4))
                                   (t/plus start-time (t/minutes 7)))
        weather-data (when (and (t/contains? start-time-int
                                             (t/zoned-date-time))
                                (weather-query-ok? db/postgres 3))
                       (get-fmi-weather-data
                        (get-conf-value :station-id)))]
    (db/insert-observation db/postgres
                           (assoc (parse-string obs-string
                                                true)
                                  :weather-data weather-data))))

(defroutes routes
  ;; Index and login
  (GET "/" request
       (if-not (db/test-db-connection db/postgres)
         (render-file "templates/error.html"
                      {})
         (render-file "templates/plots.html"
                      (get-plot-page-data request))))
  (GET "/login" [] (render-file "templates/login.html" {}))
  (POST "/login" [] login-authenticate)
  (GET "/logout" request
       (assoc (resp/redirect (str (get-conf-value :url-path) "/"))
              :session {}))
  (POST "/token-login" [] token-login)
  (GET "/get-last-obs" [] get-last-obs-data)
  ;; Observation storing
  (POST "/observations" request
        (if-not (check-auth-code (:code (:params request)))
          response-unauthorized
          (if-not (db/test-db-connection db/postgres)
            response-server-error
            (if (handle-observation-insert (:obs-string (:params request)))
              "OK" response-server-error))))
  ;; RuuviTag observation storage
  (POST "/rt-observations" request
        (if-not (check-auth-code (:code (:params request)))
          response-unauthorized
          (if-not (db/test-db-connection db/postgres)
            response-server-error
            (if (pos? (db/insert-ruuvitag-observation
                       db/postgres
                       (parse-string (:observation (:params request)) true)))
              "OK" response-server-error))))
  ;; Testbed image name storage
  (POST "/tb-image" request
        (if-not (check-auth-code (:code (:params request)))
          response-unauthorized
          (if-not (db/test-db-connection db/postgres)
            response-server-error
            (if (re-find #"testbed-\d{4}-\d{2}-\d{2}T\d{2}:\d{2}\+\d{4}\.png"
                         (:name (:params request)))
              (if (db/insert-tb-image-name db/postgres
                                           (db/get-last-obs-id
                                            db/postgres)
                                           (:name (:params
                                                   request)))
                "OK" response-server-error)
              response-invalid-request))))
  ;; Latest yardcam image name storage
  (POST "/yc-image" request
        (if-not (check-auth-code (:code (:params request)))
          response-unauthorized
          (if-not (db/test-db-connection db/postgres)
            response-server-error
            (let [image-name (:image-name (:params request))]
              (if (yc-image-validity-check image-name)
                (if (db/insert-yc-image-name db/postgres
                                             image-name)
                  "OK" response-server-error)
                response-invalid-request)))))
  ;; Serve static files
  (route/files "/")
  (route/not-found "404 Not Found"))

(defn -main
  "Starts the web server."
  []
  (let [port (Integer/parseInt (get (System/getenv)
                                    "APP_PORT" "8080"))
        production? (get-conf-value :in-production)
        defaults-config (if production?
                          ;; TODO fix CSRF tokens
                          (assoc (assoc-in (assoc-in secure-site-defaults
                                                     [:security :anti-forgery]
                                                     false)
                                           [:security :hsts]
                                           (get-conf-value :use-hsts))
                                 :proxy (get-conf-value :use-proxy))
                          (assoc-in site-defaults
                                    [:security :anti-forgery] false))
        handler (as-> routes $
                  (wrap-authorization $ auth-backend)
                  (wrap-authentication $ jwe-auth-backend auth-backend)
                  (wrap-defaults $ defaults-config)
                  (wrap-json-response $ {:pretty false})
                  (wrap-json-params $ {:keywords? true}))
        opts {:port port}]
    (run-jetty (if production?
                 handler
                 (wrap-reload handler))
               opts)))

(ns env-logger.handler
  "The main namespace of the application"
  (:gen-class)
  (:require [buddy
             [auth :refer [authenticated?]]
             [hashers :as h]]
            [buddy.auth.backends.session :refer [session-backend]]
            [buddy.auth.backends.token :refer [jwe-backend]]
            [buddy.auth.middleware :refer [wrap-authentication
                                           wrap-authorization]]
            [buddy.core.nonce :as nonce]
            [buddy.sign.jwt :as jwt]
            [cheshire.core :refer [generate-string parse-string]]
            [java-time :as t]
            [clojure set
             [string :as s]]
            [clojure.tools.logging :as log]
            [compojure
             [core :refer [defroutes DELETE GET POST]]
             [route :as route]]
            [env-logger
             [config :refer [get-conf-value]]
             [db :as db]
             [grabber :refer [calculate-start-time
                              get-fmi-weather-data
                              weather-query-ok?]]
             [user :as u]]
            [ring.adapter.jetty :refer [run-jetty]]
            [ring.middleware.defaults :refer :all]
            [ring.middleware.reload :refer [wrap-reload]]
            [ring.middleware.json :refer [wrap-json-params wrap-json-response]]
            [ring.util.response :as resp]
            [selmer.parser :refer [render-file]])
  (:import java.time.Instant
           com.yubico.client.v2.YubicoClient))

(defn otp-value-valid?
  "Checks whether the provided Yubico OTP value is valid. Returns true
  on success and false otherwise."
  [otp-value]
  (let [client (YubicoClient/getClient
                (Integer/parseInt (get-conf-value :yubico-client-id))
                (get-conf-value :yubico-secret-key))]
    (if-not (YubicoClient/isValidOTPFormat otp-value)
      false
      (.isOk (.verify client otp-value)))))

(defn check-auth-code
  "Checks whether the authentication code is valid."
  [code-to-check]
  (= (get-conf-value :auth-code) code-to-check))

(defn login-authenticate
  "Check request username and password against user data in the database.
  On successful authentication, set appropriate user into the session and
  redirect to the value of (:query-params (:next request)).
  On failed authentication, renders the login page."
  [request]
  (let [username (get-in request [:form-params "username"])
        password (get-in request [:form-params "password"])
        otp (get-in request [:form-params "otp"])
        session (:session request)
        use-ldap? (get-conf-value :use-ldap)
        user-data (if use-ldap?
                    (when-let [password (u/get-password-from-ldap username)]
                      {:pw-hash password})
                    (u/get-user-data db/postgres username))]
    (if (:error user-data)
      (render-file "templates/error.html"
                   {})
      (if (or (and user-data (h/check password (:pw-hash user-data)))
              (and (seq otp)
                   (otp-value-valid? otp)
                   (contains? (u/get-yubikey-id db/postgres username)
                              (YubicoClient/getPublicId otp))))
        (let [next-url (get-in request [:query-params :next]
                               (str (get-conf-value :url-path) "/"))
              updated-session (assoc session :identity (keyword username))]
          (assoc (resp/redirect next-url) :session updated-session))
        (render-file "templates/login.html"
                     {:error "Error: an invalid credential was provided"})))))

(defn unauthorized-handler
  "Handles unauthorized requests."
  [request metadata]
  (if (authenticated? request)
    ;; If request is authenticated, raise 403 instead of 401 as the user
    ;; is authenticated but permission denied is raised.
    (assoc (resp/response "403 Forbidden") :status 403)
    ;; In other cases, redirect it user to login
    (resp/redirect (format (str (get-conf-value :url-path) "/login?next=%s")
                           (:uri request)))))

(def response-unauthorized {:status 401
                            :headers {"Content-Type" "text/plain"}
                            :body "Unauthorized"})
(def response-invalid-request {:status 400
                               :headers {"Content-Type" "text/plain"}
                               :body "Invalid request"})
(def response-server-error {:status 500
                            :headers {"Content-Type" "text/plain"}
                            :body "Internal Server Error"})

(def jwe-secret (nonce/random-bytes 32))

(def jwe-auth-backend (jwe-backend {:secret jwe-secret
                                    :options {:alg :a256kw :enc :a128gcm}}))

(def auth-backend (session-backend
                   {:unauthorized-handler unauthorized-handler}))

(defn token-login
  "Login method for getting an token for data access."
  [request]
  (let [auth-data (get-conf-value :data-user-auth-data)
        username (get-in request [:params :username])
        password (get-in request [:params :password])
        valid? (and (and username
                         (= username (:username auth-data)))
                    (and password
                         (h/check password (:password auth-data))))]
    (if valid?
      (let [claims {:user (keyword username)
                    :exp (. (. (. Instant now) plusSeconds
                               (get-conf-value :jwt-token-timeout))
                            getEpochSecond)}
            token (jwt/encrypt claims jwe-secret {:alg :a256kw :enc :a128gcm})]
        token)
      response-unauthorized)))

(defn get-last-obs-data
  "Get data for observation with a non-null FMI temperature value."
  [request]
  (if-not (authenticated? request)
    response-unauthorized
    {:status 200
     :body {:data (first (filter #(not (nil? (:fmi_temperature %)))
                                 (reverse (db/get-obs-days db/postgres 1))))
            :rt-data (take (count (get-conf-value :ruuvitag-locations))
                           (reverse (db/get-ruuvitag-obs
                                     db/postgres
                                     (t/minus (t/local-date-time)
                                              (t/minutes 45))
                                     (t/local-date-time)
                                     (get-conf-value :ruuvitag-locations))))}}))

(defn yc-image-validity-check
  "Checks whether the yardcam image has the right format and is not too old.
  Returns true when the image name is valid and false otherwise."
  [image-name]
  (boolean (and image-name
                (re-find db/yc-image-pattern image-name)
                (<= (t/as (t/interval (t/zoned-date-time
                                       (t/formatter :iso-offset-date-time)
                                       (nth (re-find db/yc-image-pattern
                                                     image-name)
                                            1))
                                      (t/zoned-date-time))
                          :minutes)
                    (get-conf-value :yc-max-time-diff)))))

(defn get-plot-page-data
  "Returns data needed for rendering the plot page."
  [request]
  (let [start-date (when (seq (:startDate (:params request)))
                     (:startDate (:params request)))
        end-date (when (seq (:endDate (:params request)))
                   (:endDate (:params request)))
        obs-dates (db/get-obs-date-interval db/postgres)
        logged-in? (authenticated? request)
        initial-days (get-conf-value :initial-show-days)
        common-values {:obs-dates obs-dates
                       :logged-in? logged-in?
                       :yc-image-basepath (get-conf-value
                                           :yc-image-basepath)
                       :tb-image-basepath (get-conf-value
                                           :tb-image-basepath)
                       :rt-names (generate-string
                                  (get-conf-value :ruuvitag-locations))
                       :hide-rt (generate-string (get-conf-value
                                                  :hide-ruuvitag-data))}]
    (merge common-values
           (if (or start-date end-date)
             {:data (generate-string
                     (if logged-in?
                       (db/get-obs-interval db/postgres
                                            {:start start-date
                                             :end end-date})
                       (db/get-weather-obs-interval db/postgres
                                                    {:start start-date
                                                     :end end-date})))
              :rt-data (generate-string
                        (when logged-in?
                          (db/get-ruuvitag-obs
                           db/postgres
                           (db/make-local-dt start-date "start")
                           (db/make-local-dt end-date "end")
                           (get-conf-value :ruuvitag-locations))))
              :start-date start-date
              :end-date end-date}
             {:data (generate-string
                     (if logged-in?
                       (db/get-obs-days db/postgres
                                        initial-days)
                       (db/get-weather-obs-days db/postgres
                                                initial-days)))
              :rt-data (generate-string
                        (when logged-in?
                          (db/get-ruuvitag-obs
                           db/postgres
                           (t/minus (t/local-date-time)
                                    (t/days initial-days))
                           (t/local-date-time)
                           (get-conf-value :ruuvitag-locations))))
              :start-date (t/format (t/formatter :iso-local-date)
                                    (t/minus (t/local-date (t/formatter
                                                            :iso-local-date)
                                                           (:end obs-dates))
                                             (t/days initial-days)))
              :end-date (:end obs-dates)}))))

(defn handle-observation-insert
  "Handles the insertion of an observation to the database."
  [obs-string]
  (let [start-time (calculate-start-time)
        start-time-int (t/interval (t/plus start-time (t/minutes 4))
                                   (t/plus start-time (t/minutes 7)))
        weather-data (when (and (t/contains? start-time-int
                                             (t/zoned-date-time))
                                (weather-query-ok? db/postgres 3))
                       (get-fmi-weather-data
                        (get-conf-value :station-id)))]
    (db/insert-observation db/postgres
                           (assoc (parse-string obs-string
                                                true)
                                  :weather-data weather-data))))

(defroutes routes
  ;; Index and login
  (GET "/" request
       (if-not (db/test-db-connection db/postgres)
         (render-file "templates/error.html"
                      {})
         (render-file "templates/plots.html"
                      (get-plot-page-data request))))
  (GET "/login" [] (render-file "templates/login.html" {}))
  (POST "/login" [] login-authenticate)
  (GET "/logout" request
       (assoc (resp/redirect (str (get-conf-value :url-path) "/"))
              :session {}))
  (POST "/token-login" [] token-login)
  (GET "/get-last-obs" [] get-last-obs-data)
  ;; Observation storing
  (POST "/observations" request
        (if-not (check-auth-code (:code (:params request)))
          response-unauthorized
          (if-not (db/test-db-connection db/postgres)
            response-server-error
            (if (handle-observation-insert (:obs-string (:params request)))
              "OK" response-server-error))))
  ;; RuuviTag observation storage
  (POST "/rt-observations" request
        (if-not (check-auth-code (:code (:params request)))
          response-unauthorized
          (if-not (db/test-db-connection db/postgres)
            response-server-error
            (if (pos? (db/insert-ruuvitag-observation
                       db/postgres
                       (parse-string (:observation (:params request)) true)))
              "OK" response-server-error))))
  ;; Testbed image name storage
  (POST "/tb-image" request
        (if-not (check-auth-code (:code (:params request)))
          response-unauthorized
          (if-not (db/test-db-connection db/postgres)
            response-server-error
            (if (re-find #"testbed-\d{4}-\d{2}-\d{2}T\d{2}:\d{2}\+\d{4}\.png"
                         (:name (:params request)))
              (if (db/insert-tb-image-name db/postgres
                                           (db/get-last-obs-id
                                            db/postgres)
                                           (:name (:params
                                                   request)))
                "OK" response-server-error)
              response-invalid-request))))
  ;; Latest yardcam image name storage
  (POST "/yc-image" request
        (if-not (check-auth-code (:code (:params request)))
          response-unauthorized
          (if-not (db/test-db-connection db/postgres)
            response-server-error
            (let [image-name (:image-name (:params request))]
              (if (yc-image-validity-check image-name)
                (if (db/insert-yc-image-name db/postgres
                                             image-name)
                  "OK" response-server-error)
                response-invalid-request)))))
  ;; Serve static files
  (route/files "/")
  (route/not-found "404 Not Found"))

(defn -main
  "Starts the web server."
  []
  (let [port (Integer/parseInt (get (System/getenv)
                                    "APP_PORT" "8080"))
        production? (get-conf-value :in-production)
        defaults-config (if production?
                          ;; TODO fix CSRF tokens
                          (assoc (assoc-in (assoc-in secure-site-defaults
                                                     [:security :anti-forgery]
                                                     false)
                                           [:security :hsts]
                                           (get-conf-value :use-hsts))
                                 :proxy (get-conf-value :use-proxy))
                          (assoc-in site-defaults
                                    [:security :anti-forgery] false))
        handler (as-> routes $
                  (wrap-authorization $ auth-backend)
                  (wrap-authentication $ jwe-auth-backend auth-backend)
                  (wrap-defaults $ defaults-config)
                  (wrap-json-response $ {:pretty false})
                  (wrap-json-params $ {:keywords? true}))
        opts {:port port}]
    (run-jetty (if production?
                 handler
                 (wrap-reload handler))
               opts)))

Remove redundant quotes from log in token


(ns grafter.rdf.sesame
  (:require [clojure.java.io :as io])
  (:require [grafter.rdf.protocols :as pr])
  (:import [grafter.rdf.protocols IStatement Triple Quad])
  (:import [org.openrdf.model Statement Value Resource Literal URI BNode ValueFactory]
           [org.openrdf.model.impl CalendarLiteralImpl ValueFactoryImpl URIImpl
            BooleanLiteralImpl LiteralImpl IntegerLiteralImpl NumericLiteralImpl
            StatementImpl BNodeImpl ContextStatementImpl]
           [org.openrdf.repository Repository RepositoryConnection]
           [org.openrdf.repository.sail SailRepository]
           [org.openrdf.sail.memory MemoryStore]
           [org.openrdf.rio Rio RDFWriter]
           [org.openrdf.sail.nativerdf NativeStore]
           [org.openrdf.query TupleQuery TupleQueryResult BindingSet QueryLanguage BooleanQuery GraphQuery]
           [javax.xml.datatype XMLGregorianCalendar DatatypeFactory]
           [java.util GregorianCalendar Date]
           [org.openrdf.rio RDFFormat]))

(extend-type Statement
  ;; Extend our IStatement protocol to Sesame's Statements for convenience.
  pr/IStatement
  (subject [this] (.getSubject this))
  (predicate [this] (.getPredicate this))
  (object [this] (.getObject this))
  (context [this] (.getContext this)))

(defprotocol ISesameRDFConverter
  (->sesame-rdf-type [this])
  (sesame-rdf-type->type [this]))

(extend-protocol ISesameRDFConverter

  java.lang.Boolean
  (->sesame-rdf-type [this]
    (BooleanLiteralImpl. this))

  (sesame-rdf-type->type [this]
    this)

  BooleanLiteralImpl
  (->sesame-rdf-type [this]
    this)

  (sesame-rdf-type->type [this]
    (.booleanValue this))

  java.lang.String
  ;; Assume URI's are the norm not strings
  (->sesame-rdf-type [this]
    (URIImpl. this))

  (sesame-rdf-type->type [this]
    this)

  URI
  (->sesame-rdf-type [this]
    this)

  (sesame-rdf-type->type [this]
    (str this))

  java.lang.Integer
  (->sesame-rdf-type [this]
    (NumericLiteralImpl. this))

  (sesame-rdf-type->type [this]
    this)

  NumericLiteralImpl
  (->sesame-rdf-type [this]
    this)

  (sesame-rdf-type->type [this]
    ;; TODO support this
    (assert false "TODO add grafter support for this type.  Need to inspect datatype URI's in order to properly cast")
    (.intValue this))

  java.math.BigInteger
  (->sesame-rdf-type [this]
    (NumericLiteralImpl. this))

  (sesame-rdf-type->type [this]
    this)

  java.lang.Long
  (->sesame-rdf-type [this]
    ;; hacky and probably a little slow but works for now
    (IntegerLiteralImpl. (BigInteger. (str this))))

  (sesame-rdf-type->type [this]
    this)

  clojure.lang.BigInt
  (->sesame-rdf-type [this]
    ;; hacky and probably a little slow but works for now
    (IntegerLiteralImpl. (BigInteger. (str this))))

  (sesame-rdf-type->type [this]
    this)

  Statement
  (->sesame-rdf-type [this]
    this)

  Triple
  (->sesame-rdf-type [this]
    (StatementImpl. (->sesame-rdf-type (pr/subject this))
                    (->sesame-rdf-type (pr/predicate this))
                    (->sesame-rdf-type (pr/object this))))

  Quad
  (->sesame-rdf-type [this]
    (ContextStatementImpl. (->sesame-rdf-type (pr/subject this))
                           (->sesame-rdf-type (pr/predicate this))
                           (->sesame-rdf-type (pr/object this))
                           (->sesame-rdf-type (pr/context this))))

  Value
  (->sesame-rdf-type [this]
    this)

  Resource
  (->sesame-rdf-type [this]
    this)

  Literal
  (->sesame-rdf-type [this]
    this)

  URI
  (->sesame-rdf-type [this]
    this)

  java.net.URI
  (->sesame-rdf-type [this]
    (URIImpl. (.toString this)))

  java.net.URL
  (->sesame-rdf-type [this]
    (URIImpl. (.toString this)))

  BNode
  (->sesame-rdf-type [this]
    this)

  java.util.Date
  (->sesame-rdf-type [this]
    (let [cal (doto (GregorianCalendar.)
                (.setTime this))]
      (-> (DatatypeFactory/newInstance)
          (.newXMLGregorianCalendar cal)
          CalendarLiteralImpl.)))

  clojure.lang.Keyword
  (->sesame-rdf-type [this]
    (BNodeImpl. (name this))))

(defn IStatement->sesame-statement [is]
  (if (.c is)
    (do
      (ContextStatementImpl. (->sesame-rdf-type (.s is))
                             (URIImpl. (.p is))
                             (->sesame-rdf-type (.o is))
                             (URIImpl. (.c is))))
    (StatementImpl. (->sesame-rdf-type (.s is))
                    (URIImpl. (.p is))
                    (->sesame-rdf-type (.o is)))))

(defn sesame-statement->IStatement [st]
  ;; TODO fix this to work properly with object & context.
  ;; context should return either nil or a URI
  ;; object should be converted to a clojure type.
  (Quad. (str (.getSubject st)) (str (.getPredicate st))
         (.getObject st)
         (.getContext st)))

(extend-type Repository
  pr/ITripleWriteable

  (pr/add-statement
    ([this statement]
       (pr/add-statement (.getConnection this) statement))

    ([this graph statement]
       (pr/add-statement (.getConnection this) graph statement)))

  (pr/add
    ([this triples]
       (pr/add (.getConnection this) triples))

    ([this graph triples]
       (pr/add (.getConnection this) graph triples))))

(extend-type RepositoryConnection
  pr/ITripleWriteable

  (pr/add-statement
    ([this statement]
       {:pre [(instance? IStatement statement)]}
       (doto this
         (.add (IStatement->sesame-statement statement)
               (into-array Resource []))))
    ([this graph statement]
       {:pre [(instance? IStatement statement)]}
       (doto this
         (.add (IStatement->sesame-statement statement)
               (into-array Resource [(URIImpl. graph)])))))

  (pr/add
    ([this triples]
       (if (seq triples)
         (doseq [t triples]
           (pr/add-statement this t))
         (pr/add-statement this triples)))

    ([this graph triples]
       (if (seq triples)
         (doseq [t triples]
           (pr/add-statement this graph t))
         (pr/add-statement this graph triples)))))

(defn rdf-serializer
  "Coerces destination into an java.io.Writer using
  clojure.java.io/writer and returns an RDFSerializer."

  ([destination]
     (rdf-serializer destination (Rio/getWriterFormatForFileName destination)))
  ([destination format]
     (Rio/createWriter format (io/writer destination))))

(extend-protocol pr/ITripleWriteable
  RDFWriter
  (pr/add-statement [this statement]
    (.handleStatement this (->sesame-rdf-type statement)))

  (pr/add
    ([this triples]
       (if (seq triples)
         (do
           (.startRDF this)
           (doseq [t triples]
             (pr/add-statement this t))
           (.endRDF this))
         (throw (IllegalArgumentException. "This serializer does not support writing a single statement.  It should be passed a sequence of statements."))))

    ([this _graph triples]
       ;; TODO if format allows graphs we should support
       ;; them... otherwise.. ignore the graph param
       (pr/add this triples))))

(defn memory-store []
  (MemoryStore.))

(defn native-store
  ([datadir]
     (native-store (io/file datadir) "spoc,posc,cosp"))
  ([datadir indexes]
     (NativeStore. datadir indexes)))

(defn repo
  ([] (repo (MemoryStore.)))
  ([store]
     (doto (SailRepository. store)
       (.initialize))))

(defn load-rdf [connection file base-uri-str format]
  (.add connection (io/file file) base-uri-str format (into-array Resource [])))

(defn- query-bindings->map [qbs]
  (let [boundvars (.getBindingNames qbs)]
    (->> boundvars
         (mapcat (fn [k]
                   [k (-> qbs (.getBinding k) .getValue)]))
         (apply hash-map))))

(extend-protocol pr/ITransactable
  Repository
  (begin [repo]
    (-> repo .getConnection .begin))

  (commit [repo]
    (-> repo .getConnection .commit))

  (rollback [repo]
    (-> repo .getConnection .rollback))

  RepositoryConnection
  (begin [repo]
    (-> repo .begin))

  (commit [repo]
    (-> repo .commit))

  (rollback [repo]
    (-> repo .rollback)))

(defmacro with-transaction [repo & forms]
  "Wraps the given forms in a transaction on the supplied repository.
  Exceptions are rolled back on failure."
  `(try
    (pr/begin ~repo)
    (let [return# ~@forms]
      (pr/commit ~repo)
      return#)
    (catch Exception e#
      (pr/rollback ~repo)
      (throw e#))))

(defn- sesame-results->seq
  ([prepared-query] (sesame-results->seq prepared-query identity))
  ([prepared-query converter-f]
     (let [results (.evaluate prepared-query)
           run-query (fn pull-query []
                       (if (.hasNext results)
                         (let [current-result (try
                                                (converter-f (.next results))
                                                (catch Exception e
                                                  (.close results)))]
                           (lazy-cat
                            [current-result]
                            (pull-query)))
                         (.close results)))]
       (run-query))))

(defn- evaluate-tuple-query [prepared-query]
  (sesame-results->seq query-bindings->map))

(defn- evaluate-graph-query [prepared-query]
  (sesame-results->seq prepared-query sesame-statement->IStatement))

(defprotocol ISPARQLable
  "Quick and dirty sparql SELECT results.  Takes a connection and query
string and returns a lazy sequence of results.

It doesn't clear up properly in all cases, for example if the sequence
isn't fully consumed you may cause a resource leak.

TODO: reimplement with proper resource handling."
  (query [this sparql-string]))

(extend-type Repository
  ISPARQLable
  (query [this query-str]
    (query (.getConnection this) query-str))

  pr/ITripleReadable
  (pr/statements [this]
    (pr/statements (.getConnection this))))

(extend-type RepositoryConnection
  ISPARQLable
  (query [this sparql-string]
    (let [preped-query (.prepareQuery this
                                      QueryLanguage/SPARQL
                                      sparql-string)]

      (cond
       (instance? BooleanQuery preped-query) (.evaluate preped-query)
       (instance? TupleQuery preped-query) (evaluate-tuple-query preped-query)
       (instance? GraphQuery preped-query) (evaluate-graph-query preped-query))))

  pr/ITripleReadable

  (statements [this]
    (map
     (fn [{:strs [s p o c]}]
       (Quad. s p o c))

     (query this "SELECT ?s ?p ?o ?c WHERE {
               GRAPH ?c {
                 ?s ?p ?o .
               }
            }"))))

(ns grafter.rdf.sesame
  (:require [clojure.java.io :as io])
  (:require [grafter.rdf.protocols :as pr])
  (:import [grafter.rdf.protocols IStatement Triple Quad])
  (:import [org.openrdf.model Statement Value Resource Literal URI BNode ValueFactory]
           [org.openrdf.model.impl CalendarLiteralImpl ValueFactoryImpl URIImpl
            BooleanLiteralImpl LiteralImpl IntegerLiteralImpl NumericLiteralImpl
            StatementImpl BNodeImpl ContextStatementImpl]
           [org.openrdf.repository Repository RepositoryConnection]
           [org.openrdf.repository.sail SailRepository]
           [org.openrdf.sail.memory MemoryStore]
           [org.openrdf.rio Rio RDFWriter]
           [org.openrdf.sail.nativerdf NativeStore]
           [org.openrdf.query TupleQuery TupleQueryResult BindingSet QueryLanguage BooleanQuery GraphQuery]
           [javax.xml.datatype XMLGregorianCalendar DatatypeFactory]
           [java.util GregorianCalendar Date]
           [org.openrdf.rio RDFFormat]))

(extend-type Statement
  ;; Extend our IStatement protocol to Sesame's Statements for convenience.
  pr/IStatement
  (subject [this] (.getSubject this))
  (predicate [this] (.getPredicate this))
  (object [this] (.getObject this))
  (context [this] (.getContext this)))

(defprotocol ISesameRDFConverter
  (->sesame-rdf-type [this])
  (sesame-rdf-type->type [this]))

(extend-protocol ISesameRDFConverter

  java.lang.Boolean
  (->sesame-rdf-type [this]
    (BooleanLiteralImpl. this))

  (sesame-rdf-type->type [this]
    this)

  BooleanLiteralImpl
  (->sesame-rdf-type [this]
    this)

  (sesame-rdf-type->type [this]
    (.booleanValue this))

  java.lang.String
  ;; Assume URI's are the norm not strings
  (->sesame-rdf-type [this]
    (URIImpl. this))

  (sesame-rdf-type->type [this]
    this)

  URI
  (->sesame-rdf-type [this]
    this)

  (sesame-rdf-type->type [this]
    (str this))

  java.lang.Integer
  (->sesame-rdf-type [this]
    (NumericLiteralImpl. this))

  (sesame-rdf-type->type [this]
    this)

  NumericLiteralImpl
  (->sesame-rdf-type [this]
    this)

  (sesame-rdf-type->type [this]
    ;; TODO support this
    (assert false "TODO add grafter support for this type.  Need to inspect datatype URI's in order to properly cast")
    (.intValue this))

  java.math.BigInteger
  (->sesame-rdf-type [this]
    (NumericLiteralImpl. this))

  (sesame-rdf-type->type [this]
    this)

  java.lang.Long
  (->sesame-rdf-type [this]
    ;; hacky and probably a little slow but works for now
    (IntegerLiteralImpl. (BigInteger. (str this))))

  (sesame-rdf-type->type [this]
    this)

  clojure.lang.BigInt
  (->sesame-rdf-type [this]
    ;; hacky and probably a little slow but works for now
    (IntegerLiteralImpl. (BigInteger. (str this))))

  (sesame-rdf-type->type [this]
    this)

  Statement
  (->sesame-rdf-type [this]
    this)

  Triple
  (->sesame-rdf-type [this]
    (StatementImpl. (->sesame-rdf-type (pr/subject this))
                    (->sesame-rdf-type (pr/predicate this))
                    (->sesame-rdf-type (pr/object this))))

  Quad
  (->sesame-rdf-type [this]
    (ContextStatementImpl. (->sesame-rdf-type (pr/subject this))
                           (->sesame-rdf-type (pr/predicate this))
                           (->sesame-rdf-type (pr/object this))
                           (->sesame-rdf-type (pr/context this))))

  Value
  (->sesame-rdf-type [this]
    this)

  Resource
  (->sesame-rdf-type [this]
    this)

  Literal
  (->sesame-rdf-type [this]
    this)

  URI
  (->sesame-rdf-type [this]
    this)

  java.net.URI
  (->sesame-rdf-type [this]
    (URIImpl. (.toString this)))

  java.net.URL
  (->sesame-rdf-type [this]
    (URIImpl. (.toString this)))

  BNode
  (->sesame-rdf-type [this]
    this)

  java.util.Date
  (->sesame-rdf-type [this]
    (let [cal (doto (GregorianCalendar.)
                (.setTime this))]
      (-> (DatatypeFactory/newInstance)
          (.newXMLGregorianCalendar cal)
          CalendarLiteralImpl.)))

  clojure.lang.Keyword
  (->sesame-rdf-type [this]
    (BNodeImpl. (name this))))

(defn IStatement->sesame-statement [is]
  (if (.c is)
    (do
      (ContextStatementImpl. (->sesame-rdf-type (.s is))
                             (URIImpl. (.p is))
                             (->sesame-rdf-type (.o is))
                             (URIImpl. (.c is))))
    (StatementImpl. (->sesame-rdf-type (.s is))
                    (URIImpl. (.p is))
                    (->sesame-rdf-type (.o is)))))

(defn sesame-statement->IStatement [st]
  ;; TODO fix this to work properly with object & context.
  ;; context should return either nil or a URI
  ;; object should be converted to a clojure type.
  (Quad. (str (.getSubject st)) (str (.getPredicate st))
         (.getObject st)
         (.getContext st)))

(extend-type Repository
  pr/ITripleWriteable

  (pr/add-statement
    ([this statement]
       (pr/add-statement (.getConnection this) statement))

    ([this graph statement]
       (pr/add-statement (.getConnection this) graph statement)))

  (pr/add
    ([this triples]
       (pr/add (.getConnection this) triples))

    ([this graph triples]
       (pr/add (.getConnection this) graph triples))))

(extend-type RepositoryConnection
  pr/ITripleWriteable

  (pr/add-statement
    ([this statement]
       {:pre [(instance? IStatement statement)]}
       (doto this
         (.add (IStatement->sesame-statement statement)
               (into-array Resource []))))
    ([this graph statement]
       {:pre [(instance? IStatement statement)]}
       (doto this
         (.add (IStatement->sesame-statement statement)
               (into-array Resource [(URIImpl. graph)])))))

  (pr/add
    ([this triples]
       (if (seq triples)
         (doseq [t triples]
           (pr/add-statement this t))
         (pr/add-statement this triples)))

    ([this graph triples]
       (if (seq triples)
         (doseq [t triples]
           (pr/add-statement this graph t))
         (pr/add-statement this graph triples)))))

(defn rdf-serializer
  "Coerces destination into an java.io.Writer using
  clojure.java.io/writer and returns an RDFSerializer."

  ([destination]
     (rdf-serializer destination (Rio/getWriterFormatForFileName destination)))
  ([destination format]
     (Rio/createWriter format (io/writer destination))))

(extend-protocol pr/ITripleWriteable
  RDFWriter
  (pr/add-statement [this statement]
    (.handleStatement this (->sesame-rdf-type statement)))

  (pr/add
    ([this triples]
       (if (seq triples)
         (do
           (.startRDF this)
           (doseq [t triples]
             (pr/add-statement this t))
           (.endRDF this))
         (throw (IllegalArgumentException. "This serializer does not support writing a single statement.  It should be passed a sequence of statements."))))

    ([this _graph triples]
       ;; TODO if format allows graphs we should support
       ;; them... otherwise.. ignore the graph param
       (pr/add this triples))))

(defn memory-store []
  (MemoryStore.))

(defn native-store
  ([datadir]
     (native-store (io/file datadir) "spoc,posc,cosp"))
  ([datadir indexes]
     (NativeStore. datadir indexes)))

(defn repo
  ([] (repo (MemoryStore.)))
  ([store]
     (doto (SailRepository. store)
       (.initialize))))

(defn load-rdf [connection file base-uri-str format]
  (.add connection (io/file file) base-uri-str format (into-array Resource [])))

(defn- query-bindings->map [qbs]
  (let [boundvars (.getBindingNames qbs)]
    (->> boundvars
         (mapcat (fn [k]
                   [k (-> qbs (.getBinding k) .getValue)]))
         (apply hash-map))))

(extend-protocol pr/ITransactable
  Repository
  (begin [repo]
    (-> repo .getConnection .begin))

  (commit [repo]
    (-> repo .getConnection .commit))

  (rollback [repo]
    (-> repo .getConnection .rollback))

  RepositoryConnection
  (begin [repo]
    (-> repo .begin))

  (commit [repo]
    (-> repo .commit))

  (rollback [repo]
    (-> repo .rollback)))

(defmacro with-transaction [repo & forms]
  "Wraps the given forms in a transaction on the supplied repository.
  Exceptions are rolled back on failure."
  `(try
    (pr/begin ~repo)
    (let [return# (do ~@forms)]
      (pr/commit ~repo)
      return#)
    (catch Exception e#
      (pr/rollback ~repo)
      (throw e#))))

(defn- sesame-results->seq
  ([prepared-query] (sesame-results->seq prepared-query identity))
  ([prepared-query converter-f]
     (let [results (.evaluate prepared-query)
           run-query (fn pull-query []
                       (if (.hasNext results)
                         (let [current-result (try
                                                (converter-f (.next results))
                                                (catch Exception e
                                                  (.close results)))]
                           (lazy-cat
                            [current-result]
                            (pull-query)))
                         (.close results)))]
       (run-query))))

(defn- evaluate-tuple-query [prepared-query]
  (sesame-results->seq query-bindings->map))

(defn- evaluate-graph-query [prepared-query]
  (sesame-results->seq prepared-query sesame-statement->IStatement))

(defprotocol ISPARQLable
  "Quick and dirty sparql SELECT results.  Takes a connection and query
string and returns a lazy sequence of results.

It doesn't clear up properly in all cases, for example if the sequence
isn't fully consumed you may cause a resource leak.

TODO: reimplement with proper resource handling."
  (query [this sparql-string]))

(extend-type Repository
  ISPARQLable
  (query [this query-str]
    (query (.getConnection this) query-str))

  pr/ITripleReadable
  (pr/statements [this]
    (pr/statements (.getConnection this))))

(extend-type RepositoryConnection
  ISPARQLable
  (query [this sparql-string]
    (let [preped-query (.prepareQuery this
                                      QueryLanguage/SPARQL
                                      sparql-string)]

      (cond
       (instance? BooleanQuery preped-query) (.evaluate preped-query)
       (instance? TupleQuery preped-query) (evaluate-tuple-query preped-query)
       (instance? GraphQuery preped-query) (evaluate-graph-query preped-query))))

  pr/ITripleReadable

  (statements [this]
    (map
     (fn [{:strs [s p o c]}]
       (Quad. s p o c))

     (query this "SELECT ?s ?p ?o ?c WHERE {
               GRAPH ?c {
                 ?s ?p ?o .
               }
            }"))))

Fix to support multiple forms inside with-transaction.


(ns hackernews.events
  (:require
   [re-frame.core :refer [reg-event-db after reg-event-fx reg-cofx]]
   [ajax.core :as ajax]
   [clojure.spec :as s]
   [hackernews.db :as db :refer [app-db]]))

;; -- Interceptors ------------------------------------------------------------
;;
;; See https://github.com/Day8/re-frame/blob/master/docs/Interceptors.md
;;
(defn check-and-throw
  "Throw an exception if db doesn't have a valid spec."
  [spec db [event]]
  (when-not (s/valid? spec db)
    (let [explain-data (s/explain-data spec db)]
      (throw (ex-info (str "Spec check after " event " failed: " explain-data) explain-data)))))

(def validate-spec
  (if goog.DEBUG
    (after (partial check-and-throw ::db/app-db))
    []))

;; -- Handlers --------------------------------------------------------------

(reg-event-db
 :initialize-db
 validate-spec
 (fn [_ _]
   app-db))

(reg-event-db
 :read-story
 validate-spec
 (fn [db [_ story-id]]
   (let [stories (get-in db [:front-page :front-page-stories])
         updated-stories (map #(if (= story-id (:id %)) (assoc % :read? true) %) stories)]
     (println updated-stories)
     (assoc-in db [:front-page :front-page-stories] updated-stories))))

(reg-event-fx
 :loaded-front-page-stories
 validate-spec
 (fn [cofx [_ stories]]
   {:db (-> (update-in (:db cofx) [:front-page :front-page-stories] #(apply conj % stories))
            (update-in [:front-page :current-page-num] inc))}))

;; -- Effects --

(def hn-api "https://node-hnapi.herokuapp.com/news" )

(reg-event-fx
 :load-front-page-stories
 (fn [{:keys [db]} [_]]
   {:db db
    :http-xhrio {:method          :get
                 :uri             hn-api
                 :params {:page (get-in db [:front-page :current-page-num])}
                 :timeout         8000
                 :response-format (ajax/json-response-format {:keywords? true})
                 :on-success      [:loaded-front-page-stories]
                 :on-failure      [:failed-loading-front-page-stories]}}))

(ns hackernews.events
  (:require
   [re-frame.core :refer [reg-event-db after reg-event-fx reg-cofx]]
   [ajax.core :as ajax]
   [clojure.spec :as s]
   [hackernews.db :as db :refer [app-db]]))

;; -- Interceptors ------------------------------------------------------------
;;
;; See https://github.com/Day8/re-frame/blob/master/docs/Interceptors.md
;;
(defn check-and-throw
  "Throw an exception if db doesn't have a valid spec."
  [spec db [event]]
  (when-not (s/valid? spec db)
    (let [explain-data (s/explain-data spec db)]
      (throw (ex-info (str "Spec check after " event " failed: " explain-data) explain-data)))))

(def validate-spec
  (if goog.DEBUG
    (after (partial check-and-throw ::db/app-db))
    []))

;; -- Handlers --------------------------------------------------------------

(reg-event-db
 :initialize-db
 validate-spec
 (fn [_ _]
   app-db))

(reg-event-db
 :read-story
 validate-spec
 (fn [db [_ story-id]]
   (let [stories (get-in db [:front-page :front-page-stories])
         updated-stories (map #(if (= story-id (:id %)) (assoc % :read? true) %) stories)]
     (assoc-in db [:front-page :front-page-stories] updated-stories))))

(reg-event-fx
 :loaded-front-page-stories
 validate-spec
 (fn [cofx [_ stories]]
   {:db (-> (update-in (:db cofx) [:front-page :front-page-stories] #(apply conj % stories))
            (update-in [:front-page :current-page-num] inc)
            (assoc-in [:front-page :is-loading?] false))}))

;; -- Effects --

(def hn-api "https://node-hnapi.herokuapp.com/news" )

(reg-event-fx
 :load-front-page-stories
 (fn [{:keys [db]} [_]]
   (if (not (get-in db [:front-page :is-loading?]))
     {:db (assoc-in db [:front-page :is-loading?] true)
      :http-xhrio {:method          :get
                   :uri             hn-api
                   :params {:page (get-in db [:front-page :current-page-num])}
                   :timeout         8000
                   :response-format (ajax/json-response-format {:keywords? true})
                   :on-success      [:loaded-front-page-stories]
                   :on-failure      [:failed-loading-front-page-stories]}}
     {:db db})))

Read and Loading

Read and Loading


(ns uxbox.ui.shapes.icon
  (:require [sablono.core :refer-macros [html]]
            [cuerdas.core :as str]
            [rum.core :as rum]
            [lentes.core :as l]
            [uxbox.rstore :as rs]
            [uxbox.state :as st]
            [uxbox.shapes :as ush]
            [uxbox.data.workspace :as dw]
            [uxbox.ui.core :as uuc]
            [uxbox.ui.mixins :as mx]
            [uxbox.ui.keyboard :as kbd]
            [uxbox.ui.shapes.core :as uusc]
            [uxbox.util.dom :as dom]))

;; --- Icon Component

(defn on-mouse-down
  [event {:keys [id group] :as shape} selected]
  (let [selected? (contains? selected id)
        drawing? @uusc/drawing-state-l]
    (when-not (:blocked shape)
      (cond
        (or drawing?
            (and group (:locked (ush/resolve-parent shape))))
        nil

        (and (not selected?) (empty? selected))
        (do
          (dom/stop-propagation event)
          (uuc/acquire-action! "ui.shape.move")
          (rs/emit! (dw/select-shape id)))

        (and (not selected?) (not (empty? selected)))
        (do
          (dom/stop-propagation event)
          (if (kbd/shift? event)
            (rs/emit! (dw/select-shape id))
            (rs/emit! (dw/deselect-all)
                      (dw/select-shape id))))

        :else
        (do
          (dom/stop-propagation event)
          (uuc/acquire-action! "ui.shape.move"))))))

(defn on-mouse-up
  [event {:keys [id group] :as shape}]
  (cond
    (and group (:locked (ush/resolve-parent shape)))
    nil

    :else
    (do
      (dom/stop-propagation event)
      (uuc/release-action! "ui.shape"))))

(declare handlers)

(defmethod uusc/render-component :default ;; :builtin/icon
  [own shape]
  (let [{:keys [id x y width height group]} shape
        selected (rum/react uusc/selected-shapes-l)
        selected? (contains? selected id)
        on-mouse-down #(on-mouse-down % shape selected)
        on-mouse-up #(on-mouse-up % shape)]
    (html
     [:g.shape {:class (when selected? "selected")
                :on-mouse-down on-mouse-down
                :on-mouse-up on-mouse-up}
      (uusc/render-shape shape #(uusc/shape %))
      (when (and selected? (= (count selected) 1))
        (handlers shape))])))

;; --- Icon Handlers

(defn- handlers-render
  [own shape]
  (letfn [(on-mouse-down [vid event]
            (dom/stop-propagation event)
            (uuc/acquire-action! "ui.shape.resize"
                                 {:vid vid :shape (:id shape)}))

          (on-mouse-up [vid event]
            (dom/stop-propagation event)
            (uuc/release-action! "ui.shape.resize"))]
    (let [{:keys [x y width height]} (ush/outer-rect' shape)]
      (html
       [:g.controls
        [:rect {:x x :y y :width width :height height :stroke-dasharray "5,5"
                :style {:stroke "#333" :fill "transparent"
                        :stroke-opacity "1"}}]
        [:circle.top-left
         (merge uusc/+circle-props+
                {:on-mouse-up #(on-mouse-up 1 %)
                 :on-mouse-down #(on-mouse-down 1 %)
                 :cx x
                 :cy y})]
        [:circle.top-right
         (merge uusc/+circle-props+
                {:on-mouse-up #(on-mouse-up 2 %)
                 :on-mouse-down #(on-mouse-down 2 %)
                 :cx (+ x width)
                 :cy y})]
        [:circle.bottom-left
         (merge uusc/+circle-props+
                {:on-mouse-up #(on-mouse-up 3 %)
                 :on-mouse-down #(on-mouse-down 3 %)
                 :cx x
                 :cy (+ y height)})]
        [:circle.bottom-right
         (merge uusc/+circle-props+
                {:on-mouse-up #(on-mouse-up 4 %)
                 :on-mouse-down #(on-mouse-down 4 %)
                 :cx (+ x width)
                 :cy (+ y height)})]]))))

(def ^:const handlers
  (mx/component
   {:render handlers-render
    :name "handlers"
    :mixins [mx/static]}))

;; --- Shape & Shape Svg

(defmethod uusc/render-shape :builtin/icon
  [{:keys [data id] :as shape} _]
  (let [key (str id)
        rfm (ush/transformation shape)
        attrs (merge {:id key :key key :transform (str rfm)}
                     (uusc/extract-style-attrs shape)
                     (uusc/make-debug-attrs shape))]
    (html
     [:g attrs data])))

(defmethod uusc/render-shape-svg :builtin/icon
  [{:keys [data id view-box] :as shape}]
  (let [key (str "icon-svg-" id)
        view-box (apply str (interpose " " view-box))
        props {:view-box view-box :id key :key key}]
    (html
     [:svg props data])))

(ns uxbox.ui.shapes.icon
  (:require [sablono.core :refer-macros [html]]
            [cuerdas.core :as str]
            [rum.core :as rum]
            [lentes.core :as l]
            [uxbox.rstore :as rs]
            [uxbox.state :as st]
            [uxbox.shapes :as ush]
            [uxbox.data.workspace :as dw]
            [uxbox.ui.core :as uuc]
            [uxbox.ui.mixins :as mx]
            [uxbox.ui.keyboard :as kbd]
            [uxbox.ui.shapes.core :as uusc]
            [uxbox.util.dom :as dom]))

;; --- Icon Component

(defn on-mouse-down
  [event {:keys [id group] :as shape} selected]
  (let [selected? (contains? selected id)
        drawing? @uusc/drawing-state-l]
    (when-not (:blocked shape)
      (cond
        (or drawing?
            (and group (:locked (ush/resolve-parent shape))))
        nil

        (and (not selected?) (empty? selected))
        (do
          (dom/stop-propagation event)
          (rs/emit! (dw/select-shape id))
          (uuc/acquire-action! "ui.shape.move"))

        (and (not selected?) (not (empty? selected)))
        (do
          (dom/stop-propagation event)
          (if (kbd/shift? event)
            (rs/emit! (dw/select-shape id))
            (rs/emit! (dw/deselect-all)
                      (dw/select-shape id))))

        :else
        (do
          (dom/stop-propagation event)
          (uuc/acquire-action! "ui.shape.move"))))))

(defn on-mouse-up
  [event {:keys [id group] :as shape}]
  (cond
    (and group (:locked (ush/resolve-parent shape)))
    nil

    :else
    (do
      (dom/stop-propagation event)
      (uuc/release-action! "ui.shape"))))

(declare handlers)

(defmethod uusc/render-component :default ;; :builtin/icon
  [own shape]
  (let [{:keys [id x y width height group]} shape
        selected (rum/react uusc/selected-shapes-l)
        selected? (contains? selected id)
        on-mouse-down #(on-mouse-down % shape selected)
        on-mouse-up #(on-mouse-up % shape)]
    (html
     [:g.shape {:class (when selected? "selected")
                :on-mouse-down on-mouse-down
                :on-mouse-up on-mouse-up}
      (uusc/render-shape shape #(uusc/shape %))
      (when (and selected? (= (count selected) 1))
        (handlers shape))])))

;; --- Icon Handlers

(defn- handlers-render
  [own shape]
  (letfn [(on-mouse-down [vid event]
            (dom/stop-propagation event)
            (uuc/acquire-action! "ui.shape.resize"
                                 {:vid vid :shape (:id shape)}))

          (on-mouse-up [vid event]
            (dom/stop-propagation event)
            (uuc/release-action! "ui.shape.resize"))]
    (let [{:keys [x y width height]} (ush/outer-rect' shape)]
      (html
       [:g.controls
        [:rect {:x x :y y :width width :height height :stroke-dasharray "5,5"
                :style {:stroke "#333" :fill "transparent"
                        :stroke-opacity "1"}}]
        [:circle.top-left
         (merge uusc/+circle-props+
                {:on-mouse-up #(on-mouse-up 1 %)
                 :on-mouse-down #(on-mouse-down 1 %)
                 :cx x
                 :cy y})]
        [:circle.top-right
         (merge uusc/+circle-props+
                {:on-mouse-up #(on-mouse-up 2 %)
                 :on-mouse-down #(on-mouse-down 2 %)
                 :cx (+ x width)
                 :cy y})]
        [:circle.bottom-left
         (merge uusc/+circle-props+
                {:on-mouse-up #(on-mouse-up 3 %)
                 :on-mouse-down #(on-mouse-down 3 %)
                 :cx x
                 :cy (+ y height)})]
        [:circle.bottom-right
         (merge uusc/+circle-props+
                {:on-mouse-up #(on-mouse-up 4 %)
                 :on-mouse-down #(on-mouse-down 4 %)
                 :cx (+ x width)
                 :cy (+ y height)})]]))))

(def ^:const handlers
  (mx/component
   {:render handlers-render
    :name "handlers"
    :mixins [mx/static]}))

;; --- Shape & Shape Svg

(defmethod uusc/render-shape :builtin/icon
  [{:keys [data id] :as shape} _]
  (let [key (str id)
        rfm (ush/transformation shape)
        attrs (merge {:id key :key key :transform (str rfm)}
                     (uusc/extract-style-attrs shape)
                     (uusc/make-debug-attrs shape))]
    (html
     [:g attrs data])))

(defmethod uusc/render-shape-svg :builtin/icon
  [{:keys [data id view-box] :as shape}]
  (let [key (str "icon-svg-" id)
        view-box (apply str (interpose " " view-box))
        props {:view-box view-box :id key :key key}]
    (html
     [:svg props data])))

Send the select-shape event before acquire move action.


(ns webapp.password_admin
  (:refer-clojure :exclude [sort find])
  (:require
      [taoensso.carmine :as car :refer (wcar)]
      [cemerick.friend :as friend] (cemerick.friend [workflows :as workflows] [credentials :as creds])))

(def server1-conn {:pool {} :spec {:host "127.0.0.1" :port 6379}})
(defmacro wcar* [& body] `(car/wcar server1-conn ~@body))

(defn set_roles_to_redis [username password roles] (wcar* (car/set (str "password:" username) {:hashed-password (creds/hash-bcrypt password) :roles roles})))

(set_roles_to_redis "" "" #{:webapp.core/user})
(set_roles_to_redis "doug_admin" "pimpin" #{:webapp.core/admin})

Update password_admin.clj

Update password_admin.clj


(ns icfp2014.compiler
  (:require [clojure.java.io]
            [clojure.string :as string]))

(def macros
  {'up [[:ldc 0 "; up"]]
   'right [[:ldc 1 "; right"]]
   'down [[:ldc 2 "; down"]]
   'left [[:ldc 3 "; left"]]})

(def builtins
  {'inc (fn [x]
          [x
           [:ldc 1 "; inc"]
           [:add "; inc"]])
   'dec (fn [x]
          [x
           [:ldc 1 "; inc"]
           [:sub "; inc"]])})

(defn compile-form
  [vars fns form]
  {:post [(sequential? %)
          (every? vector? %)]}
  (cond
    (integer? form)
    [[:ldc form]]

    (macros form)
    (macros form)

    (symbol? form)
    (if (fns form)
      [[:ldf form]]
      [[:ld 0 (.indexOf vars form)]])

    (vector? form)
    (if (empty? form)
      [[:ldc 0]]
      (concat (mapcat #(compile-form vars fns %) form)
              [[:ldc 0]]
              (repeat (count form) [:cons])))

    (seq? form)
    (let [[fn-name & args] form
          evaled-args (mapcat #(compile-form vars fns %) args)]
      (if (= fn-name 'quote)
        (concat (mapcat #(compile-form vars fns %) (first args))
                (repeat (dec (count form)) [:cons]))
        (if (builtins fn-name)
          (apply (builtins fn-name) evaled-args)
          (concat
            ;; Push the args onto the stack
            evaled-args
            [[:ldf fn-name]
             [:ap (dec (count form))]]))))

    :else
    (throw (IllegalArgumentException. (format "Don't know how to compile %s which is %s" form (type form))))))

(defn assign-addresses
  [fns]
  {:pre [(map? fns)
         (every? symbol? (keys fns))
         (every? map? (vals fns))]}
  (let [main (fns 'main)
        others (vals (sort (dissoc fns 'main)))]
    (loop [funcs (apply vector main others)
           index 0
           address 0]
      (if-let [func (get funcs index)]
        (let [new-funcs (update-in funcs [index] assoc :address address)
              address (+ address (count (:code func)))]
          (recur new-funcs (inc index) address))
        funcs))))

(defn code->str
  [fn-addrs line]
  {:pre [(map? fn-addrs)]
   :post [(string? %)]}
  (condp = (first line)
    :ldf
    (format "LDF %s ; load function %s"
            (fn-addrs (second line))
            (last line))

    (let [[op & args] line]
      (string/join " " (cons (string/upper-case (name op)) args)))))

(defn emit-code
  [fns]
  {:pre [(vector? fns)
         (every? map? fns)]
   :post [(string? %)]}
  (let [fn-addrs (into {} (map (juxt :name :address) fns))]
    (->> (mapcat :code fns)
         (map #(code->str fn-addrs %))
         (string/join "\n"))))

(defn compile-function
  [[name args & body :as code] fns]
  {:pre [(list? code)]}
  (let [fns (assoc fns name {})
        [stmt & stmts] (mapcat #(compile-form args fns %) body)]
    (concat [(conj stmt (format "; define %s" name))]
            stmts
            [[:rtn]])))

(defn compile-ai
  [file]
  {:pre [(string? file)]
   :post [(string? %)]}
  (let [prog (java.io.PushbackReader. (clojure.java.io/reader file))]
    (loop [form (read prog false nil)
           fns {}]
      (if form
        (let [code (compile-function form fns)]
          (recur (read prog false nil) (assoc fns (first form) {:name (first form) :code code})))
        (emit-code (assign-addresses fns))))))

(ns icfp2014.compiler
  (:require [clojure.java.io]
            [clojure.string :as string]))

(def macros
  {'up [[:ldc 0 "; up"]]
   'right [[:ldc 1 "; right"]]
   'down [[:ldc 2 "; down"]]
   'left [[:ldc 3 "; left"]]})

(def builtins
  {'inc (fn [x]
          [x
           [:ldc 1 "; inc"]
           [:add "; inc"]])
   'dec (fn [x]
          [x
           [:ldc 1 "; inc"]
           [:sub "; inc"]])})

(defn compile-form
  [vars fns form]
  {:post [(sequential? %)
          (every? vector? %)]}
  (cond
    (integer? form)
    [[:ldc form]]

    (macros form)
    (macros form)

    (symbol? form)
    (if (fns form)
      [[:ldf form]]
      [[:ld 0 (.indexOf vars form)]])

    (vector? form)
    (if (empty? form)
      [[:ldc 0]]
      (concat (mapcat #(compile-form vars fns %) form)
              [[:ldc 0]]
              (repeat (count form) [:cons])))

    (seq? form)
    (let [[fn-name & args] form
          evaled-args (mapcat #(compile-form vars fns %) args)]
      (if (= fn-name 'quote)
        (concat (mapcat #(compile-form vars fns %) (first args))
                (repeat (dec (count form)) [:cons]))
        (if (builtins fn-name)
          (apply (builtins fn-name) evaled-args)
          (concat
            ;; Push the args onto the stack
            evaled-args
            [[:ldf fn-name]
             [:ap (dec (count form))]]))))

    :else
    (throw (IllegalArgumentException. (format "Don't know how to compile %s which is %s" form (type form))))))

(defn assign-addresses
  [fns]
  {:pre [(map? fns)
         (every? symbol? (keys fns))
         (every? map? (vals fns))]}
  (let [main (fns 'main)
        others (vals (sort (dissoc fns 'main)))]
    (loop [funcs (apply vector main others)
           index 0
           address 0]
      (if-let [func (get funcs index)]
        (let [new-funcs (update-in funcs [index] assoc :address address)
              address (+ address (:length func))]
          (recur new-funcs (inc index) address))
        funcs))))

(defn code->str
  [fn-addrs line]
  {:pre [(map? fn-addrs)]
   :post [(string? %)]}
  (condp = (first line)
    :ldf
    (format "LDF %s ; load function %s"
            (fn-addrs (second line))
            (last line))

    (let [[op & args] line]
      (string/join " " (cons (string/upper-case (name op)) args)))))

(defn emit-code
  [fns]
  {:pre [(vector? fns)
         (every? map? fns)]
   :post [(string? %)]}
  (let [fn-addrs (into {} (map (juxt :name :address) fns))]
    (->> (mapcat :code fns)
         (map #(code->str fn-addrs %))
         (string/join "\n"))))

(defn compile-function
  [[name args & body :as code] fns]
  {:pre [(list? code)]}
  (let [fns (assoc fns name {})
        [stmt & stmts] (mapcat #(compile-form args fns %) body)
        code (concat [(conj stmt (format "; define %s" name))]
                     stmts
                     [[:rtn]])]
    {:name name
     :code code
     :length (count code)}))

(defn compile-ai
  [file]
  {:pre [(string? file)]
   :post [(string? %)]}
  (let [prog (java.io.PushbackReader. (clojure.java.io/reader file))]
    (loop [form (read prog false nil)
           fns {}]
      (if form
        (let [func (compile-function form fns)]
          (recur (read prog false nil) (assoc fns (:name func) func)))
        (emit-code (assign-addresses fns))))))

Standardize a function map structure

Standardize a function map structure


(ns moves-server.core
  (:gen-class)
  (:require [ring.adapter.jetty :as jetty]
            [ring.middleware.keyword-params :refer [wrap-keyword-params]]
            [ring.middleware.params :refer [wrap-params]]
            [ring.middleware.resource :refer [wrap-resource]]
            [clj-http.client :as client]
            [environ.core :refer [env]]))

(defn get-access-token [code]
  (let [client-id (env :client-id)
        client-secret (env :client-secret)
        redirect-uri (env :redirect-uri)
        url (str "https://api.moves-app.com/oauth/v1/access_token?grant_type=authorization_code&code=" code "&client_id=" client-id "&client_secret=" client-secret)]
    (:body (client/post url {:throw-exceptions false}))))

(defn auth-handler [request]
  (if-let [code (-> request :params :code)]
    {:status 200
     :body (get-access-token code)}
    {:status 500
     :body "error"}))

(defn unmatched-handler [request]
  {:status 404
   :body (str "404 Unknown Route " (:uri request))})

(defn handler [request]
  (case (:uri request)
    "/auth" (auth-handler request)
    (unmatched-handler request)))

(def app (-> handler
             (wrap-resource "web/public")
             wrap-keyword-params
             wrap-params))

(defn -main [& args]
  (jetty/run-jetty app {:port (Integer. (or (env :port) "3333"))}))

(ns moves-server.core
  (:require [ring.adapter.jetty :as jetty]
            [ring.middleware.keyword-params :refer [wrap-keyword-params]]
            [ring.middleware.params :refer [wrap-params]]
            [ring.middleware.resource :refer [wrap-resource]]
            [clj-http.client :as client]
            [environ.core :refer [env]])
  (:gen-class))

(defn get-access-token [code]
  (let [client-id (env :client-id)
        client-secret (env :client-secret)
        redirect-uri (env :redirect-uri)
        url (str "https://api.moves-app.com/oauth/v1/access_token?grant_type=authorization_code&code=" code "&client_id=" client-id "&client_secret=" client-secret)]
    (:body (client/post url {:throw-exceptions false}))))

(defn auth-handler [request]
  (if-let [code (-> request :params :code)]
    {:status 200
     :body (get-access-token code)}
    {:status 500
     :body "error"}))

(defn unmatched-handler [request]
  {:status 404
   :body (str "404 Unknown Route " (:uri request))})

(defn handler [request]
  (case (:uri request)
    "/auth" (auth-handler request)
    (unmatched-handler request)))

(def app (-> handler
             (wrap-resource "web/public")
             wrap-keyword-params
             wrap-params))

(defn -main [& args]
  (jetty/run-jetty app {:port (Integer. (or (env :port) "3333"))}))

Move class location

:point_down: Move class location


(ns ontrail.websocket
  (:require [lamina.core :as lamina]
            [aleph.http :as aleph]
            [clojure.data.json :as json]
            [ontrail.auth :as auth]
            [ontrail.formats :as formats]
            [ontrail.scheduler :as scheduler]
            [clj-time.local :as local]
            )
  (:use [compojure.core]
        [ontrail.scheduler])
  (:import [java.lang IllegalStateException]))

(def #^{:private true} logger (org.slf4j.LoggerFactory/getLogger (str *ns*)))

(def message-buffer-size 100)

;; Ring for in-memory persistence of last messages.
;; conjoining to end, popping from beginning.
(def message-ring (atom (clojure.lang.PersistentQueue/EMPTY)))

;; user -> last ping epoch
(def last-ping (atom {}))

(def active-user-last-ping-millis 8000)

(defn get-active-users []
  (let [now (System/currentTimeMillis)]
    (keys (into {}
                (filter (fn [entry] (< (- now (last entry)) active-user-last-ping-millis))
                        @last-ping)))))

(defn message-init [ch]
  (lamina/receive-all
   ch
   (fn [message]
     (.info logger (str "chat message: " message))
     (swap! message-ring conj message)
     (if (> (count @message-ring) message-buffer-size)
       (swap! message-ring pop)))))

;; All websockets from users are connected to message channel, which distributes
;; messages to user channels.
(def broadcast-channel (lamina/named-channel "messages" message-init))

(defn heartbeat []
  (scheduler/schedule-work
   (fn []
     (lamina/enqueue broadcast-channel
                     (json/write-str {:user "Ontrail"
                                      :action "sanoi"
                                      :message (formats/to-human-comment-date (local/local-now))})))
   3600)) ;; seconds

(defn ex-link [ex]
  (str "ex/"
       (if-let [id (:id ex)]
         id
         (:_id ex))))

(defn server-message [type user value]
  (condp = type
    :comment-ex {:user user
                 :action (str "kommentoi käyttäjän " (:user value) " harjoitusta")
                 :message (:title value)
                 :link (ex-link value)}
    :create-ex {:user user
                :action "kirjasi harjoituksen"
                :message (:title value)
                :link (ex-link value)}))

;; submits server messages to all users
(defn submit [type user value]
  (lamina/enqueue broadcast-channel (json/write-str (server-message type user value))))

(defn process-user-message [user json]
  (.trace logger (str "user sent a message " (class json)))
  (try
    (let [as-json (json/read-str json)]
      (if (= (as-json "action") "server")
        nil
        (json/write-str (merge as-json {:user user}))))
    (catch Exception e
      (.trace logger (str "process user message ") e)
      nil)))

(defn to-server-channel [user json]
  (try
    (let [as-json (json/read-str json)]
      (if (not= (as-json "action") "server")
        nil
        (condp = (as-json "message")
          "ping" (do (.trace logger (str "ping by " user))
                     (swap! last-ping assoc user (System/currentTimeMillis))
                     (json/write-str {:action "server" :message "pong"}))
          "/who" (do
                   (.info logger (str "/who by " user))
                   (json/write-str {:user "Ontrail"
                                    :action "sanoi"
                                    :message (str "Käyttäjät: "
                                                  (apply str (interpose ", " (get-active-users))))}))
          nil)))
    (catch Exception e
      (.trace logger (str "process user message ") e)
      nil)))

(defn message-handler [user ch]
  (let [server-channel (lamina/filter*
                        identity
                        (lamina/map*
                         (partial to-server-channel user)
                         ch))
        user-channel (lamina/filter*
                      identity
                      (lamina/map*
                       (partial process-user-message user)
                       ch))]
    (mapv (partial lamina/enqueue ch) @message-ring)
    (lamina/siphon server-channel ch)
    (lamina/siphon user-channel broadcast-channel)
    (lamina/siphon broadcast-channel ch)))

(defn connect-message [user ch request]
  (if (:websocket request)
    (message-handler user ch)
    (throw (IllegalStateException.
            (str user " is attempting non-websocket operation on websocket route on " request)))))

(defroutes async
  (GET "/rest/v1/async" {cookies :cookies}
       (let [user (auth/user-from-cookie cookies)]
         (if (not= "nobody" user)
           (aleph/wrap-aleph-handler (partial connect-message user))
           {:status 200}))))

(ns ontrail.websocket
  (:require [lamina.core :as lamina]
            [aleph.http :as aleph]
            [clojure.data.json :as json]
            [ontrail.auth :as auth]
            [ontrail.formats :as formats]
            [ontrail.scheduler :as scheduler]
            [clj-time.local :as local]
            )
  (:use [compojure.core]
        [ontrail.scheduler]
        [ontrail.user])
  (:import [java.lang IllegalStateException]))

(def #^{:private true} logger (org.slf4j.LoggerFactory/getLogger (str *ns*)))

(def message-buffer-size 100)

;; Ring for in-memory persistence of last messages.
;; conjoining to end, popping from beginning.
(def message-ring (atom (clojure.lang.PersistentQueue/EMPTY)))

;; user -> last ping epoch
(def last-ping (atom {}))

(def active-user-last-ping-millis 8000)

(defn get-active-users []
  (let [now (System/currentTimeMillis)]
    (keys (into {}
                (filter (fn [entry] (< (- now (last entry)) active-user-last-ping-millis))
                        @last-ping)))))

(defn message-init [ch]
  (lamina/receive-all
   ch
   (fn [message]
     (.info logger (str "chat message: " message))
     (swap! message-ring conj message)
     (if (> (count @message-ring) message-buffer-size)
       (swap! message-ring pop)))))

;; All websockets from users are connected to message channel, which distributes
;; messages to user channels.
(def broadcast-channel (lamina/named-channel "messages" message-init))

(defn heartbeat []
  (scheduler/schedule-work
   (fn []
     (lamina/enqueue broadcast-channel
                     (json/write-str {:user "Ontrail"
                                      :action "sanoi"
                                      :message (formats/to-human-comment-date (local/local-now))})))
   3600)) ;; seconds

(defn ex-link [ex]
  (str "ex/"
       (if-let [id (:id ex)]
         id
         (:_id ex))))

(defn server-message [type user value]
  (condp = type
    :comment-ex {:user user
                 :avatar (get-avatar-url user)
                 :action (str "kommentoi käyttäjän " (:user value) " harjoitusta")
                 :otherUser (:user value)
                 :message (:title value)
                 :link (ex-link value)}
    :create-ex {:user user
                :avatar (get-avatar-url user)
                :action "kirjasi harjoituksen"
                :message (:title value)
                :link (ex-link value)}))

;; submits server messages to all users
(defn submit [type user value]
  (lamina/enqueue broadcast-channel (json/write-str (server-message type user value))))

(defn process-user-message [user json]
  (.trace logger (str "user sent a message " (class json)))
  (try
    (let [as-json (json/read-str json)]
      (if (= (as-json "action") "server")
        nil
        (json/write-str (merge as-json {:user user}))))
    (catch Exception e
      (.trace logger (str "process user message ") e)
      nil)))

(defn to-server-channel [user json]
  (try
    (let [as-json (json/read-str json)]
      (if (not= (as-json "action") "server")
        nil
        (condp = (as-json "message")
          "ping" (do (.trace logger (str "ping by " user))
                     (swap! last-ping assoc user (System/currentTimeMillis))
                     (json/write-str {:action "server" :message "pong"}))
          "/who" (do
                   (.info logger (str "/who by " user))
                   (json/write-str {:user "Ontrail"
                                    :action "sanoi"
                                    :message (str "Käyttäjät: "
                                                  (apply str (interpose ", " (get-active-users))))}))
          nil)))
    (catch Exception e
      (.trace logger (str "process user message ") e)
      nil)))

(defn message-handler [user ch]
  (let [server-channel (lamina/filter*
                        identity
                        (lamina/map*
                         (partial to-server-channel user)
                         ch))
        user-channel (lamina/filter*
                      identity
                      (lamina/map*
                       (partial process-user-message user)
                       ch))]
    (mapv (partial lamina/enqueue ch) @message-ring)
    (lamina/siphon server-channel ch)
    (lamina/siphon user-channel broadcast-channel)
    (lamina/siphon broadcast-channel ch)))

(defn connect-message [user ch request]
  (if (:websocket request)
    (message-handler user ch)
    (throw (IllegalStateException.
            (str user " is attempting non-websocket operation on websocket route on " request)))))

(defroutes async
  (GET "/rest/v1/async" {cookies :cookies}
       (let [user (auth/user-from-cookie cookies)]
         (if (not= "nobody" user)
           (aleph/wrap-aleph-handler (partial connect-message user))
           {:status 200}))))

Add more data to latest request for rendering purposes.