├── resources └── public │ ├── css │ └── style.css │ └── index.html ├── src ├── fhir_face │ ├── config.cljs │ ├── views.cljs │ ├── nav.cljs │ ├── routes.cljs │ ├── style.cljs │ ├── core.cljs │ ├── grid.cljs │ ├── select_xhr.cljs │ ├── widgets.cljs │ ├── form.cljs │ └── model.cljs ├── zframes │ ├── cookies.cljs │ ├── openid.cljs │ ├── window_location.cljs │ ├── redirect.cljs │ └── fetch.cljs └── graph_view │ ├── widgets.cljs │ └── core.cljs ├── .gitignore ├── dev └── user.clj ├── README.md └── project.clj /resources/public/css/style.css: -------------------------------------------------------------------------------- 1 | /* some style */ 2 | 3 | -------------------------------------------------------------------------------- /src/fhir_face/config.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.config) 2 | 3 | (def debug? 4 | ^boolean goog.DEBUG) 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /zzz_resources/public/js/compiled/** 2 | figwheel_server.log 3 | pom.xml 4 | *jar 5 | /lib/ 6 | /classes/ 7 | /out/ 8 | /target/ 9 | .lein-deps-sum 10 | .lein-repl-history 11 | .rebel_readline_history 12 | .lein-plugins/ 13 | .repl 14 | .nrepl-port 15 | -------------------------------------------------------------------------------- /src/zframes/cookies.cljs: -------------------------------------------------------------------------------- 1 | (ns zframes.cookies 2 | (:refer-clojure :exclude [get set!]) 3 | (:require [goog.net.cookies :as gcookies] 4 | [re-frame.core :as rf] 5 | [cljs.reader :as reader])) 6 | 7 | 8 | (defn get-cookie "Returns the cookie after parsing it with cljs.reader/read-string." 9 | [k] (reader/read-string (or (.get goog.net.cookies (name k)) "nil"))) 10 | 11 | (defn set-cookie "Stores the cookie value using pr-str." 12 | [k v] (.set goog.net.cookies (name k) (pr-str v))) 13 | 14 | (defn remove! [k] (.remove goog.net.cookies (name k))) 15 | 16 | (defn watch-expires [k] 17 | ;; todo 18 | ) 19 | 20 | (rf/reg-cofx 21 | ::get 22 | (fn [coeffects key] 23 | (assoc-in coeffects [:cookie key] (get-cookie key)))) 24 | 25 | (rf/reg-fx 26 | ::set 27 | (fn [{k :key v :value :as opts}] 28 | (set-cookie k v))) 29 | 30 | (rf/reg-fx 31 | ::remove 32 | (fn [{k :key}] 33 | (.remove goog.net.cookies (name k)))) 34 | 35 | -------------------------------------------------------------------------------- /src/zframes/openid.cljs: -------------------------------------------------------------------------------- 1 | (ns zframes.openid 2 | (:require 3 | [clojure.spec.alpha :as s] 4 | [re-frame.core :as rf] 5 | [clojure.string :as str] 6 | [goog.crypt.base64 :refer [encodeString decodeString]])) 7 | 8 | (defn ^:export decode 9 | [token] 10 | (let [segments (s/conform (s/cat :header string? :payload string? :signature string?) 11 | (str/split token "."))] 12 | (if-not (map? segments) 13 | (throw (js/Error. "invalid token")) 14 | (let [header (.parse js/JSON (js/atob (:header segments))) 15 | payload (.parse js/JSON (js/atob (:payload segments)))] 16 | payload)))) 17 | 18 | (defn check-token [] 19 | (let [hash (when-let [h (.. js/window -location -hash)] (str/replace h #"^#" ""))] 20 | (when (str/index-of hash "id_token") 21 | (let [token (->> (str/split hash "&") 22 | (filter #(str/starts-with? % "id_token=")) 23 | (map (fn [x] (str/replace x #"^id_token=" ""))) 24 | (first)) 25 | jwt (js->clj (decode token) :keywordize-keys true)] 26 | (set! (.. js/window -location -hash) (or (first (str/split hash "#")) "")) 27 | (assoc jwt :id_token token))))) 28 | 29 | (rf/reg-cofx 30 | ::jwt 31 | (fn [coeffects] 32 | (assoc-in coeffects [:jwt] (check-token)))) 33 | -------------------------------------------------------------------------------- /src/graph_view/widgets.cljs: -------------------------------------------------------------------------------- 1 | (ns graph-view.widgets) 2 | 3 | (defn input-range [{:keys [state path] :as params}] 4 | [:input (merge {:type "range" 5 | :min 1 6 | :max 100 7 | :step 1 8 | :class :input 9 | :value (get-in @state path) 10 | :on-change #(swap! state assoc-in path (js/parseFloat (.. % -target -value)))} 11 | (dissoc params :state :path))]) 12 | 13 | (defn input-checkbox [{:keys [state path] :as params}] 14 | [:input (merge {:type "checkbox" 15 | :class :input 16 | :checked (= "true" (str (get-in @state path))) 17 | :on-change #(swap! state assoc-in path (.. % -target -checked))} 18 | (dissoc params :state :path))]) 19 | 20 | (defn input-integer [{:keys [state path] :as params}] 21 | [:input (merge {:type "number" 22 | :class :input 23 | ;;:step "1" 24 | :value (str (get-in @state path)) 25 | :on-change #(swap! state assoc-in path (js/parseFloat (.. % -target -value)))} 26 | (dissoc params :state :path))]) 27 | 28 | (defn input-textarea [{:keys [state path] :as params}] 29 | [:textarea (merge {:class :input 30 | :value (str (get-in @state path)) 31 | :on-change #(swap! state assoc-in path (.. % -target -value))} 32 | (dissoc params :state :path))]) 33 | -------------------------------------------------------------------------------- /dev/user.clj: -------------------------------------------------------------------------------- 1 | (ns user 2 | (:require 3 | [figwheel-sidecar.repl-api :as f])) 4 | 5 | ;; user is a namespace that the Clojure runtime looks for and 6 | ;; loads if its available 7 | 8 | ;; You can place helper functions in here. This is great for starting 9 | ;; and stopping your webserver and other development services 10 | 11 | ;; The definitions in here will be available if you run "lein repl" or launch a 12 | ;; Clojure repl some other way 13 | 14 | ;; You have to ensure that the libraries you :require are listed in your dependencies 15 | 16 | ;; Once you start down this path 17 | ;; you will probably want to look at 18 | ;; tools.namespace https://github.com/clojure/tools.namespace 19 | ;; and Component https://github.com/stuartsierra/component 20 | 21 | 22 | (defn fig-start 23 | "This starts the figwheel server and watch based auto-compiler." 24 | [] 25 | ;; this call will only work are long as your :cljsbuild and 26 | ;; :figwheel configurations are at the top level of your project.clj 27 | ;; and are not spread across different lein profiles 28 | 29 | ;; otherwise you can pass a configuration into start-figwheel! manually 30 | (f/start-figwheel!)) 31 | 32 | (defn fig-stop 33 | "Stop the figwheel server and watch based auto-compiler." 34 | [] 35 | (f/stop-figwheel!)) 36 | 37 | ;; if you are in an nREPL environment you will need to make sure you 38 | ;; have setup piggieback for this to work 39 | (defn cljs-repl 40 | "Launch a ClojureScript REPL that is connected to your build and host environment." 41 | [] 42 | (f/cljs-repl)) 43 | -------------------------------------------------------------------------------- /src/fhir_face/views.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.views 2 | (:require 3 | [re-frame.core :as re-frame] 4 | [fhir-face.grid :as grid] 5 | [fhir-face.form :as form] 6 | [graph-view.core :as graph-view] 7 | 8 | 9 | )) 10 | 11 | #_(defn home-panel [] 12 | (let [;;name (re-frame/subscribe [:subs/name]) 13 | _ 33] 14 | [:div 15 | [:h1 (str "Hello from fhir-face. This is the Home Page.")] 16 | ;;[:button {:on-click (fn [] (re-frame/dispatch [::model/check-base-url]))} "Check"] 17 | ;;[:button {:on-click (fn [] (re-frame/dispatch [::cookies/set {:key "test" :value "test"}]))} "Set cookie"] 18 | ;;[:button {:on-click (fn [] (re-frame/dispatch [:set-cookie {:key "test" :value "test"}]))} "Set cookie"] 19 | ;;[:button {:on-click (fn [] (re-frame/dispatch [:remove-cookie "test"]))} "Remove cookie"] 20 | [:div [:a {:href "#/resource"} "go to Resource Page"]] 21 | [:br] 22 | [:div [:a {:href "#/about"} "go to About Page"]]])) 23 | 24 | #_(defn about-panel [] 25 | [:div 26 | [:h1 "This is the About Page."] 27 | [:div 28 | [:a {:href "#/"} "go to Home Page"]]]) 29 | 30 | 31 | (def routes 32 | (merge 33 | grid/routes 34 | form/routes 35 | graph-view/routes 36 | )) 37 | 38 | (re-frame/reg-sub 39 | ::active-panel 40 | (fn [db _] (:active-panel db))) 41 | 42 | (defn main-panel [] 43 | (let [params @(re-frame/subscribe [::active-panel])] 44 | (if-let [route-fn (routes (:page params))] 45 | [route-fn params] 46 | [:div {:style {:font-size "30px"}} (str "No matched route " params)]))) 47 | 48 | -------------------------------------------------------------------------------- /src/fhir_face/nav.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.nav 2 | (:require [reagent.core :as r] 3 | ;;[re-frame.core :as rf] 4 | ;;[clojure.string :as str] 5 | [fhir-face.style :as style] 6 | [zframes.redirect :refer [href redirect]] 7 | ;;[graph-view.widgets :as ws] 8 | ;;[fhir-face.model :as model] 9 | )) 10 | 11 | (def style 12 | [:.nav-bar {:width "65px" 13 | ;;:justify-content :space-between 14 | :align-items :center 15 | :padding "20px 0" 16 | :flex-direction :column 17 | :position :fixed 18 | :min-height "100vh" 19 | :background-color "#f4f5f7" 20 | :display :flex} 21 | [:.nav-item {;;:display :block 22 | :margin-bottom "15px" 23 | ;;:color "#333" 24 | } 25 | [:i {:width "40px" 26 | :height "40px" 27 | :margin "0 auto" 28 | :border :none 29 | :text-align :center 30 | :box-shadow "0px 0px 2px #aaa" 31 | :font-size "25px" 32 | :border-radius "50%" 33 | :display :table-cell 34 | :vertical-align :middle 35 | :cursor :pointer}]] 36 | 37 | ]) 38 | 39 | (defn nav-bar [] 40 | [:div.nav-bar 41 | [style/style style] 42 | ;;"menu" 43 | ;;"list" 44 | [:div.nav-item [:i.material-icons 45 | {:on-click #(redirect (href "resource"))} 46 | "reorder"]] 47 | [:div.nav-item [:i.material-icons 48 | {:on-click #(redirect (href "graph-view"))} 49 | "timeline"]] 50 | ]) -------------------------------------------------------------------------------- /src/zframes/window_location.cljs: -------------------------------------------------------------------------------- 1 | (ns zframes.window-location 2 | (:refer-clojure :exclude [get set!]) 3 | (:require [re-frame.core :as rf] 4 | [clojure.string :as str])) 5 | 6 | (defn url-decode [x] (js/decodeURIComponent x)) 7 | 8 | (defn url-encode [x] (js/encodeURIComponent x)) 9 | 10 | (defn parse-querystring [s] 11 | (-> (str/replace s #"^\?" "") 12 | (str/split #"&") 13 | (->> 14 | (reduce (fn [acc kv] 15 | (let [[k v] (str/split kv #"=" 2)] 16 | (assoc acc (keyword k) 17 | (cond 18 | (str/ends-with? k "*") (into #{} (str/split v #",")) 19 | :else (url-decode v))))) 20 | {})))) 21 | 22 | (defn gen-query-string [params] 23 | (->> params 24 | (map (fn [[k v]] 25 | (cond 26 | (set? v) (str (name k) "=" (str/join "," v)) 27 | :else (str (name k) "=" (url-encode v))))) 28 | (str/join "&") 29 | (str "?"))) 30 | 31 | (defn get-location [] 32 | (let [loc (.. js/window -location) 33 | href (.. loc -href) 34 | search (.. loc -search)] 35 | {:href href 36 | :query-string (parse-querystring search) 37 | :url (first (str/split href #"#")) 38 | :hash (str/replace (or (.. loc -hash) "") #"^#" "") 39 | :host (.. loc -host) 40 | :origin (.. loc -origin) 41 | :protocol (.. loc -protocol) 42 | :hostname (.. loc -hostname) 43 | :search search})) 44 | 45 | #_(defn window-location [coef & opts] 46 | (assoc coef :location (get-location))) 47 | 48 | #_(rf/reg-cofx :window-location window-location) 49 | 50 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # fhir-face 2 | 3 | Universal frontend view to any sansara/hapi/... fhir server 4 | 5 | ## [Play with online demo!](https://codepen.io/Ivana-/project/full/DQNzwY/) 6 | 7 | ## Overview 8 | 9 | This application allows simple full-text search, CRUD and possible pretty view 10 | for any fhir resource, containing in choosen supported fhir server. 11 | 12 | ![alt text](https://user-images.githubusercontent.com/10473034/45783479-9199cb80-bc6e-11e8-959b-90f46b4c5a45.png "Reference graph view") 13 | 14 | ![alt text](https://user-images.githubusercontent.com/10473034/45785396-d0328480-bc74-11e8-8eaa-4fdfb54902b8.png "Resource grid view") 15 | 16 | ![alt text](https://user-images.githubusercontent.com/10473034/45785400-d4f73880-bc74-11e8-974b-e6616280ae87.png "Resource edit view") 17 | 18 | ![alt text](https://user-images.githubusercontent.com/10473034/45785406-dcb6dd00-bc74-11e8-9d57-35ab7462c8da.png "Resource edit view") 19 | 20 | 21 | ## Setup 22 | 23 | To get an interactive development environment run: 24 | 25 | lein figwheel 26 | 27 | and open your browser at `http://localhost:3449/?base-url=#/resource` 28 | 29 | This will auto compile and send all changes to the browser without the 30 | need to reload. After the compilation process is complete, you will 31 | get a Browser Connected REPL. An easy way to try it is: 32 | 33 | (js/alert "Am I connected?") 34 | 35 | and you should see an alert in the browser window. 36 | 37 | To clean all compiled files: 38 | 39 | lein clean 40 | 41 | To create a production build run: 42 | 43 | lein do clean, cljsbuild once min 44 | 45 | And open your browser in `resources/public/index.html`. You will not 46 | get live reloading, nor a REPL. 47 | 48 | ## License 49 | 50 | Copyright © 2018 51 | 52 | Distributed under the Eclipse Public License either version 1.0 or (at your option) any later version. 53 | -------------------------------------------------------------------------------- /src/fhir_face/routes.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.routes 2 | (:require-macros [secretary.core :refer [defroute]]) 3 | (:import goog.History) 4 | (:require 5 | [secretary.core :as secretary] 6 | [goog.events :as gevents] 7 | [goog.history.EventType :as EventType] 8 | [re-frame.core :as re-frame] 9 | [fhir-face.model :as model])) 10 | 11 | (re-frame/reg-event-db 12 | ::set-active-panel 13 | (fn [db [_ active-panel]] 14 | (-> db 15 | (assoc :active-panel active-panel) 16 | (assoc-in (conj model/root-path :data :is-fetching) true)))) 17 | 18 | (defn hook-browser-navigation! [] 19 | (doto (History.) 20 | (gevents/listen 21 | EventType/NAVIGATE 22 | (fn [event] 23 | (secretary/dispatch! (.-token event)))) 24 | (.setEnabled true))) 25 | 26 | (defn app-routes [] 27 | (secretary/set-config! :prefix "#") 28 | ;; -------------------- 29 | ;; define routes here 30 | ;; https://github.com/gf3/secretary 31 | #_(defroute "/" [] 32 | (re-frame/dispatch [::set-active-panel :home-panel])) 33 | 34 | #_(defroute "/about" [] 35 | (re-frame/dispatch [::set-active-panel (merge params {:page :about-panel})])) 36 | 37 | (defroute "/resource" {:as params} 38 | (re-frame/dispatch [::set-active-panel (merge params {:page :resource-grid})])) 39 | 40 | (defroute "/resource/new" {:as params} 41 | (re-frame/dispatch [::set-active-panel (merge params {:page :resource-new})])) 42 | 43 | (defroute "/resource/edit" {:as params} 44 | (re-frame/dispatch [::set-active-panel (merge params {:page :resource-edit})])) 45 | 46 | #_(defroute "/auth#:auth" {:as params} 47 | (re-frame/dispatch [:events/auth (:auth params)])) 48 | 49 | 50 | (defroute "/graph-view" [:as params] 51 | (re-frame/dispatch [::set-active-panel (merge params {:page :graph-view})])) 52 | 53 | 54 | 55 | ;; must be at the end, cause routes matches by order 56 | (defroute "*" [] 57 | (re-frame/dispatch [::set-active-panel {:page :resource-grid ;;:blank 58 | }])) 59 | 60 | ;; -------------------- 61 | (hook-browser-navigation!)) 62 | 63 | -------------------------------------------------------------------------------- /src/fhir_face/style.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.style 2 | (:require 3 | [garden.core :as garden])) 4 | 5 | (defn style [css] [:style (garden/css css)]) 6 | 7 | (defn with-common-style [css] 8 | (let [content-style (into [:.content 9 | {;;:width "1000px" 10 | ;;:margin "0 auto" 11 | ;;-------------------------------------- 12 | ;;:margin "0 200px" 13 | ;;:padding-bottom "500px" 14 | :margin "0 15% 25% 15%" 15 | :width :auto 16 | :font-family :fantasy} 17 | 18 | [:.bar {:display :flex 19 | :justify-content :space-between 20 | :align-items :center 21 | :padding-bottom "10px" 22 | :border-bottom "1px solid" 23 | :border-color :gray 24 | :margin-bottom "20px"}] 25 | 26 | #_[:.input {:outline :none 27 | :font-size "16px" 28 | :font-weight :bold}] 29 | 30 | [:.search {:margin-left "10px" 31 | :width "400px"}] 32 | [:.action {:font-size "20px" 33 | :font-weight :bold 34 | :cursor :pointer 35 | :margin-left "10px"}] 36 | [:.label {:font-size "20px" 37 | :font-weight :bold 38 | :margin-left "10px"}] 39 | 40 | [:.btn {:font-size "20px"}] 41 | [:.footer-actions {:margin-top "20px" 42 | :padding-top "20px" 43 | :border-top "1px solid" 44 | :border-color :gray}] 45 | ] css)] 46 | (style [:.page content-style]))) 47 | 48 | (def borders 49 | {:thin-gray {:border "1px solid" 50 | :border-color "#ddd"}}) 51 | -------------------------------------------------------------------------------- /resources/public/index.html: -------------------------------------------------------------------------------- 1 | 2 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 66 | 67 | 68 |
69 |
Loading
70 |
71 | 72 | 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /src/zframes/redirect.cljs: -------------------------------------------------------------------------------- 1 | (ns zframes.redirect 2 | (:require [re-frame.core :as rf] 3 | [zframes.window-location :as window-location] 4 | [clojure.string :as str])) 5 | 6 | (defn page-redirect [url] 7 | (set! (.-href (.-location js/window)) url)) 8 | 9 | (defn redirect [url] 10 | (set! (.-hash (.-location js/window)) url)) 11 | 12 | #_(defn redirect [url] 13 | (aset (.-location js/window) "hash" url)) 14 | 15 | #_(rf/reg-fx 16 | ::redirect 17 | (fn [opts] 18 | (redirect (str (:uri opts) 19 | (when-let [params (:params opts)] 20 | (window-location/gen-query-string params)))))) 21 | #_(rf/reg-event-fx 22 | ::redirect 23 | (fn [fx [_ opts]] 24 | {::redirect opts})) 25 | 26 | (rf/reg-fx 27 | ::page-redirect 28 | (fn [opts] 29 | (page-redirect (str (:uri opts) 30 | (when-let [params (:params opts)] 31 | (->> params 32 | (map (fn [[k v]] (str (name k) "=" (js/encodeURIComponent v)))) 33 | (str/join "&") 34 | (str "?"))))))) 35 | 36 | #_(rf/reg-fx 37 | ::set-query-string 38 | (fn [params] 39 | (let [loc (.. js/window -location)] 40 | (.pushState 41 | js/history 42 | #js{} (:title params) 43 | (str (window-location/gen-query-string (dissoc params :title)) (.-hash loc))) 44 | (zframes.routing/dispatch-context nil)))) 45 | 46 | #_(rf/reg-event-fx 47 | ::merge-params 48 | (fn [{db :db} [_ params]] 49 | (let [pth (get db :fragment-path) 50 | nil-keys (reduce (fn [acc [k v]] 51 | (if (nil? v) (conj acc k) acc)) [] params) 52 | old-params (or (get-in db [:fragment-params :params]) {})] 53 | {::redirect {:uri pth 54 | :params (apply dissoc (merge old-params params) 55 | nil-keys)}}))) 56 | 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | 59 | #_(defn to-query-params [params] 60 | (->> params 61 | (map (fn [[k v]] (str (name k) "=" v))) 62 | (str/join "&"))) 63 | 64 | (defn href [& parts] 65 | (let [params (if (map? (last parts)) (last parts) nil) 66 | parts (if params (butlast parts) parts) 67 | url (str "/" (str/join "/" (map (fn [x] (if (keyword? x) (name x) (str x))) parts)))] 68 | #_(when-not (route-map/match [:. url] routes) 69 | (println (str url " is not matches routes"))) 70 | (str "#" url (if-not (empty? params) (window-location/gen-query-string params))))) 71 | 72 | 73 | #_(defn parse-query-string [s] 74 | (let [[uri ps] (str/split s #"\?")] 75 | (cond-> {} ;;{:uri uri} 76 | ps (merge (reduce (fn [a x] 77 | (let [[k v] (str/split x #"\=")] 78 | (assoc a (keyword k) v))) {} (str/split ps #"\&")))))) 79 | 80 | #_(defn route-params [] (parse-query-string (-> js/window .-location .-href))) 81 | -------------------------------------------------------------------------------- /src/fhir_face/core.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.core 2 | (:require [reagent.core :as reagent :refer [atom]] 3 | [re-frame.core :as rf] 4 | [fhir-face.routes :as routes] 5 | [fhir-face.views :as views] 6 | [fhir-face.config :as config] 7 | [clojure.string :as str] 8 | [zframes.cookies :as cookies] 9 | [zframes.openid :as openid] 10 | [zframes.window-location :as window-location] 11 | [zframes.fetch] 12 | [zframes.redirect :as redirect] 13 | [re-frisk.core :refer [enable-re-frisk!]] 14 | 15 | ;;[fhir-face.test-svg :as test-svg] 16 | 17 | )) 18 | 19 | #_(defn on-js-reload [] 20 | ;; optionally touch your app-state to force rerendering depending on 21 | ;; your application 22 | (swap! app-state update-in [:__figwheel_counter] inc)) 23 | 24 | (rf/reg-event-db 25 | ::initialize-db 26 | (fn [_ _] {})) 27 | 28 | #_(rf/reg-event-fx 29 | ::auth 30 | (fn [{db :db} [_ params]] 31 | (let [auth (->> (str/split params #"&") 32 | (map #(str/split % #"=")) 33 | (reduce (fn [a [k v]] (assoc a (keyword k) v)) {}))] 34 | {:db (assoc db :auth auth) 35 | :cookies/set {:key :test :value params}}))) 36 | 37 | (rf/reg-event-fx 38 | ::initialize 39 | [(rf/inject-cofx ::openid/jwt :auth)] 40 | (fn [{db :db jwt :jwt :as cofx} _] 41 | ;;(prn "========================================= ::initialize") 42 | ;;(prn cofx) 43 | ;;(prn (cookies/get-cookie :auth)) 44 | (let [default-base-url "https://hapi.fhir.org/baseDstu3" 45 | 46 | 47 | 48 | {qs :query-string host :hostname hash :hash url :url :as loc} (window-location/get-location) 49 | base-url (or (:base-url qs) default-base-url) ;; "https://cleo-sansara.health-samurai.io" 50 | openid-url (or (:openid-url qs) (str base-url "/oauth2/authorize")) 51 | cookie-auth-key (str "auth_" base-url) 52 | auth (cookies/get-cookie cookie-auth-key)] 53 | 54 | ;; FIXME !!! 55 | 56 | (if false ;; 57 | ;;(and (nil? jwt) (nil? auth)) 58 | {::redirect/page-redirect 59 | {:uri openid-url 60 | :params {:redirect_uri (let [url-items (str/split (.. js/window -location -href) #"#")] 61 | (str (first url-items) "#" (second url-items))) 62 | :client_id (or (:client_id qs) "local") 63 | :scope "openid profile email" 64 | :nonce "ups" 65 | :response_type "id_token"}}} 66 | {;;:dispatch-n [[:route-map/init routes/routes workflow/context-routes]] 67 | ::cookies/set {:key cookie-auth-key :value (or jwt auth)} 68 | :db (merge db {:auth (or jwt auth) 69 | :config {:base-url base-url 70 | :openid-url openid-url 71 | 72 | ;; FIXME 73 | :settings (cond 74 | (re-find #"//hapi\.fhir\.org" base-url) {:fhir-server-type :hapi}) 75 | 76 | 77 | }})})))) 78 | 79 | (defn dev-setup [] 80 | (when config/debug? 81 | (enable-re-frisk!) 82 | (enable-console-print!) 83 | (println "dev mode"))) 84 | 85 | (defn mount-root [] 86 | (rf/clear-subscription-cache!) 87 | (reagent/render [views/main-panel] (.getElementById js/document "app"))) 88 | 89 | (defn ^:export init [] 90 | (routes/app-routes) 91 | (rf/dispatch-sync [::initialize-db]) 92 | (dev-setup) 93 | (rf/dispatch [::initialize]) 94 | (mount-root)) 95 | 96 | -------------------------------------------------------------------------------- /src/fhir_face/grid.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.grid 2 | (:require [re-frame.core :as rf] 3 | [clojure.string :as str] 4 | [fhir-face.style :as style] 5 | [fhir-face.nav :as nav] 6 | [fhir-face.model :as model] 7 | [zframes.redirect :refer [href redirect]] 8 | [fhir-face.widgets :as ws])) 9 | 10 | (def style 11 | [[:.input (merge (:thin-gray style/borders) 12 | {:outline :none 13 | :font-size "16px" 14 | :font-weight :bold})] 15 | 16 | 17 | [:table {:width "100%" 18 | :border-collapse :collapse}] 19 | [:th {:color "#ddd"}] 20 | [:td {:font-family :system-ui 21 | :font-size "20px" 22 | :height "50px" 23 | :cursor :pointer 24 | :border-bottom "1px solid #ddd"}] 25 | ;;[:td:hover {:background-color "#f5f5f5"}] 26 | [:.item:hover {:background-color "#f5f5f5"}] 27 | 28 | ;;[:.id :.display {:text-align :left}] 29 | [:.display {:padding-left "20px"}] 30 | [:.size {:padding-left "20px" 31 | :text-align :right}] 32 | 33 | ]) 34 | 35 | 36 | (defn search-box [params] 37 | (let [on-key-down (fn [ev] 38 | (when (= 13 (.-which ev)) 39 | (let [v (.. ev -target -value)] 40 | (redirect (href "resource" 41 | (if (str/blank? v) 42 | (dissoc params :_text) 43 | (merge params {:_text v})))))))] 44 | [:div.search {:style {:display :flex}} 45 | [:i.material-icons :search] 46 | [:input (cond-> {:class :input 47 | :style {:width "100%"} 48 | ;;:type :search 49 | :on-key-down on-key-down 50 | ;;:auto-focus true 51 | :default-value (:_text params) 52 | :placeholder "Search on enter...."} 53 | ;; ;;;; (str/blank? (:_text params)) (assoc :value "") 54 | )]])) 55 | 56 | 57 | (defn resource-grid [params] 58 | ;; (prn "resource-grid" params) 59 | (let [data @(rf/subscribe [::model/data]) 60 | entity (mapv :id (:entity data)) 61 | items (:resource-grid data) 62 | {:keys [type]} params] 63 | [:div.page 64 | [style/with-common-style style] 65 | [nav/nav-bar] 66 | [:div.content 67 | [:span 68 | {:style {:display :flex 69 | :align-items :baseline}} 70 | [:h1.h (if type (str type " grid") "Select resource type")]] 71 | 72 | [:div.bar 73 | [:span {:style {:display :flex}} 74 | (into [:select {:class :input 75 | :value (str type) 76 | :on-change #(let [v (.. % -target -value)] 77 | (redirect (href "resource" 78 | (if (str/blank? v) 79 | {} ;;(dissoc params :type) 80 | (merge params {:type v})))))} 81 | [:option ""]] 82 | (mapv (fn [x] [:option x]) entity)) 83 | (if type [search-box params])] 84 | (if type [:span.action {:on-click #(redirect (href "resource" "new" {:type type}))} (str "New " type)])] 85 | 86 | (cond 87 | (:is-fetching data) [:div.loader "Loading"] 88 | 89 | (:error data) [:div (str (:error data))] 90 | 91 | (and type (= type (get-in data [:query-params :type]))) 92 | (if (empty? items) 93 | [:div "Nothing to show"] 94 | [:table 95 | (into 96 | [:tbody 97 | [:tr [:th.id "Id"] 98 | [:th.display "Display"] 99 | [:th.size "Size"]]] 100 | (for [i items] 101 | [:tr.item {:key (:id i) 102 | :on-click #(redirect (href "resource" "edit" {:type type :id (:id i)}))} 103 | [:td.id (:id i)] 104 | [:td.display (ws/resource-display i)] 105 | [:td.size (.-length (str i))] 106 | ]))]) 107 | )]])) 108 | 109 | (def routes {:resource-grid (fn [params] 110 | ;; (prn "grid-panel --------------------------------------" params) 111 | (rf/dispatch [::model/load-all params]) 112 | [resource-grid (:query-params params)])}) 113 | 114 | -------------------------------------------------------------------------------- /src/zframes/fetch.cljs: -------------------------------------------------------------------------------- 1 | (ns zframes.fetch 2 | (:require [re-frame.core :as rf] 3 | [clojure.string :as str])) 4 | 5 | (defn to-query [params] 6 | (->> params 7 | (mapv (fn [[k v]] (str (name k) "=" v))) 8 | (str/join "&"))) 9 | 10 | #_(rf/reg-sub 11 | :xhr/url 12 | (fn [db [_ url]] 13 | (str (get-in db [:config :base-url]) url))) 14 | 15 | #_(comment 16 | (defn json-fetch [{:keys [uri token headers params success error] :as opts}] 17 | (let [headers (merge (or headers {}) 18 | {"Accept" "application/json" 19 | "content-type" "application/json" 20 | "Authorization" (str "Bearer " token)}) 21 | fetch-opts (-> (merge {:method "get" :mode "cors"} opts) 22 | (dissoc :uri :headers :success :error :params) 23 | (assoc :headers headers)) 24 | fetch-opts (if (:body opts) 25 | (assoc fetch-opts :body (.stringify js/JSON (clj->js (:body opts)))) 26 | fetch-opts) 27 | url uri] 28 | (-> 29 | (js/fetch (str url (when params (str "?" (to-query params)))) 30 | (clj->js fetch-opts)) 31 | (.then 32 | (fn [resp] 33 | (.then (.json resp) 34 | (fn [doc] 35 | (let [data (js->clj doc :keywordize-keys true) 36 | event-params {:request opts 37 | :response resp 38 | :data data}] 39 | (if (< (.-status resp) 299) 40 | ;; if success/error are maps - calling dispatch events, else calling as functions 41 | (cond 42 | (map? success) (rf/dispatch [(:event success) (merge success event-params)]) 43 | success (success data)) 44 | (cond 45 | (map? error) (rf/dispatch [(:event error) (merge error event-params)]) 46 | error (error data))))))))))) 47 | 48 | (defn json-fetch* [x] 49 | (cond (map? x) (json-fetch x) 50 | (vector? x) (doseq [i x] (json-fetch i)))) 51 | 52 | (rf/reg-fx :json/fetch json-fetch*) 53 | ) 54 | 55 | 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | ;; Via promices 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | 60 | 61 | (defn fetch-promise [{:keys [uri token headers params] :as opts}] 62 | (let [headers (merge (or headers {}) 63 | {"Accept" "application/json" 64 | "content-type" "application/json" 65 | 66 | ;; FIXME return on sansara servers 67 | ;;"Authorization" (str "Bearer " token) 68 | 69 | }) 70 | fetch-opts (-> (merge {:method "get" :mode "cors"} opts) 71 | (dissoc :uri :headers :params) 72 | (assoc :headers headers)) 73 | fetch-opts (if (:body opts) 74 | (assoc fetch-opts :body (.stringify js/JSON (clj->js (:body opts)))) 75 | fetch-opts) 76 | url uri] 77 | (-> 78 | (js/fetch (str url (when params (str "?" (to-query params)))) 79 | (clj->js fetch-opts)) 80 | #_(.then 81 | (fn [resp] 82 | (.then (.json resp) 83 | (fn [doc] 84 | (let [data (js->clj doc :keywordize-keys true) 85 | res {:request opts 86 | :response resp 87 | :data data}] 88 | (if (> (.-status resp) 299) 89 | (let [e (js/Error. (str "Failed to fetch " uri))] 90 | (aset e "params" res) 91 | (throw e)) 92 | (js/Promise.resolve res))))) 93 | )) 94 | 95 | (.then (fn [resp] (js/Promise.all [resp (.json resp)]))) 96 | 97 | (.then (fn [[resp doc]] (let [data (js->clj doc :keywordize-keys true) 98 | res {:request opts 99 | :response resp 100 | :data data}] 101 | (if (> (.-status resp) 299) 102 | (let [e (js/Error. (str "Failed to fetch " uri))] 103 | ;;(aset e "params" res) 104 | 105 | 106 | 107 | (set! (.-params e) res) 108 | (throw e)) 109 | (js/Promise.resolve res))))) 110 | 111 | ;; (.catch (fn [e] (throw (js/Error. (str "failed to fetch " uri))))) 112 | ))) 113 | 114 | (defn error-data [e] (.-params e)) 115 | (defn error-message [e] (.-message e)) 116 | 117 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject fhir-face "0.1.0-SNAPSHOT" 2 | :description "FIXME: write this!" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | 7 | :min-lein-version "2.7.1" 8 | 9 | :dependencies [[org.clojure/clojure "1.9.0"] 10 | [org.clojure/clojurescript "1.10.238"] 11 | [org.clojure/core.async "0.4.474"] 12 | [reagent "0.7.0"] 13 | [re-frame "0.10.5" :exclusions [cljsjs/react]] 14 | [secretary "1.2.3"] 15 | [re-frisk "0.5.4" :exclusions [cljsjs/react]] 16 | [cljs-http "0.1.45"] 17 | [garden "1.3.5"] 18 | ] 19 | 20 | :plugins [[lein-figwheel "0.5.16"] 21 | [lein-cljsbuild "1.1.7" :exclusions [[org.clojure/clojure]]]] 22 | 23 | :source-paths ["src"] 24 | 25 | :cljsbuild {:builds 26 | [{:id "dev" 27 | :source-paths ["src"] 28 | 29 | ;; The presence of a :figwheel configuration here 30 | ;; will cause figwheel to inject the figwheel client 31 | ;; into your build 32 | :figwheel {:on-jsload "fhir-face.core/on-js-reload" 33 | ;; :open-urls will pop open your application 34 | ;; in the default browser once Figwheel has 35 | ;; started and compiled your application. 36 | ;; Comment this out once it no longer serves you. 37 | :open-urls [;;"http://localhost:3449/?base-url=http://localhost:8080&client_id=local#/resource" 38 | ;;"http://localhost:3449/?base-url=http://localhost:8080&client_id=local#/graph-view" 39 | 40 | ;;"http://localhost:3449/?base-url=http://hapi.fhir.org/baseDstu3#/graph-view" 41 | 42 | 43 | "http://localhost:3449/?base-url=http://hapi.fhir.org/baseDstu3#/resource" 44 | 45 | ]} 46 | 47 | :compiler {:main fhir-face.core 48 | :asset-path "js/compiled/out" 49 | :output-to "resources/public/js/compiled/fhir_face.js" 50 | :output-dir "resources/public/js/compiled/out" 51 | :source-map-timestamp true 52 | ;; To console.log CLJS data-structures make sure you enable devtools in Chrome 53 | ;; https://github.com/binaryage/cljs-devtools 54 | :preloads [devtools.preload]}} 55 | ;; This next build is a compressed minified build for 56 | ;; production. You can build this with: 57 | ;; lein cljsbuild once min 58 | {:id "min" 59 | :source-paths ["src"] 60 | :compiler {:output-to "resources/public/js/compiled/fhir_face.js" 61 | :main fhir-face.core 62 | :optimizations :advanced 63 | :pretty-print false}}]} 64 | 65 | :figwheel { 66 | ;; :nrepl-middleware ["cemerick.piggieback/wrap-cljs-repl" 67 | ;; "cider.nrepl/cider-middleware"] 68 | 69 | :http-server-root "public" ;; default and assumes "resources" 70 | :server-port 3449 ;; default 71 | ;; :server-ip "127.0.0.1" 72 | 73 | :css-dirs ["resources/public/css"] ;; watch and update CSS 74 | 75 | ;; Start an nREPL server into the running figwheel process 76 | :nrepl-port 7003 ;; 7888 77 | 78 | ;; Server Ring Handler (optional) 79 | ;; if you want to embed a ring handler into the figwheel http-kit 80 | ;; server, this is for simple ring servers, if this 81 | 82 | ;; doesn't work for you just run your own server :) (see lein-ring) 83 | 84 | ;; :ring-handler hello_world.server/handler 85 | 86 | ;; To be able to open files in your editor from the heads up display 87 | ;; you will need to put a script on your path. 88 | ;; that script will have to take a file path and a line number 89 | ;; ie. in ~/bin/myfile-opener 90 | ;; #! /bin/sh 91 | ;; emacsclient -n +$2 $1 92 | ;; 93 | ;; :open-file-command "myfile-opener" 94 | 95 | ;; if you are using emacsclient you can just use 96 | ;; :open-file-command "emacsclient" 97 | 98 | ;; if you want to disable the REPL 99 | ;; :repl false 100 | 101 | ;; to configure a different figwheel logfile path 102 | ;; :server-logfile "tmp/logs/figwheel-logfile.log" 103 | 104 | ;; to pipe all the output to the repl 105 | ;; :server-logfile false 106 | } 107 | 108 | 109 | ;; Setting up nREPL for Figwheel and ClojureScript dev 110 | ;; Please see: 111 | ;; https://github.com/bhauman/lein-figwheel/wiki/Using-the-Figwheel-REPL-within-NRepl 112 | :profiles {:dev {:dependencies [[binaryage/devtools "0.9.9"] 113 | [figwheel-sidecar "0.5.16"] 114 | [cider/piggieback "0.3.1"]] 115 | ;; need to add dev source path here to get user.clj loaded 116 | :source-paths ["src" "dev"] 117 | ;; for CIDER 118 | ;; :plugins [[cider/cider-nrepl "0.12.0"]] 119 | :repl-options {:nrepl-middleware [cider.piggieback/wrap-cljs-repl]} 120 | ;; need to add the compliled assets to the :clean-targets 121 | :clean-targets ^{:protect false} ["resources/public/js/compiled" 122 | :target-path]}}) 123 | -------------------------------------------------------------------------------- /src/fhir_face/select_xhr.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.select-xhr 2 | (:require [reagent.core :as r] 3 | [re-frame.core :as rf] 4 | [garden.units :as u] 5 | [garden.core :as garden] 6 | [clojure.string :as str] 7 | [zframes.fetch :as fetch])) 8 | 9 | (def style 10 | [:.select-xhr {:display :inline-flex 11 | :align-items :baseline 12 | :font-family :system-ui} 13 | 14 | [:.value-xhr {:display :inline-block 15 | :position :relative 16 | :min-width "200px" 17 | :font-size "16px" 18 | :font-weight :bold 19 | :margin-left "20px"} 20 | 21 | [:.choosen {:display :flex 22 | :align-items :center 23 | :cursor :pointer 24 | :border "1px solid" 25 | :border-color "#ddd" 26 | :padding "2px 0"} 27 | [:.triangle {:margin "0px 10px"}] 28 | [:.value {:flex-grow "1"}] 29 | [:.icon {:padding "0px 5px 0 10px"}]] 30 | 31 | [:.drop-menu {:z-index 1 32 | :position :absolute 33 | :min-width "100%" 34 | :width :max-content 35 | :background-color "#ffffff"} 36 | [:.query-loader {:display :flex 37 | :align-items :center 38 | :width :-webkit-fill-available 39 | :border "1px solid" 40 | :border-color "#ddd"} 41 | [:.query {:flex-grow 1 42 | :padding "2px 2px 2px 16px" 43 | ;;:width "100%" 44 | :outline :inherit ;;none 45 | :font-size :inherit 46 | :font-weight :inherit 47 | :border :none}] 48 | [:.loader {;;:display :inline-block 49 | :margin "0px 5px 0px 5px" 50 | :font-size "4px" 51 | :width "1.5em" 52 | :height "1.5em"}]] 53 | 54 | [:.suggestions {:overflow-y :auto 55 | :border "1px solid" 56 | :border-color "#ddd" 57 | :display :flex 58 | :flex-direction :column 59 | :max-height "300px"} 60 | [:.info {:text-align :center 61 | :padding "10px" 62 | :color :gray}] 63 | [:.suggestion {:cursor :pointer 64 | :padding "0 16px" 65 | :line-height "32px"} 66 | [:&:hover {:background-color "#f1f1f1"}]]] 67 | 68 | ]]]) 69 | 70 | 71 | (rf/reg-sub 72 | ::common-fetch-params 73 | (fn [db] {:base-url (get-in db [:config :base-url]) 74 | :id_token (get-in db [:auth :id_token]) 75 | ;; FIXME hack to get all possible resourceType 76 | :all-resourceTypes (mapv :id (get-in db [:main :data :entity]))})) 77 | 78 | ;; in our case inner search would be faster than outer 79 | (defn is-child? [par child] 80 | (if (.isEqualNode par child) 81 | true 82 | (some identity 83 | (map #(is-child? % child) 84 | (array-seq (.-childNodes par)))))) 85 | 86 | (defn select-xhr [{:keys [value resourceType value-type] :as opts}] 87 | (let [common-fetch-params (rf/subscribe [::common-fetch-params]) 88 | 89 | ;; FIXME show all types if incoming list is empty 90 | resourceType (let [rt (into [""] (if (empty? resourceType) (:all-resourceTypes @common-fetch-params) resourceType))] 91 | (if ;;(and (not (str/blank? value-type)) 92 | (not (contains? (set rt) value-type)) ;;) 93 | (conj rt value-type) 94 | rt)) 95 | state (r/atom {:resourceType value-type ;;(if (= 1 (count resourceType)) (first resourceType)) 96 | :suggestions []}) 97 | close #(swap! state assoc 98 | :active false 99 | :suggestions []) 100 | doc-click-listener (fn [e] 101 | (let [outer-click? (not (is-child? (:root-node @state) (.-target e)))] 102 | (when (and outer-click? (:active @state)) 103 | (when-let [f (:on-blur opts)] (f e)) 104 | (swap! state assoc :active false))))] 105 | (r/create-class 106 | {:component-did-mount 107 | (fn [this] 108 | (let [root (r/dom-node this)] 109 | (swap! state assoc :root-node root)) 110 | (.addEventListener js/document "click" doc-click-listener)) 111 | 112 | :component-will-unmount 113 | (fn [this] 114 | (.removeEventListener js/document "click" doc-click-listener)) 115 | 116 | :reagent-render 117 | (fn [{:keys [value on-change label-fn value-fn placeholder] :as props}] 118 | (let [label-fn (or label-fn pr-str) 119 | value-fn (or value-fn identity) 120 | fetch-load #_(fn [text] 121 | ;;(prn @common-fetch-params) 122 | (swap! state assoc :loading true) 123 | (fetch/json-fetch 124 | {:uri (str (:base-url @common-fetch-params) "/" (:resourceType @state)) 125 | :token (:id_token @common-fetch-params) 126 | :params (cond-> {:_count 50} ;; :_sort "name"} 127 | (and text (not (str/blank? text))) (assoc :_text text)) 128 | :success (fn [x] 129 | (swap! state assoc 130 | :loading false 131 | :suggestions (mapv (comp value-fn :resource) (:entry x))))})) 132 | (fn [text] 133 | (when-let [rt (:resourceType @state)] 134 | (swap! state assoc :loading true) 135 | (-> (fetch/fetch-promise {:uri (str (:base-url @common-fetch-params) "/" rt) 136 | :token (:id_token @common-fetch-params) 137 | :params (cond-> {:_count 50} ;; :_sort "name"} 138 | (and text (not (str/blank? text))) (assoc :_text text))}) 139 | (.then (fn [x] (swap! state assoc 140 | :loading false 141 | :suggestions (mapv (comp value-fn :resource) (:entry (:data x)))))) 142 | (.catch (fn [e] (prn (fetch/error-message e)))))))] 143 | 144 | [:div.select-xhr 145 | [:style (garden/css style)] 146 | 147 | (into [:select {:class :input 148 | :value (str (:resourceType @state)) 149 | :on-change #(let [v (.. % -target -value)] 150 | (swap! state assoc :resourceType v :suggestions []) 151 | (when on-change (on-change nil)) 152 | (close))}] 153 | (mapv (fn [x] [:option x]) resourceType)) 154 | 155 | [:div.value-xhr 156 | [:div.choosen 157 | {:on-click (fn [_] (cond 158 | (:active @state) (close) 159 | (not (str/blank? (:resourceType @state))) (do 160 | (fetch-load nil) 161 | (swap! state assoc :active true)) 162 | :else (js/alert "select resource type")))} 163 | [:span.triangle "▾"] 164 | [:span.value (if value (label-fn value) placeholder)] 165 | (when value 166 | [:span.icon 167 | {:on-click (fn [e] 168 | (when on-change (on-change nil)) 169 | (.stopPropagation e))} 170 | [:i.material-icons :close]])] 171 | 172 | (when (:active @state) 173 | [:div.drop-menu 174 | [:div.query-loader 175 | [:input.query 176 | {:type "text" 177 | :placeholder "Search on enter..." 178 | :auto-focus true 179 | :on-key-down (fn [ev] (when (= 13 (.-keyCode ev)) (fetch-load (.. ev -target -value))))}] 180 | (when (:loading @state) [:div.loader "loading..."])] 181 | (when-not (:loading @state) 182 | [:div.suggestions 183 | (cond 184 | (empty? (:suggestions @state)) [:div.info "No results"] 185 | :else (for [i (:suggestions @state)] ^{:key (pr-str i)} 186 | ;; (:suggestions @state) already mapped by value-fn on upload fetch results 187 | [:div.suggestion 188 | {:on-click #(do (when on-change (on-change i)) 189 | (close))} 190 | (label-fn i)]))])]) 191 | ]]))}))) 192 | 193 | -------------------------------------------------------------------------------- /src/fhir_face/widgets.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.widgets 2 | (:require [reagent.core :as r] 3 | [re-frame.core :as rf] 4 | [clojure.string :as str] 5 | [fhir-face.select-xhr :as xhr])) 6 | 7 | (rf/reg-sub 8 | ::get-value 9 | (fn [db [_ path]] (get-in db path))) 10 | 11 | (rf/reg-event-db 12 | ::set-value 13 | (fn [db [_ path v]] (assoc-in db path v))) 14 | 15 | #_(defn text-db [{:keys [path min-size max-size] :as params}] 16 | (let [value (str @(rf/subscribe [::get-value path])) 17 | min-size* (or min-size 3) 18 | max-size* (or max-size 100)] 19 | [:input (-> params 20 | (dissoc :path :min-size :max-size) 21 | (assoc 22 | :type "text" 23 | :value value 24 | :size (max min-size* (min max-size* (int (* 1.5 (+ 1 (.-length value)))))) 25 | :on-change #(rf/dispatch [::set-value path (.. % -target -value)])))])) 26 | 27 | (defn select [{:keys [path items] :as params}] 28 | (let [value (str @(rf/subscribe [::get-value path]))] 29 | (into 30 | [:select (-> params 31 | (dissoc :path :items) 32 | (assoc 33 | :value value 34 | :on-change #(rf/dispatch [::set-value path (.. % -target -value)]))) 35 | [:option ""] 36 | (if (and (not (str/blank? value)) (not (contains? (set items) value))) [:option value])] 37 | (mapv (fn [x] [:option x]) items)))) 38 | 39 | 40 | (defn- node-auto-width [node] 41 | (set! (.. node -style -width) "1px") 42 | (set! (.. node -style -width) (str (+ (.. node -scrollWidth) 0) "px"))) 43 | 44 | (defn- node-auto-height [node] 45 | (set! (.. node -style -height) "1px") 46 | (set! (.. node -style -height) (str (+ (.. node -scrollHeight) 2) "px"))) 47 | 48 | (defn- node-auto-size [node] 49 | (if node (case (.. node -tagName) 50 | "TEXTAREA" (node-auto-height node) 51 | "INPUT" (node-auto-width node)))) 52 | 53 | (defn text [{:keys [path] :as params}] 54 | (let [value (str @(rf/subscribe [::get-value path])) 55 | multi-line? (r/atom (or (> (.-length value) 50) (str/includes? value "\n")))] 56 | (r/create-class 57 | {:reagent-render (fn [params] 58 | (let [value (str @(rf/subscribe [::get-value path])) 59 | props (-> params 60 | (dissoc :path) 61 | (assoc :value value))] 62 | (conj 63 | (if @multi-line? 64 | [:div 65 | {:style {:display :flex ;;:inline-flex ;;:flex 66 | ;;:width "100%" 67 | }} 68 | [:textarea (-> props 69 | (assoc :on-change (fn [e] 70 | (node-auto-height (.. e -target)) 71 | (rf/dispatch [::set-value path (.. e -target -value)])) 72 | :style {:-webkit-box-sizing :border-box 73 | :-moz-box-sizing :border-box 74 | :box-sizing :border-box 75 | :width "100%" 76 | :resize :none 77 | :overflow :hidden 78 | ;;:margin "0 0 2px 0" 79 | }))]] 80 | [:span 81 | {:style {:display :inline-flex 82 | ;;:vertical-align :bottom 83 | :align-items :center 84 | }} 85 | [:input (-> props 86 | (assoc :type "text" 87 | :on-change (fn [e] 88 | (node-auto-width (.. e -target)) 89 | (rf/dispatch [::set-value path (.. e -target -value)])) 90 | :style {:min-width "20px" 91 | :padding "2px"}))]]) 92 | [:i.material-icons 93 | {:on-click (fn [e] (.stopPropagation e) (swap! multi-line? not)) 94 | ;; :style {:margin-left "5px" :margin-top "5px"} 95 | } 96 | (if @multi-line? :location_on :play_arrow)]))) 97 | 98 | :component-did-mount (fn [this] 99 | ;;(prn "component-did-mount") 100 | (node-auto-size (.. (r/dom-node this) -firstChild))) 101 | :component-did-update (fn [this] 102 | ;;(prn "component-did-update") 103 | (let [node (.. (r/dom-node this) -firstChild)] 104 | (node-auto-size node) 105 | (.focus node)))}))) 106 | 107 | 108 | (defn checkbox [{:keys [path] :as params}] 109 | [:input (-> params 110 | (dissoc :path) 111 | (assoc 112 | :type "checkbox" 113 | :checked (= "true" (str @(rf/subscribe [::get-value path]))) 114 | :on-change #(rf/dispatch [::set-value path (.. % -target -checked)])))]) 115 | 116 | (defn date [{:keys [path] :as params}] 117 | [:input (-> params 118 | (dissoc :path) 119 | (assoc 120 | :type "date" 121 | :value (str @(rf/subscribe [::get-value path])) 122 | :on-change #(rf/dispatch [::set-value path (.. % -target -value)])))]) 123 | 124 | (defn date-time [{:keys [path] :as params}] 125 | (let [v (str @(rf/subscribe [::get-value path])) 126 | cnt-v (count v) 127 | value (cond 128 | (= 0 cnt-v) "" 129 | (>= cnt-v 16) (subs v 0 16) 130 | :else (str v (subs "2018-01-01T00:00" cnt-v)))] 131 | [:input (-> params 132 | (dissoc :path) 133 | (assoc 134 | :type "datetime-local" 135 | :value value 136 | :on-change #(rf/dispatch [::set-value path (str (.. % -target -value) ":00Z")])))])) 137 | 138 | (defn time-time [{:keys [path] :as params}] 139 | [:input (-> params 140 | (dissoc :path) 141 | (assoc 142 | :type "time" 143 | :value (str @(rf/subscribe [::get-value path])) 144 | :on-change #(rf/dispatch [::set-value path (.. % -target -value)])))]) 145 | 146 | ;; js/isNaN 147 | 148 | (defn decimal [{:keys [path] :as params}] 149 | [:input (-> params 150 | (dissoc :path) 151 | (assoc 152 | :type "number" 153 | :step "0.000000000000001" 154 | :value (str @(rf/subscribe [::get-value path])) 155 | :on-change #(rf/dispatch [::set-value path (js/parseFloat (.. % -target -value))])))]) 156 | 157 | 158 | (defn integer [{:keys [path] :as params}] 159 | [:input (-> params 160 | (dissoc :path) 161 | (assoc 162 | :type "number" 163 | ;;:step "1" 164 | :value (str @(rf/subscribe [::get-value path])) 165 | :on-change #(rf/dispatch [::set-value path (js/parseFloat (.. % -target -value))])))]) 166 | 167 | (defn unsignedInt [{:keys [path] :as params}] 168 | [:input (-> params 169 | (dissoc :path) 170 | (assoc 171 | :type "number" 172 | :min "0" 173 | ;;:step "1" 174 | :value (str @(rf/subscribe [::get-value path])) 175 | :on-change #(rf/dispatch [::set-value path (js/parseFloat (.. % -target -value))])))]) 176 | 177 | (defn positiveInt [{:keys [path] :as params}] 178 | [:input (-> params 179 | (dissoc :path) 180 | (assoc 181 | :type "number" 182 | :min "1" 183 | ;;:step "1" 184 | :value (str @(rf/subscribe [::get-value path])) 185 | :on-change #(rf/dispatch [::set-value path (js/parseFloat (.. % -target -value))])))]) 186 | 187 | 188 | 189 | (defn get-display-from [r k] 190 | (let [v (get r k)] 191 | (cond 192 | (str/blank? v) nil 193 | (and (= :name k) 194 | (or (vector? v) (:given v))) (let [n (if (vector? v) (first v) v)] 195 | (->> [(:text n) (str/join " " (conj (or (:given n) []) (:family n)))] 196 | (remove str/blank?) 197 | first)) 198 | (string? v) v))) 199 | 200 | (defn resource-display [r] 201 | (if (nil? r) 202 | nil 203 | (or (->> [:display :name] 204 | (map #(get-display-from r %)) 205 | (remove str/blank?) 206 | first) 207 | (->> [:patient 208 | :subject ;; Encounter 209 | :beneficiary ;;:subscriber :policyHolder ;; Coverage 210 | :details ;; AidboxNotification 211 | ] 212 | (map #(resource-display (% r))) 213 | (remove str/blank?) 214 | first)))) 215 | 216 | 217 | (defn reference [{:keys [path resourceType settings] :as params}] 218 | (let [value @(rf/subscribe [::get-value path])] 219 | [xhr/select-xhr (merge 220 | {:value value 221 | ;;:placeholder "Xhr select" 222 | ;;:on-blur identity 223 | :on-change #(rf/dispatch [::set-value path %]) 224 | :resourceType resourceType} 225 | (case (:fhir-server-type settings) 226 | :hapi 227 | {:label-fn (fn [x] (let [[rt id] (str/split (:reference x) #"/")] (str (if id (str "[" id "] ")) (:display x)))) 228 | :value-fn (fn [x] (let [d (resource-display x)] 229 | (cond-> {:reference (str (:resourceType x) "/" (:id x))} 230 | (not (str/blank? d)) (assoc :display d)))) 231 | :value-type (str (first (str/split (:reference value) #"/")))} 232 | {:label-fn #(str "[" (:id %) "] " (:display %)) 233 | :value-fn #(let [d (resource-display %)] 234 | (cond-> (select-keys % [:id :resourceType]) 235 | (not (str/blank? d)) (assoc :display d))) 236 | :value-type (str (:resourceType value))}))])) 237 | -------------------------------------------------------------------------------- /src/fhir_face/form.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.form 2 | (:require 3 | [reagent.core :as r] 4 | [re-frame.core :as rf] 5 | [clojure.string :as str] 6 | [fhir-face.style :as style] 7 | [fhir-face.nav :as nav] 8 | [fhir-face.model :as model] 9 | [zframes.redirect :refer [href redirect]] 10 | [fhir-face.widgets :as ws] 11 | [clojure.set :as set])) 12 | 13 | (defonce atom-style (r/atom {:style 0})) 14 | 15 | (def styles [:block :inline-table :inline-grid]) 16 | 17 | (defn style [] 18 | [[:.root {:margin-left "-40px"}] 19 | 20 | [:.input (merge (:thin-gray style/borders) 21 | {:outline :none 22 | :font-size "16px" 23 | :font-weight :bold 24 | :margin-left "25px" 25 | :width :fit-content})] 26 | 27 | [:.non-selectable {:-webkit-user-select :none 28 | :-moz-user-select :none 29 | :-ms-user-select :none}] 30 | [:.atts 31 | [:.active 32 | ;;[:.name {}] 33 | [:.type {:color "#777777"}] 34 | [:.description {:color "#777777"}]] 35 | [:.unactive {:color "#cccccc"}] 36 | [:.extra {:color "#cc8888"}]] 37 | 38 | [:.collapsed-summary {:background-color :lightblue 39 | :width :fit-content}] 40 | 41 | [:.name-value {:display (get styles (:style @atom-style)) 42 | :padding-left "40px" 43 | :font-size "20px" 44 | ;;:border "1px solid" 45 | }] 46 | 47 | [:.item-value {:width :-webkit-fill-available ;;"100%" 48 | :font-size "1px" 49 | ;;:border "1px solid" 50 | :padding "10px 10px 10px 0" 51 | ;;:padding-right "20px" 52 | ;;:padding-bottom "10px" 53 | ;;:padding-top "10px" 54 | }] 55 | 56 | [:.material-icons {:font-size "14px"}] 57 | 58 | [:.on-off {:margin-top "15px" 59 | :margin-bottom "10px"}] 60 | 61 | [:.name {:font-size "20px" 62 | :margin-left "10px"}] 63 | 64 | [:.type {:font-size "16px" 65 | :margin-left "10px"}] 66 | 67 | [:.description {:font-size "16px" 68 | :margin-left "10px"}] 69 | 70 | [:.coll {;;:padding-left "30px" 71 | :margin-right "-10px" 72 | :display :flex 73 | :flex-wrap :wrap 74 | ;; :align-items :flex-start 75 | ;;:justify-content :space-evenly ;;:space-between 76 | }] 77 | 78 | [:.item (merge nil ;;(:thin-gray style/borders) 79 | {:display :flex 80 | :margin "10px 15px 10px 5px" 81 | :font-size "20px" 82 | ;;:flex "1 1 20%" 83 | ;;:flex "1 0 20%" 84 | :flex "1 0 0" 85 | :box-shadow "3px 3px 20px #cbcbcb" 86 | :border-radius "5px" 87 | })] 88 | 89 | [:.error {:font-family :monospace 90 | :font-size "20px" 91 | :color :red 92 | :margin "20px 0"}] 93 | ]) 94 | 95 | 96 | 97 | 98 | 99 | (def fhir-primitive-types 100 | {:string ws/text 101 | :code ws/text 102 | :id ws/text 103 | :markdown ws/text 104 | :uri ws/text 105 | :oid ws/text 106 | :boolean ws/checkbox 107 | :date ws/date 108 | :dateTime ws/date-time 109 | :instant ws/date-time 110 | :time ws/time-time 111 | :decimal ws/decimal 112 | :integer ws/integer 113 | :unsignedInt ws/unsignedInt 114 | :positiveInt ws/positiveInt 115 | ;; :base64Binary 116 | 117 | ;; additional? 118 | ;; :Resource 119 | ;; :Extension 120 | :Reference ws/reference 121 | :Narrative ws/text 122 | :number ws/decimal}) 123 | 124 | #_(defn value-set [s] (str/split s #" \| ")) 125 | 126 | (defn primitive-component [{:keys [type path enum content settings]}] 127 | (let [cmp (if enum ws/select (get fhir-primitive-types type ws/text))] 128 | [cmp (merge {:path (into (conj model/root-path :data :resource) path) 129 | :class :input} 130 | (cond 131 | enum {:items enum} 132 | (= type :Reference) {:resourceType (get-in content [:resourceType :enum]) 133 | :settings settings}))])) 134 | 135 | (def Quantity {:value {:type :decimal} 136 | :comparator {:type :code :enum ["<" "<=" ">=" ">"]} 137 | :unit {:type :string} 138 | :system {:type :uri} 139 | :code {:type :code}}) 140 | 141 | (def fhir-basic-types 142 | 143 | {:ContactPoint {:system {:type :code :isRequired true :enum ["phone" "fax" "email" "pager" "url" "sms" "other"]} 144 | :value {:type :string} 145 | :use {:type :code :enum ["home" "work" "temp" "old" "mobile"]} 146 | :rank {:type :positiveInt} 147 | :period {:type :Period}} 148 | 149 | :Identifier {:use {:type :code :enum ["usual" "official" "temp" "secondary"]} 150 | :type {:type :CodeableConcept} 151 | :system {:type :uri} 152 | :value {:type :string} 153 | :period {:type :Period} 154 | :assigner {:type :Reference 155 | :content {:resourceType {:enum ["Organization"]}} 156 | ;;:ref-types ["Organization"] 157 | }} 158 | 159 | :HumanName {:use {:type :code :enum ["usual" "official" "temp" "nickname" "anonymous" "old" "maiden"]} 160 | :text {:type :string} 161 | :family {:type :string} 162 | :given {:type :string :isCollection true} 163 | :prefix {:type :string :isCollection true} 164 | :suffix {:type :string :isCollection true} 165 | :period {:type :Period}} 166 | 167 | :Coding {:system {:type :uri} 168 | :version {:type :string} 169 | :code {:type :code} 170 | :display {:type :string} 171 | :userSelected {:type :boolean}} 172 | 173 | :CodeableConcept {:coding {:type :Coding :isCollection true} 174 | :text {:type :string}} 175 | 176 | :Period {:start {:type :dateTime} 177 | :end {:type :dateTime}} 178 | 179 | :Address {:use {:type :code :enum ["home" "work" "temp" "old"]} 180 | :type {:type :code :enum ["postal" "physical" "both"]} 181 | :text {:type :string} 182 | :line {:type :string :isCollection true} 183 | :city {:type :string} 184 | :district {:type :string} 185 | :state {:type :string} 186 | :postalCode {:type :string} 187 | :country {:type :string} 188 | :period {:type :Period}} 189 | 190 | :Quantity Quantity 191 | :Age Quantity 192 | :Count Quantity 193 | :Distance Quantity 194 | :Duration Quantity 195 | :Money Quantity 196 | :SimpleQuantity Quantity 197 | 198 | :Range {:low {:type :SimpleQuantity} 199 | :high {:type :SimpleQuantity}} 200 | 201 | :Ratio {:numerator {:type :Quantity} 202 | :denominator {:type :Quantity}} 203 | 204 | :SampledData {:origin {:type :SimpleQuantity} 205 | :period {:type :decimal} 206 | :factor {:type :decimal} 207 | :lowerLimit {:type :decimal} 208 | :upperLimit {:type :decimal} 209 | :dimensions {:type :positiveInt} 210 | :data {:type :string}} 211 | 212 | :Timing {:event {:type :dateTime :isCollection true} 213 | :repeat {:type :Timing-repeat} 214 | :code {:type :CodeableConcept}} 215 | 216 | :Timing-repeat {:bounds {:type [:Duration :Range :Period]} 217 | :count {:type :integer} 218 | :countMax {:type :integer} 219 | :duration {:type :decimal} 220 | :durationMax {:type :decimal} 221 | :durationUnit {:type :code} 222 | :frequency {:type :integer} 223 | :frequencyMax {:type :integer} 224 | :period {:type :decimal} 225 | :periodMax {:type :decimal} 226 | :periodUnit {:type :code :enum ["s" "min" "h" "d" "wk" "mo" "a"]} 227 | :dayOfWeek {:type :code :isCollection true :enum ["mon" "tue" "wed" "thu" "fri" "sat" "sun"]} 228 | :timeOfDay {:type :time :isCollection true} 229 | :when {:type :code :isCollection true} 230 | :offset {:type :unsignedInt}} 231 | 232 | :Signature {:type {:type :Coding :isCollection true} 233 | :when {:type :instant} 234 | :who {:type [:Reference :uri] 235 | :content {:resourceType 236 | {:enum ["Practitioner" "RelatedPerson" "Patient" "Device" "Organization"]}}} 237 | :onBehalfOf {:type [:Reference :uri] 238 | :content {:resourceType 239 | {:enum ["Practitioner" "RelatedPerson" "Patient" "Device" "Organization"]}}} 240 | :contentType {:type :code} 241 | :blob {:type :base64Binary}} 242 | 243 | :Annotation {:author {:type [:Reference :string] 244 | :content {:resourceType {:enum ["Practitioner" "Patient" "RelatedPerson"]}}} 245 | :time {:type :dateTime} 246 | :text {:type :string}} 247 | 248 | :Attachment {:contentType {:type :code} 249 | :language {:type :code} 250 | :data {:type :base64Binary} 251 | :url {:type :uri} 252 | :size {:type :unsignedInt} 253 | :hash {:type :base64Binary} 254 | :title {:type :string} 255 | :creation {:type :dateTime}} 256 | 257 | :Meta {:versionId {:type :id} 258 | :lastUpdated {:type :instant} 259 | :profile {:type :uri :isCollection true} 260 | :security {:type :Coding :isCollection true} 261 | :tag {:type :Coding :isCollection true}} 262 | }) 263 | 264 | ;; ;; Open 265 | ;; boolean 266 | ;; integer 267 | ;; decimal 268 | ;; base64Binary 269 | ;; instant 270 | ;; string 271 | ;; uri 272 | ;; date 273 | ;; dateTime 274 | ;; time 275 | ;; code 276 | ;; oid 277 | ;; id 278 | ;; unsignedInt 279 | ;; positiveInt 280 | ;; markdown 281 | 282 | ;; Annotation 283 | ;; Attachment 284 | ;; Identifier 285 | ;; CodeableConcept 286 | ;; Coding 287 | ;; Quantity 288 | ;; Range 289 | ;; Period 290 | ;; Ratio 291 | ;; SampledData 292 | ;; Signature 293 | ;; HumanName 294 | ;; Address 295 | ;; ContactPoint 296 | ;; Timing 297 | ;; Reference - a reference to another resource 298 | ;; Meta 299 | 300 | 301 | (defn click-dispatch [args] 302 | {:on-click (fn [e] 303 | (.stopPropagation e) 304 | (rf/dispatch args)) 305 | :style {:cursor :pointer}}) 306 | 307 | (declare zofo) 308 | 309 | (defn coll-zofo [r e path attrs] 310 | (let [items (vec (map-indexed 311 | (fn [i _] (let [path* (conj path i)] 312 | [:div.item {:key i} 313 | [zofo r e path* (dissoc attrs :isCollection)] 314 | [:span 315 | (update (click-dispatch [::model/expand-collapse-node-deep path*]) 316 | :style merge 317 | {:display :flex 318 | :flex-direction :column 319 | ;;:background-color "#fafafa" 320 | }) 321 | [:i.material-icons 322 | (click-dispatch [::model/delete-collection-item path i]) 323 | :close]]])) 324 | (get-in r path)))] 325 | (into [:div.coll] items))) 326 | 327 | (defn key-name [x] (if (keyword? x) (name x) (str x))) 328 | 329 | (defn keys* [x] (if (map? x) (keys x) [])) 330 | 331 | (defn exists-in? [m ks] 332 | (or (empty? ks) ;; true ;; (boolean m) 333 | (let [holder-path (vec (butlast ks)) 334 | holder-value (if (empty? holder-path) m (get-in m holder-path))] 335 | (contains? holder-value (last ks))))) 336 | 337 | 338 | 339 | 340 | 341 | 342 | 343 | ;;:HumanName 344 | #_{:use {:type :code :enum ["usual" "official" "temp" "nickname" "anonymous" "old" "maiden"]} 345 | :text {:type :string} 346 | :family {:type :string} 347 | :given {:type :string :isCollection true} 348 | :prefix {:type :string :isCollection true} 349 | :suffix {:type :string :isCollection true} 350 | :period {:type :Period}} 351 | 352 | 353 | (defn zofo [r {:keys [expands settings] :as e} path attrs*] 354 | (let [val? (exists-in? r path) 355 | val (get-in r path) 356 | name (last path) 357 | type (:type attrs*) 358 | attrs (if-let [cnt (fhir-basic-types type)] (assoc attrs* :content cnt) attrs*) 359 | collection? (or (:isCollection attrs) (vector? val)) 360 | expanded? (or (empty? path) (get-in expands path)) 361 | count-all (count (set/union (-> attrs :content keys* set) (-> val keys* set))) 362 | count-val (if (coll? val) (count val) 0) 363 | collapsed-info [:span.label.non-selectable.collapsed-summary 364 | (click-dispatch [::model/expand-collapse-node path]) 365 | (if collection? 366 | (str "[" count-val " item" (if (not= 1 count-val) "s") "]") 367 | (str "{" (if (= count-val count-all) count-all (str count-val "/" count-all)) 368 | " key" (if (not= 1 count-all) "s") "}"))] 369 | ] 370 | [:div 371 | {:class (cond (keyword? name) :name-value 372 | (empty? path) :root 373 | :else :item-value)} 374 | (if (keyword? name) [:span.non-selectable 375 | (cond-> {:class (cond (:extra? attrs) :extra 376 | (not val?) :unactive 377 | :else :active)} 378 | (and val? 379 | (or (and (> count-all 0) (not (fhir-primitive-types type))) 380 | collection?)) 381 | (merge (click-dispatch [::model/expand-collapse-node-deep path]))) 382 | 383 | [:i.material-icons.on-off 384 | (click-dispatch [::model/attribute-on-off path]) 385 | (if val? "lens" "radio_button_unchecked")] 386 | 387 | [:span.name (key-name name)] 388 | (if type [:span.type (key-name type)]) 389 | (if (:description attrs) [:span.description (:description attrs)]) 390 | 391 | (if (and collection? expanded?) 392 | [:span.label 393 | [:i.material-icons 394 | (click-dispatch [::model/add-collection-item path]) 395 | "add_circle_outline"]])]) 396 | (cond 397 | (not val?) nil 398 | 399 | collection? (if expanded? [coll-zofo r e path attrs] collapsed-info) 400 | 401 | (or (fhir-primitive-types type) (= 0 count-all)) [primitive-component (assoc attrs :path path :settings settings)] 402 | 403 | (not expanded?) collapsed-info 404 | 405 | :else (let [wids-attrs (let [content (:content attrs)] 406 | (reduce (fn [a name] (conj a [zofo r e (conj path name) (get content name)])) 407 | [] (sort (keys content)))) 408 | 409 | ;; add extra attributes - existing in object by path, but not existing in content attrs 410 | set-keys-attrs (-> attrs :content keys* set) 411 | extra-attrs (reduce (fn [a k] 412 | (if (set-keys-attrs k) 413 | a 414 | (assoc a k {:extra? true :isCollection (vector? (get val k))}))) 415 | {} (keys* val)) 416 | 417 | wids-all (let [content extra-attrs] 418 | (reduce (fn [a name] (conj a [zofo r e (conj path name) (get content name)])) 419 | wids-attrs (sort (keys content))))] 420 | (into [:div.atts] wids-all)) 421 | )])) 422 | 423 | 424 | (defn resource-form [{:keys [type id] :as params}] 425 | ;;(prn "resource-form" params) 426 | (let [{:keys [resource resource-expands resource-structure is-fetching error]} @(rf/subscribe [::model/data]) 427 | settings @(rf/subscribe [::ws/get-value [:config :settings]])] 428 | [:div.page 429 | [style/with-common-style (style)] 430 | [nav/nav-bar] 431 | [:div.content 432 | [:span 433 | {:style {:display :flex 434 | :align-items :baseline}} 435 | [:h1.h (str (if id "Edit " "New ") (:type params))] [:span.label (:id params)]] 436 | 437 | [:div.bar 438 | [:span {:style {:display :flex}} 439 | [:button.btn {:on-click (fn [] (rf/dispatch [::model/expand-all]))} "Expand all"] 440 | [:button.btn {:on-click (fn [] (rf/dispatch [::model/collapse-all]))} "Collapse all"] 441 | [:button.btn {:on-click (fn [] (swap! atom-style update :style #(mod (inc %) (count styles))))} 442 | (str (get styles (:style @atom-style)) " style")]] 443 | [:span.action {:on-click #(redirect (href "resource" {:type type}))} (str type " grid")]] 444 | 445 | (if is-fetching 446 | [:div.loader "Loading"] 447 | [:div 448 | [zofo resource {:expands resource-expands :settings settings} [] {:content resource-structure}] 449 | [:div.footer-actions 450 | [:button.btn {:on-click (fn [] (rf/dispatch [::model/save-resource params]))} "Save"] 451 | #_[:a.btn.btn-danger {:href (href "locations")} "Cancel"]] 452 | (if error [:div.error ;;:pre.error 453 | (str (or (:issue error) error)) 454 | ;;(with-out-str (cljs.pprint/pprint error)) 455 | ])]) 456 | ]])) 457 | 458 | (defn for-routes [params] 459 | ;; (prn "form-panel --------------------------------------" params) 460 | (rf/dispatch [::model/load-all params]) 461 | [resource-form (:query-params params)]) 462 | 463 | (def routes {:resource-edit for-routes 464 | :resource-new for-routes}) 465 | 466 | -------------------------------------------------------------------------------- /src/graph_view/core.cljs: -------------------------------------------------------------------------------- 1 | (ns graph-view.core 2 | (:require [reagent.core :as r] 3 | [re-frame.core :as rf] 4 | [clojure.string :as str] 5 | [fhir-face.style :as style] 6 | [fhir-face.nav :as nav] 7 | [graph-view.widgets :as ws] 8 | [fhir-face.model :as model])) 9 | 10 | (def style 11 | [:.content {:display "flex" 12 | :height :-webkit-fill-available 13 | :padding "5px"} 14 | ;; [:.input (merge (:thin-gray style/borders) 15 | ;; {:outline :none 16 | ;; :font-size "16px" 17 | ;; :font-weight :bold})] 18 | 19 | 20 | ;; [:table {:width "100%" 21 | ;; :border-collapse :collapse}] 22 | ;; [:th {:color "#ddd"}] 23 | ;; [:td {:font-family :system-ui 24 | ;; :font-size "20px" 25 | ;; :height "50px" 26 | ;; :cursor :pointer 27 | ;; :border-bottom "1px solid #ddd"}] 28 | ;; ;;[:td:hover {:background-color "#f5f5f5"}] 29 | ;; [:.item:hover {:background-color "#f5f5f5"}] 30 | 31 | ;; ;;[:.id :.display {:text-align :left}] 32 | ;; [:.display {:padding-left "20px"}] 33 | ;; [:.size {:padding-left "20px" 34 | ;; :text-align :right}] 35 | 36 | [:.bar {:display "inline-flex" 37 | :flex-direction "column" 38 | :margin "0 10px 0 65px"}] 39 | 40 | [:.svg-container {:width "100%" 41 | ;;:background-color :black 42 | ;;:border "10px solid" 43 | }] 44 | 45 | [:.field {;;:border "1px solid #ddd" 46 | ;;:background-color :black 47 | }] 48 | 49 | [:.draggable {:cursor :move}] 50 | [:.vertex-name {:font-family :system-ui 51 | ;;:font-size "10px" 52 | :color :gray 53 | :cursor :pointer 54 | }] 55 | [:.vertex-menu {:z-index 1 56 | :position :absolute 57 | ;;:min-width "100%" 58 | ;;:width :max-content 59 | :background-color "#ffffff"}] 60 | 61 | [:.btn-group {:display :flex}] 62 | 63 | [:.btn {:font-size "20px" 64 | :cursor :pointer 65 | :background-color :lightgray 66 | :border :none 67 | :outline :none 68 | :flex-grow 1 69 | :width "100px"} 70 | ] 71 | [:.red {:background-color "#cc0000"}] 72 | [:.green {:background-color "#009900"}] 73 | 74 | 75 | [:.splitter {:height "20px"}] 76 | 77 | [:.input {:outline :none 78 | :font-size "16px" 79 | ;;:font-weight :bold 80 | ;;:color :honeydew 81 | ;;:background-color :black 82 | :border "1px solid #ccc" 83 | ;;:margin-top "5px" 84 | }] 85 | 86 | [:.label {:margin "10px 5px 0 0" 87 | ;;:color :gray 88 | }] 89 | 90 | [:.vertexes-names {:display :flex 91 | :align-items :flex-end}] 92 | 93 | [:.vertexes-edges {:display :flex 94 | :align-items :baseline} 95 | [:.input {:width "45px" 96 | :height :fit-conten}]] 97 | 98 | #_[:.edges-list {:resize :none 99 | :flex-grow 1 100 | :spell-check false}] 101 | 102 | [:.vertex-list {:height "300px" 103 | :flex-grow 1 104 | :display :flex 105 | :flex-direction :column 106 | :margin-top "10px" 107 | :border "1px solid gray" 108 | :overflow-y :auto}] 109 | 110 | [:.menu-item {:font-family :system-ui 111 | :padding "2px 5px" 112 | :cursor :pointer} 113 | [:&:hover {;;:background-color "#f1f1f1" 114 | :text-decoration :underline}]] 115 | 116 | [:.added {:background-color :gainsboro}] 117 | [:.not-added {:background-color :white}] 118 | 119 | 120 | ]) 121 | 122 | 123 | (defn p2 [x] (* x x)) 124 | 125 | (defn close-to [x x*] (< -1E-15 (- x* x) 1E-15)) 126 | 127 | (defn in-diap [x from to] (min to (max from x))) 128 | 129 | (defn norm-by-abs [x limit] (min limit (max (- limit) x))) 130 | 131 | 132 | (defn out-of-limit [x limit] x #_(if (>= x 0) (max limit x) (min (- limit) x))) 133 | 134 | (defn smooth-slide [x] (if-not x 0 (let [v (/ x 100)] (* v v)))) 135 | 136 | 137 | (defn fo [id {x :x y :y edges :edges} 138 | id* {x* :x y* :y edges* :edges} 139 | {:keys [repulsive-force coupling-stiffness-factor relative-edge-length]}] 140 | 141 | (if (and (close-to x x*) (close-to y y*)) 142 | [0 0] 143 | (let [k-rep-f (* 0.0001 (smooth-slide repulsive-force)) 144 | k-stiff (* 0.3 (smooth-slide coupling-stiffness-factor)) 145 | edge-len (* 0.5 (smooth-slide relative-edge-length)) 146 | 147 | edge? (or (contains? edges id*) (contains? edges* id)) 148 | l2 (+ 149 | ;;0.000001 150 | (p2 (- x x*)) (p2 (- y y*))) 151 | l (Math/sqrt l2) 152 | 153 | fv (- (/ 1 l2)) 154 | fe (if edge? (- l edge-len) 0) 155 | 156 | ;;f (+ (* 0.0001 fv) (* 0.1 fe)) 157 | f (+ (* k-rep-f fv) (* k-stiff fe)) 158 | 159 | k (/ f l) 160 | 161 | fx (* k (out-of-limit (- x* x) 1E-10)) 162 | fy (* k (out-of-limit (- y* y) 1E-10)) 163 | 164 | ;; ke (/ fe l) 165 | ;; fex (* ke (- x* x)) 166 | ;; fey (* ke (- y* y)) 167 | 168 | 169 | ;; kD 0 ;;-0.002 170 | 171 | ;; dfx (* kD (norm-by-abs (- fx (or fvx 0)) 0.1)) 172 | ;; dfy (* kD (norm-by-abs (- fy (or fvy 0)) 0.1)) 173 | 174 | ;; kI 0 ;;0.00002 175 | ;; fix* (* kI (norm-by-abs (+ fex (or fix 0)) 100)) 176 | ;; fiy* (* kI (norm-by-abs (+ fey (or fiy 0)) 100)) 177 | ] 178 | [(+ fx 179 | ;; dfx fix* 180 | ) (+ fy 181 | ;; dfy fiy* 182 | )] 183 | ))) 184 | 185 | (defn foall [id {:keys [x y fix fiy] :as p} vs params] 186 | (let [ 187 | [dx* dy*] (reduce (fn [[xa ya] [idv v]] 188 | (let [[xi yi] (fo id p idv v params)] [(+ xa xi) (+ ya yi)])) 189 | [0 0] vs) 190 | 191 | [dx dy] (reduce (fn [[xa ya] v] 192 | (let [[xi yi] (fo id p nil v params)] [(+ xa xi) (+ ya yi)])) 193 | [dx* dy*] [{:x x :y 0} {:x x :y 1} {:x 0 :y y} {:x 1 :y y}]) 194 | 195 | dx (norm-by-abs dx 0.05) 196 | dy (norm-by-abs dy 0.05) 197 | 198 | fx (in-diap (+ x dx) 0.001 0.999) 199 | fy (in-diap (+ y dy) 0.001 0.999) 200 | ] 201 | 202 | ;;(prn p (->> ps (mapv #(fo p %))) dx dy) 203 | 204 | {:x fx :y fy 205 | ;; :fvx dx :fvy dy 206 | ;; :fix (+ dx (or fix 0)) :fiy (+ dy (or fiy 0)) 207 | })) 208 | 209 | 210 | 211 | 212 | 213 | 214 | (defn on-tik [state] 215 | (let [db @state 216 | {vs :data} db 217 | params (select-keys db [:repulsive-force :coupling-stiffness-factor :relative-edge-length]) 218 | r (reduce (fn [a [id v]] (assoc a id (merge v (if (= id (get-in db [:dragging-id])) 219 | {:x (:x v) :y (:y v)} 220 | (foall id v vs params))))) {} vs)] 221 | (swap! state assoc :data r) 222 | (:simulation-on @state))) 223 | 224 | (defn periodic [f v] 225 | (-> (js/Promise. (fn [resolve] (js/setTimeout #(resolve (f v)) 100))) 226 | (.then #(if % (periodic f v))) 227 | (.catch prn))) 228 | 229 | (defn stop-go [state] 230 | (if-not (:simulation-on @state) (periodic on-tik state)) 231 | (swap! state update :simulation-on not)) 232 | 233 | 234 | 235 | (defn read-graph-from-string [s] 236 | (let [ft (->> s 237 | str/split-lines 238 | (remove str/blank?) 239 | (map (fn [e] (let [[f t & _] (-> e str/trim (str/split #"\s"))] {:f f :t t})))) 240 | vertex (->> ft 241 | (reduce (fn [a {:keys [f t]}] (cond-> a 242 | f (conj f) 243 | t (conj t))) #{}) 244 | (reduce (fn [a x] (conj a 245 | {:x (Math/random) ;;(+ 0.5 (* 1E-10 (Math/random))) 246 | :y (Math/random) ;;(+ 0.5 (* 1E-10 (Math/random))) 247 | :id (str x)})) [])) 248 | edges (reduce (fn [a {:keys [f t]}] (if-not t a (assoc a f (conj (get a f #{}) t)))) {} ft)] 249 | (reduce (fn [a {id :id :as v}] (assoc a id 250 | (-> v 251 | (dissoc :id) 252 | (assoc :edges (edges id))))) {} vertex))) 253 | 254 | (defn user-data [state] 255 | (let [r (read-graph-from-string (:input-graph @state))] 256 | (swap! state assoc 257 | :data r 258 | :vertexes-amount (count r) 259 | :edges-amount (reduce (fn [a [_ {es :edges}]] (+ a (count es))) 0 r)))) 260 | 261 | (defn random-data [state] 262 | (let [db @state 263 | n (:vertexes-amount db) 264 | e (:edges-amount db) 265 | max-e (quot (* n (- n 1)) 2)] 266 | (if (> e max-e) 267 | (js/alert (str "Amount of edges can not be greater than v*(v-1)/2 = " max-e)) 268 | (let [coin-p-q (fn [p q] (cond (= 0 p) false (= p q) true :else (< (* q (Math/random)) p))) 269 | [r vs] (loop [p e, q max-e, f 1, t 2, r "", r-size 0, vs #{}] 270 | (if (= e r-size) 271 | [r vs] 272 | (let [[f* t*] (if (> (inc t) n) [(inc f) (+ 2 f)] [f (inc t)])] 273 | (if (coin-p-q p q) 274 | (recur (dec p) (dec q) f* t* (str r f " " t "\n") (inc r-size) (conj vs f t)) 275 | (recur p (dec q) f* t* r r-size vs))))) 276 | s (str r (->> (range 1 (inc n)) 277 | (remove #(contains? vs %)) 278 | (str/join "\n")))] 279 | (swap! state assoc 280 | :input-graph s 281 | :data (read-graph-from-string s)))))) 282 | 283 | 284 | (def to-color "red") 285 | (def from-color "blue") 286 | 287 | (defn create-vertex-menu [data state id] 288 | ;;(js/alert id) 289 | (let [graph (:references-graph data) 290 | to (sort (get-in graph [id :edges])) 291 | from (sort (reduce (fn [a [k {e :edges}]] (if-not (contains? e id) a (conj a k))) [] graph)) 292 | 293 | add-vertex (fn [id] 294 | 295 | (if (get-in @state [:data id]) 296 | (swap! state update :data #(dissoc % id)) 297 | (swap! state update :data 298 | #(assoc % id (assoc (get (:references-graph data) id) 299 | :x (Math/random) :y (Math/random)))) 300 | 301 | )) 302 | 303 | 304 | ] 305 | 306 | 307 | [:div 308 | (if-not (empty? to) [:div.menu-group.to 309 | {:style {:border (str "1px solid " to-color) 310 | :margin-bottom "5px"}} 311 | (doall (map (fn [id] [:div.menu-item {:key id 312 | :class (if (get-in @state [:data id]) :added :not-added) 313 | :on-click #(add-vertex id)} id]) to)) 314 | ]) 315 | 316 | (if-not (empty? from) [:div.menu-group.from 317 | {:style {:border (str "1px solid " from-color) 318 | :margin-bottom "5px"}} 319 | (doall (map (fn [id] [:div.menu-item {:key id 320 | :class (if (get-in @state [:data id]) :added :not-added) 321 | :on-click #(add-vertex id)} id]) from)) 322 | ])] 323 | 324 | )) 325 | 326 | 327 | (defn area-component [{state :state rf-data :data}] 328 | (let [handle-mouse-move (fn mouse-move [e] 329 | (let [{:keys [dragging-id dx dy area-node area-width area-height]} @state 330 | area-bounds (.getBoundingClientRect area-node) 331 | x (/ (- (.-clientX e) (.-left area-bounds) (.-clientLeft area-node) dx) area-width) 332 | y (/ (- (.-clientY e) (.-top area-bounds) (.-clientTop area-node) dy) area-height)] 333 | (if dragging-id 334 | (swap! state #(-> % 335 | (assoc-in [:data dragging-id :x] x) 336 | (assoc-in [:data dragging-id :y] y)))))) 337 | handle-mouse-up (fn mouse-up [e] 338 | ;;(prn "up") 339 | (swap! state dissoc :dragging-id) 340 | (.removeEventListener js/document "mousemove" handle-mouse-move) 341 | (.removeEventListener js/document "mouseup" mouse-up)) 342 | 343 | handle-mouse-down (fn [e] 344 | ;;(prn "down") 345 | (.removeAllRanges (.getSelection js/window)) 346 | (let [bounds (-> e .-target .getBoundingClientRect) 347 | dx (- (.-clientX e) (/ (+ (.-left bounds) (.-right bounds)) 2)) 348 | dy (- (.-clientY e) (/ (+ (.-top bounds) (.-bottom bounds)) 2))] 349 | (swap! state assoc 350 | :dragging-id (-> e .-currentTarget (.getAttribute "data-id")) :dx dx :dy dy) 351 | (.addEventListener js/document "mousemove" handle-mouse-move) 352 | (.addEventListener js/document "mouseup" handle-mouse-up))) 353 | 354 | norm (fn [x limit] (* x limit))] 355 | 356 | (r/create-class 357 | { 358 | :component-did-mount (fn [this] 359 | (let [root (r/dom-node this) 360 | bounds (.getBoundingClientRect root)] 361 | (swap! state assoc 362 | :area-node root 363 | :area-width (- (.-right bounds) (.-left bounds) 200) 364 | :area-height (- (.-bottom bounds) (.-top bounds))))) 365 | 366 | ;;:component-will-unmount (fn [this] 367 | ;; (.removeEventListener js/document "mousemove" handle-mouse-move) 368 | ;; (.removeEventListener js/document "mouseup" handle-mouse-up)) 369 | 370 | :reagent-render (fn [{state :state rf-data :data}] 371 | (let [{:keys [area-width area-height data show-vertex-names vertex-menu]} @state] 372 | [:div.svg-container 373 | [:svg.field 374 | {:width "100%" :height "100%"} 375 | ;;{:viewBox "0 0 1 1"} 376 | 377 | (into [:defs] 378 | (for [[id v] data 379 | e (:edges v) 380 | :let [vt (get data e)] 381 | :when vt] 382 | (let [id-gr (str id "-" e) 383 | x1 (norm (:x v) area-width) 384 | y1 (norm (:y v) area-height) 385 | x2 (norm (:x vt) area-width) 386 | y2 (norm (:y vt) area-height)] 387 | ^{:key (gensym)} 388 | [:linearGradient {:id id-gr :x1 x1 :y1 y1 :x2 x2 :y2 y2 :gradientUnits "userSpaceOnUse"} 389 | [:stop {:stop-color to-color :offset "20%"}] 390 | [:stop {:stop-color from-color :offset "80%"}]]))) 391 | 392 | (for [[id v] data 393 | e (:edges v) 394 | :let [vt (get data e)] 395 | :when vt] 396 | (let [id-gr (str id "-" e) 397 | x1 (norm (:x v) area-width) 398 | y1 (norm (:y v) area-height) 399 | x2 (norm (:x vt) area-width) 400 | y2 (norm (:y vt) area-height)] 401 | ^{:key (gensym)} 402 | [:line {:x1 x1 :y1 y1 :x2 x2 :y2 y2 :stroke (str "url(#" id-gr ")") :stroke-width 1}])) 403 | 404 | (for [[id v] data] 405 | ^{:key id} 406 | [:circle.draggable {:cx (norm (:x v) area-width) :cy (norm (:y v) area-height) 407 | :r 8 :stroke "#444" :stroke-width 6 :fill "aliceblue" 408 | :onMouseDown handle-mouse-down 409 | :data-id id 410 | :on-drag-start (fn [ev] false)}]) 411 | 412 | (if true ;;show-vertex-names 413 | (for [[id v] data] 414 | (let [x (+ 12 (norm (:x v) area-width)) 415 | y (+ 12 (norm (:y v) area-height))] 416 | ^{:key id} 417 | [:text.vertex-name {:x x :y y 418 | ;;:stroke "yellow" 419 | :on-click (fn [e] 420 | 421 | ;;(prn node) 422 | (swap! state assoc 423 | :vertex-menu {:id id 424 | :x (- (.-clientX e) 10) 425 | :y (- (.-clientY e) 10) 426 | }))} id]))) 427 | ] 428 | (if vertex-menu [:div.vertex-menu 429 | {:style {:left (str (:x vertex-menu) "px") 430 | :top (str (:y vertex-menu) "px")} 431 | :on-mouse-leave #(swap! state dissoc :vertex-menu) 432 | 433 | } 434 | [create-vertex-menu rf-data state (:id vertex-menu)]]) 435 | ]))}))) 436 | 437 | (defn rf-data [data state] 438 | (let [rg (:references-graph data) 439 | vx-from-edges (reduce (fn [a [k {e :edges}]] (into a e)) #{} rg) 440 | graph (as-> rg $ 441 | ;;(reduce (fn [a {id :id}] (if (get a id) a (assoc a id {}))) $ (:entity data)) 442 | (reduce (fn [a id] (if (get a id) a (assoc a id {}))) $ vx-from-edges) 443 | (reduce (fn [a [k v]] (assoc a k (assoc v :x (Math/random) :y (Math/random)))) {} $))] 444 | (swap! state assoc 445 | :data graph 446 | ;;:vertexes-amount (count r) 447 | ;;:edges-amount (reduce (fn [a [_ {es :edges}]] (+ a (count es))) 0 r) 448 | ))) 449 | 450 | (defn main-page [params] 451 | ;;(prn "main-page" params) 452 | (let [state (r/atom {:repulsive-force 80 453 | :coupling-stiffness-factor 25 454 | :relative-edge-length 90 455 | ;;:show-vertex-names true 456 | ;;:vertexes-amount 30 457 | ;;:edges-amount 30 458 | ;;:input-graph "" 459 | :data {}})] 460 | ;;(random-data state) 461 | ;;(user-data state) 462 | 463 | (fn [params] 464 | ;;(prn "main-page-fn" params) 465 | (let [data @(rf/subscribe [::model/data])] 466 | (cond 467 | (:is-fetching data) [:div.loader "Loading"] 468 | 469 | (:error data) [:div (str (:error data))] 470 | 471 | :else [:div.page 472 | [style/style style] 473 | [nav/nav-bar] 474 | [:div.content 475 | ;;[:div (str @state)] 476 | [:span.bar 477 | [:div.btn-group 478 | [:button.btn {:on-click #(stop-go state) 479 | :class (if (:simulation-on @state) :red :green)} (if (:simulation-on @state) "Stop" "Go!")] 480 | [:button.btn {:on-click #(swap! state assoc :data {})} "Clear"]] 481 | [:label.label "repulsive force"] 482 | [ws/input-range {:state state 483 | :path [:repulsive-force]}] 484 | [:label.label "coupling stiffness factor"] 485 | [ws/input-range {:state state 486 | :path [:coupling-stiffness-factor]}] 487 | [:label.label "relative edge length"] 488 | [ws/input-range {:state state 489 | :min 10 490 | :path [:relative-edge-length]}] 491 | #_[:div.vertexes-names 492 | [:label.label "show vertex names"] 493 | [ws/input-checkbox {:state state 494 | :path [:show-vertex-names]}]] 495 | #_[:div.splitter] 496 | #_[:button.btn {:on-click #(rf-data data state)} "RF data"] 497 | #_[:button.btn {:on-click #(random-data state)} "Random data"] 498 | #_[:div.vertexes-edges 499 | [:label.label "vertices"] 500 | [ws/input-integer {:state state 501 | :path [:vertexes-amount] 502 | :class "input integer"}] 503 | [:label.label ""] 504 | [:label.label "edges"] 505 | [ws/input-integer {:state state 506 | :path [:edges-amount] 507 | :class "input integer"}]] 508 | #_[:div.splitter] 509 | #_[:button.btn {:on-click #(user-data state)} "Custom data"] 510 | #_[ws/input-textarea {:state state 511 | :path [:input-graph] 512 | :class "input edges-list"}] 513 | [:div.vertex-list 514 | (doall (map-indexed (fn [i x] 515 | (let [id (:id x)] 516 | [:div.menu-item {:key i 517 | :on-click (fn [] 518 | (if (get-in @state [:data id]) 519 | (swap! state update :data #(dissoc % id)) 520 | (swap! state update :data 521 | #(assoc % id (assoc (get (:references-graph data) id) 522 | :x (Math/random) :y (Math/random)))))) 523 | :class (if (get-in @state [:data id]) :added :not-added)} 524 | (str id " " (count (get-in data [:references-graph id :edges])))])) (:entity data)))] 525 | ] 526 | [area-component {:state state :data data}]]]))))) 527 | 528 | (def routes {:graph-view (fn [params] 529 | ;;(prn "graph-view --------------------------------------" params) 530 | (rf/dispatch [::model/load-all params]) 531 | [main-page (:query-params params)])}) 532 | -------------------------------------------------------------------------------- /src/fhir_face/model.cljs: -------------------------------------------------------------------------------- 1 | (ns fhir-face.model 2 | (:require [re-frame.core :as rf] 3 | [clojure.string :as str] 4 | [zframes.redirect :refer [href redirect]] 5 | [zframes.fetch :refer [fetch-promise error-data error-message]])) 6 | 7 | (def root-path [:main]) 8 | 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; Loader 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | 14 | 15 | #_(comment 16 | (defn dec-counter-check-finish [db] 17 | (let [counter-path (conj root-path :tmp :fetching-counter) 18 | fetching-counter (dec (or (get-in db counter-path) 0))] 19 | (cond-> (assoc-in db counter-path fetching-counter) 20 | (<= fetching-counter 0) 21 | (update-in root-path (fn [x] (-> x 22 | (update :data (fn [d] (merge 23 | (dissoc d :is-fetching) 24 | (-> (:tmp x) 25 | (dissoc :fetching-counter) 26 | ;;(update :query-params #(merge % (:query-params d))) 27 | )))) 28 | (dissoc :tmp))))))) 29 | (rf/reg-event-fx 30 | ::load-all 31 | (fn [{db :db} [_ {page :page params :query-params}]] 32 | ;; (prn "::load-all" params) 33 | (let [{:keys [type _text id]} params 34 | base-url (get-in db [:config :base-url]) 35 | token (get-in db [:auth :id_token]) 36 | data (get-in db (conj root-path :data)) 37 | fetch-vec (cond-> [] 38 | (nil? (:entity data)) 39 | (conj {:uri (str base-url "/Entity") 40 | :params {:_count 500 :.type "resource" :_sort ".id"} 41 | :token token 42 | :success {:event ::entity-loaded}}) 43 | 44 | (and type (not= type (get-in db (conj root-path :data :query-params :type)))) 45 | ;; http://localhost:8080/Attribute?_format=yaml&entity=Patient 46 | (conj {:uri (str base-url "/Attribute") 47 | :params {:entity type} 48 | :token token 49 | :success {:event ::resource-structure-loaded 50 | :params params}}) 51 | 52 | (and type (= :resource-grid page)) 53 | (conj {:uri (str base-url "/" type) 54 | :token token 55 | :params (cond-> {:_count 50} ;; :_sort "name"} 56 | (and _text (not (str/blank? _text))) (assoc :_text _text)) 57 | :success {:event ::resource-grid-loaded}}) 58 | 59 | (and type id (= :resource-edit page)) 60 | (conj {:uri (str base-url "/" type "/" id) 61 | :token token 62 | :success {:event ::resource-item-loaded}}) 63 | ) 64 | fetching-counter (count fetch-vec) 65 | new? (= :resource-new page) 66 | new-resource {:resourceType type}] 67 | (if (> fetching-counter 0) 68 | {:json/fetch fetch-vec 69 | :db (cond-> (-> db 70 | (assoc-in (conj root-path :tmp) {:fetching-counter fetching-counter 71 | :query-params params}) 72 | (assoc-in (conj root-path :data :is-fetching) true) 73 | (update-in (conj root-path :data) dissoc :error)) 74 | new? (assoc-in (conj root-path :tmp :resource) new-resource))} 75 | {:db (cond-> (-> db 76 | (update-in (conj root-path :data) dissoc :is-fetching) 77 | (update-in (conj root-path :data) dissoc :error)) 78 | new? (assoc-in (conj root-path :data :resource) new-resource))})))) 79 | 80 | (rf/reg-event-db 81 | ::entity-loaded 82 | (fn [db [_ {:keys [data]}]] 83 | ;;(prn "--------------- entity loaded") 84 | (-> db 85 | (assoc-in (conj root-path :tmp :entity) (mapv :resource (:entry data))) 86 | dec-counter-check-finish))) 87 | 88 | (rf/reg-event-db 89 | ::resource-structure-loaded 90 | (fn [db [_ {:keys [data params]}]] 91 | ;;(prn "--------------- structure loaded" params) 92 | (let [type (:type params) 93 | s (reduce (fn [a x] 94 | (update-in a 95 | (->> (:path x) (interpose :content) (mapv keyword)) 96 | #(merge % (cond-> x 97 | (:type x) (assoc ;;:type-full (:type x) 98 | :type (keyword (get-in x [:type :id]))) 99 | true (dissoc :resource :path :id :meta :resourceType))))) 100 | {} (mapv :resource (:entry data))) 101 | s-with-meta (merge s {:meta {:type :Meta} 102 | :resourceType {:type :code}})] 103 | (-> db 104 | (assoc-in (conj root-path :tmp :resource-structure) s-with-meta) 105 | ;;(assoc-in (conj root-path :tmp :type) type) 106 | dec-counter-check-finish)))) 107 | 108 | (rf/reg-event-db 109 | ::resource-grid-loaded 110 | (fn [db [_ {:keys [data]}]] 111 | ;;(prn "--------------- grid loaded") 112 | (-> db 113 | (assoc-in (conj root-path :tmp :resource-grid) (mapv :resource (:entry data))) 114 | dec-counter-check-finish))) 115 | 116 | (rf/reg-event-db 117 | ::resource-item-loaded 118 | (fn [db [_ {data :data}]] 119 | ;;(prn "--------------- item loaded") 120 | (-> db 121 | (assoc-in (conj root-path :tmp :resource) data) 122 | dec-counter-check-finish))) 123 | ) 124 | 125 | ;; Via promises 126 | 127 | (defn load-all-sansara [db [_ {page :page params :query-params}]] 128 | ;;(prn "test-fetch" page params) 129 | (let [{:keys [type _text id]} params 130 | base-url (get-in db [:config :base-url]) 131 | token (get-in db [:auth :id_token]) 132 | data (get-in db (conj root-path :data)) 133 | fp (fn [k] (conj root-path :data k)) 134 | fetching-path (fp :is-fetching) 135 | get-res-structure (fn [resp] 136 | (let [s (reduce (fn [a x] 137 | (update-in a 138 | (->> (:path x) (interpose :content) (mapv keyword)) 139 | #(merge % (cond-> x 140 | (:type x) (assoc ;;:type-full (:type x) 141 | :type (keyword (get-in x [:type :id]))) 142 | true (dissoc :resource :path :id :meta :resourceType))))) 143 | {} (mapv :resource (get-in resp [:data :entry]))) 144 | s-with-meta (merge s {:meta {:type :Meta} 145 | :resourceType {:type :code}})] 146 | s-with-meta))] 147 | 148 | ;; good series queries 149 | 150 | #_(-> (if (:entity data) (js/Promise.resolve nil) (fetch-promise {:uri (str base-url "/Entity") 151 | :params {:_count 500 :.type "resource" :_sort ".id"} 152 | :token token})) 153 | 154 | (.then (fn [x] (js/Promise.all [(cond-> {} 155 | x (assoc :entity (mapv :resource (get-in x [:data :entry])))) 156 | (if (and type (not= type (get-in data [:query-params :type]))) 157 | (fetch-promise {:uri (str base-url "/Attribute") 158 | :params {:entity type} 159 | :token token}))]))) 160 | (.then (fn [[x y]] (js/Promise.all [(cond-> x 161 | y (assoc :resource-structure (get-res-structure y))) 162 | (if (and type (= :resource-grid page)) 163 | (fetch-promise {:uri (str base-url "/" type) 164 | :token token 165 | :params (cond-> {:_count 50} ;; :_sort "name"} 166 | (and _text (not (str/blank? _text))) 167 | (assoc :_text _text))}))]))) 168 | (.then (fn [[x y]] (js/Promise.all [(cond-> x 169 | y (assoc :resource-grid (mapv :resource (get-in y [:data :entry])))) 170 | (if (and type id (= :resource-edit page)) 171 | (fetch-promise {:uri (str base-url "/" type "/" id) 172 | :token token}))]))) 173 | (.then (fn [[x y]] 174 | (let [r (cond-> x 175 | y (assoc :resource (:data y)))] 176 | (rf/dispatch [::set-values-by-paths 177 | (reduce (fn [a [k v]] (if v (assoc a (fp k) v) a)) 178 | {(fp :error) nil 179 | fetching-path false 180 | (fp :query-params) params} r)] 181 | )))) 182 | 183 | (.catch (fn [e] (rf/dispatch [::set-values-by-paths {(conj root-path :data :error) (str e) 184 | fetching-path false}])))) 185 | 186 | ;; parallel query 187 | 188 | (-> (js/Promise.all [(if-not (:entity data) 189 | (fetch-promise {:uri (str base-url "/Entity") 190 | :params {:_count 1000 :.type "resource" :_sort ".id"} 191 | :token token})) 192 | (if (and type (not= type (get-in data [:query-params :type]))) 193 | (fetch-promise {:uri (str base-url "/Attribute") 194 | :params {:entity type} 195 | :token token})) 196 | (if (and type (= :resource-grid page)) 197 | (fetch-promise {:uri (str base-url "/" type) 198 | :token token 199 | :params (cond-> {:_count 50} ;; :_sort "name"} 200 | (and _text (not (str/blank? _text))) (assoc :_text _text))})) 201 | (if (and type id (= :resource-edit page)) 202 | (fetch-promise {:uri (str base-url "/" type "/" id) 203 | :token token})) 204 | (if (and (= :graph-view page) (empty? (:references-graph data))) 205 | (fetch-promise {:uri (str base-url "/Attribute") 206 | :params {:_text "resourceType\"]" ;; id: Immunization.patient.resourceType, path: [patient, resourceType] 207 | :_count 2000 208 | :_elements "resource,enum"} 209 | :token token}))]) 210 | (.then (fn [[e a g i rg]] 211 | (rf/dispatch [::set-values-by-paths 212 | (cond-> {(fp :error) nil 213 | fetching-path false 214 | (fp :query-params) params} 215 | e (assoc (fp :entity) (mapv :resource (get-in e [:data :entry]))) 216 | a (assoc (fp :resource-structure) (get-res-structure a)) 217 | g (assoc (fp :resource-grid) (mapv :resource (get-in g [:data :entry]))) 218 | i (assoc (fp :resource) (:data i)) 219 | rg (assoc (fp :references-graph) 220 | (reduce (fn [a x] (update-in a [(get-in x [:resource :resource :id]) :edges] 221 | #(into (or % #{}) (set (get-in x [:resource :enum]))))) 222 | {} (get-in rg [:data :entry]))) 223 | (= :resource-new page) (assoc (fp :resource) {:resourceType type}) 224 | )]))) 225 | 226 | (.catch (fn [e] (rf/dispatch [::set-values-by-paths {(fp :error) (str e) 227 | fetching-path false}])))) 228 | 229 | #_(-> (js/Promise.resolve {:qqq 333}) 230 | (.then #(assoc-in % [:transit :zazaza] "zazaza"))) 231 | 232 | {:db (assoc-in db fetching-path true)} 233 | )) 234 | 235 | 236 | 237 | (defn load-all-hapi [db [_ {page :page params :query-params}]] 238 | ;;(prn "test-fetch" page params) 239 | (let [{:keys [type _text id]} params 240 | base-url (get-in db [:config :base-url]) 241 | token (get-in db [:auth :id_token]) 242 | data (get-in db (conj root-path :data)) 243 | fp (fn [k] (conj root-path :data k)) 244 | fetching-path (fp :is-fetching) 245 | get-res-structure (fn [resp] 246 | (let [s (reduce (fn [a x] 247 | (update-in a 248 | (->> (str/split (:path x) #"\.") rest (interpose :content) (mapv keyword)) 249 | #(merge % (cond-> x 250 | (:type x) (assoc ;;:type-full (:type x) 251 | :type (keyword (get-in x [:type 0 :code]))) 252 | 253 | (:type x) (assoc-in [:content :resourceType :enum] 254 | (mapv (fn [t] (last (str/split (:targetProfile t) #"/"))) (:type x))) 255 | ;;(get-in content [:resourceType :enum]) 256 | ;;:type [1 items] 257 | ;;{:code "Reference" 258 | ;; :targetProfile "http://hl7.org/fhir/StructureDefinition/Organization"} 259 | 260 | (< 0 (or (:min x) 0)) (assoc :isRequired true) 261 | (= "*" (:max x)) (assoc :isCollection true) 262 | (:short x) (assoc :description (:short x)) 263 | ;;true (dissoc :resource :path :id :meta :resourceType) 264 | )))) 265 | {} (get-in resp [:data :snapshot :element]) ;;(mapv :resource (get-in resp [:data :entry])) 266 | ) 267 | s-with-meta (merge s {:meta {:type :Meta} 268 | :resourceType {:type :code}})] 269 | s-with-meta)) 270 | get-ref-graph (fn [resp] 271 | (let [reference-set (fn [x] (reduce (fn [a t] 272 | (if (= "Reference" (:code t)) 273 | (conj a (last (str/split (:targetProfile t) #"/"))) 274 | a)) #{} x))] 275 | (reduce (fn [a {{:keys [type snapshot]} :resource}] 276 | (update-in a [type :edges] 277 | #(into (or % #{}) 278 | (reduce (fn [a {type :type}] (into a (reference-set type))) #{} (:element snapshot))))) 279 | {} (get-in resp [:data :entry])))) 280 | ] 281 | 282 | (-> (js/Promise.all [#_(if-not (:entity data) 283 | (fetch-promise {:uri (str base-url "/Entity") 284 | :params {:_count 1000 :.type "resource" :_sort ".id"} 285 | :token token})) 286 | #_(if (and type (not= type (get-in data [:query-params :type]))) 287 | (fetch-promise {:uri (str base-url "/Attribute") 288 | :params {:entity type} 289 | :token token})) 290 | #_(if (and type (= :resource-grid page)) 291 | (fetch-promise {:uri (str base-url "/" type) 292 | :token token 293 | :params (cond-> {:_count 50} ;; :_sort "name"} 294 | (and _text (not (str/blank? _text))) (assoc :_text _text))})) 295 | #_(if (and type id (= :resource-edit page)) 296 | (fetch-promise {:uri (str base-url "/" type "/" id) 297 | :token token})) 298 | #_(if (and (= :graph-view page) (empty? (:references-graph data))) 299 | (fetch-promise {:uri (str base-url "/Attribute") 300 | :params {:_text "resourceType\"]" ;; id: Immunization.patient.resourceType, path: [patient, resourceType] 301 | :_count 2000 302 | :_elements "resource,enum"} 303 | :token token})) 304 | 305 | 306 | (if-not (:entity data) 307 | (fetch-promise {:uri (str base-url "/StructureDefinition") 308 | :params {:_count 1000 309 | :_elements "id,name,type,url" 310 | :_sort "type" 311 | ;;:type "Location" 312 | :derivation "specialization" 313 | :base "http://hl7.org/fhir/StructureDefinition/DomainResource"} 314 | :token token})) 315 | 316 | (if (and type (not= type (get-in data [:query-params :type]))) 317 | (fetch-promise {:uri (str base-url "/StructureDefinition/" type) 318 | ;;:params {:entity type} 319 | :token token})) 320 | 321 | (if (and type (= :resource-grid page)) 322 | (fetch-promise {:uri (str base-url "/" type) 323 | :token token 324 | :params (cond-> {:_count 50} ;; :_sort "name"} 325 | (and _text (not (str/blank? _text))) (assoc :_content _text))})) 326 | 327 | (if (and type id (= :resource-edit page)) 328 | (fetch-promise {:uri (str base-url "/" type "/" id) 329 | :token token})) 330 | 331 | (if (and (= :graph-view page) (empty? (:references-graph data))) 332 | (fetch-promise {:uri (str base-url "/StructureDefinition") 333 | :params {:_count 1000 334 | :derivation "specialization" 335 | :base "http://hl7.org/fhir/StructureDefinition/DomainResource"} 336 | :token token})) 337 | 338 | #_(fetch-promise {:uri (str base-url "/StructureDefinition") 339 | :params {:_count 1000 :type "Location" } 340 | :token token}) 341 | 342 | ]) 343 | (.then (fn [[e a g i rg]] 344 | (rf/dispatch [::set-values-by-paths 345 | (cond-> {(fp :error) nil 346 | fetching-path false 347 | (fp :query-params) params} 348 | e (assoc (fp :entity) (mapv (fn [x] {:id (get-in x [:resource :type])}) (get-in e [:data :entry]))) 349 | a (assoc (fp :resource-structure) (get-res-structure a)) 350 | g (assoc (fp :resource-grid) (mapv :resource (get-in g [:data :entry]))) 351 | i (assoc (fp :resource) (:data i)) 352 | rg (assoc (fp :references-graph) (get-ref-graph rg)) 353 | (= :resource-new page) (assoc (fp :resource) {:resourceType type}) 354 | 355 | ;;zzz (assoc (fp :zzz) (:data zzz) #_(mapv :resource (get-in zzz [:data :entry]))) 356 | )]))) 357 | 358 | (.catch (fn [e] (rf/dispatch [::set-values-by-paths {(fp :error) (str e) 359 | fetching-path false}])))) 360 | 361 | #_(-> (js/Promise.resolve {:qqq 333}) 362 | (.then #(assoc-in % [:transit :zazaza] "zazaza"))) 363 | 364 | {:db (assoc-in db fetching-path true)} 365 | )) 366 | 367 | 368 | (rf/reg-event-fx 369 | ::load-all 370 | (fn [{db :db} args] 371 | ((case (get-in db [:config :settings :fhir-server-type]) 372 | :hapi load-all-hapi 373 | load-all-sansara) 374 | db args))) 375 | 376 | 377 | 378 | #_(rf/reg-event-fx 379 | ::load-attribute 380 | (fn [{db :db} [_ {page :page params :query-params}]] 381 | ;;(prn "test-fetch" page params) 382 | (let [;;{:keys [type _text id]} params 383 | base-url (get-in db [:config :base-url]) 384 | token (get-in db [:auth :id_token]) 385 | data (get-in db (conj root-path :data)) 386 | fp (fn [k] (conj root-path :data k)) 387 | fetching-path (fp :is-fetching) 388 | ] 389 | 390 | 391 | ;;enum: [DiagnosticReport, ImagingStudy, Immunization, MedicationAdministration, 392 | ;; MedicationDispense, Observation, Procedure, SupplyDelivery] 393 | ;;resource: {id: ChargeItem, resourceType: Entity} 394 | 395 | (-> (fetch-promise {:uri (str base-url "/Attribute") 396 | :params {:_text "resourceType\"]" 397 | :_count 2000 398 | :_elements "resource,enum"} 399 | ;;id: Immunization.patient.resourceType 400 | ;;enum: [Patient] 401 | ;;path: [patient, resourceType] 402 | :token token}) 403 | (.then (fn [x] (rf/dispatch [::set-values-by-paths 404 | {(fp :error) nil 405 | fetching-path false 406 | ;;(fp :query-params) params 407 | (fp :resource-graph) ;;(mapv :resource (get-in x [:data :entry])) 408 | (reduce (fn [a x] (update-in a [(get-in x [:resource :resource :id]) :edges] 409 | #(into (or % #{}) (set (get-in x [:resource :enum]))))) 410 | {} (get-in x [:data :entry])) 411 | 412 | }]))) 413 | 414 | (.catch (fn [e] (rf/dispatch [::set-values-by-paths {(fp :error) (str e) 415 | fetching-path false}])))) 416 | {:db (assoc-in db fetching-path true)}))) 417 | 418 | (rf/reg-sub 419 | ::data 420 | (fn [db] (get-in db (conj root-path :data)))) 421 | 422 | 423 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 424 | ;; UI actions 425 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 426 | 427 | 428 | (rf/reg-event-db 429 | ::set-value 430 | (fn [db [_ path v]] (assoc-in db (into (conj root-path :data :resource) path) v))) 431 | 432 | ;; (defn add-del-val [db path data-key v] 433 | ;; (let [k (last path)] 434 | 435 | ;; (prn path data-key v) 436 | 437 | ;; (update-in db (into (conj root-path :data data-key) (butlast path)) 438 | ;; #(if (contains? % k) (dissoc % k) (assoc % k v))))) 439 | 440 | (def expand-existing-item {}) 441 | (def expand-non-existing-item nil) 442 | 443 | (defn to-expand-structure [r] 444 | (cond 445 | (map? r) (reduce (fn [a [k v]] (assoc a k (to-expand-structure v))) {} r) 446 | (vector? r) (mapv to-expand-structure r) 447 | #_(:a (reduce (fn [{a :a i :i} v] {:a (assoc a i (to-expand-structure v)) :i (inc i)}) {:a {} :i 0} r)) 448 | :else expand-existing-item)) 449 | 450 | (defn get-expanded-structure [db path] (to-expand-structure (get-in db (into (conj root-path :data :resource) path)))) 451 | 452 | (defn to-expand-structure-1l [r] 453 | (cond 454 | ;;(map? r) (reduce (fn [a [k v]] (assoc a k expand-existing-item)) {} r) 455 | (vector? r) (mapv (fn [_] expand-non-existing-item) r) ;;(mapv (fn [_] expand-existing-item) r) 456 | :else expand-existing-item)) 457 | 458 | (defn get-expanded-structure-1l [db path] (to-expand-structure-1l (get-in db (into (conj root-path :data :resource) path)))) 459 | 460 | ;; ;;(defn assoc-in* [m keys v] (let [x (get-in m keys)] (if (or (nil? x) (map? x)) (assoc-in m keys v) m))) 461 | 462 | ;; (defn collapse-node [db path] 463 | ;; ;;(update-in db (into (conj root-path :data :resource-expands) (butlast path)) #(dissoc % (last path))) 464 | ;; (assoc-in db (into (conj root-path :data :resource-expands) path) false)) 465 | 466 | ;; (defn expand-node [db path] 467 | ;; ;;(update-in db (into (conj root-path :data :resource-expands) (butlast path)) #(assoc % (last path) expand-existing-item)) 468 | ;; (assoc-in db (into (conj root-path :data :resource-expands) path) expand-existing-item)) 469 | 470 | ;; (defn expand-node-deep [db path] 471 | ;; #_(update-in db (into (conj root-path :data :resource-expands) (butlast path)) 472 | ;; #(assoc % (last path) (to-expand-structure (get-in db (into (conj root-path :data :resource) path))))) 473 | ;; (assoc-in db (into (conj root-path :data :resource-expands) path) 474 | ;; (to-expand-structure (get-in db (into (conj root-path :data :resource) path))))) 475 | 476 | (rf/reg-event-db 477 | ::delete-collection-item 478 | (fn [db [_ path i]] 479 | ;;(prn "::delete-collection-item" path i) 480 | (let [del-ind (fn [v] (vec (concat (subvec v 0 i) (subvec v (inc i)))))] 481 | (-> db 482 | (update-in (into (conj root-path :data :resource) path) del-ind) 483 | (update-in (into (conj root-path :data :resource-expands) path) del-ind))))) 484 | 485 | (rf/reg-event-db 486 | ::add-collection-item 487 | (fn [db [_ path]] 488 | ;;(prn "::add-collection-item" path) 489 | (-> db 490 | (update-in (into (conj root-path :data :resource) path) #(conj (or % []) nil)) 491 | (update-in (into (conj root-path :data :resource-expands) path) #(conj (if (vector? %) % []) expand-existing-item))))) 492 | 493 | 494 | (rf/reg-event-db 495 | ::attribute-on-off 496 | (fn [db [_ path]] 497 | ;;(prn "::attribute-on-off") 498 | (let [k (last path) 499 | pre-path (into (conj root-path :data :resource) (butlast path)) 500 | exp-path (into (conj root-path :data :resource-expands) path)] 501 | #_(update-in (into (conj root-path :data :resource) (butlast path)) 502 | #(if (contains? % k) (dissoc % k) (assoc % k nil))) 503 | (if (contains? (get-in db pre-path) k) 504 | (-> db 505 | (update-in pre-path #(dissoc % k)) 506 | (assoc-in exp-path expand-non-existing-item)) 507 | (-> db 508 | (update-in pre-path #(assoc % k nil)) 509 | (assoc-in exp-path (get-expanded-structure db path))))))) 510 | 511 | 512 | (defn swap-val-nil [db path val] 513 | (let [full-path (into (conj root-path :data :resource-expands) path) 514 | v (get-in db full-path)] 515 | (assoc-in db full-path (if v expand-non-existing-item val)))) 516 | 517 | (rf/reg-event-db 518 | ::expand-collapse-node 519 | (fn [db [_ path]] 520 | ;;(prn "::expand-collapse-node" path) 521 | (swap-val-nil db path (get-expanded-structure-1l db path)))) 522 | 523 | (rf/reg-event-db 524 | ::expand-collapse-node-deep 525 | (fn [db [_ path]] 526 | ;;(prn "::expand-collapse-node-deep" path) 527 | (swap-val-nil db path (get-expanded-structure db path)))) 528 | 529 | (rf/reg-event-db 530 | ::expand-all 531 | (fn [db _] 532 | (assoc-in db (conj root-path :data :resource-expands) 533 | ;;(to-expand-structure (get-in db (conj root-path :data :resource))) 534 | (get-expanded-structure db [])))) 535 | 536 | (rf/reg-event-db 537 | ::collapse-all 538 | (fn [db _] (update-in db (conj root-path :data) #(dissoc % :resource-expands)))) 539 | 540 | 541 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 542 | ;; Saver 543 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 544 | 545 | #_(comment 546 | (rf/reg-event-fx 547 | ::save-resource 548 | (fn [{db :db} [_ {:keys [type id] :as params}]] 549 | ;;(prn "::save-resource" params type) 550 | (let [base-url (get-in db [:config :base-url]) 551 | res (get-in db (conj root-path :data :resource)) 552 | ;;id (:id res) 553 | ] 554 | {:db (update-in db (conj root-path :data) dissoc :error) 555 | :json/fetch 556 | (merge {:body res 557 | :token (get-in db [:auth :id_token]) 558 | :success {:event ::save-resource-success} 559 | :error {:event ::save-resource-error}} 560 | (if id 561 | {:uri (str base-url "/" type "/" id) 562 | :method "PUT"} 563 | {:uri (str base-url "/" type) 564 | :method "POST"}))}))) 565 | 566 | (rf/reg-event-fx 567 | ::save-resource-success 568 | (fn [{db :db} [_ {data :data}]] 569 | (redirect (href "resource" {:type (:resourceType data)})) 570 | {})) 571 | 572 | (rf/reg-event-fx 573 | ::save-resource-error 574 | (fn [{db :db} [_ {data :data}]] 575 | {:db (assoc-in db (conj root-path :data :error) data)})) 576 | ) 577 | 578 | 579 | ;; Via promises 580 | 581 | (rf/reg-event-fx 582 | ::save-resource 583 | (fn [{db :db} [_ {:keys [type id] :as params}]] 584 | ;;(prn "::save-resource" params type) 585 | (let [base-url (get-in db [:config :base-url]) 586 | res (get-in db (conj root-path :data :resource)) 587 | ;;id (:id res) 588 | ] 589 | (-> (fetch-promise (merge {:body res 590 | :token (get-in db [:auth :id_token])} 591 | (if id 592 | {:uri (str base-url "/" type "/" id) 593 | :method "PUT"} 594 | {:uri (str base-url "/" type) 595 | :method "POST"}))) 596 | (.then (fn [_] (rf/dispatch [::set-values-by-paths {(conj root-path :data :is-fetching) false}]))) 597 | (.then (fn [_] (redirect (href "resource" {:type type})))) 598 | (.catch (fn [e] (rf/dispatch [::set-values-by-paths {(conj root-path :data :error) 599 | (or 600 | (dissoc (:data (error-data e)) :resourceType) 601 | (error-message e)) 602 | (conj root-path :data :is-fetching) false}])))) 603 | {:db (update-in db (conj root-path :data) #(-> % 604 | (dissoc :error) 605 | #_(assoc :is-fetching true)))}))) 606 | 607 | 608 | (rf/reg-event-db 609 | ::set-values-by-paths 610 | (fn [db [_ paths-values]] (reduce (fn [a [k v]] ((if (vector? k) assoc-in assoc) a k v)) db paths-values))) 611 | 612 | 613 | 614 | #_(comment 615 | ;; https://gist.github.com/pesterhazy/74dd6dc1246f47eb2b9cd48a1eafe649 616 | (ns my.promises 617 | "Demo to show different approaches to handling promise chains in ClojureScript 618 | In particular, this file investigates how to pass data between Promise 619 | callbacks in a chain. 620 | See Axel Rauschmayer's post 621 | http://2ality.com/2017/08/promise-callback-data-flow.html for a problem 622 | statement. 623 | The examples is this: based on n, calculate (+ (square n) n), but with each step 624 | calculated asynchronously. The problem for a Promise-based solution is that the 625 | sum step needs access to a previous value, n. 626 | Axel's solution 1 is stateful and not idiomatic in Clojurescript. 627 | Solution 1 (nested scopes) is implemented in test3. 628 | Solution 2 (multiple return values) is implemented in test1 and test2. 629 | For reference, a synchronous implementation is implemented in test0." 630 | (:refer-clojure :exclude [resolve])) 631 | 632 | (enable-console-print!) 633 | 634 | ;; helpers for working with promises in CLJS 635 | 636 | (defn every [& args] 637 | (js/Promise.all (into-array args))) 638 | 639 | (defn soon 640 | "Simulate an asynchronous result" 641 | ([v] (soon v identity)) 642 | ([v f] (js/Promise. (fn [resolve] 643 | (js/setTimeout #(resolve (f v)) 644 | 500))))) 645 | 646 | (defn resolve [v] 647 | (js/Promise.resolve v)) 648 | 649 | ;; helpers 650 | 651 | (defn square [n] (* n n)) 652 | 653 | ;; test0 654 | 655 | (defn test0 656 | "Synchronous version - for comparison 657 | The code has three steps: 658 | - get value for n 659 | - get square of n 660 | - get sum of n and n-squared 661 | Note that step 3 requires access to the original value, n, and to the computed 662 | value, n-squared." 663 | [] 664 | (let [n 5 665 | n-squared (square 5) 666 | result (+ n n-squared)] 667 | (prn result))) 668 | 669 | ;; test1 670 | 671 | (defn square-step [n] 672 | (soon (every n (soon n square)))) 673 | 674 | (defn sum-step [[n squared-n]] ;; Note: CLJS destructuring works with JS arrays 675 | (soon (+ n squared-n))) 676 | 677 | (defn test1 678 | "Array approach, flat chain: thread multiple values through promise chain by using Promise.all" 679 | [] 680 | (-> (resolve 5) 681 | (.then square-step) 682 | (.then sum-step) 683 | (.then prn))) 684 | 685 | ;; test2 686 | 687 | (defn to-map-step [array] 688 | (zipmap [:n :n-squared] array)) 689 | 690 | (defn sum2-step [{:keys [n n-squared] :as m}] 691 | (soon (assoc m :result (+ n n-squared)))) 692 | 693 | (defn test2 694 | "Accumulative map approach, flat chain: add values to CLJS map in each `then` step, making 695 | it possible for later members of the chain to access previous results" 696 | [] 697 | (-> (resolve 5) 698 | (.then square-step) 699 | (.then to-map-step) 700 | (.then sum2-step) 701 | ;; Note: `(.then :result)` doesn't work because `:result` is not 702 | ;; recognized as a function. So we need to wrap it in an anon fn. 703 | ;; This could be easily fixed by adding a CLJS `then` function that 704 | ;; has a more inclusive notion of what a function is. 705 | (.then #(:result %)) 706 | (.then prn))) 707 | 708 | ;; test3 709 | 710 | (defn square-step-fn [n] 711 | ;; This could be called a "resolver factory" fn. It's a higher-order function 712 | ;; that returns a resolve function. `n` is captured in a closure. 713 | (fn [n-squared] 714 | (soon (+ n n-squared)))) 715 | 716 | (defn square-and-sum-step [n] 717 | (-> (soon (square n)) 718 | ;; note that square-step-fn is _called_ here, not referenced, in order to 719 | ;; provide its inner body with access to the previous result, `n`. 720 | (.then (square-step-fn n)))) 721 | 722 | (defn test3 723 | "Nested chain approach: instead of a flat list, use a hierarchy, nesting one Promise chain in another. 724 | Uses a closure to capture the intermediate result, `n`, making it available to the nested chain." 725 | [] 726 | (-> (resolve 5) 727 | (.then square-and-sum-step) 728 | (.then prn))) 729 | 730 | ) 731 | --------------------------------------------------------------------------------