summaryrefslogtreecommitdiff
path: root/lisp/webapps
diff options
context:
space:
mode:
authorBret Koppel <bret@olo.com>2025-10-07 09:00:37 -0400
committerGitHub <noreply@github.com>2025-10-07 09:00:37 -0400
commit910d7fd656b9e957181732b36761449de5a970d1 (patch)
tree0f8ee46af3e93aa489785d64d54c5e155ef0057b /lisp/webapps
parent9adba239b937df2830a5110adaa1dae17b7dd7d7 (diff)
parent0ad86ba37be273ee1fe4d9bdd5f7bb15c5701abf (diff)
Merge pull request #1 from ololabs/initial-commit
initial commit
Diffstat (limited to 'lisp/webapps')
l---------lisp/webapps/snow/cljs-out1
-rw-r--r--lisp/webapps/snow/clojurescript/snow/.gitignore16
-rw-r--r--lisp/webapps/snow/clojurescript/snow/dev.cljs.edn2
-rw-r--r--lisp/webapps/snow/clojurescript/snow/project.clj20
-rw-r--r--lisp/webapps/snow/clojurescript/snow/src/core.cljs688
l---------lisp/webapps/snow/conf/options.lisp1
-rw-r--r--lisp/webapps/snow/site.lisp158
-rw-r--r--lisp/webapps/snow/static/css/stylesheet.css25
-rw-r--r--lisp/webapps/snow/static/images/olo-logo.svg24
-rw-r--r--lisp/webapps/webapp-loader.lisp167
10 files changed, 1102 insertions, 0 deletions
diff --git a/lisp/webapps/snow/cljs-out b/lisp/webapps/snow/cljs-out
new file mode 120000
index 0000000..b4909b9
--- /dev/null
+++ b/lisp/webapps/snow/cljs-out
@@ -0,0 +1 @@
+clojurescript/snow/resources/public/cljs-out \ No newline at end of file
diff --git a/lisp/webapps/snow/clojurescript/snow/.gitignore b/lisp/webapps/snow/clojurescript/snow/.gitignore
new file mode 100644
index 0000000..77c3a20
--- /dev/null
+++ b/lisp/webapps/snow/clojurescript/snow/.gitignore
@@ -0,0 +1,16 @@
+target
+classes
+resources
+checkouts
+pom.xml
+pom.xml.asc
+*.jar
+*.class
+.lein-*
+.nrepl-port
+.rebel_readline_history
+.hgignore
+.hg
+figwheel-main.edn
+figwheel_server.log
+.rebel_readline_history
diff --git a/lisp/webapps/snow/clojurescript/snow/dev.cljs.edn b/lisp/webapps/snow/clojurescript/snow/dev.cljs.edn
new file mode 100644
index 0000000..4a6eb73
--- /dev/null
+++ b/lisp/webapps/snow/clojurescript/snow/dev.cljs.edn
@@ -0,0 +1,2 @@
+^{:watch-dirs ["src"]}
+{:main snow.core}
diff --git a/lisp/webapps/snow/clojurescript/snow/project.clj b/lisp/webapps/snow/clojurescript/snow/project.clj
new file mode 100644
index 0000000..ae821a3
--- /dev/null
+++ b/lisp/webapps/snow/clojurescript/snow/project.clj
@@ -0,0 +1,20 @@
+(defproject snow.core "0.1.0-SNAPSHOT"
+ :description "FIXME"
+ :url "FIXME"
+ :license "public domain"
+ :min-lein-version "2.7.1"
+ :dependencies [[org.clojure/clojure "LATEST"]
+ [org.clojure/clojurescript "LATEST"]
+ [cljs-ajax "LATEST"]
+ [prismatic/dommy "LATEST"]
+ [hiccups "LATEST"]
+ [cljsjs/showdown "LATEST"]
+ [com.andrewmcveigh/cljs-time "LATEST"]]
+ :source-paths ["src"]
+ :aliases {"fig:build" ["trampoline" "run" "-m" "figwheel.main" "-b" "dev" "-r"]
+ "fig:min" ["run" "-m" "figwheel.main" "-O" "advanced" "-bo" "dev"]}
+ :profiles {:dev {:dependencies [[com.bhauman/figwheel-main "LATEST"]
+ [org.slf4j/slf4j-nop "LATEST"]
+ [com.bhauman/rebel-readline-cljs "LATEST"]]
+ :resource-paths ["target"]
+ :clean-targets ^{:protect false} ["target"]}})
diff --git a/lisp/webapps/snow/clojurescript/snow/src/core.cljs b/lisp/webapps/snow/clojurescript/snow/src/core.cljs
new file mode 100644
index 0000000..1f6fe21
--- /dev/null
+++ b/lisp/webapps/snow/clojurescript/snow/src/core.cljs
@@ -0,0 +1,688 @@
+(ns snow.core
+ (:require-macros [hiccups.core :as hiccups :refer [html]])
+ (:require [ajax.core :refer [GET POST]]
+ [dommy.core :as dommy]
+ [hiccups.runtime :as hiccupsrt]
+ [clojure.string :as str]
+ [org-ckons-cljs.notifications.core :as ck-notifications]
+ [org-ckons-cljs.form.core :as ck-form]))
+
+;; declarations
+
+(enable-console-print!)
+(def jquery (js* "$"))
+
+(declare notifications)
+(declare template-generic-wait)
+(declare template-menu)
+(declare handler-menu)
+(declare render-menu)
+(declare template-home)
+(declare handler-home)
+(declare render-home)
+(declare template-git-update)
+(declare handler-git-update)
+(declare render-git-update)
+(declare template-git-update-view)
+(declare handler-git-update-view)
+(declare render-git-update-view)
+(declare template-git-update)
+(declare handler-git-update)
+(declare render-git-update)
+(declare template-git-update-view)
+(declare handler-git-update-view)
+(declare render-git-update-view)
+(declare on-git-update-view-clicked)
+(declare template-git-update-results)
+(declare handler-git-update-results)
+(declare render-git-update-results)
+(declare template-asg-recycle)
+(declare handler-asg-recycle)
+(declare render-asg-recycle)
+(declare template-asg-recycle-view)
+(declare handler-asg-recycle-view)
+(declare render-asg-recycle-view)
+(declare on-asg-recycle-results-clicked)
+(declare template-asg-recycle-results)
+(declare handler-asg-recycle-results)
+(declare render-asg-recycle-results)
+(declare on-asg-recycle-results-submit-clicked)
+(declare template-asg-recycle-results-submit)
+(declare handler-asg-recycle-results-submit)
+(declare render-asg-recycle-results-submit)
+(declare template-tfcloud-apply)
+(declare handler-tfcloud-apply)
+(declare render-tfcloud-apply)
+(declare template-tfcloud-apply-view)
+(declare handler-tfcloud-apply-view)
+(declare render-tfcloud-apply-view)
+(declare on-tfcloud-apply-results-clicked)
+(declare template-tfcloud-apply-results)
+(declare handler-tfcloud-apply-results)
+(declare render-tfcloud-apply-results)
+(declare on-tfcloud-apply-results-submit-clicked)
+(declare template-tfcloud-apply-results-submit)
+(declare handler-tfcloud-apply-results-submit)
+(declare render-tfcloud-apply-results-submit)
+(declare template-octopus-machines-with-roles)
+(declare handler-octopus-machines-with-roles)
+(declare render-octopus-machines-with-roles)
+(declare template-octopus-machines-with-roles-view)
+(declare handler-octopus-machines-with-roles-view)
+(declare render-octopus-machines-with-roles-view)
+(declare on-octopus-machines-with-roles-results-clicked)
+(declare template-octopus-machines-with-roles-results)
+(declare handler-octopus-machines-with-roles-results)
+(declare render-octopus-machines-with-roles-results)
+(declare template-octopus-environments-with-roles)
+(declare handler-octopus-environments-with-roles)
+(declare render-octopus-environments-with-roles)
+(declare template-octopus-environments-with-roles-view)
+(declare handler-octopus-environments-with-roles-view)
+(declare render-octopus-environments-with-roles-view)
+(declare on-octopus-environments-with-roles-results-clicked)
+(declare template-octopus-environments-with-roles-results)
+(declare handler-octopus-environments-with-roles-results)
+(declare render-octopus-environments-with-roles-results)
+(declare template-octopus-projects-with-roles)
+(declare handler-octopus-projects-with-roles)
+(declare render-octopus-projects-with-roles)
+(declare template-octopus-projects-with-roles-view)
+(declare handler-octopus-projects-with-roles-view)
+(declare render-octopus-projects-with-roles-view)
+(declare on-octopus-projects-with-roles-results-clicked)
+(declare template-octopus-projects-with-roles-results)
+(declare handler-octopus-projects-with-roles-results)
+(declare render-octopus-projects-with-roles-results)
+(declare template-octopus-ode-deploy-release)
+(declare handler-octopus-ode-deploy-release)
+(declare render-octopus-ode-deploy-release)
+(declare template-octopus-ode-deploy-release-view)
+(declare handler-octopus-ode-deploy-release-view)
+(declare render-octopus-ode-deploy-release-view)
+(declare on-octopus-ode-deploy-release-results-clicked)
+(declare template-octopus-ode-deploy-release-results)
+(declare handler-octopus-ode-deploy-release-results)
+(declare render-octopus-ode-deploy-release-results)
+(declare template-octopus-latest-deployments)
+(declare handler-octopus-latest-deployments)
+(declare render-octopus-latest-deployments)
+(declare template-octopus-latest-deployments-view)
+(declare handler-octopus-latest-deployments-view)
+(declare render-octopus-latest-deployments-view)
+(declare on-octopus-latest-deployments-results-clicked)
+(declare template-octopus-latest-deployments-results)
+(declare handler-octopus-latest-deployments-results)
+(declare render-octopus-latest-deployments-results)
+(declare on-menu-clicked)
+(declare handler-location)
+(declare goto-location)
+
+;; generic table
+
+(defn generic-table [jsonobj & [reverse-p]]
+ (let [results (get jsonobj "results")
+ keys (remove (fn [x]
+ (not (get (first results) x)))
+ (sort #(if reverse-p (compare %2 %1) (compare %1 %2)) (keys (first results))))]
+ (cond (empty? results)
+ [:h5 {:style "text-align: center"} "No results found."]
+ :else
+ [:div
+ [:p (str (count results) " results.")]
+ [:table {:class "table table-hover"}
+ [:thead
+ [:tr
+ (for [key keys]
+ [:th key])]]
+ [:tbody
+ (for [rec results]
+ [:tr
+ (for [key keys]
+ [:td [:code (str (get rec key))]])])]]])))
+
+;; notifications
+
+(defn notifications [jsonobj]
+ (ck-notifications/maybe-message jsonobj)
+ (ck-notifications/maybe-error jsonobj))
+
+;; generic wait
+
+(hiccups/defhtml template-generic-wait []
+ [:h5 {:style "text-align: center"} "Processing..."])
+
+;; menu
+
+(hiccups/defhtml template-menu [menuitems]
+ [:ul {:class "nav nav-pills"}
+ (for [menuitem menuitems]
+ [:li {:class "nav-item"}
+ [:a {:class (cond (= (str/upper-case (get menuitem "handler"))
+ (str/upper-case (dommy/html (dommy/sel1 :#location))))
+ "nav-link active"
+ :else
+ "nav-link")
+ :id (get menuitem "id")
+ :onclick (str (namespace ::x) ".on_menu_clicked('" (get menuitem "handler") "')")}
+ (get menuitem "label")]])])
+
+(defn handler-menu [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (dommy/set-html! (dommy/sel1 :#menu) (template-menu (get jsonobj "menuitems")))))
+
+(defn render-menu []
+ (GET "/menu" {:handler handler-menu}))
+
+;; home
+
+(hiccups/defhtml template-home [jsonobj]
+ [:h3 {:style "text-align: center"} (get jsonobj "content")]
+ [:div {:style "text-align: center"}
+ [:img {:src "/static/images/olo-logo.svg"}]])
+
+(defn handler-home [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-home jsonobj))))
+
+(defn render-home
+ ([]
+ (GET "/home" {:handler handler-home}))
+ ([message errormsg]
+ (POST "/home" {:format :raw
+ :params {:message message
+ :errormsg errormsg}
+ :handler handler-home})))
+
+;; git-update
+
+(hiccups/defhtml template-git-update [jsonobj]
+ [:h3 {:style "text-align: center"} "Update the Olo git checkouts on your workstation."]
+ [:h5 {:style "text-align: center"} "(Assumes that a working github-cli is present.)"]
+ [:div {:id "content"}]
+ [:div {:id "results"}])
+
+(defn handler-git-update [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-git-update jsonobj))
+ (render-git-update-view)))
+
+(defn render-git-update []
+ (GET "/git-update" {:handler handler-git-update}))
+
+;; git-update-view
+
+(hiccups/defhtml template-git-update-view [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(defn handler-git-update-view [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#content) (template-git-update-view jsonobj))))
+
+(defn render-git-update-view []
+ (GET "/git-update/view" {:handler handler-git-update-view}))
+
+;; git-update-results
+
+(defn on-git-update-view-clicked []
+ (render-git-update-results))
+
+(hiccups/defhtml template-git-update-results [jsonobj]
+ [:h5 {:style "text-align: center"}
+ "Process started in background. See the output at " [:code (get jsonobj "stdout")]])
+
+(defn handler-git-update-results [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results) (template-git-update-results jsonobj))))
+
+(defn render-git-update-results []
+ (POST "/git-update/results" {:handler handler-git-update-results}))
+
+;; asg-recycle
+
+(hiccups/defhtml template-asg-recycle [jsonobj]
+ [:h3 {:style "text-align: center"} "Recycle the ASGs matching the filter."]
+ [:div {:id "content"}]
+ [:div {:id "results-submit-ack"}]
+ [:div {:id "results-submit"}]
+ [:div {:id "results"}])
+
+(defn handler-asg-recycle [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-asg-recycle jsonobj))
+ (render-asg-recycle-view)))
+
+(defn render-asg-recycle []
+ (GET "/asg-recycle" {:handler handler-asg-recycle}))
+
+;; asg-recycle-view
+
+(hiccups/defhtml template-asg-recycle-view [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(defn handler-asg-recycle-view [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#content) (template-asg-recycle-view jsonobj))))
+
+(defn render-asg-recycle-view []
+ (GET "/asg-recycle/view" {:handler handler-asg-recycle-view}))
+
+;; asg-recycle-results
+
+(defn on-asg-recycle-results-clicked []
+ (when (-> (jquery "#asg-recycle-form")
+ (.get "0")
+ (.checkValidity))
+ (dommy/set-html! (dommy/sel1 :#results) (template-generic-wait))
+ (dommy/set-html! (dommy/sel1 :#results-submit) "")
+ (dommy/set-html! (dommy/sel1 :#results-submit-ack) "")
+ (render-asg-recycle-results)))
+
+(hiccups/defhtml template-asg-recycle-results-form [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(hiccups/defhtml template-asg-recycle-results [jsonobj]
+ (generic-table jsonobj true))
+
+(defn handler-asg-recycle-results [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results) (template-asg-recycle-results jsonobj))
+ (when (not (empty? (get jsonobj "results")))
+ (dommy/set-html! (dommy/sel1 :#results-submit) (template-asg-recycle-results-form jsonobj)))))
+
+(defn render-asg-recycle-results []
+ (POST "/asg-recycle/results" {:format :raw
+ :params {:profile (dommy/value (dommy/sel1 :#profile))
+ :region (dommy/value (dommy/sel1 :#region))
+ :filter (dommy/value (dommy/sel1 :#filter))}
+ :handler handler-asg-recycle-results}))
+
+;; asg-recycle-results-submit
+
+(defn on-asg-recycle-results-submit-clicked [howmany]
+ (dommy/set-html! (dommy/sel1 :#results-submit-ack) (template-generic-wait))
+ (render-asg-recycle-results-submit howmany))
+
+(hiccups/defhtml template-asg-recycle-results-submit [jsonobj]
+ [:h5 {:style "text-align: center"} "Process started in background."])
+
+(defn handler-asg-recycle-results-submit [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results-submit) "")
+ (dommy/set-html! (dommy/sel1 :#results-submit-ack) (template-asg-recycle-results-submit jsonobj))))
+
+(defn render-asg-recycle-results-submit [howmany]
+ (POST "/asg-recycle/results/submit" {:format :raw
+ :params {:howmany howmany}
+ :handler handler-asg-recycle-results-submit}))
+
+;; tfcloud-apply
+
+(hiccups/defhtml template-tfcloud-apply [jsonobj]
+ [:h3 {:style "text-align: center"} "Apply the TFCloud workspaces matching the filter."]
+ [:div {:id "content"}]
+ [:div {:id "results-submit-ack"}]
+ [:div {:id "results-submit"}]
+ [:div {:id "results"}])
+
+(defn handler-tfcloud-apply [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-tfcloud-apply jsonobj))
+ (render-tfcloud-apply-view)))
+
+(defn render-tfcloud-apply []
+ (GET "/tfcloud-apply" {:handler handler-tfcloud-apply}))
+
+;; tfcloud-apply-view
+
+(hiccups/defhtml template-tfcloud-apply-view [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(defn handler-tfcloud-apply-view [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#content) (template-tfcloud-apply-view jsonobj))))
+
+(defn render-tfcloud-apply-view []
+ (GET "/tfcloud-apply/view" {:handler handler-tfcloud-apply-view}))
+
+;; tfcloud-apply-results
+
+(defn on-tfcloud-apply-results-clicked []
+ (when (-> (jquery "#tfcloud-apply-form")
+ (.get "0")
+ (.checkValidity))
+ (dommy/set-html! (dommy/sel1 :#results) (template-generic-wait))
+ (dommy/set-html! (dommy/sel1 :#results-submit) "")
+ (dommy/set-html! (dommy/sel1 :#results-submit-ack) "")
+ (render-tfcloud-apply-results)))
+
+(hiccups/defhtml template-tfcloud-apply-results-form [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(hiccups/defhtml template-tfcloud-apply-results [jsonobj]
+ (generic-table jsonobj true))
+
+(defn handler-tfcloud-apply-results [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results) (template-tfcloud-apply-results jsonobj))
+ (when (not (empty? (get jsonobj "results")))
+ (dommy/set-html! (dommy/sel1 :#results-submit) (template-tfcloud-apply-results-form jsonobj)))))
+
+(defn render-tfcloud-apply-results []
+ (POST "/tfcloud-apply/results" {:format :raw
+ :params {:filter (dommy/value (dommy/sel1 :#filter))}
+ :handler handler-tfcloud-apply-results}))
+
+;; tfcloud-apply-results-submit
+
+(defn on-tfcloud-apply-results-submit-clicked []
+ (dommy/set-html! (dommy/sel1 :#results-submit-ack) (template-generic-wait))
+ (render-tfcloud-apply-results-submit))
+
+(hiccups/defhtml template-tfcloud-apply-results-submit [jsonobj]
+ [:h5 {:style "text-align: center"} "Process started in background."])
+
+(defn handler-tfcloud-apply-results-submit [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results-submit) "")
+ (dommy/set-html! (dommy/sel1 :#results-submit-ack) (template-tfcloud-apply-results-submit jsonobj))))
+
+(defn render-tfcloud-apply-results-submit []
+ (POST "/tfcloud-apply/results/submit" {:handler handler-tfcloud-apply-results-submit}))
+
+;; octopus-machines-with-roles
+
+(hiccups/defhtml template-octopus-machines-with-roles [jsonobj]
+ [:h3 {:style "text-align: center"} "Find the Octopus machines and their environments containing the roles."]
+ [:div {:id "content"}]
+ [:div {:id "results"}])
+
+(defn handler-octopus-machines-with-roles [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-octopus-machines-with-roles jsonobj))
+ (render-octopus-machines-with-roles-view)))
+
+(defn render-octopus-machines-with-roles []
+ (GET "/octopus-machines-with-roles" {:handler handler-octopus-machines-with-roles}))
+
+;; octopus-machines-with-roles-view
+
+(hiccups/defhtml template-octopus-machines-with-roles-view [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(defn handler-octopus-machines-with-roles-view [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#content) (template-octopus-machines-with-roles-view jsonobj))))
+
+(defn render-octopus-machines-with-roles-view []
+ (GET "/octopus-machines-with-roles/view" {:handler handler-octopus-machines-with-roles-view}))
+
+;; octopus-machines-with-roles-results
+
+(defn on-octopus-machines-with-roles-results-clicked []
+ (when (-> (jquery "#octopus-machines-with-roles-form")
+ (.get "0")
+ (.checkValidity))
+ (dommy/set-html! (dommy/sel1 :#results) (template-generic-wait))
+ (render-octopus-machines-with-roles-results)))
+
+(hiccups/defhtml template-octopus-machines-with-roles-results [jsonobj]
+ (generic-table jsonobj))
+
+(defn handler-octopus-machines-with-roles-results [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results) (template-octopus-machines-with-roles-results jsonobj))))
+
+(defn render-octopus-machines-with-roles-results []
+ (POST "/octopus-machines-with-roles/results" {:format :raw
+ :params {:roles (dommy/value (dommy/sel1 :#roles))}
+ :handler handler-octopus-machines-with-roles-results}))
+
+;; octopus-environments-with-roles
+
+(hiccups/defhtml template-octopus-environments-with-roles [jsonobj]
+ [:h3 {:style "text-align: center"} "Find the octopus ODE environments with machines containing the roles."]
+ [:div {:id "content"}]
+ [:div {:id "results"}])
+
+(defn handler-octopus-environments-with-roles [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-octopus-environments-with-roles jsonobj))
+ (render-octopus-environments-with-roles-view)))
+
+(defn render-octopus-environments-with-roles []
+ (GET "/octopus-environments-with-roles" {:handler handler-octopus-environments-with-roles}))
+
+;; octopus-environments-with-roles-view
+
+(hiccups/defhtml template-octopus-environments-with-roles-view [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(defn handler-octopus-environments-with-roles-view [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#content) (template-octopus-environments-with-roles-view jsonobj))))
+
+(defn render-octopus-environments-with-roles-view []
+ (GET "/octopus-environments-with-roles/view" {:handler handler-octopus-environments-with-roles-view}))
+
+;; octopus-environments-with-roles-results
+
+(defn on-octopus-environments-with-roles-results-clicked []
+ (when (-> (jquery "#octopus-environments-with-roles-form")
+ (.get "0")
+ (.checkValidity))
+ (dommy/set-html! (dommy/sel1 :#results) (template-generic-wait))
+ (render-octopus-environments-with-roles-results)))
+
+(hiccups/defhtml template-octopus-environments-with-roles-results [jsonobj]
+ (generic-table jsonobj true))
+
+(defn handler-octopus-environments-with-roles-results [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results) (template-octopus-environments-with-roles-results jsonobj))))
+
+(defn render-octopus-environments-with-roles-results []
+ (POST "/octopus-environments-with-roles/results" {:format :raw
+ :params {:roles (dommy/value (dommy/sel1 :#roles))
+ :ode_only_p (.-checked (dommy/sel1 :#ode_only_p))}
+ :handler handler-octopus-environments-with-roles-results}))
+
+;; octopus-projects-with-roles
+
+(hiccups/defhtml template-octopus-projects-with-roles [jsonobj]
+ [:h3 {:style "text-align: center"} "Find all octopus projects containing the supplied roles."]
+ [:div {:id "content"}]
+ [:div {:id "results"}])
+
+(defn handler-octopus-projects-with-roles [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-octopus-projects-with-roles jsonobj))
+ (render-octopus-projects-with-roles-view)))
+
+(defn render-octopus-projects-with-roles []
+ (GET "/octopus-projects-with-roles" {:handler handler-octopus-projects-with-roles}))
+
+;; octopus-projects-with-roles-view
+
+(hiccups/defhtml template-octopus-projects-with-roles-view [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(defn handler-octopus-projects-with-roles-view [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#content) (template-octopus-projects-with-roles-view jsonobj))))
+
+(defn render-octopus-projects-with-roles-view []
+ (GET "/octopus-projects-with-roles/view" {:handler handler-octopus-projects-with-roles-view}))
+
+;; octopus-projects-with-roles-results
+
+(defn on-octopus-projects-with-roles-results-clicked []
+ (when (-> (jquery "#octopus-projects-with-roles-form")
+ (.get "0")
+ (.checkValidity))
+ (dommy/set-html! (dommy/sel1 :#results) (template-generic-wait))
+ (render-octopus-projects-with-roles-results)))
+
+(hiccups/defhtml template-octopus-projects-with-roles-results [jsonobj]
+ [:h5 {:style "text-align: center"}
+ "Process started in background. See the output at " [:code (get jsonobj "stdout")]])
+
+(defn handler-octopus-projects-with-roles-results [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results) (template-octopus-projects-with-roles-results jsonobj))))
+
+(defn render-octopus-projects-with-roles-results []
+ (POST "/octopus-projects-with-roles/results" {:format :raw
+ :params {:roles (dommy/value (dommy/sel1 :#roles))}
+ :handler handler-octopus-projects-with-roles-results}))
+
+;; octopus-ode-deploy-release
+
+(hiccups/defhtml template-octopus-ode-deploy-release [jsonobj]
+ [:h3 {:style "text-align: center"} "Deploy an octopus release to one or more ODEs."]
+ [:div {:id "content"}]
+ [:div {:id "results"}])
+
+(defn handler-octopus-ode-deploy-release [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-octopus-ode-deploy-release jsonobj))
+ (render-octopus-ode-deploy-release-view)))
+
+(defn render-octopus-ode-deploy-release []
+ (GET "/octopus-ode-deploy-release" {:handler handler-octopus-ode-deploy-release}))
+
+;; octopus-ode-deploy-release-view
+
+(hiccups/defhtml template-octopus-ode-deploy-release-view [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(defn handler-octopus-ode-deploy-release-view [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#content) (template-octopus-ode-deploy-release-view jsonobj))))
+
+(defn render-octopus-ode-deploy-release-view []
+ (GET "/octopus-ode-deploy-release/view" {:handler handler-octopus-ode-deploy-release-view}))
+
+;; octopus-ode-deploy-release-results
+
+(defn on-octopus-ode-deploy-release-results-clicked []
+ (when (-> (jquery "#octopus-ode-deploy-release-form")
+ (.get "0")
+ (.checkValidity))
+ (dommy/set-html! (dommy/sel1 :#results) (template-generic-wait))
+ (render-octopus-ode-deploy-release-results)))
+
+(hiccups/defhtml template-octopus-ode-deploy-release-results [jsonobj]
+ [:h5 {:style "text-align: center"}
+ "Process started in background. See the output at " [:code (get jsonobj "stdout")]])
+
+(defn handler-octopus-ode-deploy-release-results [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results) (template-octopus-ode-deploy-release-results jsonobj))))
+
+(defn render-octopus-ode-deploy-release-results []
+ (POST "/octopus-ode-deploy-release/results" {:format :raw
+ :params {:project_name (dommy/value (dommy/sel1 :#project_name))
+ :version (dommy/value (dommy/sel1 :#version))
+ :ode_names (dommy/value (dommy/sel1 :#ode_names))}
+ :handler handler-octopus-ode-deploy-release-results}))
+
+;; octopus-latest-deployments
+
+(hiccups/defhtml template-octopus-latest-deployments [jsonobj]
+ [:h3 {:style "text-align: center"} "Find the latest octopus deployments in each environment."]
+ [:div {:id "content"}]
+ [:div {:id "results"}])
+
+(defn handler-octopus-latest-deployments [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-octopus-latest-deployments jsonobj))
+ (render-octopus-latest-deployments-view)))
+
+(defn render-octopus-latest-deployments []
+ (GET "/octopus-latest-deployments" {:handler handler-octopus-latest-deployments}))
+
+;; octopus-latest-deployments-view
+
+(hiccups/defhtml template-octopus-latest-deployments-view [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(defn handler-octopus-latest-deployments-view [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#content) (template-octopus-latest-deployments-view jsonobj))))
+
+(defn render-octopus-latest-deployments-view []
+ (GET "/octopus-latest-deployments/view" {:handler handler-octopus-latest-deployments-view}))
+
+;; octopus-latest-deployments-results
+
+(defn on-octopus-latest-deployments-results-clicked []
+ (when (-> (jquery "#octopus-latest-deployments-form")
+ (.get "0")
+ (.checkValidity))
+ (dommy/set-html! (dommy/sel1 :#results) (template-generic-wait))
+ (render-octopus-latest-deployments-results)))
+
+(hiccups/defhtml template-octopus-latest-deployments-results [jsonobj]
+ (generic-table jsonobj false))
+
+(defn handler-octopus-latest-deployments-results [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results) (template-octopus-latest-deployments-results jsonobj))))
+
+(defn render-octopus-latest-deployments-results []
+ (POST "/octopus-latest-deployments/results" {:format :raw
+ :params {:ode_only_p (.-checked (dommy/sel1 :#ode_only_p))}
+ :handler handler-octopus-latest-deployments-results}))
+
+;; location
+
+(defn on-menu-clicked [handler]
+ (dommy/set-html! (dommy/sel1 :#location) handler)
+ (render-menu)
+ (cond (= handler "/home") (render-home))
+ (cond (= handler "/git-update") (render-git-update))
+ (cond (= handler "/asg-recycle") (render-asg-recycle))
+ (cond (= handler "/tfcloud-apply") (render-tfcloud-apply))
+ (cond (= handler "/octopus-machines-with-roles") (render-octopus-machines-with-roles))
+ (cond (= handler "/octopus-environments-with-roles") (render-octopus-environments-with-roles))
+ (cond (= handler "/octopus-projects-with-roles") (render-octopus-projects-with-roles))
+ (cond (= handler "/octopus-ode-deploy-release") (render-octopus-ode-deploy-release))
+ (cond (= handler "/octopus-latest-deployments") (render-octopus-latest-deployments)))
+
+(defn handler-location [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (on-menu-clicked (get jsonobj "location"))
+ (notifications jsonobj)))
+
+(defn goto-location [location]
+ (POST "/location" {:format :raw
+ :params {:location location}
+ :handler handler-location}))
diff --git a/lisp/webapps/snow/conf/options.lisp b/lisp/webapps/snow/conf/options.lisp
new file mode 120000
index 0000000..efdd414
--- /dev/null
+++ b/lisp/webapps/snow/conf/options.lisp
@@ -0,0 +1 @@
+/etc/snow/options.lisp \ No newline at end of file
diff --git a/lisp/webapps/snow/site.lisp b/lisp/webapps/snow/site.lisp
new file mode 100644
index 0000000..868a188
--- /dev/null
+++ b/lisp/webapps/snow/site.lisp
@@ -0,0 +1,158 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :snow)
+
+(defmacro .base (&optional (onload-fn "goto_location('/home')"))
+ `(org-ckons-http::html5
+ `(html
+ (head
+ ((meta :name "viewport" :content "width=device-width, initial-scale=1, shrink-to-fit=no"))
+ ((meta :charset "utf-8"))
+ ((title) ,(title *webapp*))
+ ,@(mapcar (lambda (css)
+ `((link :rel "stylesheet" :href ,(getf css :href) :integrity ,(getf css :integrity) :crossorigin ,(getf css :crossorigin))))
+ '((:href "https://cdn.jsdelivr.net/npm/bootstrap@4.6.2/dist/css/bootstrap.min.css" :integrity "sha384-xOolHFLEh07PJGoPkLv1IbcEPTNtaed2xpHsD9ESMhqIYd0nLMwNLD69Npy4HI+N" :crossorigin "anonymous")
+ (:href "/static/css/stylesheet.css" :crossorigin "anonymous")))
+ ,@(mapcar (lambda (js)
+ `((script :type "text/javascript" :src ,(getf js :src) :integrity ,(getf js :integrity) :crossorigin ,(getf js :crossorigin))))
+ '((:src "https://code.jquery.com/jquery-3.7.1.slim.min.js" :integrity "ha256-kmHvs0B+OpCW5GVHUNjv9rOmY0IvSIRcf7zGUDTDQM8=" :crossorigin "anonymous")))
+ ((script :type "text/javascript" :src "/cljs-out/dev-main.js")))
+ ((body :onload ,(format nil "snow.core.~a" ,onload-fn))
+ ((div :class "container-fluid")
+ ((div :class "row")
+ ((div :class "col") "&nbsp;")
+ ((div :class "col")
+ ((div :class "page-header")
+ ((h2 :align "center") ,(title *webapp*))))
+ ((div :class "col") "&nbsp;"))
+ ((div :id "menu" :class "well"))
+ ((div :id "location" :style "display: none"))
+ ((div :id "errormsg"))
+ ((div :id "message"))
+ ((div :id "body"))
+ ,@(mapcar (lambda (js)
+ `((script :type "text/javascript" :src ,(getf js :src) :integrity ,(getf js :integrity) :crossorigin ,(getf js :crossorigin))))
+ '((:src "https://cdn.jsdelivr.net/npm/bootstrap@4.6.2/dist/js/bootstrap.bundle.min.js" :integrity "sha384-Fy6S3B9q64WdZWQUiU+q4/2Lc9npb8tCaSX9FK7E8HnRr0Jz8D6OP9dO5Vg3Q9ct" :crossorigin "anonymous"))))))))
+
+(defmacro .location ()
+ `(location-json location))
+
+(defmacro .home-get ()
+ `(home-json))
+
+(defmacro .home-post ()
+ `(home-json message errormsg))
+
+(defmacro .menu ()
+ `(menu-json))
+
+(defmacro .git-update ()
+ `(git-update-json))
+
+(defmacro .git-update-view ()
+ `(git-update-view-json))
+
+(defmacro .git-update-results ()
+ `(git-update-results-json))
+
+(defmacro .asg-recycle ()
+ `(asg-recycle-json))
+
+(defmacro .asg-recycle-view ()
+ `(asg-recycle-view-json))
+
+(defmacro .asg-recycle-results ()
+ `(asg-recycle-results-json profile region filter))
+
+(defmacro .asg-recycle-results-submit ()
+ `(asg-recycle-results-submit-json howmany))
+
+(defmacro .tfcloud-apply ()
+ `(tfcloud-apply-json))
+
+(defmacro .tfcloud-apply-view ()
+ `(tfcloud-apply-view-json))
+
+(defmacro .tfcloud-apply-results ()
+ `(tfcloud-apply-results-json filter))
+
+(defmacro .tfcloud-apply-results-submit ()
+ `(tfcloud-apply-results-submit-json))
+
+(defmacro .octopus-machines-with-roles ()
+ `(octopus-machines-with-roles-json))
+
+(defmacro .octopus-machines-with-roles-view ()
+ `(octopus-machines-with-roles-view-json))
+
+(defmacro .octopus-machines-with-roles-results ()
+ `(octopus-machines-with-roles-results-json roles))
+
+(defmacro .octopus-environments-with-roles ()
+ `(octopus-environments-with-roles-json))
+
+(defmacro .octopus-environments-with-roles-view ()
+ `(octopus-environments-with-roles-view-json))
+
+(defmacro .octopus-environments-with-roles-results ()
+ `(octopus-environments-with-roles-results-json ode_only_p roles))
+
+(defmacro .octopus-projects-with-roles ()
+ `(octopus-projects-with-roles-json))
+
+(defmacro .octopus-projects-with-roles-view ()
+ `(octopus-projects-with-roles-view-json))
+
+(defmacro .octopus-projects-with-roles-results ()
+ `(octopus-projects-with-roles-results-json roles))
+
+(defmacro .octopus-ode-deploy-release ()
+ `(octopus-ode-deploy-release-json))
+
+(defmacro .octopus-ode-deploy-release-view ()
+ `(octopus-ode-deploy-release-view-json))
+
+(defmacro .octopus-ode-deploy-release-results ()
+ `(octopus-ode-deploy-release-results-json project_name version ode_names))
+
+(defmacro .octopus-latest-deployments ()
+ `(octopus-latest-deployments-json))
+
+(defmacro .octopus-latest-deployments-view ()
+ `(octopus-latest-deployments-view-json))
+
+(defmacro .octopus-latest-deployments-results ()
+ `(octopus-latest-deployments-results-json ode_only_p))
+
+(define-endpoint :get "/" () .base)
+(define-endpoint :post "/location" ((location :parameter-type 'string)) .location)
+(define-endpoint :get "/home" () .home-get)
+(define-endpoint :post "/home" ((message :parameter-type 'string) (errormsg :parameter-type 'string)) .home-post)
+(define-endpoint :get "/menu" () .menu)
+(define-endpoint :get "/git-update" () .git-update)
+(define-endpoint :get "/git-update/view" () .git-update-view)
+(define-endpoint :post "/git-update/results" () .git-update-results)
+(define-endpoint :get "/asg-recycle" () .asg-recycle)
+(define-endpoint :get "/asg-recycle/view" () .asg-recycle-view)
+(define-endpoint :post "/asg-recycle/results" ((profile :parameter-type 'string) (region :parameter-type 'string) (filter :parameter-type 'string)) .asg-recycle-results)
+(define-endpoint :post "/asg-recycle/results/submit" ((howmany :parameter-type 'string)) .asg-recycle-results-submit)
+(define-endpoint :get "/tfcloud-apply" () .tfcloud-apply)
+(define-endpoint :get "/tfcloud-apply/view" () .tfcloud-apply-view)
+(define-endpoint :post "/tfcloud-apply/results" ((filter :parameter-type 'string)) .tfcloud-apply-results)
+(define-endpoint :post "/tfcloud-apply/results/submit" () .tfcloud-apply-results-submit)
+(define-endpoint :get "/octopus-machines-with-roles" () .octopus-machines-with-roles)
+(define-endpoint :get "/octopus-machines-with-roles/view" () .octopus-machines-with-roles-view)
+(define-endpoint :post "/octopus-machines-with-roles/results" ((roles :parameter-type 'string)) .octopus-machines-with-roles-results)
+(define-endpoint :get "/octopus-environments-with-roles" () .octopus-environments-with-roles)
+(define-endpoint :get "/octopus-environments-with-roles/view" () .octopus-environments-with-roles-view)
+(define-endpoint :post "/octopus-environments-with-roles/results" ((ode_only_p :parameter-type 'string) (roles :parameter-type 'string)) .octopus-environments-with-roles-results)
+(define-endpoint :get "/octopus-projects-with-roles" () .octopus-projects-with-roles)
+(define-endpoint :get "/octopus-projects-with-roles/view" () .octopus-projects-with-roles-view)
+(define-endpoint :post "/octopus-projects-with-roles/results" ((roles :parameter-type 'string)) .octopus-projects-with-roles-results)
+(define-endpoint :get "/octopus-ode-deploy-release" () .octopus-ode-deploy-release)
+(define-endpoint :get "/octopus-ode-deploy-release/view" () .octopus-ode-deploy-release-view)
+(define-endpoint :post "/octopus-ode-deploy-release/results" ((project_name :parameter-type 'string) (version :parameter-type 'string) (ode_names :parameter-type 'string)) .octopus-ode-deploy-release-results)
+(define-endpoint :get "/octopus-latest-deployments" () .octopus-latest-deployments)
+(define-endpoint :get "/octopus-latest-deployments/view" () .octopus-latest-deployments-view)
+(define-endpoint :post "/octopus-latest-deployments/results" ((ode_only_p :parameter-type 'string)) .octopus-latest-deployments-results)
diff --git a/lisp/webapps/snow/static/css/stylesheet.css b/lisp/webapps/snow/static/css/stylesheet.css
new file mode 100644
index 0000000..3f79ffd
--- /dev/null
+++ b/lisp/webapps/snow/static/css/stylesheet.css
@@ -0,0 +1,25 @@
+body {
+ font-size: 14px;
+}
+
+.container-fluid {
+ width: 100%;
+ margin: 20px auto;
+}
+
+.nav-link {
+ cursor: pointer;
+ cursor: hand;
+}
+
+.form-control {
+ width: 600px;
+}
+
+#body {
+ min-height: 500px;
+}
+
+#footer {
+ text-align: center;
+}
diff --git a/lisp/webapps/snow/static/images/olo-logo.svg b/lisp/webapps/snow/static/images/olo-logo.svg
new file mode 100644
index 0000000..70611c1
--- /dev/null
+++ b/lisp/webapps/snow/static/images/olo-logo.svg
@@ -0,0 +1,24 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<svg width="145px" height="89px" viewBox="0 0 145 89" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+ <!-- Generator: Sketch 48.1 (47250) - http://www.bohemiancoding.com/sketch -->
+ <title>logo@2x</title>
+ <desc>Created with Sketch.</desc>
+ <defs>
+ <polygon id="path-1" points="0 89 145 89 145 0 0 0"></polygon>
+ </defs>
+ <g id="1.-login" stroke="none" stroke-width="1" fill="none" fill-rule="evenodd" transform="translate(-280.000000, -154.000000)">
+ <g id="Group" transform="translate(150.000000, 83.000000)">
+ <g id="logo" transform="translate(127.000000, 40.000000)">
+ <g id="Page-1" transform="translate(3.000000, 31.000000)">
+ <path d="M29.5,60.0798218 C20.8964099,60.0798218 13.9364421,53.1035901 13.9364421,44.5 C13.9364421,35.912431 20.8964099,28.9361994 29.5,28.9361994 C38.1035901,28.9361994 45.0635579,35.912431 45.0635579,44.5 C45.0635579,53.1035901 38.1035901,60.0798218 29.5,60.0798218 M29.5,15 C13.2113646,15 0,28.2113646 0,44.5 C0,60.7886354 13.2113646,74 29.5,74 C45.7886354,74 59,60.7886354 59,44.5 C59,28.2113646 45.7886354,15 29.5,15" id="Fill-1" fill="#06A7E1"></path>
+ <path d="M115.5,60.0798218 C106.89641,60.0798218 99.9364421,53.1035901 99.9364421,44.5 C99.9364421,35.912431 106.89641,28.9361994 115.5,28.9361994 C124.103347,28.9361994 131.063558,35.912431 131.063558,44.5 C131.063558,53.1035901 124.103347,60.0798218 115.5,60.0798218 M115.5,15 C99.2111218,15 86,28.2113646 86,44.5 C86,60.7886354 99.2111218,74 115.5,74 C131.788635,74 145,60.7886354 145,44.5 C145,28.2113646 131.788635,15 115.5,15" id="Fill-3" fill="#06A7E1"></path>
+ <mask id="mask-2" fill="white">
+ <use xlink:href="#path-1"></use>
+ </mask>
+ <g id="Clip-6"></g>
+ <polygon id="Fill-5" fill="#06A7E1" mask="url(#mask-2)" points="65 89 79 89 79 0 65 0"></polygon>
+ </g>
+ </g>
+ </g>
+ </g>
+</svg> \ No newline at end of file
diff --git a/lisp/webapps/webapp-loader.lisp b/lisp/webapps/webapp-loader.lisp
new file mode 100644
index 0000000..fd55c1e
--- /dev/null
+++ b/lisp/webapps/webapp-loader.lisp
@@ -0,0 +1,167 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :snow)
+
+(defvar *acceptor* nil)
+(defvar *dispatch-table* '(#'dispatch-easy-handlers #'default-dispatcher))
+(defvar *webapps* (make-hash-table :test 'equal))
+(defvar *webapp* nil)
+(defparameter *port* 3013)
+(defparameter *session-timeout* 14400)
+(defparameter *server-root* (namestring (asdf:system-relative-pathname (intern (package-name #.*package*)) "./"))
+ "The location of the web server root on the filesystem.")
+
+(defclass webapp ()
+ ((name :initarg :name
+ :initform nil
+ :accessor name
+ :documentation "The name of the webapp as used in the code. A
+string used as the key to any webapp config lookup.")
+ (url :initarg :url
+ :initform nil
+ :accessor url
+ :documentation "The domain portion of the URL to the
+root of the webapp.")
+ (document-root :initarg :document-root
+ :initform nil
+ :accessor document-root
+ :documentation "The absolute filesystem path to
+the webapp's top-level directory, which is inside the webapps
+folder.")
+ (title :initarg :title
+ :initform nil
+ :accessor title
+ :documentation "The default title that shows up in
+the browser title bar.")
+ (meta-description :initarg :meta-description
+ :initform nil
+ :accessor meta-description
+ :documentation "The text that goes into the META DESCRIPTION
+tag, and anywhere else we want to put this text so that it will show
+up in Google.")
+ (region :initarg :region
+ :initform nil
+ :accessor region
+ :documentation "The default AWS region.")
+ (queue :initarg :queue
+ :initform nil
+ :accessor queue
+ :documentation "Settings for the worker queues."))
+ (:documentation ""))
+
+(defgeneric get-site-file-path (webapp)
+ (:documentation "Builds a full filesystem path to a webapp's site
+file."))
+
+(defmethod get-site-file-path ((webapp webapp))
+ (format nil "~a/site" (document-root webapp)))
+
+(defgeneric get-pages-file-paths (webapp)
+ (:documentation ""))
+
+(defmethod get-pages-file-paths ((webapp webapp))
+ (mapcar (lambda (pages-file)
+ (ppcre:regex-replace-all "\\.lisp$" (format nil "~a" pages-file) ""))
+ (remove-if (lambda (x) (equal x "shared"))
+ (org-ckons-core::shell-wrapper (format nil "find '~a' -maxdepth 1 -type f -iname 'pages*.lisp' |sort" (document-root webapp))))))
+
+(defun make-server-path (relative-path)
+ "Makes a relative filesystem path into a full one, using
+`*server-root*' as the base."
+ (make-document-root-path *server-root* relative-path))
+
+(defun make-document-root-path (document-root relative-path)
+ "Makes a relative filesystem path into a full one, using
+`document-root' as the base."
+ (concatenate 'string document-root relative-path))
+
+(defun make-webapp-path (relative-path)
+ "Makes an absolute filesystem path to a location in the webapps
+folder."
+ (concatenate 'string *server-root* "webapps/" relative-path))
+
+(defun get-options-files ()
+ (mapcar (lambda (webapp-directory)
+ (format nil "~a/conf/options.lisp" webapp-directory))
+ (remove-if (lambda (x) (or (org-ckons-core::match-it "webapps/$" x)
+ (org-ckons-core::match-it "webapps/shared$" x)
+ (org-ckons-core::match-it "webapps/CVS$" x)
+ (org-ckons-core::match-it "webapps/\\.$" x)
+ (org-ckons-core::match-it "webapps/\\.\\.$" x)))
+ (org-ckons-core::shell-wrapper (format nil "find '~a' -maxdepth 1 -type d |sort" (make-webapp-path ""))))))
+
+(defun set-webapp (webapp)
+ "Sets a `webapp' object in `*webapps*'. The lookup key is the
+webapp name. If a webapp already exists under this key, it gets
+overwritten with the new one."
+ (setf (gethash (name webapp) *webapps*) webapp))
+
+(defun get-webapp (key)
+ "Gets the webapp object."
+ (gethash key *webapps*))
+
+(defun generate-sessionid ()
+ "Generates a unique random string to seed the
+`*session-secret*'. The string is a SHA256 hash."
+ (let ((entropic-value (make-array '(32) :element-type '(unsigned-byte 8))))
+ (with-open-file (urandom-file "/dev/urandom" :direction :input :element-type '(unsigned-byte 8))
+ (loop for i from 0 to 31 do
+ (setf (elt entropic-value i) (read-byte urandom-file))))
+ (let ((digest (ironclad:make-digest 'ironclad:sha256)))
+ (ironclad:update-digest digest entropic-value)
+ (ironclad:byte-array-to-hex-string (ironclad:produce-digest digest)))))
+
+(defun populate-webapps ()
+ (loop for options-file in (get-options-files) do
+ (with-open-file (input options-file :direction :input)
+ (let* ((form (car (read input))))
+ (set-webapp (make-instance 'webapp
+ :name (getf form :name)
+ :url (getf form :url)
+ :document-root (make-webapp-path (getf form :document-root))
+ :title (getf form :title)
+ :meta-description (getf form :meta-description)
+ :region (getf form :region)
+ :queue (getf form :queue)))))))
+
+(defun snow ()
+ "Call this to start the server."
+ (when (null *acceptor*)
+ (let ((package (string-downcase (package-name *package*))))
+ (populate-webapps)
+ (sb-unix:unix-mkdir "/tmp/snow" #o777)
+ (sb-unix:unix-mkdir "/var/log/lisp" #o777)
+ (setf (log-manager) (make-instance 'log-manager :message-class 'formatted-message))
+ (start-messenger 'text-file-messenger :filename (format nil "/var/log/lisp/~a.log" package))
+ (setf *session-secret* (generate-sessionid))
+ (populate-webapps)
+ (setf *acceptor* (start (make-instance 'easy-acceptor
+ :port *port*
+ :document-root (make-server-path (format nil "webapps/~a/" package))
+ :name (format nil "~a-acceptor" package)))))))
+
+(defmacro with-request-wrapper (uri page-function)
+ ;; Assigning package outside the backquote is necessary because
+ ;; *package* resolves incorrectly to common-lisp-user inside the
+ ;; backquote.
+ (let ((package (string-downcase (package-name *package*))))
+ `(let ((*webapp* (get-webapp ,package)))
+ (org-ckons-core::logger (format nil "Page request URI: [~a]" ,uri))
+ (loop for queue in '(git aws tfcloud octopus-slow octopus-fast awx)
+ do (queue-generator queue))
+ (unless *session*
+ (start-session)
+ (setf (session-max-time *session*) *session-timeout*)
+ (setf (session-value :permissions) "anonymous"))
+ (,page-function))))
+
+(defmacro define-endpoint (request-type uri var-list page-function)
+ "Does the grunt work of creating an `easy-handler' for each page you
+wish to publish."
+ (let ((name (gensym)))
+ `(progn
+ (org-ckons-core::logger (format nil "Publishing page. URL = [~a]" ,uri))
+ (define-easy-handler (,name :uri ,uri :default-request-type ,request-type)
+ ,var-list
+ (with-request-wrapper ,uri ,page-function)))))