diff options
48 files changed, 3153 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..696753b --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*~ +*swp +*.fasl diff --git a/ci/.gitignore b/ci/.gitignore new file mode 100644 index 0000000..7ca3a5c --- /dev/null +++ b/ci/.gitignore @@ -0,0 +1,2 @@ +tmp +docker-start.tar.xz diff --git a/ci/Dockerfile b/ci/Dockerfile new file mode 100644 index 0000000..9058561 --- /dev/null +++ b/ci/Dockerfile @@ -0,0 +1,13 @@ +FROM arm64v8/ubuntu:noble +MAINTAINER Olo Platform Evolution #eng-platform-evolution-help +ADD tmp/docker-start.tar.xz / +ARG OLO_USERNAME=root +ARG OLO_GROUPNAME=root +ARG OLO_UID=0 +ARG OLO_GID=0 +RUN data/install-root.sh +USER ${OLO_UID}:${OLO_GID} +RUN data/install-user-sbcl.sh +ENTRYPOINT [ "data/start_app.sh" ] +#ENTRYPOINT [ "/bin/bash", "-l", "-c" ] +CMD [] diff --git a/ci/data/etc/sbclrc b/ci/data/etc/sbclrc new file mode 100644 index 0000000..3a931d0 --- /dev/null +++ b/ci/data/etc/sbclrc @@ -0,0 +1,6 @@ +;;; The following lines added by ql:add-to-init-file: +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) diff --git a/ci/data/etc/snow/figwheel-main.edn b/ci/data/etc/snow/figwheel-main.edn new file mode 100644 index 0000000..864266c --- /dev/null +++ b/ci/data/etc/snow/figwheel-main.edn @@ -0,0 +1,34 @@ +;; Figwheel-main configuration options see: https://figwheel.org/config-options +;; these will be overriden by the metadata config options in dev.cljs.edn build file +{ + ;; Set the server port https://figwheel.org/config-options#ring-server-options + ;; :ring-server-options {:port 9500} + + ;; Change the target directory from the "target" to "resources" + ;; https://figwheel.org/config-options#target-dir + ;; :target-dir "resources" + + ;; Server Ring Handler (optional) https://figwheel.org/docs/ring-handler.html + ;; If you want to embed a ring handler into the figwheel server, this + ;; is for simple ring servers + ;; :ring-handler hello_world.server/handler + + ;; To be able to open files in your editor from the heads up display + ;; you will need to put a script on your path. This script will have + ;; to take a file path and a line number ie. + ;; in ~/bin/myfile-opener: + ;; + ;; #! /bin/sh + ;; emacsclient -n +$2:$3 $1 + ;; + ;; :open-file-command "myfile-opener" + + ;; if you are using emacsclient you can just use + ;; :open-file-command "emacsclient" + + ;; Logging output gets printed to the REPL, if you want to redirect it to a file: + ;; :log-file "figwheel-main.log" + + :target-dir "resources" + :open-url false +} diff --git a/ci/data/etc/snow/options.lisp b/ci/data/etc/snow/options.lisp new file mode 100644 index 0000000..290ba00 --- /dev/null +++ b/ci/data/etc/snow/options.lisp @@ -0,0 +1,20 @@ +((:name "snow" + :url "http://localhost:3013" + :document-root "snow" + :title "Super Nifty Olo Webapp" + :meta-description "Super Nifty Olo Webapp" + :region "us-east-1" + :queue (:sleep-interval 15 + :git (:num-process-threads 10 + :wait-interval 0 + :exclude-dirs (".vscode" "frodomat" "frodomat-ci" "frodomat-teamcity" "ssh-tunnel" "ssl-cert" "datamat" "datamat-ci")) + :aws (:num-process-threads 30 + :wait-interval 90) + :octopus-slow (:num-process-threads 1 + :wait-interval 0) + :octopus-fast (:num-process-threads 10 + :wait-interval 0) + :tfcloud (:num-process-threads 1 + :wait-interval 0) + :awx (:num-process-threads 10 + :wait-interval 0)))) diff --git a/ci/data/install-root.sh b/ci/data/install-root.sh new file mode 100755 index 0000000..ca4f1c4 --- /dev/null +++ b/ci/data/install-root.sh @@ -0,0 +1,40 @@ +#!/bin/bash + +echo 'APT::Acquire::Retries "3";' > /etc/apt/apt.conf.d/80-retries +export DEBIAN_FRONTEND=noninteractive +apt-get update +apt-get -y -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" dist-upgrade +apt-get -y install -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" aptitude +aptitude -y install -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" apt-transport-https ca-certificates software-properties-common language-pack-de +update-ca-certificates +aptitude update +aptitude -y install -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" sbcl sbcl-source leiningen dnsutils bind9-host vim curl wget rlwrap pass rsync sudo gh jq lsof zip unzip + +mkdir -p /opt/aws-cli +pushd /tmp +rm -rf aws +curl -o awscliv2.zip https://awscli.amazonaws.com/awscli-exe-linux-aarch64.zip +unzip awscliv2.zip +pushd aws +./install -i /opt/aws-cli -b /usr/local/bin --update +popd +popd + +rsync -av /data/ / + +if (( OLO_UID != 0 )); then + userdel ubuntu || true + groupdel ubuntu || true + rm -rf /home/ubuntu || true + export HOMEDIR="/home/${OLO_USERNAME}" + groupadd -g "${OLO_GID}" "${OLO_GROUPNAME}" || OLO_GROUPNAME=$(grep -F "x:${OLO_GID}:" /etc/group | awk -F: '{print $1}') + useradd -s /bin/bash -m -u "${OLO_UID}" -g "${OLO_GROUPNAME}" "${OLO_USERNAME}" || OLO_USERNAME=$(grep -F "x:${OLO_UID}:" /etc/passwd | awk -F: '{print $1}') + SUDOERS_FILENAME="${OLO_USERNAME//\./_}" + echo "${OLO_USERNAME} ALL=(ALL) NOPASSWD: ALL" > "/etc/sudoers.d/${SUDOERS_FILENAME}" + chmod 0440 "/etc/sudoers.d/${SUDOERS_FILENAME}" + mkdir -p "${HOMEDIR}/.gnupg" + chown "${OLO_USERNAME}":"${OLO_GROUPNAME}" "${HOMEDIR}/.gnupg" + chmod 0700 "${HOMEDIR}/.gnupg" +fi + +exit 0 diff --git a/ci/data/install-user-sbcl.sh b/ci/data/install-user-sbcl.sh new file mode 100755 index 0000000..e9d03ff --- /dev/null +++ b/ci/data/install-user-sbcl.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +curl -o ~/quicklisp.lisp https://beta.quicklisp.org/quicklisp.lisp +sbcl --load ~/quicklisp.lisp --eval "(quicklisp-quickstart:install)" --eval "(sb-ext:exit)" +sbcl --eval "(loop for pkg in '(cl-ppcre cl-smtp hunchentoot cl-log ironclad cl-markdown tmpdir swank net-telent-date uffi drakma cl-json postmodern fiveam local-time trivial-octet-streams cl-ppcre) do (ql:quickload (symbol-name pkg)))" --eval "(sb-ext:exit)" + +mkdir -p ~/.config/common-lisp +echo "(:source-registry (:tree (:home \"common-lisp/systems\")) :inherit-configuration)" | tee ~/.config/common-lisp/source-registry.conf + +exit 0 diff --git a/ci/data/snow-starter.lisp b/ci/data/snow-starter.lisp new file mode 100644 index 0000000..e808f7a --- /dev/null +++ b/ci/data/snow-starter.lisp @@ -0,0 +1,7 @@ +(load "/etc/sbclrc") +(asdf:operate 'asdf:load-op 'swank) +(setf swank::*loopback-interface* "0.0.0.0") +(swank:create-server :port 4109 :dont-close t) +(asdf:operate 'asdf:load-op 'snow) +(in-package :snow) +(snow) diff --git a/ci/data/start_app.sh b/ci/data/start_app.sh new file mode 100755 index 0000000..029afe1 --- /dev/null +++ b/ci/data/start_app.sh @@ -0,0 +1,45 @@ +#!/bin/bash + +mkdir -p ~/common-lisp/systems ~/opt +cd ~/opt +git clone -b main git@ns:repos/snow.git +git clone -b master git@github.com:ckonstanski/org-ckons-cljs.form.git +git clone -b master git@github.com:ckonstanski/org-ckons-cljs.notifications +git clone -b master git@github.com:ckonstanski/org-ckons-condition +git clone -b master git@github.com:ckonstanski/org-ckons-core +git clone -b master git@github.com:ckonstanski/org-ckons-file +git clone -b master git@github.com:ckonstanski/org-ckons-http +git clone -b master git@github.com:ckonstanski/org-ckons-json +git clone -b master git@github.com:ckonstanski/org-ckons-serializable +git clone -b master git@github.com:ckonstanski/org-ckons-session +git clone -b master git@github.com:ckonstanski/org-ckons-sql + +logdir="/var/log/lisp" +mv ${logdir}/snow.log.1 ${logdir}/snow.log.2 +mv ${logdir}/${APPNAME}snow.log ${logdir}/snow.log.1 + +pushd ~/common-lisp/systems +ln -s ~/opt/snow/lisp/snow.asd snow.asd +ln -s ~/opt/org-ckons-condition/org-ckons-condition.asd org-ckons-condition.asd +ln -s ~/opt/org-ckons-core/org-ckons-core.asd org-ckons-core.asd +ln -s ~/opt/org-ckons-file/org-ckons-file.asd org-ckons-file.asd +ln -s ~/opt/org-ckons-http/org-ckons-http.asd org-ckons-http.asd +ln -s ~/opt/org-ckons-json/org-ckons-json.asd org-ckons-json.asd +ln -s ~/opt/org-ckons-serializable/org-ckons-serializable.asd org-ckons-serializable.asd +ln -s ~/opt/org-ckons-session/org-ckons-session.asd org-ckons-session.asd +ln -s ~/opt/org-ckons-sql/org-ckons-sql.asd org-ckons-sql.asd +popd + +pushd ~/opt/snow/lisp/webapps/snow/clojurescript/snow +ln -s /etc/snow/figwheel-main.edn figwheel-main.edn +mkdir checkouts +pushd checkouts +ln -s ~/opt/org-ckons-cljs.form org-ckons-cljs.form +ln -s ~/opt/org-ckons-cljs.notifications org-ckons-cljs.notifications +popd + +lein clean +lein fig:build | tee /tmp/snow/lein.log & +popd + +SBCL_HOME=/usr/lib/sbcl SBCL_SOURCE_ROOT=/usr/lib/sbcl/src exec sbcl --dynamic-space-size 2048 --userinit /data/snow-starter.lisp | tee /tmp/snow/sbcl.log diff --git a/ci/docker-build.sh b/ci/docker-build.sh new file mode 100755 index 0000000..05f180e --- /dev/null +++ b/ci/docker-build.sh @@ -0,0 +1,26 @@ +#!/bin/bash -e + +. env.sh + +builddir='tmp' +container='snow' + +rm -rf ${builddir} +mkdir ${builddir} +rsync -aq data ${builddir} +pushd ${builddir} 2>/dev/null + +tar Jcvf docker-start.tar.xz data/ +docker stop ${container} || true +docker container prune -f +docker rmi --force ${container} + +DOCKER_BUILDKIT=0 docker compose --ansi "never" build \ + --no-cache \ + --pull \ + --progress "plain" + +popd 2>/dev/null +rm -rf tmp + +exit 0 diff --git a/ci/docker-compose.yaml b/ci/docker-compose.yaml new file mode 100644 index 0000000..930ed8b --- /dev/null +++ b/ci/docker-compose.yaml @@ -0,0 +1,81 @@ +services: + snow: + image: snow:v0.1 + tty: true + build: + context: . + args: + OLO_USERNAME: ${OLO_USERNAME} + OLO_GROUPNAME: ${OLO_GROUPNAME} + OLO_UID: ${OLO_UID} + OLO_GID: ${OLO_GID} + network_mode: "host" + container_name: snow + volumes: + - type: bind + source: /tmp/snow + target: /tmp/snow + - type: bind + source: ~/.aws + target: /home/${OLO_USERNAME}/.aws + - type: bind + source: ~/.terraform.d + target: /home/${OLO_USERNAME}/.terraform.d + - type: bind + source: ~/.m2 + target: /home/${OLO_USERNAME}/.m2 + - type: bind + source: ~/.bashrc + target: /home/${OLO_USERNAME}/.bashrc + - type: bind + source: ~/.bash_history + target: /home/${OLO_USERNAME}/.bash_history + - type: bind + source: ~/.vimrc + target: /home/${OLO_USERNAME}/.vimrc + - type: bind + source: ~/.gitconfig + target: /home/${OLO_USERNAME}/.gitconfig + - type: bind + source: ~/.ssh + target: /home/${OLO_USERNAME}/.ssh + - type: bind + source: ~/.tsh + target: /home/${OLO_USERNAME}/.tsh + - type: bind + source: ~/.local + target: /home/${OLO_USERNAME}/.local + - type: bind + source: ~/.emacs.d + target: /home/${OLO_USERNAME}/.emacs.d + - type: bind + source: ~/.password-store + target: /home/${OLO_USERNAME}/.password-store + - type: bind + source: ~/.gnupg + target: /home/${OLO_USERNAME}/.gnupg + - type: bind + source: /run/user/${OLO_UID} + target: /run/user/${OLO_UID} + - type: bind + source: /run/user/${OLO_UID}/gnupg/S.gpg-agent + target: /home/${OLO_USERNAME}/.gnupg/S.gpg-agent + - type: bind + source: /etc/hosts + target: /etc/hosts + - type: bind + source: /etc/ssh + target: /etc/ssh + - type: bind + source: /var/log/lisp + target: /var/log/lisp + environment: + - TERM=xterm-256color + - AWS_SDK_LOAD_CONFIG=1 + - https_proxy=${https_proxy} + - http_proxy=${http_proxy} + - no_proxy=${no_proxy} + - OLO_PROJECT_HOME=${OLO_PROJECT_HOME} + - GITHUB_TOKEN=${GITHUB_TOKEN} + - GPG_AGENT_INFO=/home/${OLO_USERNAME}/.gnupg/S.gpg-agent:0:1 + command: [ "/bin/bash -l -c" ] diff --git a/ci/docker-run.sh b/ci/docker-run.sh new file mode 100755 index 0000000..c368224 --- /dev/null +++ b/ci/docker-run.sh @@ -0,0 +1,7 @@ +#!/bin/bash -e + +. env.sh + +docker compose --ansi "never" up -d + +exit 0 diff --git a/ci/env.sh b/ci/env.sh new file mode 100644 index 0000000..a49fb54 --- /dev/null +++ b/ci/env.sh @@ -0,0 +1,4 @@ +export OLO_USERNAME=$(id -un) +export OLO_GROUPNAME=$(id -gn) +export OLO_UID=$(id -u) +export OLO_GID=$(id -g) diff --git a/lisp/aws/aws.lisp b/lisp/aws/aws.lisp new file mode 100644 index 0000000..f5d6b93 --- /dev/null +++ b/lisp/aws/aws.lisp @@ -0,0 +1,221 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass aws () + ((profile :initarg :profile + :initform nil + :accessor profile) + (region :initarg :region + :initform (region *webapp*) + :accessor region)) + (:documentation "")) + +(defclass aws-tag () + ((key :initarg :key + :initform nil + :accessor key) + (value :initarg :value + :initform nil + :accessor value)) + (:documentation "")) + +(defclass aws-asg (aws) + ((name :initarg :name + :initform nil + :accessor name) + (arn :initarg :arn + :initform nil + :accessor arn) + (count-min :initarg :count-min + :initform nil + :accessor count-min) + (count-max :initarg :count-max + :initform nil + :accessor count-max) + (count-desired :initarg :count-desired + :initform nil + :accessor count-desired) + (instances :initarg :instances + :initform nil + :accessor instances) + (howmany :initarg :howmany + :initform nil + :accessor howmany)) + (:documentation "")) + +(defclass aws-certificate (aws) + ((arn :initarg :arn + :initform nil + :accessor arn) + (domain-name :initarg :domain-name + :initform nil + :accessor domain-name) + (status :initarg :status + :initform nil + :accessor status) + (renewal-eligibility :initarg :renewal-eligibility + :initform nil + :accessor renewal-eligibility) + (not-before :initarg :not-before + :initform nil + :accessor not-before) + (not-after :initarg :not-after + :initform nil + :accessor not-after) + (tags :initarg :tags + :initform nil + :accessor tags) + (cert :initarg :cert + :initform nil + :accessor cert) + (chain :initarg :chain + :initform nil + :accessor chain) + (key :initarg :key + :initform nil + :accessor key) + (passphrase :initarg :passphrase + :initform nil + :accessor passphrase)) + (:documentation "")) + +(defclass aws-ssm-parameter (aws) + ((name :initarg :name + :initform nil + :accessor name) + (value :initarg :value + :initform nil + :accessor value)) + (:documentation "")) + +(defmethod sanitize-json ((aws-asg aws-asg)) + (make-instance 'aws-asg + :profile nil + :region nil + :name (name aws-asg) + :count-min (count-min aws-asg) + :count-max (count-max aws-asg) + :count-desired (count-desired aws-asg) + :instances (instances aws-asg) + :howmany nil)) + +(defmethod run-aws-cli ((aws aws) command) + "Runs an awscli command and returns the results as CL-JSON object." + (let ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t))) + (with-output-to-string (stream output) + (uffi:run-shell-command (format nil + "~a --profile ~a --region ~a" + command + (profile aws) + (region aws)) + :output stream)) + (if (org-ckons-core::null-or-empty-p output) + output + (cl-json:decode-json-from-string output)))) + +(defmethod get-asgs ((aws aws) filter) + (let ((command "aws autoscaling describe-auto-scaling-groups")) + (loop for asg in (cdar (run-aws-cli aws command)) + when (org-ckons-core::match-it filter (cdr (assoc :*auto-scaling-group-name asg))) + collect (make-instance 'aws-asg + :profile (profile aws) + :region (region aws) + :name (cdr (assoc :*auto-scaling-group-name asg)) + :arn (cdr (assoc :*auto-scaling-group-+arn+ asg)) + :count-min (cdr (assoc :*min-size asg)) + :count-max (cdr (assoc :*max-size asg)) + :count-desired (cdr (assoc :*desired-capacity asg)) + :instances (loop for instance in (cdr (assoc :*instances asg)) + collect (cdr (assoc :*instance-id instance))))))) + +(defmethod get-certificates ((aws aws) &optional filter) + (sort (loop for cert in (cdr (assoc :*certificate-summary-list (run-aws-cli aws "aws acm list-certificates"))) + when (or (and (null filter) + (string= (cdr (assoc :*status cert)) "ISSUED")) + (string= filter (cdr (assoc :*domain-name cert)))) + collect (make-instance 'aws-certificate + :profile (profile aws) + :region (region aws) + :arn (cdr (assoc :*certificate-arn cert)) + :domain-name (cdr (assoc :*domain-name cert)) + :status (cdr (assoc :*status cert)) + :renewal-eligibility (cdr (assoc :*renewal-eligibility cert)) + :not-before (cdr (assoc :*not-before cert)) + :not-after (cdr (assoc :*not-after cert)))) + (lambda (x y) (string< (domain-name x) (domain-name y))))) + +(defmethod get-certificate-tags ((aws-certificate aws-certificate)) + (setf (tags aws-certificate) (sort (loop for tag in (cdr (assoc :*tags (run-aws-cli aws-certificate (format nil "aws acm list-tags-for-certificate --certificate-arn ~a" (arn aws-certificate))))) + collect (make-instance 'aws-tag + :key (cdr (assoc :*key tag)) + :value (cdr (assoc :*value tag)))) + (lambda (x y) (string< (key x) (key y)))))) + +(defun tag-exists-p (cert key value) + (find-if (lambda (x) + (and (string= (key x) key) + (string= (value x) value))) + (tags cert))) + +(defun get-certificates-to-renew (certs environment) + (loop for cert in certs + do (get-certificate-tags cert)) + (loop for cert in certs + when (and (or (tag-exists-p cert "Purpose" "KafkaAuth") + (tag-exists-p cert "Purpose" "OloAuthSigningKey")) + (tag-exists-p cert "Environment" environment)) + collect cert)) + +(defmethod bg-perform ((aws-asg aws-asg)) + (labels ((do-scale (count-desired) + (let ((command (format nil + "aws autoscaling set-desired-capacity --auto-scaling-group-name ~a --desired-capacity ~a" + (name aws-asg) + count-desired))) + (run-aws-cli aws-asg command))) + (instances-ready-p () + (let ((updated-asg (car (get-asgs aws-asg (name aws-asg)))) + (in-service-p t)) + (loop for id in (instances updated-asg) + do (let* ((command (format nil "aws autoscaling describe-auto-scaling-instances --instance-id ~a" id)) + (instance (cadar (run-aws-cli updated-asg command)))) + (when (not (string= (cdr (assoc :*lifecycle-state instance)) "InService")) + (setf in-service-p nil)))) + in-service-p))) + (let ((count (cond ((string= (howmany aws-asg) "all") (count-desired aws-asg)) + ((string= (howmany aws-asg) "one") 1) + (t 0)))) + (loop for index from 1 to count + do (progn + (do-scale (+ (count-desired aws-asg) 1)) + (sleep 15) + (do-scale (count-desired aws-asg)) + (sleep 15) + (loop while (not (instances-ready-p)) + do (sleep 30))))))) + +(defmethod recycle-asg ((aws-asg aws-asg)) + (enqueue *queue-aws* aws-asg)) + +(defmethod bg-perform ((aws-certificate aws-certificate)) + ) + +(defmethod renew-certificates ((aws-certificate aws-certificate) environment filter) + (loop for cert in (get-certificates-to-renew (get-certificates aws-certificate filter) environment) + do (let* ((passphrase (cl-base64:string-to-base64-string (org-ckons-session::generate-sessionid))) + (exported-cert (run-aws-cli aws-certificate (format nil "aws acm export-certificate --certificate-arn ~a --passphrase ~a --output json" (arn cert) passphrase)))) + (setf (cert cert) (cdr (assoc :*certificate exported-cert))) + (setf (chain cert) (cdr (assoc :*certificate-chain exported-cert))) + (setf (key cert) (cdr (assoc :*private-key exported-cert))) + (setf (passphrase cert) passphrase)))) + ;;do (enqueue *queue-aws* cert))) + +(defun get-aws-ssm-parameter (profile key) + (let* ((aws-ssm-parameter (make-instance 'aws-ssm-parameter :profile profile :region "us-east-1")) + (command (format nil "aws ssm get-parameter --with-decryption --name \"~a\"" key)) + (results (run-aws-cli aws-ssm-parameter command))) + (setf (name aws-ssm-parameter) (cdr (assoc :*name (cdar results)))) + (setf (value aws-ssm-parameter) (cdr (assoc :*value (cdar results)))) + aws-ssm-parameter)) diff --git a/lisp/awx/awx.lisp b/lisp/awx/awx.lisp new file mode 100644 index 0000000..1cc295b --- /dev/null +++ b/lisp/awx/awx.lisp @@ -0,0 +1,29 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass awx () + ((username :initarg :username + :initform nil + :accessor username) + (password :initarg :password + :initform nil + :accessor password) + (client-id :initarg :client-id + :initform nil + :accessor client-id) + (secret-key :initarg :secret-key + :initform nil + :accessor secret-key) + (baseurl :initarg :baseurl + :initform nil + :accessor baseurl) + (token :initarg :token + :initform nil + :accessor token) + (scope :initarg :scope + :initform "read" + :accessor scope)) + (:documentation "")) + diff --git a/lisp/condition/condition.lisp b/lisp/condition/condition.lisp new file mode 100644 index 0000000..d0bad15 --- /dev/null +++ b/lisp/condition/condition.lisp @@ -0,0 +1,7 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(define-condition handled-error (error) + ((text :initarg :text :reader text))) diff --git a/lisp/core/core.lisp b/lisp/core/core.lisp new file mode 100644 index 0000000..3fc978f --- /dev/null +++ b/lisp/core/core.lisp @@ -0,0 +1,8 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(defpackage :snow + (:use :cl :cl-log :hunchentoot) + (:export :snow)) + +(in-package :snow) diff --git a/lisp/git/git.lisp b/lisp/git/git.lisp new file mode 100644 index 0000000..403c25e --- /dev/null +++ b/lisp/git/git.lisp @@ -0,0 +1,104 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defun shell-wrapper-as-string (command) + (multiple-value-bind (outlist return-code) + (org-ckons-core::shell-wrapper command) + (values (ppcre:regex-replace-all (format nil "~a" #\Return) + (org-ckons-core::reduce-to-newline-separated-string outlist) + (format nil "~a" #\Newline)) + return-code))) + +(defclass git () + ((stdout :initarg :stdout + :initform nil + :accessor stdout) + (pwd :initarg :pwd + :initform (sb-ext:posix-getenv "OLO_PROJECT_HOME") + :accessor pwd) + (exclude-dirs :initarg :exclude-dirs + :initform (getf (getf (queue (get-webapp "snow")) :git) :exclude-dirs) + :accessor exclude-dirs)) + (:documentation "")) + +(defclass git-update (git) + () + (:documentation "")) + +(defclass git-update-task (git-update) + ((remote :initarg :remote + :initform nil + :accessor remote)) + (:documentation "")) + +(defmethod bg-perform ((git-update git-update)) + (let ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t)) + (all-remotes-command "gh repo list ololabs -L 9999 --no-archived --json sshUrl | jq -M '.[].sshUrl'") + (all-locals-command (format nil "cd ~a ; find . -maxdepth 1 -type d" (pwd git-update))) + all-remotes + all-remote-dirs + all-locals) + (setf all-remotes (sort (remove-if (lambda (item) + (or (org-ckons-core::match-it "CDN.git" item) + (org-ckons-core::match-it "terraform-github-import-playground.git" item) + (org-ckons-core::match-it "MvvmCross.git" item))) + (loop for remote in (org-ckons-core::shell-wrapper all-remotes-command) + collect (ppcre:regex-replace-all "\"" remote ""))) + 'string<)) + (setf all-remote-dirs (loop for remote in all-remotes + collect (subseq remote 23 (- (length remote) 4)))) + (setf all-locals (sort (set-difference (loop for dir in (org-ckons-core::shell-wrapper all-locals-command) + when (not (string= dir ".")) + collect (if (string= "./" (subseq dir 0 2)) + (subseq dir 2) + dir)) + (exclude-dirs git-update) + :test 'string=) + 'string<)) + (with-output-to-string (stream output) + (format stream "~a~%~%" all-remotes) + (loop for dir in (set-difference all-remote-dirs all-locals :test 'string=) + do (progn + (format stream "Deleting ~a/~a~%" (pwd git-update) dir) + (org-ckons-core::shell-wrapper (format nil "rm -rf ~a/~a~%" (pwd git-update) dir)))) + (loop for remote in all-remotes + do (enqueue *queue-git* (make-instance 'git-update-task + :stdout (stdout git-update) + :remote remote))) + (format stream "~%~%~%")) + (with-open-file (stream (stdout git-update) :direction :output :if-exists :append :if-does-not-exist :create) + (format stream output)))) + +(defmethod update-git ((git-update git-update)) + (enqueue *queue-git* git-update)) + +(defmethod bg-perform ((git-update-task git-update-task)) + (let* ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t)) + (dir (subseq (remote git-update-task) 23 (- (length (remote git-update-task)) 4))) + (status-command (format nil "cd ~a/~a ; git status" (pwd git-update-task) dir)) + (fetch-command (format nil "cd ~a/~a ; git fetch --prune" (pwd git-update-task) dir)) + (branch-command (format nil "cd ~a/~a ; PAGER=cat git branch | grep -F '*' | awk '{print $2}'" (pwd git-update-task) dir)) + (clone-command (format nil "cd ~a ; git clone ~a" (pwd git-update-task) (remote git-update-task)))) + (with-output-to-string (stream output) + (if (probe-file (format nil "~a/~a" (pwd git-update-task) dir)) + (progn + (format stream "Checking ~a~%" dir) + (multiple-value-bind (stdout return-code) + (shell-wrapper-as-string status-command) + (format stream "~a~%" stdout) + (when (= return-code 0) + (format stream (shell-wrapper-as-string fetch-command)) + (let ((branch (string-trim '(#\Space #\Tab #\Newline) (shell-wrapper-as-string branch-command)))) + (if (position branch '("main" "develop" "master") :test 'string=) + (progn + (format stream "Updating repo ~a on branch ~a~%" dir branch) + (format stream (shell-wrapper-as-string (format nil "cd ~a/~a ; git pull origin ~a" (pwd git-update-task) dir branch)))) + (format stream "~a not pulled because it is on branch ~a~%" dir branch)))))) + (progn + (format stream "Cloning ~a~%" dir) + (format stream (shell-wrapper-as-string clone-command)))) + (format stream "~%~%~%")) + (with-open-file (stream (stdout git-update-task) :direction :output :if-exists :append :if-does-not-exist :create) + (format stream output)))) diff --git a/lisp/octopus/octopus.lisp b/lisp/octopus/octopus.lisp new file mode 100644 index 0000000..e9e1004 --- /dev/null +++ b/lisp/octopus/octopus.lisp @@ -0,0 +1,460 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass octopus () + ((apikey :initarg :apikey + :initform (get-aws-ssm-parameter (sb-ext:posix-getenv "OLO_AWS_BUILD_PROFILE") "/octopus/ode-mgmt/token") + :accessor apikey) + (baseurl :initarg :baseurl + :initform "https://octopus.olobuild.net/api" + :accessor baseurl) + (proxy :initarg :proxy + :initform (let ((proxy-string (uffi:getenv "http_proxy"))) + (when (not (org-ckons-core::null-or-empty-p proxy-string)) + (let ((proxy-list (cl-ppcre:split ":" (car (last (cl-ppcre:split "//" proxy-string)))))) + (setf (elt proxy-list 1) (parse-integer (elt proxy-list 1))) + proxy-list))) + :accessor proxy) + (cookie-jar :initarg :cookie-jar + :initform (make-instance 'drakma:cookie-jar) + :accessor cookie-jar)) + (:documentation "")) + +(defclass octopus-environment () + ((id :initarg :id + :initform nil + :accessor id) + (name :initarg :name + :initform nil + :accessor name)) + (:documentation "")) + +(defclass octopus-project () + ((id :initarg :id + :initform nil + :accessor id) + (name :initarg :name + :initform nil + :accessor name)) + (:documentation "")) + +(defclass octopus-machine () + ((id :initarg :id + :initform nil + :accessor id) + (environment-ids :initarg :environment-ids + :initform nil + :accessor environment-ids) + (name :initarg :name + :initform nil + :accessor name) + (roles :initarg :roles + :initform nil + :accessor roles) + (uri :initarg :uri + :initform nil + :accessor uri) + (health-status :initarg :health-status + :initform nil + :accessor health-status)) + (:documentation "")) + +(defclass octopus-release () + ((id :initarg :id + :initform nil + :accessor id) + (version :initarg :version + :initform nil + :accessor version) + (version-control-reference :initarg :version-control-reference + :initform nil + :accessor version-control-reference) + (project :initarg :project + :initform nil + :accessor project)) + (:documentation "")) + +(defclass octopus-deployment () + ((id :initarg :id + :initform nil + :accessor id) + (task-id :initarg :task-id + :initform nil + :accessor task-id) + (release-version :initarg :release-version + :initform nil + :accessor release-version) + (environment :initarg :environment + :initform nil + :accessor environment) + (project :initarg :project + :initform nil + :accessor project) + (release :initarg :release + :initform nil + :accessor release) + (completed-time :initarg :completed-time + :initform nil + :accessor completed-time)) + (:documentation "")) + +(defclass octopus-task () + ((id :initarg :id + :initform nil + :accessor id) + (completed-p :initarg :completed-p + :initform nil + :accessor completed-p) + (successful-p :initarg :successful-p + :initform nil + :accessor successful-p) + (error-message :initarg :error-message + :initform nil + :accessor error-message)) + (:documentation "")) + +(defclass octopus-process-step (octopus) + ((id :initarg :id + :initform nil + :accessor id) + (name :initarg :name + :initform nil + :accessor name) + (target-roles :initarg :target-roles + :initform nil + :accessor target-roles + :documentation "Does double duty: the roles associated with a process step from +octopus are stored here as output, and also the roles we want to use +as an input filter are stored here for the ride through the queue.") + (project :initarg :project + :initform nil + :accessor project) + (stdout :initarg :stdout + :initform nil + :accessor stdout)) + (:documentation "")) + +(defclass octopus-ode-deploy-release (octopus) + ((project-name :initarg :project-name + :initform nil + :accessor project-name) + (ode-names :initarg :ode-names + :initform nil + :accessor ode-names) + (version :initarg :version + :initform nil + :accessor version) + (environment :initarg :environment + :initform nil + :accessor environment) + (project :initarg :project + :initform nil + :accessor project) + (release :initarg :release + :initform nil + :accessor release) + (stdout :initarg :stdout + :initform nil + :accessor stdout)) + (:documentation "")) + +(defclass octopus-latest-deployment () + ((deployment-id :initarg :deployment-id + :initform nil + :accessor deployment-id) + (task-id :initarg :task-id + :initform nil + :accessor task-id) + (release-version :initarg :release-version + :initform nil + :accessor release-version) + (git-commit :initarg :git-commit + :initform nil + :accessor git-commit) + (completed-time :initarg :completed-time + :initform nil + :accessor completed-time) + (environment-name :initarg :environment-name + :initform nil + :accessor environment-name) + (project-name :initarg :project-name + :initform nil + :accessor project-name)) + (:documentation "")) + +(defmacro with-octopus ((instance-name) &body body) + `(let ((,instance-name (make-instance 'octopus))) + ,@body)) + +(defmethod sanitize ((octopus-machine octopus-machine)) + (make-instance 'octopus-machine + :id (id octopus-machine) + :name (name octopus-machine) + :roles (roles octopus-machine))) + +(defmacro define-octopus-api-call ((method-name) &body macro-body) + (let ((endpoint (gensym))) + `(progn + (defgeneric ,method-name (octopus uri &key method macro-content-type params)) + (defmethod ,method-name ((octopus octopus) uri &key method macro-content-type params) + (let ((,endpoint (format nil "~a/~a" (baseurl octopus) uri)) + results) + (multiple-value-bind (body status-code headers uri stream must-close reason) + (apply #'org-ckons-http::drakma-request + `(,,endpoint + ,(cookie-jar octopus) + :method ,method + :content-type ,macro-content-type + :proxy ,(proxy octopus) + ,@(if (eq method :get) + `(:parameters ,(append params `(("skip" . "0") + ("take" . "100000")))) + `(:content ,params)) + :additional-headers (("X-Octopus-ApiKey" . ,(apikey octopus))))) + (declare (ignore headers uri stream must-close reason)) + (let ((response (cl-json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8)))) + (cond ((< status-code 300) + (org-ckons-core::add-to-list results ,@macro-body)) + (t + (error (format nil "Error response from octopus.~%Method = [~a]~%Endpoint = [~a]~%Params = [~a]~%Response = [~a]" method ,endpoint params response)))))) + results))))) + +(define-octopus-api-call (get-octopus-items-raw-impl) + response) + +(define-octopus-api-call (get-octopus-items-default-impl) + (cdr (assoc :*items response))) + +(define-octopus-api-call (get-octopus-items-process-steps-impl) + (cdr (assoc :*steps response))) + +(defmethod get-octopus-environments ((octopus octopus) &key ode-only-p filter) + (sort (loop for environment in (get-octopus-items-default-impl octopus "environments" :method :get :params `(("name" . ,(if ode-only-p "OnDemand-" "")))) + when (or (null filter) + (string= "all" (car filter)) + (intersection (loop for f in filter + when (not (string= "all" f)) + collect f) + `(,(cdr (assoc :*name environment))) + :test (lambda (x y) (org-ckons-core::match-it x y)))) + collect (make-instance 'octopus-environment + :id (cdr (assoc :*id environment)) + :name (cdr (assoc :*name environment)))) + (lambda (x y) (string< (name x) (name y))))) + +(defmethod get-octopus-ode-environments ((octopus octopus) &key filter) + (get-octopus-environments octopus + :ode-only-p t + :filter (if (string= "all" (car filter)) + filter + (loop for f in filter + collect (format nil "OnDemand-~a" f))))) + +(defmethod get-octopus-projects ((octopus octopus)) + (sort (loop for project in (get-octopus-items-default-impl octopus "projects" :method :get) + when (not (cdr (assoc :*is-disabled project))) + collect (make-instance 'octopus-project + :id (cdr (assoc :*id project)) + :name (cdr (assoc :*name project)))) + (lambda (x y) (string< (name x) (name y))))) + +(defmethod get-octopus-project ((octopus octopus) project-name) + (car (loop for project in (get-octopus-projects octopus) + when (string= project-name (name project)) + collect project))) + +(defmethod get-octopus-process-steps ((octopus octopus) project) + (let ((steps (handler-case + (get-octopus-items-process-steps-impl octopus (format nil "projects/~a/main/deploymentprocesses" (id project)) :method :get) + (error (e) + (declare (ignore e)) + (handler-case + (get-octopus-items-process-steps-impl octopus (format nil "projects/~a/deploymentprocesses" (id project)) :method :get) + (error (f) + (org-ckons-core::logger (format nil "Error in get-octopus-process-steps in project ~a ~a : ~a" (id project) (name project) f)) + ())))))) + (loop for step in steps + collect (make-instance 'octopus-process-step + :id (cdr (assoc :*id step)) + :name (cdr (assoc :*name step)) + :target-roles (let ((roles (cdr (assoc :*octopus.*action.*target-roles (cdr (assoc :*properties step)))))) + (if (listp roles) roles (list roles))) + :project project)))) + +(defmethod get-octopus-releases ((octopus octopus) project) + (sort (loop for release in (get-octopus-items-default-impl octopus (format nil "projects/~a/releases" (id project)) :method :get) + collect (make-instance 'octopus-release + :id (cdr (assoc :*id release)) + :version (cdr (assoc :*version release)) + :version-control-reference (cdr (assoc :*version-control-reference release)) + :project project)) + (lambda (x y) (string< (version x) (version y))))) + +(defmethod get-octopus-release ((octopus octopus) project version) + (when project + (car (loop for release in (get-octopus-releases octopus project) + when (string= version (version release)) + collect release)))) + +(defmethod get-octopus-machines-with-roles ((octopus octopus) roles) + (loop for machine in (get-octopus-items-default-impl octopus "machines" :method :get) + when (intersection roles (cdr (assoc :*roles machine)) :test 'string=) + collect (make-instance 'octopus-machine + :id (cdr (assoc :*id machine)) + :environment-ids (cdr (assoc :*environment-ids machine)) + :name (cdr (assoc :*name machine)) + :roles (cdr (assoc :*roles machine)) + :uri (cdr (assoc :*uri machine)) + :health-status (cdr (assoc :*health-status machine))))) + +(defmethod get-octopus-environments-with-roles ((octopus octopus) &key ode-only-p roles) + (let ((all-environments (get-octopus-environments octopus :ode-only-p ode-only-p))) + (remove-duplicates (sort (org-ckons-core::flatten + (loop for machine in (get-octopus-machines-with-roles octopus roles) + collect (loop for environment in all-environments + when (intersection (environment-ids machine) `(,(id environment)) :test 'string=) + collect environment))) + (lambda (x y) (string< (name x) (name y)))) + :test (lambda (x y) (string= (name x) (name y)))))) + +(defmethod do-octopus-deployment ((octopus-ode-deploy-release octopus-ode-deploy-release)) + (let ((deployment (get-octopus-items-raw-impl octopus-ode-deploy-release + "deployments" + :method :post + :params (json:encode-json-alist-to-string + `((:*environment-id . ,(id (environment octopus-ode-deploy-release))) + (:*project-id . ,(id (project octopus-ode-deploy-release))) + (:*release-id . ,(id (release octopus-ode-deploy-release))) + (:*use-guided-failure . nil) + (:*force-package-download . t) + (:*force-package-redeployment . t)))))) + (when deployment + (make-instance 'octopus-deployment + :id (cdr (assoc :*id deployment)) + :task-id (cdr (assoc :*task-id deployment)) + :environment (environment octopus-ode-deploy-release) + :project (project octopus-ode-deploy-release) + :release (release octopus-ode-deploy-release))))) + +(defmethod get-octopus-task ((octopus octopus) task-id) + (let ((task (get-octopus-items-raw-impl octopus (format nil "tasks/~a" task-id) :method :get))) + (when task + (make-instance 'octopus-task + :id (cdr (assoc :*id task)) + :completed-p (cdr (assoc :*is-completed task)) + :successful-p (cdr (assoc :*finished-successfully task)) + :error-message (cdr (assoc :*error-message task)))))) + +(defmethod bg-perform ((octopus-process-step octopus-process-step)) + (let ((projects (sort + (remove-duplicates + (loop for project in (get-octopus-projects octopus-process-step) + when (loop for step in (get-octopus-process-steps octopus-process-step project) + when (intersection (target-roles octopus-process-step) (target-roles step) :test 'string=) + collect step) + collect project) + :test (lambda (x y) (string= (name x) (name y)))) + (lambda (x y) (string< (name x) (name y)))))) + (with-open-file (stream (stdout octopus-process-step) :direction :output :if-exists :append :if-does-not-exist :create) + (loop for project in projects + do (format stream "~16a~a~%" (id project) (name project)))))) + +(defmethod get-octopus-projects-with-roles ((octopus-process-step octopus-process-step)) + (enqueue *queue-octopus-fast* octopus-process-step)) + +(defmethod bg-perform ((octopus-ode-deploy-release octopus-ode-deploy-release)) + (let ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t)) + (deployment (do-octopus-deployment octopus-ode-deploy-release)) + task) + (with-output-to-string (stream output) + (format stream + "Deployed ~a ~a ~a ~a to ~a ~a~%" + (name (project octopus-ode-deploy-release)) + (id (project octopus-ode-deploy-release)) + (id (release octopus-ode-deploy-release)) + (task-id deployment) + (id (environment octopus-ode-deploy-release)) + (name (environment octopus-ode-deploy-release))) + (loop while (or (not task) + (not (completed-p task))) + do (sleep 15) + (setf task (get-octopus-task octopus-ode-deploy-release (task-id deployment)))) + (when (not (successful-p task)) + (format stream " ~a failed: ~a~%" (id task) (error-message task))) + (format stream "~%")) + (with-open-file (stream (stdout octopus-ode-deploy-release) :direction :output :if-exists :append :if-does-not-exist :create) + (format stream output)))) + +(defmethod do-octopus-ode-deploy-release ((octopus-ode-deploy-release octopus-ode-deploy-release)) + (let* ((project (get-octopus-project octopus-ode-deploy-release (project-name octopus-ode-deploy-release))) + (release (get-octopus-release octopus-ode-deploy-release project (version octopus-ode-deploy-release)))) + (when (and project release) + (loop for environment in (remove-if (lambda (x) (or (string= "OnDemand-oid" (name x)) + (string= "OnDemand-verify" (name x)))) + (get-octopus-ode-environments octopus-ode-deploy-release :filter (ode-names octopus-ode-deploy-release))) + do (let ((job (make-instance 'octopus-ode-deploy-release + :project-name (project-name octopus-ode-deploy-release) + :ode-names (ode-names octopus-ode-deploy-release) + :version (version octopus-ode-deploy-release) + :project project + :release release + :environment environment + :stdout (stdout octopus-ode-deploy-release)))) + (cond ((string= "Platform Database Release" (project-name octopus-ode-deploy-release)) + (enqueue *queue-octopus-slow* job)) + (t + (enqueue *queue-octopus-fast* job)))))))) + +(defmethod get-octopus-deployments-successful ((octopus octopus)) + (loop for deployment in (get-octopus-items-default-impl octopus "dashboard/dynamic" :method :get) + when (string= (cdr (assoc :*state deployment)) "Success") + collect deployment)) + +(defmethod get-octopus-deployments ((octopus octopus) &key ode-only-p) + (let ((environments (get-octopus-environments octopus :ode-only-p ode-only-p :filter '("all"))) + (projects (get-octopus-projects octopus))) + (sort (loop for deployment in (get-octopus-deployments-successful octopus) + for environment = (find-if (lambda (x) + (string= (id x) (cdr (assoc :*environment-id deployment)))) + environments) + for project = (find-if (lambda (x) + (string= (id x) (cdr (assoc :*project-id deployment)))) + projects) + when (and environment project) + collect (make-instance 'octopus-deployment + :id (cdr (assoc :*id deployment)) + :task-id (cdr (assoc :*task-id deployment)) + :release-version (cdr (assoc :*release-version deployment)) + :completed-time (local-time:to-rfc3339-timestring (local-time:parse-timestring (cdr (assoc :*completed-time deployment)))) + :environment environment + :project project)) + (lambda (x y) (string> (completed-time x) (completed-time y)))))) + +(defmethod get-octopus-latest-deployments ((octopus octopus) &key ode-only-p) + (labels ((deployment-included-p (deployment deploy-hash) + (and (not (intersection '("Feature Flags for Pipeline" "Channel Resource Release") `(,(name (project deployment))) :test 'string=)) + (not (org-ckons-core::match-it ".*-rc$" (release-version deployment))) + (not (org-ckons-core::match-it ".*-main$" (release-version deployment))) + (not (org-ckons-core::match-it "EKS" (name (project deployment)))) + (not (org-ckons-core::match-it "YARP" (name (project deployment)))) + (or (not (gethash (name (environment deployment)) deploy-hash)) + (string> (completed-time deployment) (completed-time (gethash (name (environment deployment)) deploy-hash))))))) + (let* ((deploy-hash (make-hash-table :test 'equal)) + (deployments (loop for deployment in (get-octopus-deployments octopus :ode-only-p ode-only-p) + when (deployment-included-p deployment deploy-hash) + do (let ((release (get-octopus-release octopus (project deployment) (release-version deployment)))) + (when (version-control-reference release) + (setf (release deployment) release) + (setf (gethash (name (environment deployment)) deploy-hash) deployment)))))) + (sort (loop for deployment being the hash-values of deploy-hash + collect (make-instance 'octopus-latest-deployment + :deployment-id (id deployment) + :task-id (task-id deployment) + :release-version (release-version deployment) + :git-commit (cdr (assoc :*git-commit (version-control-reference (release deployment)))) + :completed-time (completed-time deployment) + :environment-name (name (environment deployment)) + :project-name (name (project deployment)))) + (lambda (x y) (string< (completed-time x) (completed-time y))))))) diff --git a/lisp/queue/fifo.lisp b/lisp/queue/fifo.lisp new file mode 100644 index 0000000..8bbd106 --- /dev/null +++ b/lisp/queue/fifo.lisp @@ -0,0 +1,44 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:snow) + +(defclass fifo () + ((buffer :initarg :buffer + :initform () + :accessor buffer) + (mutex :initarg :mutex + :initform (sb-thread:make-mutex) + :accessor mutex) + (discard-preceding :initarg :discard-preceding + :initform nil + :accessor discard-preceding) + (wait-interval :initarg :wait-interval + :initform 0 + :accessor wait-interval) + (timestamp :initarg :timestamp + :initform (get-universal-time) + :accessor timestamp)) + (:documentation "")) + +(defmethod dequeue ((fifo fifo)) + (sb-thread:with-mutex ((mutex fifo)) + (when (or (= (wait-interval fifo) 0) + (> (get-universal-time) (+ (timestamp fifo) (wait-interval fifo)))) + (setf (timestamp fifo) (get-universal-time)) + (when (buffer fifo) + (pop (buffer fifo)))))) + +(defmethod enqueue ((fifo fifo) obj) + (sb-thread:with-mutex ((mutex fifo)) + (if (discard-preceding fifo) + (setf (buffer fifo) `(,obj)) + (push obj (buffer fifo))))) + +(defmethod empty-p ((fifo fifo)) + (sb-thread:with-mutex ((mutex fifo)) + (endp (buffer fifo)))) + +(defmethod len ((fifo fifo)) + (sb-thread:with-mutex ((mutex fifo)) + (length (buffer fifo)))) diff --git a/lisp/queue/queue.lisp b/lisp/queue/queue.lisp new file mode 100644 index 0000000..da86f6c --- /dev/null +++ b/lisp/queue/queue.lisp @@ -0,0 +1,87 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defvar *queue-git* nil) +(defvar *queue-aws* nil) +(defvar *queue-tfcloud* nil) +(defvar *queue-octopus-slow* nil) +(defvar *queue-octopus-fast* nil) +(defvar *queue-awx* nil) +(defvar *queue-mutex* (sb-thread:make-mutex)) + +(defmacro with-error-handled-thread ((thread-name level) &body body) + "`level' is either :warning or :critical." + (let ((thread-fn (intern (string-upcase thread-name) *package*))) + `(progn + (defun ,thread-fn () + (handler-case + ,@body + (error (e) + (let ((message (format nil "The ~a thread died unexpectedly.~% exception = [~a]" ,thread-name e))) + (org-ckons-core::logger message) + ;; sleep so we don't get an error shitstorm + (sleep 10) + (sb-thread:make-thread (lambda () (funcall #',thread-fn)) + :name ,thread-name))))) + (sb-thread:make-thread (lambda () (funcall #',thread-fn)) + :name ,thread-name)))) + +(defmacro without-error-handled-thread ((thread-name level) &body body) + "For development. Falls into the debugger and dies on error." + (declare (ignore level)) + (let ((thread-fn (intern (string-upcase thread-name) *package*))) + `(progn + (defun ,thread-fn () + ,@body) + (sb-thread:make-thread (lambda () (funcall #',thread-fn)) + :name ,thread-name)))) + +(defun generate-thread-id () + "Generates a unique random string to use in the process thread +names. The string is a SHA1 hash." + (subseq (generate-sessionid) 0 32)) + +(defun queue-generator (queue-type) + (let* ((queue-name (symbol-name queue-type)) + (symbol-queue-name (intern (format nil "*QUEUE-~a*" queue-name) (package-name #.*package*))) + (queue-keyword (intern queue-name "KEYWORD")) + (symbol-sleep-interval (intern "SLEEP-INTERVAL" "KEYWORD")) + (symbol-num-process-threads (intern "NUM-PROCESS-THREADS" "KEYWORD")) + (symbol-wait-interval (intern "WAIT-INTERVAL" "KEYWORD"))) + (when (null (eval symbol-queue-name)) + (set symbol-queue-name (make-instance 'fifo :wait-interval (getf (getf (queue *webapp*) queue-keyword) symbol-wait-interval))) + (process-thread-generator queue-name queue-keyword symbol-queue-name symbol-sleep-interval symbol-num-process-threads)))) + +(defun process-thread-generator (queue-name queue-keyword symbol-queue-name symbol-sleep-interval symbol-num-process-threads) + (let ((sleep-interval (getf (queue *webapp*) symbol-sleep-interval)) + (num-threads (getf (getf (queue *webapp*) queue-keyword) symbol-num-process-threads))) + (loop for i from 1 to num-threads + do (let ((process-thread-name (format nil "~a-PROCESS-THREAD-~a" queue-name (generate-thread-id)))) + (process-thread-function symbol-queue-name process-thread-name sleep-interval))))) + +(defun process-thread-function (symbol-queue-name process-thread-name sleep-interval) + (with-error-handled-thread (process-thread-name :warning) + (labels ((do-dequeue () + (dequeue (eval symbol-queue-name))) + (do-process (object) + (bg-perform object)) + (do-sleep () + (sleep sleep-interval))) + (loop + (let (object + do-process-p + do-sleep-p) + (sb-thread:with-mutex (*queue-mutex*) + (cond ((empty-p (eval symbol-queue-name)) + (setf do-sleep-p t)) + (t + (setf object (do-dequeue)) + (if object + (setf do-process-p t) + (setf do-sleep-p t))))) + (when do-sleep-p + (do-sleep)) + (when (and do-process-p object) + (do-process object))))))) diff --git a/lisp/service/asg-recycle-service.lisp b/lisp/service/asg-recycle-service.lisp new file mode 100644 index 0000000..821abb5 --- /dev/null +++ b/lisp/service/asg-recycle-service.lisp @@ -0,0 +1,65 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass asg-recycle-service (rest-service) + () + (:documentation "")) + +(defun asg-recycle-json () + (with-noauth (instance asg-recycle-service) + t)) + +(defclass asg-recycle/view-service (asg-recycle-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun asg-recycle-view-json () + (with-noauth (instance asg-recycle/view-service) + (setf (form instance) + (make-form "asg-recycle-form" + nil + t + `((:name "profile" :label "Profile" :field-type "text" :required "required" :value ,(or (session-value :profile) "")) + (:name "region" :label "Region" :field-type "text" :required "required" :value ,(or (session-value :region) (region *webapp*))) + (:name "filter" :label "Filter" :field-type "text" :required "required" :value ,(or (session-value :asg-recycle-filter) "")) + (:label "Find Matching ASGs" :field-type "button" :onclick "on_asg_recycle_results_clicked()")))))) + +(defclass asg-recycle/results-service (asg-recycle/view-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initform nil)) + (:documentation "")) + +(defun asg-recycle-results-json (profile region filter) + (with-noauth (instance asg-recycle/results-service) + (let* ((aws (make-instance 'aws :profile profile :region region)) + (asgs (get-asgs aws filter))) + (setf (results instance) (mapcar (lambda (asg) + (sanitize-json asg)) + asgs)) + (setf (session-value :profile) profile) + (setf (session-value :region) region) + (setf (session-value :asg-recycle-filter) filter) + (setf (session-value :asg-recycle-asgs) asgs) + (setf (form instance) + (make-form "asg-recycle-submit-form" + nil + t + `((:label "Recycle All Hosts in ASGs" :field-type "button" :onclick "on_asg_recycle_results_submit_clicked('all')") + (:label "Recycle One Host in ASGs" :field-type "button" :onclick "on_asg_recycle_results_submit_clicked('one')"))))))) + +(defclass asg-recycle/results-submit-service (asg-recycle-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun asg-recycle-results-submit-json (howmany) + (with-noauth (instance asg-recycle/results-submit-service) + (loop for asg in (session-value :asg-recycle-asgs) + do (setf (howmany asg) howmany) + (recycle-asg asg)))) diff --git a/lisp/service/auth-service.lisp b/lisp/service/auth-service.lisp new file mode 100644 index 0000000..cdf9550 --- /dev/null +++ b/lisp/service/auth-service.lisp @@ -0,0 +1,21 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass auth-service (rest-service) + () + (:documentation "")) + +(defmethod initialize-instance :after ((auth-service auth-service) &key) + (when (not (string= (session-value :permissions) "admin")) + (setf (location auth-service) "/home") + (setf (errormsg auth-service) "You are not authorized to access this resource."))) + +(defmacro with-noauth ((instance rest-service) &body body) + `(let ((,instance (make-instance ',rest-service))) + ,@body + (when (location-p ,instance) + (setf (session-value :message) nil) + (setf (session-value :errormsg) nil)) + (org-ckons-json::objects-to-json `(,,instance)))) diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp new file mode 100644 index 0000000..6760ada --- /dev/null +++ b/lisp/service/base-service.lisp @@ -0,0 +1,8 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass base-service () + () + (:documentation "")) diff --git a/lisp/service/generic-form.lisp b/lisp/service/generic-form.lisp new file mode 100644 index 0000000..7902ff6 --- /dev/null +++ b/lisp/service/generic-form.lisp @@ -0,0 +1,87 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass generic-form (base-service) + ((name :initarg :name + :initform nil + :accessor name) + (http-method :initarg :http-method + :initform "POST" + :accessor http-method) + (action :initarg :action + :initform nil + :accessor action) + (required-p :initarg :required-p + :initform nil + :accessor required-p) + (form-fields :initarg :form-fields + :initform nil + :accessor form-fields)) + (:documentation "")) + +(defclass form-field (base-service) + ((name :initarg :name + :initform nil + :accessor name) + (label :initarg :label + :initform nil + :accessor label) + (value :initarg :value + :initform nil + :accessor value) + (checked :initarg :checked + :initform nil + :accessor checked) + (field-type :initarg :field-type + :initform nil + :accessor field-type) + (required :initarg :required + :initform nil + :accessor required) + (dismiss :initarg :dismiss + :initform nil + :accessor dismiss) + (options :initarg :options + :initform nil + :accessor options) + (onclick :initarg :onclick + :initform nil + :accessor onclick) + (onchange :initarg :onchange + :initform nil + :accessor onchange)) + (:documentation "")) + +(defclass option (base-service) + ((label :initarg :label + :initform nil + :accessor label) + (value :initarg :value + :initform nil + :accessor value)) + (:documentation "")) + +(defun make-form (name action required-p fields) + (make-instance 'generic-form + :name name + :action action + :required-p required-p + :form-fields (mapcar (lambda (field) + (make-instance 'form-field + :name (getf field :name) + :label (getf field :label) + :value (getf field :value) + :checked (getf field :checked) + :field-type (getf field :field-type) + :required (getf field :required) + :dismiss (getf field :dismiss) + :options (mapcar (lambda (option) + (make-instance 'option + :label (getf option :label) + :value (getf option :value))) + (getf field :options)) + :onclick (getf field :onclick) + :onchange (getf field :onchange))) + fields))) diff --git a/lisp/service/git-update-service.lisp b/lisp/service/git-update-service.lisp new file mode 100644 index 0000000..31b1c32 --- /dev/null +++ b/lisp/service/git-update-service.lisp @@ -0,0 +1,40 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass git-update-service (rest-service) + () + (:documentation "")) + +(defun git-update-json () + (with-noauth (instance git-update-service) + t)) + +(defclass git-update/view-service (git-update-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun git-update-view-json () + (with-noauth (instance git-update/view-service) + (setf (form instance) + (make-form "git-update-form" + nil + t + `((:label "Update Git Checkouts" :field-type "button" :onclick "on_git_update_view_clicked()")))))) + +(defclass git-update/results-service (git-update-service) + ((stdout :initarg :stdout + :initform nil + :accessor stdout) + (location-p :initform nil)) + (:documentation "")) + +(defun git-update-results-json () + (with-noauth (instance git-update/results-service) + (cl-fad:with-output-to-temporary-file (f :template "/tmp/snow/temp-%") + (update-git (make-instance 'git-update :stdout (pathname f))) + (setf (stdout instance) (uiop:native-namestring (pathname f)))))) diff --git a/lisp/service/home-service.lisp b/lisp/service/home-service.lisp new file mode 100644 index 0000000..509be5e --- /dev/null +++ b/lisp/service/home-service.lisp @@ -0,0 +1,18 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass home-service (rest-service) + ((content :initarg :content + :initform nil + :accessor content)) + (:documentation "")) + +(defmethod initialize-instance :after ((home-service home-service) &key) + (setf (content home-service) (format nil "Welcome to the ~a" (title *webapp*)))) + +(defun home-json (&optional message errormsg) + (with-noauth (instance home-service) + (when message (setf (message instance) message)) + (when errormsg (setf (errormsg instance) errormsg)))) diff --git a/lisp/service/menu-service.lisp b/lisp/service/menu-service.lisp new file mode 100644 index 0000000..7911e32 --- /dev/null +++ b/lisp/service/menu-service.lisp @@ -0,0 +1,59 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defparameter *menu-config* '((:id "a_menu_home" :label "Home" :handler "/home" :permissions "t") + (:id "a_menu_git_update" :label "Git Update" :handler "/git-update" :permissions "t") + (:id "a_menu_asg_recycle" :label "ASG Recycle" :handler "/asg-recycle" :permissions "t") + (:id "a_menu_tfcloud_apply" :label "TFCloud Apply" :handler "/tfcloud-apply" :permissions "t") + (:id "a_menu_octopus_machines_with_roles" :label "Octo Machines With Roles" :handler "/octopus-machines-with-roles" :permissions "t") + (:id "a_menu_octopus_environments_with_roles" :label "Octo Envs With Roles" :handler "/octopus-environments-with-roles" :permissions "t") + (:id "a_menu_octopus_projects_with_roles" :label "Octo Projects With Roles" :handler "/octopus-projects-with-roles" :permissions "t") + (:id "a_menu_octopus_ode_deploy_release" :label "Deploy Octo Release to ODEs" :handler "/octopus-ode-deploy-release" :permissions "t") + (:id "a_menu_octopus_latest_deployments" :label "Octo Latest Deployments" :handler "/octopus-latest-deployments" :permissions "t"))) + +(defclass menuitem () + ((id :initarg :id + :initform nil + :accessor id) + (label :initarg :label + :initform nil + :accessor label) + (handler :initarg :handler + :initform nil + :accessor handler) + (permissions :initarg :permissions + :initform nil + :accessor permissions) + (children :initarg :children + :initform nil + :accessor children)) + (:documentation "")) + +(defclass menu-service (base-service) + ((menuitems :initarg :menuitems + :initform nil + :accessor menuitems) + (location-p :initarg :location-p + :initform nil + :accessor location-p)) + (:documentation "")) + +(defmethod initialize-instance :after ((menu-service menu-service) &key) + (setf (menuitems menu-service) + (mapcar (lambda (x) + (make-instance 'menuitem + :id (getf x :id) + :label (getf x :label) + :handler (getf x :handler))) + (remove-if 'null (mapcar (lambda (x) + (when (find-if (lambda (y) + (string= (getf x :permissions) y)) + `("t" ,(session-value :permissions))) + x)) + *menu-config*))))) + +(defun menu-json () + (with-noauth (instance menu-service) + t)) diff --git a/lisp/service/octopus-environments-with-roles-service.lisp b/lisp/service/octopus-environments-with-roles-service.lisp new file mode 100644 index 0000000..8cd494e --- /dev/null +++ b/lisp/service/octopus-environments-with-roles-service.lisp @@ -0,0 +1,47 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass octopus-environments-with-roles-service (rest-service) + () + (:documentation "")) + +(defun octopus-environments-with-roles-json () + (with-noauth (instance octopus-environments-with-roles-service) + t)) + +(defclass octopus-environments-with-roles/view-service (octopus-environments-with-roles-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-environments-with-roles-view-json () + (with-noauth (instance octopus-environments-with-roles/view-service) + (setf (form instance) + (make-form "octopus-environments-with-roles-form" + nil + t + `((:name "roles" :label "Roles (comma or space separated)" :field-type "text" :required "required" :value ,(or (session-value :octopus-roles) "")) + (:name "ode_only_p" :label "ODE only?" :field-type "checkbox") + (:label "Find Envs With Roles" :field-type "button" :onclick "on_octopus_environments_with_roles_results_clicked()")))))) + +(defclass octopus-environments-with-roles/results-service (octopus-environments-with-roles/view-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-environments-with-roles-results-json (ode_only_p roles) + (with-noauth (instance octopus-environments-with-roles/results-service) + (with-octopus (octopus) + (let ((environments (get-octopus-environments-with-roles octopus + :ode-only-p (string= "true" ode_only_p) + :roles (remove-if (lambda (x) + (org-ckons-core::null-or-empty-p x)) + (cl-ppcre:split "[, ]" roles))))) + (setf (results instance) environments) + (setf (session-value :octopus-roles) roles))))) diff --git a/lisp/service/octopus-latest-deployments-service.lisp b/lisp/service/octopus-latest-deployments-service.lisp new file mode 100644 index 0000000..4b786bd --- /dev/null +++ b/lisp/service/octopus-latest-deployments-service.lisp @@ -0,0 +1,41 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass octopus-latest-deployments-service (rest-service) + () + (:documentation "")) + +(defun octopus-latest-deployments-json () + (with-noauth (instance octopus-latest-deployments-service) + t)) + +(defclass octopus-latest-deployments/view-service (octopus-latest-deployments-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-latest-deployments-view-json () + (with-noauth (instance octopus-latest-deployments/view-service) + (setf (form instance) + (make-form "octopus-latest-deployments-form" + nil + t + `((:name "ode_only_p" :label "ODE only?" :field-type "checkbox") + (:label "Find Latest Deployments" :field-type "button" :onclick "on_octopus_latest_deployments_results_clicked()")))))) + +(defclass octopus-latest-deployments/results-service (octopus-latest-deployments/view-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-latest-deployments-results-json (ode_only_p) + (with-noauth (instance octopus-latest-deployments/results-service) + (with-octopus (octopus) + (let ((deployments (get-octopus-latest-deployments octopus :ode-only-p (string= "true" ode_only_p)))) + (setf (results instance) deployments))))) diff --git a/lisp/service/octopus-machines-with-roles-service.lisp b/lisp/service/octopus-machines-with-roles-service.lisp new file mode 100644 index 0000000..b9bf74f --- /dev/null +++ b/lisp/service/octopus-machines-with-roles-service.lisp @@ -0,0 +1,42 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass octopus-machines-with-roles-service (rest-service) + () + (:documentation "")) + +(defun octopus-machines-with-roles-json () + (with-noauth (instance octopus-machines-with-roles-service) + t)) + +(defclass octopus-machines-with-roles/view-service (octopus-machines-with-roles-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-machines-with-roles-view-json () + (with-noauth (instance octopus-machines-with-roles/view-service) + (setf (form instance) + (make-form "octopus-machines-with-roles-form" + nil + t + `((:name "roles" :label "Roles (comma or space separated)" :field-type "text" :required "required" :value ,(or (session-value :octopus-roles) "")) + (:label "Find Machines With Roles" :field-type "button" :onclick "on_octopus_machines_with_roles_results_clicked()")))))) + +(defclass octopus-machines-with-roles/results-service (octopus-machines-with-roles/view-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-machines-with-roles-results-json (roles) + (with-noauth (instance octopus-machines-with-roles/results-service) + (with-octopus (octopus) + (let ((machines (get-octopus-machines-with-roles octopus (remove-if (lambda (x) (org-ckons-core::null-or-empty-p x)) (cl-ppcre:split "[, ]" roles))))) + (setf (results instance) (loop for machine in machines collect (sanitize machine))) + (setf (session-value :octopus-roles) roles))))) diff --git a/lisp/service/octopus-ode-deploy-release-service.lisp b/lisp/service/octopus-ode-deploy-release-service.lisp new file mode 100644 index 0000000..411fc15 --- /dev/null +++ b/lisp/service/octopus-ode-deploy-release-service.lisp @@ -0,0 +1,50 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass octopus-ode-deploy-release-service (rest-service) + () + (:documentation "")) + +(defun octopus-ode-deploy-release-json () + (with-noauth (instance octopus-ode-deploy-release-service) + t)) + +(defclass octopus-ode-deploy-release/view-service (octopus-ode-deploy-release-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-ode-deploy-release-view-json () + (with-noauth (instance octopus-ode-deploy-release/view-service) + (setf (form instance) + (make-form "octopus-ode-deploy-release-form" + nil + t + `((:name "project_name" :label "Project Name" :field-type "text" :required "required" :value ,(or (session-value :octopus-project-name) "")) + (:name "version" :label "Release" :field-type "text" :required "required" :value ,(or (session-value :octopus-release) "")) + (:name "ode_names" :label "ODE Names (comma or space separated) (\"all\" for all ODEs)" :field-type "text" :required "required" :value ,(or (session-value :octopus-ode-names) "")) + (:label "Deploy Release to ODEs" :field-type "button" :onclick "on_octopus_ode_deploy_release_results_clicked()")))))) + +(defclass octopus-ode-deploy-release/results-service (octopus-ode-deploy-release/view-service) + ((stdout :initarg :stdout + :initform nil + :accessor stdout) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-ode-deploy-release-results-json (project_name version ode_names) + (with-noauth (instance octopus-ode-deploy-release/results-service) + (cl-fad:with-output-to-temporary-file (f :template "/tmp/snow/temp-%") + (do-octopus-ode-deploy-release (make-instance 'octopus-ode-deploy-release + :project-name project_name + :version version + :ode-names (cl-ppcre:split "[, ]" ode_names) + :stdout (pathname f))) + (setf (stdout instance) (uiop:native-namestring (pathname f)))) + (setf (session-value :octopus-project-name) project_name) + (setf (session-value :octopus-release) version) + (setf (session-value :octopus-ode-names) ode_names))) diff --git a/lisp/service/octopus-projects-with-roles-service.lisp b/lisp/service/octopus-projects-with-roles-service.lisp new file mode 100644 index 0000000..c3d9a67 --- /dev/null +++ b/lisp/service/octopus-projects-with-roles-service.lisp @@ -0,0 +1,44 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass octopus-projects-with-roles-service (rest-service) + () + (:documentation "")) + +(defun octopus-projects-with-roles-json () + (with-noauth (instance octopus-projects-with-roles-service) + t)) + +(defclass octopus-projects-with-roles/view-service (octopus-projects-with-roles-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-projects-with-roles-view-json () + (with-noauth (instance octopus-projects-with-roles/view-service) + (setf (form instance) + (make-form "octopus-projects-with-roles-form" + nil + t + `((:name "roles" :label "Roles (comma or space separated)" :field-type "text" :required "required" :value ,(or (session-value :octopus-roles) "")) + (:label "Find Projects With Roles" :field-type "button" :onclick "on_octopus_projects_with_roles_results_clicked()")))))) + +(defclass octopus-projects-with-roles/results-service (octopus-projects-with-roles/view-service) + ((stdout :initarg :stdout + :initform nil + :accessor stdout) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-projects-with-roles-results-json (roles) + (with-noauth (instance octopus-projects-with-roles/results-service) + (cl-fad:with-output-to-temporary-file (f :template "/tmp/snow/temp-%") + (get-octopus-projects-with-roles (make-instance 'octopus-process-step + :target-roles (remove-if (lambda (x) (org-ckons-core::null-or-empty-p x)) (cl-ppcre:split "[, ]" roles)) + :stdout (pathname f))) + (setf (stdout instance) (uiop:native-namestring (pathname f)))) + (setf (session-value :octopus-roles) roles))) diff --git a/lisp/service/rest-service.lisp b/lisp/service/rest-service.lisp new file mode 100644 index 0000000..a060863 --- /dev/null +++ b/lisp/service/rest-service.lisp @@ -0,0 +1,36 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass rest-service (base-service) + ((location :initarg :location + :initform nil + :accessor location) + (location-p :initarg :location-p + :initform t + :accessor location-p) + (message :initarg :message + :initform nil + :accessor message) + (errormsg :initarg :errormsg + :initform nil + :accessor errormsg)) + (:documentation "")) + +(defmethod initialize-instance :after ((rest-service rest-service) &key) + (when (location-p rest-service) + (if (message rest-service) + (setf (session-value :message) (message rest-service)) + (setf (message rest-service) (session-value :message))) + (if (errormsg rest-service) + (setf (session-value :errormsg) (errormsg rest-service)) + (setf (errormsg rest-service) (session-value :errormsg))) + (when (null (location rest-service)) + (setf (location rest-service) (type-to-path rest-service))))) + +(defun location-json (&optional (location "/home")) + (format nil "{\"location\":\"~a\"}" location)) + +(defun type-to-path (rest-type) + (concatenate 'string "/" (ppcre:regex-replace "-service" (string-downcase (type-of rest-type)) "/"))) diff --git a/lisp/service/tfcloud-apply-service.lisp b/lisp/service/tfcloud-apply-service.lisp new file mode 100644 index 0000000..ac5f6f0 --- /dev/null +++ b/lisp/service/tfcloud-apply-service.lisp @@ -0,0 +1,59 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass tfcloud-apply-service (rest-service) + () + (:documentation "")) + +(defun tfcloud-apply-json () + (with-noauth (instance tfcloud-apply-service) + t)) + +(defclass tfcloud-apply/view-service (tfcloud-apply-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun tfcloud-apply-view-json () + (with-noauth (instance tfcloud-apply/view-service) + (setf (form instance) + (make-form "tfcloud-apply-form" + nil + t + `((:name "filter" :label "Filter" :field-type "text" :required "required" :value ,(or (session-value :tfcloud-apply-filter) "")) + (:label "Find Matching Workspaces" :field-type "button" :onclick "on_tfcloud_apply_results_clicked()")))))) + +(defclass tfcloud-apply/results-service (tfcloud-apply/view-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initform nil)) + (:documentation "")) + +(defun tfcloud-apply-results-json (filter) + (with-noauth (instance tfcloud-apply/results-service) + (with-tfcloud (tfcloud) + (let ((workspaces (get-tfcloud-workspaces tfcloud filter))) + (setf (results instance) (mapcar (lambda (workspace) + (sanitize-json workspace)) + workspaces)) + (setf (session-value :tfcloud-apply-filter) filter) + (setf (session-value :tfcloud-apply-workspaces) workspaces) + (setf (form instance) + (make-form "tfcloud-apply-submit-form" + nil + t + `((:label "Apply Workspaces" :field-type "button" :onclick "on_tfcloud_apply_results_submit_clicked()")))))))) + +(defclass tfcloud-apply/results-submit-service (tfcloud-apply-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun tfcloud-apply-results-submit-json () + (with-noauth (instance tfcloud-apply/results-submit-service) + (loop for workspace in (session-value :tfcloud-apply-workspaces) + do (apply-tfcloud-workspace workspace)))) diff --git a/lisp/snow.asd b/lisp/snow.asd new file mode 100644 index 0000000..741a1d0 --- /dev/null +++ b/lisp/snow.asd @@ -0,0 +1,79 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :cl) + +(defpackage :snow-system (:use :cl :asdf)) +(in-package :snow-system) + +(defmacro do-defsystem (&key name version maintainer author description long-description depends-on components) + `(defsystem ,name + :name ,name + :version ,version + :maintainer ,maintainer + :author ,author + :description ,description + :long-description ,long-description + :depends-on ,(eval depends-on) + :components ,components)) + +(defparameter *quicklisp-packages* '(net-telent-date simple-date local-time cl-ppcre uffi hunchentoot cl-log ironclad)) +(defparameter *asdf-packages* '(org-ckons-core org-ckons-condition org-ckons-http org-ckons-json org-ckons-file org-ckons-session)) +(defparameter *all-packages* (append *quicklisp-packages* *asdf-packages*)) + +(loop for pkg in *quicklisp-packages* do + (ql:quickload (symbol-name pkg))) + +(do-defsystem :name "snow" + :version "1" + :maintainer "Carlos Konstanski <me@ckons.org>" + :author "Carlos Konstanski <me@ckons.org>" + :description "snow" + :long-description "SNOW is a web application written in Common Lisp, based on the Hunchentoot web server. It is a webapp framework for Platform Evolution engineer tools." + :depends-on *all-packages* + :components ((:module core + :components ((:file "core"))) + (:module condition + :depends-on (core) + :components ((:file "condition"))) + (:module queue + :depends-on (condition) + :components ((:file "fifo") + (:file "queue" :depends-on ("fifo")))) + (:module git + :depends-on (queue) + :components ((:file "git"))) + (:module aws + :depends-on (queue) + :components ((:file "aws"))) + (:module tfcloud + :depends-on (queue) + :components ((:file "tfcloud"))) + (:module octopus + :depends-on (queue aws) + :components ((:file "octopus"))) + (:module awx + :depends-on (queue aws) + :components ((:file "awx"))) + (:module service + :depends-on (git aws tfcloud octopus) + :components ((:file "base-service") + (:file "rest-service" :depends-on ("base-service")) + (:file "auth-service" :depends-on ("rest-service")) + (:file "generic-form" :depends-on ("rest-service")) + (:file "menu-service" :depends-on ("base-service")) + (:file "home-service" :depends-on ("auth-service")) + (:file "git-update-service" :depends-on ("auth-service")) + (:file "asg-recycle-service" :depends-on ("auth-service")) + (:file "tfcloud-apply-service" :depends-on ("auth-service")) + (:file "octopus-machines-with-roles-service" :depends-on ("auth-service")) + (:file "octopus-environments-with-roles-service" :depends-on ("auth-service")) + (:file "octopus-projects-with-roles-service" :depends-on ("auth-service")) + (:file "octopus-ode-deploy-release-service" :depends-on ("auth-service")) + (:file "octopus-latest-deployments-service" :depends-on ("auth-service")))) + (:module webapps + :depends-on (service) + :components ((:file "webapp-loader") + (:module snow + :depends-on ("webapp-loader") + :components ((:file "site"))))))) diff --git a/lisp/tfcloud/tfcloud.lisp b/lisp/tfcloud/tfcloud.lisp new file mode 100644 index 0000000..167abb6 --- /dev/null +++ b/lisp/tfcloud/tfcloud.lisp @@ -0,0 +1,97 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass tfcloud () + ((token :initarg :token + :initform (cdr (assoc :token (cdadr (car (cl-json:decode-json-from-string (uiop:read-file-string "~/.terraform.d/credentials.tfrc.json")))))) + :accessor token) + (baseurl :initarg :baseurl + :initform "https://app.terraform.io/api/v2" + :accessor baseurl) + (proxy :initarg :proxy + :initform (let ((proxy-string (uffi:getenv "http_proxy"))) + (when (not (org-ckons-core::null-or-empty-p proxy-string)) + (let ((proxy-list (cl-ppcre:split ":" (car (last (cl-ppcre:split "//" proxy-string)))))) + (setf (elt proxy-list 1) (parse-integer (elt proxy-list 1))) + proxy-list))) + :accessor proxy) + (cookie-jar :initarg :cookie-jar + :initform (make-instance 'drakma:cookie-jar) + :accessor cookie-jar)) + (:documentation "")) + +(defclass tfcloud-workspace (tfcloud) + ((id :initarg :id + :initform nil + :accessor id) + (name :initarg :name + :initform nil + :accessor name)) + (:documentation "")) + + (defmacro with-tfcloud ((instance-name) &body body) + `(let ((,instance-name (make-instance 'tfcloud))) + ,@body)) + +(defmethod sanitize-json ((tfcloud-workspace tfcloud-workspace)) + (make-instance 'tfcloud-workspace + :id (id tfcloud-workspace) + :name (name tfcloud-workspace) + :token nil + :baseurl nil + :proxy nil + :cookie-jar nil)) + +(defmacro define-tfcloud-api-call ((method-name) &body macro-body) + (let ((endpoint (gensym))) + `(progn + (defgeneric ,method-name (tfcloud uri &key method macro-content-type params paginate-p)) + (defmethod ,method-name ((tfcloud tfcloud) uri &key method macro-content-type params paginate-p) + (let ((,endpoint (format nil "~a/~a" (baseurl tfcloud) uri)) + (page "1") + results) + (loop until (null page) do + (multiple-value-bind (body status-code headers uri stream must-close reason) + (apply #'org-ckons-http::drakma-request + `(,,endpoint + ,(cookie-jar tfcloud) + :method ,method + :content-type ,macro-content-type + :proxy ,(proxy tfcloud) + ,@(if (eq method :get) + `(:parameters ,(append params (when paginate-p `(("page[number]" . ,(format nil "~a" page)) + ("page[size]" . "100"))))) + `(:content ,params)) + :additional-headers (("Authorization" . ,(format nil "Bearer ~a" (token tfcloud)))))) + (declare (ignore headers uri stream must-close reason)) + (let ((response (cl-json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8)))) + (cond ((< status-code 300) + (org-ckons-core::add-to-list results ,@macro-body) + (setf page (when paginate-p + (cdr (assoc :next-page (cdr (assoc :pagination (cdr (assoc :meta response))))))))) + (t + (error (format nil "Error response from tfcloud.~%Method = [~a]~%Endpoint = [~a]~%Params = [~a]~%Page = [~a]~%Response = [~a]" method ,endpoint params page response))))))) + results))))) + +(define-tfcloud-api-call (tfcloud-default-impl) + (cdr (assoc :data response))) + +(defmethod get-tfcloud-workspaces ((tfcloud tfcloud) filter) + (sort (loop for workspace in (tfcloud-default-impl tfcloud "organizations/olo/workspaces" :method :get :paginate-p t) + when (org-ckons-core::match-it filter (cdr (assoc :name (cdr (assoc :attributes workspace))))) + collect (make-instance 'tfcloud-workspace + :id (cdr (assoc :id workspace)) + :name (cdr (assoc :name (cdr (assoc :attributes workspace)))))) + (lambda (x y) (string< (name x) (name y))))) + +(defmethod bg-perform ((tfcloud-workspace tfcloud-workspace)) + (tfcloud-default-impl tfcloud-workspace + "runs" + :method :post + :macro-content-type "application/vnd.api+json" + :params (cl-json:encode-json-to-string `((:data . ((:attributes . ((:message . "Applied via Snow"))) (:type . "runs") (:relationships . ((:workspace . ((:data . ((:type . "workspaces") (:id . ,(id tfcloud-workspace)))))))))))))) + +(defmethod apply-tfcloud-workspace ((tfcloud-workspace tfcloud-workspace)) + (enqueue *queue-tfcloud* tfcloud-workspace)) 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") " ") + ((div :class "col") + ((div :class "page-header") + ((h2 :align "center") ,(title *webapp*)))) + ((div :class "col") " ")) + ((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))))) |
