conlink 2.0.0

package/src/conlink/net2dot.cljs

@@ -0,0 +1,158 @@
+#!/usr/bin/env nbb
+
+(ns conlink.net2dot
+  (:require [clojure.string :as S]
+            [clojure.pprint :refer [pprint]]
+            [promesa.core :as P]
+            [conlink.util :refer [parse-opts Eprintln Epprint fatal]]
+            [conlink.core :as conlink]))
+            
+(def usage "
+net2dot: convert conlink network config to GraphViz/dot representation.
+
+Usage:
+  net2dot [options]
+
+Options:
+  -v, --verbose                     Show verbose output (stderr)
+                                    [env: VERBOSE]
+  --network-file NETWORK-FILE...    Network config file
+  --compose-file COMPOSE-FILE...    Docker compose file with network config
+")
+
+(def DEFAULT-PROPS "shape=box fontsize=12 style=filled penwidth=1")
+(def CONLINK-PROPS  "style=\"rounded,filled\" fillcolor = \"#c1b5c7\" color = \"#9673a6\"")
+(def BRIDGE-PROPS "style= filled fillcolor=\"#dae8fc\" color=\"#6c8ebf\"")
+(def HOST-PROPS "style=filled fillcolor=\"#f5f5f5\" color=\"#666666\"")
+(def TUNNEL-PROPS "fillcolor=\"#a5a5a5\" color=\"#888888\"")
+(def CONTAINER-PROPS "style=\"rounded,filled\" fillcolor = \"#e1d5e7\" color = \"#9673a6\"")
+(def SERVICE-PROPS (str CONTAINER-PROPS " fillcolor = \"#d1c5e7\" penwidth = 2"))
+(def INTF-PROPS "width=0.1 height=0.1 fontsize=10 fillcolor=\"#ffbb9e\" color=\"#d7db00\"")
+(def NIC-PROPS "fontsize=12 fillcolor=\"#ffbb9e\" color=\"#d7db00\"")
+
+(set! conlink/INTF-MAX-LEN 100)
+
+(defn dot-id [n]
+  (-> n
+      (S/replace #"[:]" "_COLON_")
+      (S/replace #"[-]" "_DASH_")
+      (S/replace #"[*]" "_STAR_")
+      (S/replace #"[$]" "_DOLLAR_")
+      (S/replace #"[{]" "_LCURLY_")
+      (S/replace #"[}]" "_LCURLY_")
+      (S/replace #"[ ]" "_SPACE_")))
+
+(defn digraph [links tunnels]
+  (let [veth-links (filter #(= :veth (:type %)) links)
+        vlan-links (filter #(conlink/VLAN-TYPES (:type %)) links)]
+    (S/join
+      "\n"
+      (flatten
+        [(str "digraph D {")
+         (str "  splines = true;")
+         (str "  compound = true;")
+         (str "  node [" DEFAULT-PROPS "];")
+
+         ""
+         " // host system"
+         (str "  subgraph cluster_host {")
+         (str "    label = \"host system\";")
+         (str "    " HOST-PROPS ";")
+
+         ""
+         "    // main link nodes"
+         (for [{:keys [dev dev-id]} links]
+           (str "    " (dot-id dev-id) " [label=\"" dev "\" " INTF-PROPS "];"))
+
+         ""
+         "    // containers and their links/interfaces"
+         (for [[container-name links] (group-by (comp :name :container) links)]
+           [(str "    subgraph cluster_" (dot-id container-name) " {")
+            (str "      label = \"" (:container-label (first links)) "\";")
+            (if (:service (first links))
+              (str "      " SERVICE-PROPS ";")
+              (str "      " CONTAINER-PROPS ";"))
+            (for [link links]
+              (str "      " (dot-id (:dev-id link))))
+            (str "    }")])
+
+         ""
+         "    // bridges, tunnels, veth connections"
+         (str "    subgraph cluster_conlink {")
+         (str "      label = \"conlink/network\";")
+         (str "      " CONLINK-PROPS ";")
+         (for [bridge (set (keep :bridge veth-links))
+               :let [blinks (filter #(= bridge (:bridge %)) veth-links)]]
+           [(str "      subgraph cluster_bridge_" (dot-id bridge) " {")
+            (str "        label = \"" bridge "\";")
+            (str "        " BRIDGE-PROPS ";")
+            (str "        bridge_"  (dot-id bridge) " [shape=point style=invis];")
+            (for [{:keys [dev-id outer-dev]} blinks]
+              [(str "        " (dot-id outer-dev)
+                   " [label=\"" outer-dev "\" " INTF-PROPS "];")
+               (str "        " (dot-id dev-id) " -> " (dot-id outer-dev))])
+            (for [{:keys [bridge outer-dev]} tunnels]
+              (str "        " (dot-id outer-dev)
+                   " [label=\"" outer-dev "\" " INTF-PROPS "];"))
+            (str "      }")])
+         (str "    }")
+
+         ""
+         "    // vlan/vtap links"
+         (for [outer-dev (set (keep :outer-dev vlan-links))
+               :let [olinks (filter #(= outer-dev (:outer-dev %)) vlan-links)]]
+           [(str "    " (dot-id outer-dev) " [label=\"" outer-dev "\" " NIC-PROPS "];")
+            (for [{:keys [dev-id outer-dev type vlanid vni ip]} olinks
+                  :let [label (str (name type) (when vlanid
+                                                 (str " " vlanid)))]]
+              (str "    " (dot-id dev-id) " -> " (dot-id outer-dev)
+                   " [label=\"" label "\"];"))])
+
+         "  // end of host system"
+         (str "  }")
+
+         ""
+         "  // remote hosts and tunnels links"
+         (for [{:keys [outer-dev remote]} tunnels]
+           [(str "  " (dot-id remote)
+                 " [label=\"remote host '" remote "'\" " TUNNEL-PROPS "];")
+            (str "  " (dot-id outer-dev) " -> " (dot-id remote)) ])
+
+         "}\n"]))))
+
+(defn enrich-link [{:as link :keys [service container]}]
+  (let [name (if service
+               (str "S_" service) #_(str "*_" service "_*")
+               container)
+        clabel (if service
+                 (str "service '"service "'")
+                 (str "container '" container "'"))
+        container {:id "CID"
+                   :pid 3
+                   :index 1
+                   :name name}]
+    (merge
+      (conlink/link-instance-enrich link container 2)
+      {:container-label clabel})))
+
+(defn enrich-tunnel [tunnel]
+  (conlink/tunnel-instance-enrich tunnel 2))
+
+
+(defn main
+  [& args]
+  (P/let
+    [{:keys [verbose compose-file network-file]} (parse-opts usage args)
+     _ (when (and (empty? network-file) (empty? compose-file))
+         (fatal 2 "either --network-file or --compose-file is required"))
+     network-config (P/-> (conlink/load-configs compose-file network-file)
+                          (conlink/enrich-network-config))
+     links (map enrich-link (:links network-config))
+     tunnels (map enrich-tunnel (:tunnels network-config))
+     dot-graph (digraph links tunnels)]
+    (when verbose
+      (Eprintln "Links:")
+      (Epprint links)
+      (Eprintln "Tunnels:")
+      (Epprint tunnels))
+    (println dot-graph)))

package/src/conlink/util.cljs

@@ -0,0 +1,140 @@
+(ns conlink.util
+  (:require [cljs.pprint :refer [pprint]]
+            [clojure.string :as S]
+            [clojure.walk :refer [postwalk]]
+            [clojure.edn :as edn]
+            [promesa.core :as P]
+            [cljs-bean.core :refer [->clj]]
+            ["util" :refer [promisify]]
+            ["fs" :as fs]
+            ["child_process" :as cp]
+            ["neodoc" :as neodoc]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Argument processing
+(defn clean-opts [arg-map]
+  (reduce (fn [o [a v]]
+            (let [k (keyword (S/replace a #"^[-<]*([^>]*)[>]*$" "$1"))]
+              (assoc o k (or (get o k) v))))
+          {} arg-map))
+
+(defn parse-opts [usage argv & [opts]]
+  (-> usage
+      (neodoc/run (clj->js (merge {:optionsFirst true
+                                   :smartOptions true
+                                   :argv (or argv [])}
+                                  opts)))
+      js->clj
+      clean-opts))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; General functions
+
+(def Eprn     #(binding [*print-fn* *print-err-fn*] (apply prn %&)))
+(def Eprintln #(binding [*print-fn* *print-err-fn*] (apply println %&)))
+(def Epprint  #(binding [*print-fn* *print-err-fn*] (pprint %)))
+
+(defn fatal [code & args]
+  (when (seq args)
+    (apply Eprintln args))
+  (js/process.exit code))
+
+(defn deep-merge [a b]
+  (merge-with #(cond (map? %1) (recur %1 %2)
+                     (vector? %1) (vec (concat %1 %2))
+                     (sequential? %1) (concat %1 %2)
+                     :else %2)
+              a b))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; String functions
+
+(defn snake->pascal [v]
+  (S/join
+    "" (for [[chr1 & chrN] (-> v .toLowerCase (S/split #"-"))]
+         (apply str (.toUpperCase chr1) chrN))))
+
+(defn pascal->snake [v]
+  (.toLowerCase
+    (S/join "-" (re-seq #"[^a-z]+[a-z]*[^A-Z]*" v))))
+
+(defn trim [s] (S/replace s #"\s*$" ""))
+
+(defn right-pad [s pad]
+  (.padEnd (str s) pad " "))
+
+(defn left-pad [s pad]
+  (.padStart (str s) pad " "))
+
+(defn indent [s pre]
+  (-> s
+      (S/replace #"[\n]*$" "")
+      (S/replace #"(^|[\n])" (str "$1" pre))))
+
+(def INTERPOLATE-RE (js/RegExp. "[$](?:([$])|([_a-z][_a-z0-9]*)|{([_a-z][_a-z0-9]*)(?:(:?[-?])([^}]*))?}|())" "gi"))
+
+(defn interpolate [s env]
+  (.replaceAll
+    s INTERPOLATE-RE
+    (fn [_ escaped named braced sep value invalid offset groups]
+      (cond escaped "$"
+            named   (get env named "")
+            sep     (let [unset? (not (contains? env braced))
+                          unset-or-null? (empty? (get env braced nil))]
+                      (condp = sep
+                        ":-" (if unset-or-null? value (get env braced))
+                        "-"  (if unset? value (get env braced))
+                        ":?" (when unset-or-null? (throw (js/Error value)))
+                        "?"  (when unset? (throw (js/Error value)))))
+            braced (get env braced "")
+            invalid (str "$" invalid)))))
+
+(defn interpolate-walk [o env]
+  (postwalk #(if (string? %) (interpolate % env) %) o))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Promise-based exec and file functions
+
+(def exec-promise (promisify cp/exec))
+(defn exec [cmd & [opts]]
+  (P/let [opts (merge {:encoding "utf8" :stdio "pipe"} opts)
+          res (exec-promise cmd (clj->js opts))]
+    (->clj res)))
+(defn spawn [cmd & [opts]]
+  (P/create
+    (fn [resolve reject]
+      (let [opts (merge {:stdio "pipe" :shell true} opts)
+            res (atom {:stdout [] :stderr []})
+            res-fn (fn [code]
+                     {:code code
+                      :stdout (S/join "" (:stdout @res))
+                      :stderr (S/join "" (:stderr @res))})
+            child (doto (cp/spawn cmd (clj->js opts))
+                    (.on "close" (fn [code]
+                                   (if (= 0 code)
+                                     (resolve (res-fn code))
+                                     (reject (res-fn code))))))]
+        (when-let [stdout (.-stdout child)]
+          (.setEncoding stdout "utf8")
+          (.on stdout "data" #(swap! res update :stdout conj %)))
+        (when-let [stderr (.-stderr child)]
+          (.setEncoding stderr "utf8")
+          (.on stderr "data" #(swap! res update :stderr conj %)))))))
+
+(def read-file (promisify fs/readFile))
+(def write-file (promisify fs/writeFile))
+
+(defn load-config [file]
+  (P/let [raw (P/-> file read-file .toString)
+          cfg (cond
+                (re-seq #".*\.(yml|yaml)$" file)
+                (.parse (js/require "yaml") raw)
+
+                (re-seq #".*\.json$" file)
+                (js/JSON.parse raw)
+
+                (re-seq #".*\.edn$" file)
+                (edn/read-string raw))]
+    (->clj cfg)))
+

package/tests/invalid-schema-1.yaml

@@ -0,0 +1,6 @@
+# should pass
+links:
+  - {service: internet, type: dummy, dev: i0,   ip: 8.8.8.8/24}
+
+# should fail
+commands: "abc"

package/tests/invalid-schema-2.yaml

@@ -0,0 +1,6 @@
+# should pass
+links:
+  - {service: internet, type: dummy, dev: i0,   ip: 8.8.8.8/24}
+
+# should fail
+something-else: "abc"

package/tests/invalid-schema-3.yaml

@@ -0,0 +1,17 @@
+# type and veth type requires bridge
+
+links:
+  # should pass
+  - {service: node, type: dummy}
+  - {service: node, type: veth, bridge: s1}
+  - {service: node, bridge: s1}
+  - {service: node, type: vlan, vlanid: 100}
+
+  # Should error
+  - {service: node, type: magic}
+  - {service: node, type: veth}
+  - {service: node}
+  - {service: node, type: vlan}
+  - {service: node, bridge: s1, vlanid: 100}
+
+

package/tests/invalid-schema-4.yaml

@@ -0,0 +1,14 @@
+links:
+  # should pass
+  - {service: node, bridge: s1, ip: 10.0.1.1/16}
+  - {service: node, bridge: s1, mac: "00:11:99:00:00:99"}
+  - {service: node, bridge: s1, mac: "00:11:99:0a:0b:ff"}
+
+  # Should error
+  - {service: node, bridge: s1, ip: 10.0.1}
+  - {service: node, bridge: s1, ip: 10.0.1.1}
+  - {service: node, bridge: s1, ip: 1011.0.1.1/16}
+  - {service: node, bridge: s1, mac: "00:11:99:0a:0b"}
+  - {service: node, bridge: s1, mac: "00:11:99:0a:0b:fg"}
+
+

package/tests/invalid-schema-5.yaml

@@ -0,0 +1,12 @@
+# type and veth type requires bridge
+
+links:
+  # should pass
+  - {service: node, bridge: s1}
+  - {container: node, bridge: s1}
+
+  # Should fail
+  - {type: veth, bridge: s1}
+  - {bridge: s1}
+
+

package/tests/invalid-schema-6.yaml

@@ -0,0 +1,12 @@
+
+links:
+  # should pass
+  - {service: node, bridge: s1}
+
+tunnels:
+  # should pass
+  - {type: geneve, bridge: s1, remote: 1.1.1.1, vni: 1001}
+
+  # Should error
+  - {type: geneve,             remote: 1.1.1.1, vni: 1001}
+

package/tmp/conlink/.env

@@ -0,0 +1 @@
+blah