Fix aws-ec2-ssh hang: replace subprocess AWS CLI with native jerboa-aws HTTPS
ober
7bdcaf1a3ec4af7cd175ed0011caa01a7ddcfd32
--- a/Dockerfile +++ b/Dockerfile @@ -53,6 +53,19 @@ RUN cd /tmp && \ make -j$(nproc) && make install && \ cd / && rm -rf /tmp/xcb-util-0.4.1* +# Build static OpenSSL (needed by chez-ssl for AWS API calls) +# Alpine's openssl-dev only ships shared libs; we need .a files for the static binary. +RUN apk add --no-cache openssl-dev perl && \ + OPENSSL_VER=$(apk info openssl 2>/dev/null | head -1 | grep -oE '[0-9]+\.[0-9]+\.[0-9]+' | head -1 || echo "3.3.2") && \ + wget -q https://www.openssl.org/source/openssl-${OPENSSL_VER}.tar.gz || \ + wget -q https://www.openssl.org/source/openssl-3.3.2.tar.gz && \ + tar xf openssl-*.tar.gz && \ + cd openssl-*/ && \ + ./Configure linux-x86_64 no-shared no-tests no-apps -O2 --prefix=/usr && \ + make -j$(nproc) && \ + cp libssl.a libcrypto.a /usr/lib/ && \ + cd / && rm -rf openssl-*/ openssl-*.tar.gz + # ── Phase 2: Build Qt6 qtbase static ──────────────────────────────────── ARG QT6_VERSION=6.8.3 RUN wget -q https://download.qt.io/official_releases/qt/6.8/${QT6_VERSION}/submodules/qtbase-everywhere-src-${QT6_VERSION}.tar.xz && \ --- a/Makefile +++ b/Makefile @@ -3,9 +3,12 @@ JERBOA = $(HOME)/mine/jerboa JSH = vendor/jerboa-shell/src GHERKIN = vendor/gherkin-runtime CHEZ_QT = vendor/chez-qt -LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(GHERKIN):$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla/src:$(CHEZ_QT) +JAWS = vendor/jerboa-aws +CSSL = vendor/chez-ssl/src +CHTTPS = vendor/chez-https/src +LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(GHERKIN):$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla/src:$(CHEZ_QT):$(JAWS):$(CSSL):$(CHTTPS) JERBUILD = $(SCHEME) --libdirs $(JERBOA)/lib --script $(JERBOA)/jerbuild.ss -export LD_LIBRARY_PATH := .:$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:vendor/jerboa-shell:$(LD_LIBRARY_PATH) +export LD_LIBRARY_PATH := .:$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:vendor/jerboa-shell:$(HOME)/mine/chez-ssl:$(LD_LIBRARY_PATH) export CHEZ_SCINTILLA_LIB := $(HOME)/mine/chez-scintilla export CHEZ_PCRE2_LIB := $(HOME)/mine/chez-pcre2 export CHEZ_QT_LIB := $(CURDIR) @@ -256,6 +259,9 @@ PCRE2_SRC ?= $(HOME)/mine/chez-pcre2 SCI_SRC ?= $(HOME)/mine/chez-scintilla QT_SRC ?= $(CURDIR)/vendor/chez-qt QTSHIM_SRC ?= $(HOME)/mine/gerbil-qt +JAWS_SRC ?= $(HOME)/mine/jerboa-aws/lib +CSSL_SRC ?= $(HOME)/mine/chez-ssl +CHTTPS_SRC ?= $(HOME)/mine/chez-https # Use stub if the Rust musl build hasn't been compiled yet (regular file check) _RUST_COREUTILS := $(JSH_SRC)/rust-coreutils/target/x86_64-unknown-linux-musl/release/libjsh_coreutils.a JSH_COREUTILS_LIB ?= $(shell test -f $(_RUST_COREUTILS) && echo $(_RUST_COREUTILS) || echo $(CURDIR)/vendor/libjsh_coreutils_stub.a) @@ -277,6 +283,9 @@ docker-deps: --build-context sci-src=$(SCI_SRC) \ --build-context qt-src=$(QT_SRC) \ --build-context qtshim-src=$(QTSHIM_SRC) \ + --build-context jaws-src=$(JAWS_SRC) \ + --build-context chez-ssl-src=$(CSSL_SRC) \ + --build-context chez-https-src=$(CHTTPS_SRC) \ -t $(DEPS_IMAGE) \ $(CURDIR) @@ -370,6 +379,23 @@ build-jemacs-qt-static: check-root /src/support/treesitter_shim.c -Wall && \ gcc -c -O2 -o /tmp/jemacs-build/treesitter_queries.o \ /src/support/treesitter_queries.c -Wall && \ + cp /src/vendor/chez-ssl-static.sls /deps/chez-ssl/src/chez-ssl.sls && \ + cp /src/vendor/jerboa-aws-crypto-native.sls /deps/jerboa-aws/jerboa-aws/crypto.sls && \ + find /deps/chez-ssl -name '*.so' -delete && find /deps/chez-ssl -name '*.wpo' -delete && \ + find /deps/chez-https -name '*.so' -delete && find /deps/chez-https -name '*.wpo' -delete && \ + find /deps/jerboa-aws -name '*.so' -delete && find /deps/jerboa-aws -name '*.wpo' -delete && \ + JEMACS_STATIC=1 /opt/chez/bin/scheme \ + --libdirs /deps/chez-ssl/src:/deps/jerboa/lib \ + --compile-imported-libraries -q --script /src/vendor/chez-ssl-compile-libs.ss && \ + find /deps/chez-ssl -name '*.wpo' -delete && \ + JEMACS_STATIC=1 /opt/chez/bin/scheme \ + --libdirs /deps/chez-https/src:/deps/chez-ssl/src \ + --compile-imported-libraries -q --script /src/vendor/chez-https-compile-libs.ss && \ + find /deps/chez-https -name '*.wpo' -delete && \ + JEMACS_STATIC=1 /opt/chez/bin/scheme \ + --libdirs /deps/jerboa-aws:/deps/chez-https/src:/deps/chez-ssl/src:/deps/jerboa/lib \ + --compile-imported-libraries -q --script /src/vendor/jerboa-aws-compile-libs.ss && \ + find /deps/jerboa-aws -name '*.wpo' -delete && \ JEMACS_STATIC=1 \ CHEZ_DIR=$(CHEZ_MUSL_DIR) \ JERBOA_DIR=/deps/jerboa/lib \ @@ -380,6 +406,9 @@ build-jemacs-qt-static: check-root CHEZ_QT_DIR=/deps/chez-qt \ CHEZ_QT_SHIM_DIR=/deps/gerbil-qt/vendor \ JSH_COREUTILS_LIB=/deps/jsh/libjsh_coreutils.a \ + JAWS_DIR=/deps/jerboa-aws \ + CHEZ_SSL_DIR=/deps/chez-ssl \ + CHEZ_HTTPS_DIR=/deps/chez-https/src \ TREE_SITTER_INCLUDE=/opt/tree-sitter-include \ TREE_SITTER_LIB=/opt/tree-sitter-lib \ TREE_SITTER_GRAMMARS=/opt/tree-sitter-grammars \ @@ -387,7 +416,7 @@ build-jemacs-qt-static: check-root TREE_SITTER_QUERIES_OBJ=/tmp/jemacs-build/treesitter_queries.o \ PKG_CONFIG_PATH=/opt/qt6-static/lib/pkgconfig \ /opt/chez/bin/scheme \ - --libdirs lib:/deps/jerboa/lib:/deps/jsh/src:/src/vendor/gherkin-runtime:/deps/chez-pcre2:/deps/chez-scintilla/src:/deps/chez-qt \ + --libdirs lib:/deps/jerboa/lib:/deps/jsh/src:/src/vendor/gherkin-runtime:/deps/chez-pcre2:/deps/chez-scintilla/src:/deps/chez-qt:/deps/jerboa-aws:/deps/chez-ssl/src:/deps/chez-https/src \ --script build-binary-qt.ss linux-static-qt-docker: @@ -400,8 +429,19 @@ linux-static-qt-docker: -v $(JERBOA)/lib/jerboa:/host-jerboa-core:ro \ -v $(JSH_SRC)/src:/host-jsh-src:ro \ -v $(JSH_COREUTILS_LIB):/host-jsh-coreutils.a:ro \ + -v $(JAWS_SRC):/host-jaws:ro \ + -v $(CSSL_SRC):/host-chez-ssl:ro \ + -v $(CHTTPS_SRC):/host-chez-https:ro \ $(DEPS_IMAGE) \ - sh -c "apk add --no-cache libvterm-dev libvterm-static >/dev/null 2>&1; \ + sh -c "apk add --no-cache libvterm-dev libvterm-static openssl-dev; \ + if [ ! -f /usr/lib/libssl.a ]; then \ + echo 'Building static OpenSSL (one-time)...' && \ + cd /tmp && wget -q https://www.openssl.org/source/openssl-3.3.2.tar.gz && \ + tar xf openssl-3.3.2.tar.gz && cd openssl-3.3.2 && \ + ./Configure linux-x86_64 no-shared no-tests no-apps -O2 --prefix=/usr && \ + make -j$(nproc) && cp libssl.a libcrypto.a /usr/lib/ && \ + cd / && rm -rf /tmp/openssl-3.3.2*; \ + fi; \ cp /host-jsh-coreutils.a /deps/jsh/libjsh_coreutils.a; \ cp -a /host-jsh-src/. /deps/jsh/src/; \ echo 'SYNC: bulk-copying host jerboa std/ and jerboa/ into container...'; \ @@ -415,6 +455,11 @@ linux-static-qt-docker: -q --script /tmp/compile-jerboa-core.ss && \ rm -f /deps/jerboa/lib/jerboa/*.wpo && \ echo 'COMPILED: jerboa core + prelude'; \ + mkdir -p /deps/jerboa-aws /deps/chez-ssl/src /deps/chez-https/src && \ + cp -a /host-jaws/. /deps/jerboa-aws/ && \ + cp -a /host-chez-ssl/. /deps/chez-ssl/ && \ + cp -a /host-chez-https/. /deps/chez-https/ && \ + echo 'SYNC: jerboa-aws, chez-ssl, chez-https copied'; \ chmod 755 /root && \ chown -R $(UID):$(GID) /opt/ /deps && \ mkdir -p /tmp/jemacs-build && chown $(UID):$(GID) /tmp/jemacs-build && \ --- a/build-binary-qt.ss +++ b/build-binary-qt.ss @@ -82,6 +82,15 @@ (define qt-shim-dir (or (getenv "CHEZ_QT_SHIM_DIR") (format "~a/mine/gerbil-qt/vendor" home))) +(define jaws-dir + (or (getenv "JAWS_DIR") + (format "~a/mine/jerboa-aws/lib" home))) +(define chez-ssl-dir + (or (getenv "CHEZ_SSL_DIR") + (format "~a/mine/chez-ssl" home))) +(define chez-https-dir + (or (getenv "CHEZ_HTTPS_DIR") + (format "~a/mine/chez-https/src" home))) ;; Static build detection (needed before dep checks) (define jemacs-static? @@ -115,6 +124,9 @@ (printf "Sci dir: ~a~n" sci-dir) (printf "Qt dir: ~a~n" qt-dir) (printf "Qt shim dir: ~a~n" qt-shim-dir) +(printf "jaws dir: ~a~n" jaws-dir) +(printf "chez-ssl dir: ~a~n" chez-ssl-dir) +(printf "chez-https dir:~a~n" chez-https-dir) ;; --- Step 1: Compile all modules + entry point --- (printf "~n[1/7] Compiling all modules (optimize-level 3, WPO)...~n") @@ -253,6 +265,14 @@ '("ffi" "pcre2")) ;; std/net/request (WPO-missing) (list (format "~a/std/net/request.so" jerboa-dir)) + ;; chez-ssl + chez-https (TLS for AWS API) + (list (format "~a/src/chez-ssl.so" chez-ssl-dir) + (format "~a/chez-https.so" chez-https-dir)) + ;; jerboa-aws EC2 modules + (map (lambda (m) (format "~a/jerboa-aws/~a.so" jaws-dir m)) + '("creds" "crypto" "xml" "json" "time" "uri" "sigv4" "request" "api")) + (map (lambda (m) (format "~a/jerboa-aws/ec2/~a.so" jaws-dir m)) + '("xml" "params" "api" "instances")) ;; chez-scintilla (all modules — WPO-missing) (map (lambda (m) (format "~a/chez-scintilla/~a.so" sci-dir m)) '("ffi" "constants" "style" "lexer" "scintilla" "tui")) @@ -500,6 +520,14 @@ echo OK" (display "Error: chez_scintilla_stubs.c compilation failed\n") (exit 1)))) +;; chez-ssl shim (TLS FFI for jerboa-aws EC2 API calls) +(when jemacs-static? + (let* ((cmd (format "gcc -c -O2 -o jemacs-qt-chez-ssl-shim.o ~a/chez_ssl_shim.c -Wall 2>&1" + chez-ssl-dir))) + (unless (= 0 (system cmd)) + (display "Error: chez_ssl_shim.c compilation failed\n") + (exit 1)))) + ;; pty shim (needed for static builds — pty_* symbols from support/pty_shim.c) (when jemacs-static? (let* ((cmd "gcc -c -O2 -o jemacs-qt-pty-shim.o support/pty_shim.c -Wall 2>&1")) @@ -570,17 +598,23 @@ echo OK" "/tmp/jemacs-build/crypto_stub.o" "")) ;; jsh Rust coreutils static library (musl build, pre-compiled on host) (jsh-coreutils-lib (or (getenv "JSH_COREUTILS_LIB") "")) + (ssl-libs (let ((pkgconf (shell-output "pkg-config --static --libs openssl 2>/dev/null" ""))) + (if (> (string-length pkgconf) 0) + pkgconf + "-L/usr/lib -lssl -lcrypto"))) (cmd (format "g++ -static -Wl,--export-dynamic -o jemacs-qt \ jemacs-qt-main.o jemacs-qt-chez-shim.o jemacs-qt-pcre2-shim.o jemacs-qt-jsh-ffi.o jemacs-qt-jsh-coreutils.o \ jemacs-qt-embed-crypto.o jemacs-qt-ssh-agent-stub.o ~a \ jemacs-qt-pty-shim.o jemacs-qt-vterm-shim.o jemacs-qt-repl-shim.o jemacs-qt-jerboa-landlock.o jemacs-qt-sci-stubs.o \ +jemacs-qt-chez-ssl-shim.o \ qt_static_symbols.o \ ~a ~a ~a ~a ~a ~a \ -L~a -lkernel -llz4 -lz \ +~a \ -lvterm -lm -ldl -lpthread -luuid -lncurses -lstdc++ 2>&1" crypto-stub libqt-shim qt-plugins ts-link qt-libs pcre2-libs jsh-coreutils-lib - chez-dir))) + chez-dir ssl-libs))) (printf " ~a~n" cmd) (unless (= 0 (system cmd)) (display "Error: Static link failed\n") @@ -611,7 +645,8 @@ qt_static_symbols.o \ "jemacs-qt-ssh-agent-stub.o" "jemacs-qt-ssh-agent-stub.c" "jemacs-qt-pty-shim.o" "jemacs-qt-vterm-shim.o" "jemacs-qt-jerboa-landlock.o" - "jemacs-qt-sci-stubs.o" "qt_static_symbols.o" "qt_static_symbols.c") + "jemacs-qt-sci-stubs.o" "jemacs-qt-chez-ssl-shim.o" + "qt_static_symbols.o" "qt_static_symbols.c") '()))) (printf "~n========================================~n") --- a/lib/jerboa-emacs/async.sls +++ b/lib/jerboa-emacs/async.sls @@ -552,8 +552,8 @@ (let ([v (hashtable-ref cache key - '#{miss bbhoe7u0vfcvf8wf5ezuvxl6i-1})]) - (if (eq? v '#{miss bbhoe7u0vfcvf8wf5ezuvxl6i-2}) + '#{miss omw6w8wawbthtimg5q8die4gm-1})]) + (if (eq? v '#{miss omw6w8wawbthtimg5q8die4gm-2}) (if (null? default) #f (car default)) v))) (def (weak-cache-set! cache key value) --- a/lib/jerboa-emacs/qt/commands-aws.sls +++ b/lib/jerboa-emacs/qt/commands-aws.sls @@ -14,13 +14,14 @@ mutex? mutex-name sort sort!) (std sugar) (std sort) (std srfi srfi-13) (only (std misc string) string-empty?) - (only (std misc ports) read-file-lines) (std text json) + (only (std misc ports) read-file-lines) (chez-scintilla constants) (jerboa-emacs core) (jerboa-emacs buffer) (jerboa-emacs tabulated-list) (jerboa-emacs terminal) (jerboa-emacs async) (jerboa-emacs echo) (jerboa-emacs qt buffer) (jerboa-emacs qt window) (jerboa-emacs qt sci-shim) (jerboa-emacs qt echo) (jerboa-emacs qt commands-core) + (jerboa-aws ec2 api) (jerboa-aws ec2 instances) (jerboa core) (jerboa runtime)) (def *aws-ec2-ssh-config-file* "~/.aws-custom-ssh.yaml") (def *aws-ec2-ssh-cache-ttl* 300) @@ -85,53 +86,64 @@ (def (aws-cache-clear!) (set! *aws-cache* #f) (set! *aws-cache-expiry* 0)) - (def (aws-fetch-region-cmd region) - "Build aws CLI command string for a region." - (string-append - "aws ec2 describe-instances --region " - region - " --output json --no-cli-pager 2>/dev/null")) - (def (aws-parse-instances json-str region) - "Parse AWS JSON output into a list of instance alists.\n Each instance gets an extra '_region' key." + (def (native-ht-ref ht key default) + "Hashtable-ref for native Chez symbol-keyed hashtables from jerboa-aws." + (if (hashtable? ht) (hashtable-ref ht key default) default)) + (def (native-instance-state inst) + "Get state name (running, stopped, etc.) from native instance hash." + (let ([state (native-ht-ref inst 'instanceState #f)]) + (if state (or (native-ht-ref state 'name #f) "-") "-"))) + (def (native-instance-name inst) + "Get Name tag value from native instance hash." + (let ([tags (native-ht-ref inst 'tagSet '())]) + (if (list? tags) + (let loop ([ts tags]) + (if (null? ts) + "" + (let ([tag (car ts)]) + (if (and (hashtable? tag) + (equal? (native-ht-ref tag 'key #f) "Name")) + (or (native-ht-ref tag 'value #f) "") + (loop (cdr ts)))))) + ""))) + (def (native-parse-instances response region) + "Parse describe-instances response hash into list of (cons region instance-hash).\n Only returns running instances." (with-catch (lambda (e) '()) (lambda () - (let* ([data (string->json-object json-str)] - [reservations (or (hash-ref data "Reservations" #f) - '())]) + (let ([reservations (or (native-ht-ref + response + 'reservationSet + #f) + '())]) (apply append - (map (lambda (r) - (let ([instances (or (hash-ref r "Instances" #f) - '())]) - (map (lambda (inst) - (hash-put! inst "_region" region) - inst) - instances))) - reservations)))))) - (def (aws-instance-name inst) - "Get the Name tag from an instance hash, or empty string." - (let ([tags (or (hash-ref inst "Tags" #f) '())]) - (let loop ([ts tags]) - (if (null? ts) - "" - (let ([tag (car ts)]) - (if (and (hash-ref tag "Key" #f) - (string=? (hash-ref tag "Key" "") "Name")) - (or (hash-ref tag "Value" #f) "") - (loop (cdr ts)))))))) - (def (aws-instance-state inst) - "Get the state name (running, stopped, etc.)." - (let ([state (hash-ref inst "State" #f)]) - (if state (or (hash-ref state "Name" #f) "-") "-"))) - (def (aws-instance->entry inst) - "Convert an AWS instance hash to a tabulated-list entry: (cons id (vector ...))." - (let* ([id (or (hash-ref inst "InstanceId" #f) "")] - [name (aws-instance-name inst)] - [state (aws-instance-state inst)] - [type (or (hash-ref inst "InstanceType" #f) "-")] - [ip (or (hash-ref inst "PrivateIpAddress" #f) "-")] - [region (or (hash-ref inst "_region" #f) "-")] + (map (lambda (reservation) + (if (hashtable? reservation) + (let ([instances (or (native-ht-ref + reservation + 'instancesSet + #f) + '())]) + (if (list? instances) + (filter-map + (lambda (inst) + (and (hashtable? inst) + (string=? + (native-instance-state inst) + "running") + (cons region inst))) + instances) + '())) + '())) + (if (list? reservations) reservations '()))))))) + (def (native-instance->entry region inst) + "Convert native instance hash + region to a tabulated-list entry." + (let* ([id (or (native-ht-ref inst 'instanceId #f) "")] + [name (native-instance-name inst)] + [state (native-instance-state inst)] + [type (or (native-ht-ref inst 'instanceType #f) "-")] + [ip (or (native-ht-ref inst 'privateIpAddress #f) "-")] [domain (aws-get-domain region)] [ssh-target (if (and (> (string-length name) 0) domain) (string-append name "." domain) @@ -142,7 +154,7 @@ (def *aws-pending-errors* 0) (def *aws-pending-callback* #f) (def (aws-fetch-all-regions! callback) - "Fetch instances from all configured regions asynchronously.\n Calls CALLBACK with the merged instance list when all regions complete." + "Fetch instances from all configured regions asynchronously via native API.\n Spawns one worker thread per region; results are merged on the UI thread." (let ([regions *aws-ec2-ssh-common-regions*]) (set! *aws-pending-regions* (length regions)) (set! *aws-pending-instances* '()) @@ -150,27 +162,34 @@ (set! *aws-pending-callback* callback) (for-each (lambda (region) - (async-process! (aws-fetch-region-cmd region) 'callback: - (lambda (output) - (let ([instances (aws-parse-instances output region)]) - (let ([running (filter - (lambda (inst) - (string=? - (aws-instance-state inst) - "running")) - instances)]) - (set! *aws-pending-instances* - (append *aws-pending-instances* running)))) - (set! *aws-pending-regions* (- *aws-pending-regions* 1)) - (aws-check-fetch-complete!)) - 'on-error: - (lambda (e) - (set! *aws-pending-errors* (+ *aws-pending-errors* 1)) - (set! *aws-pending-regions* (- *aws-pending-regions* 1)) - (aws-check-fetch-complete!)))) - regions))) + (spawn-worker + 'aws-fetch-region + (lambda () + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (set! *aws-pending-errors* + (+ *aws-pending-errors* 1)) + (set! *aws-pending-regions* + (- *aws-pending-regions* 1)) + (aws-check-fetch-complete!)))) + (lambda () + (let* ([client (EC2Client 'region: region)] + [result (describe-instances client)] + [running (native-parse-instances + result + region)]) + (ui-queue-push! + (lambda () + (set! *aws-pending-instances* + (append *aws-pending-instances* running)) + (set! *aws-pending-regions* + (- *aws-pending-regions* 1)) + (aws-check-fetch-complete!)))))))) + regions)))) (def (aws-check-fetch-complete!) - "Check if all region fetches are done." + "Check if all region fetches are done; fire callback when complete." (when (= *aws-pending-regions* 0) (let ([instances *aws-pending-instances*] [cb *aws-pending-callback*]) @@ -193,12 +212,16 @@ ("S" . aws-ec2-ssh-sort-region) ("q" . kill-buffer-cmd))) (mode-keymap-set! 'aws-ec2-ssh km))) (def (aws-refresh-buffer! app instances) - "Populate the *AWS EC2 SSH* buffer with instance data." + "Populate the *AWS EC2 SSH* buffer with instance data.\n INSTANCES is a list of (cons region native-hash)." (let* ([buf (buffer-by-name "*AWS EC2 SSH*")] [ed (current-qt-editor app)] [fr (app-state-frame app)]) (when buf - (let* ([entries (map aws-instance->entry instances)] + (let* ([entries (map (lambda (pair) + (native-instance->entry + (car pair) + (cdr pair))) + instances)] [sorted (sort (lambda (a b) (string<? --- a/src/jerboa-emacs/qt/commands-aws.ss +++ b/src/jerboa-emacs/qt/commands-aws.ss @@ -4,6 +4,8 @@ ;;; Emacs-like tabulated-list mode: browse EC2 instances across regions, ;;; filter/sort, and SSH into them via a terminal buffer. ;;; +;;; Uses the native jerboa-aws library for HTTPS API calls — no aws CLI needed. +;;; ;;; M-x aws-ec2-ssh — Open the instance list ;;; ;;; Key bindings (in *AWS EC2 SSH* buffer): @@ -34,7 +36,6 @@ :std/srfi/13 (only-in :std/misc/string string-empty?) (only-in :std/misc/ports read-file-lines) - :std/text/json :chez-scintilla/constants :jerboa-emacs/core :jerboa-emacs/buffer @@ -46,7 +47,9 @@ :jerboa-emacs/qt/window :jerboa-emacs/qt/sci-shim :jerboa-emacs/qt/echo - :jerboa-emacs/qt/commands-core) + :jerboa-emacs/qt/commands-core + (jerboa-aws ec2 api) + (jerboa-aws ec2 instances)) ;;; ============================================================================ ;;; Configuration @@ -67,7 +70,7 @@ ;;; ============================================================================ (def *aws-region-domain-map* '()) ;; alist: region -> domain -(def *aws-cache* #f) ;; cached instance list +(def *aws-cache* #f) ;; cached instance list (list of (region . native-hash)) (def *aws-cache-expiry* 0) ;; epoch seconds ;; Columns for the tabulated list @@ -134,63 +137,74 @@ (set! *aws-cache-expiry* 0)) ;;; ============================================================================ -;;; AWS CLI — fetch instances from one region +;;; Native EC2 response parsing +;;; Instance data: (cons region native-chez-hashtable) +;;; Keys in native hashtable are symbols matching EC2 XML element names. ;;; ============================================================================ -(def (aws-fetch-region-cmd region) - "Build aws CLI command string for a region." - (string-append "aws ec2 describe-instances --region " region - " --output json --no-cli-pager 2>/dev/null")) - -(def (aws-parse-instances json-str region) - "Parse AWS JSON output into a list of instance alists. - Each instance gets an extra '_region' key." +(def (native-ht-ref ht key default) + "Hashtable-ref for native Chez symbol-keyed hashtables from jerboa-aws." + (if (hashtable? ht) + (hashtable-ref ht key default) + default)) + +(def (native-instance-state inst) + "Get state name (running, stopped, etc.) from native instance hash." + (let ((state (native-ht-ref inst 'instanceState #f))) + (if state + (or (native-ht-ref state 'name #f) "-") + "-"))) + +(def (native-instance-name inst) + "Get Name tag value from native instance hash." + (let ((tags (native-ht-ref inst 'tagSet '()))) + (if (list? tags) + (let loop ((ts tags)) + (if (null? ts) "" + (let ((tag (car ts))) + (if (and (hashtable? tag) + (equal? (native-ht-ref tag 'key #f) "Name")) + (or (native-ht-ref tag 'value #f) "") + (loop (cdr ts)))))) + ""))) + +(def (native-parse-instances response region) + "Parse describe-instances response hash into list of (cons region instance-hash). + Only returns running instances." (with-catch (lambda (e) '()) (lambda () - (let* ((data (string->json-object json-str)) - (reservations (or (hash-ref data "Reservations" #f) '()))) + (let ((reservations (or (native-ht-ref response 'reservationSet #f) '()))) (apply append - (map (lambda (r) - (let ((instances (or (hash-ref r "Instances" #f) '()))) - (map (lambda (inst) - (hash-put! inst "_region" region) - inst) - instances))) - reservations)))))) - -(def (aws-instance-name inst) - "Get the Name tag from an instance hash, or empty string." - (let ((tags (or (hash-ref inst "Tags" #f) '()))) - (let loop ((ts tags)) - (if (null? ts) "" - (let ((tag (car ts))) - (if (and (hash-ref tag "Key" #f) - (string=? (hash-ref tag "Key" "") "Name")) - (or (hash-ref tag "Value" #f) "") - (loop (cdr ts)))))))) - -(def (aws-instance-state inst) - "Get the state name (running, stopped, etc.)." - (let ((state (hash-ref inst "State" #f))) - (if state (or (hash-ref state "Name" #f) "-") "-"))) - -(def (aws-instance->entry inst) - "Convert an AWS instance hash to a tabulated-list entry: (cons id (vector ...))." - (let* ((id (or (hash-ref inst "InstanceId" #f) "")) - (name (aws-instance-name inst)) - (state (aws-instance-state inst)) - (type (or (hash-ref inst "InstanceType" #f) "-")) - (ip (or (hash-ref inst "PrivateIpAddress" #f) "-")) - (region (or (hash-ref inst "_region" #f) "-")) - (domain (aws-get-domain region)) + (map (lambda (reservation) + (if (hashtable? reservation) + (let ((instances (or (native-ht-ref reservation 'instancesSet #f) '()))) + (if (list? instances) + (filter-map + (lambda (inst) + (and (hashtable? inst) + (string=? (native-instance-state inst) "running") + (cons region inst))) + instances) + '())) + '())) + (if (list? reservations) reservations '()))))))) + +(def (native-instance->entry region inst) + "Convert native instance hash + region to a tabulated-list entry." + (let* ((id (or (native-ht-ref inst 'instanceId #f) "")) + (name (native-instance-name inst)) + (state (native-instance-state inst)) + (type (or (native-ht-ref inst 'instanceType #f) "-")) + (ip (or (native-ht-ref inst 'privateIpAddress #f) "-")) + (domain (aws-get-domain region)) (ssh-target (if (and (> (string-length name) 0) domain) (string-append name "." domain) "-"))) (cons id (vector name state type ip region ssh-target)))) ;;; ============================================================================ -;;; Multi-region async fetch +;;; Multi-region async fetch via native jerboa-aws ;;; ============================================================================ (def *aws-pending-regions* 0) @@ -199,8 +213,8 @@ (def *aws-pending-callback* #f) (def (aws-fetch-all-regions! callback) - "Fetch instances from all configured regions asynchronously. - Calls CALLBACK with the merged instance list when all regions complete." + "Fetch instances from all configured regions asynchronously via native API. + Spawns one worker thread per region; results are merged on the UI thread." (let ((regions *aws-ec2-ssh-common-regions*)) (set! *aws-pending-regions* (length regions)) (set! *aws-pending-instances* '()) @@ -208,29 +222,29 @@ (set! *aws-pending-callback* callback) (for-each (lambda (region) - (async-process! - (aws-fetch-region-cmd region) - callback: - (lambda (output) - (let ((instances (aws-parse-instances output region))) - ;; Filter to running only - (let ((running (filter - (lambda (inst) - (string=? (aws-instance-state inst) "running")) - instances))) - (set! *aws-pending-instances* - (append *aws-pending-instances* running)))) - (set! *aws-pending-regions* (- *aws-pending-regions* 1)) - (aws-check-fetch-complete!)) - on-error: - (lambda (e) - (set! *aws-pending-errors* (+ *aws-pending-errors* 1)) - (set! *aws-pending-regions* (- *aws-pending-regions* 1)) - (aws-check-fetch-complete!)))) - regions))) + (spawn-worker 'aws-fetch-region + (lambda () + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (set! *aws-pending-errors* (+ *aws-pending-errors* 1)) + (set! *aws-pending-regions* (- *aws-pending-regions* 1)) + (aws-check-fetch-complete!)))) + (lambda () + (let* ((client (EC2Client 'region: region)) + (result (describe-instances client)) + (running (native-parse-instances result region))) + (ui-queue-push! + (lambda () + (set! *aws-pending-instances* + (append *aws-pending-instances* running)) + (set! *aws-pending-regions* (- *aws-pending-regions* 1)) + (aws-check-fetch-complete!)))))))) + regions)))) (def (aws-check-fetch-complete!) - "Check if all region fetches are done." + "Check if all region fetches are done; fire callback when complete." (when (= *aws-pending-regions* 0) (let ((instances *aws-pending-instances*) (cb *aws-pending-callback*)) @@ -243,9 +257,7 @@ (def (aws-ec2-ssh-setup-mode!) "Register the AWS EC2 SSH mode keymap and buffer-name mapping." - ;; Register buffer name -> mode mapping (hash-put! *buffer-name-mode-map* "*AWS EC2 SSH*" 'aws-ec2-ssh) - ;; Create and register mode keymap (let ((km (make-keymap))) (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) '(("n" . next-line) @@ -265,29 +277,28 @@ ;;; ============================================================================ (def (aws-refresh-buffer! app instances) - "Populate the *AWS EC2 SSH* buffer with instance data." + "Populate the *AWS EC2 SSH* buffer with instance data. + INSTANCES is a list of (cons region native-hash)." (let* ((buf (buffer-by-name "*AWS EC2 SSH*")) (ed (current-qt-editor app)) (fr (app-state-frame app))) (when buf - ;; Convert instances to tabulated-list entries, sorted by name - (let* ((entries (map aws-instance->entry instances)) + (let* ((entries (map (lambda (pair) + (native-instance->entry (car pair) (cdr pair))) + instances)) (sorted (sort (lambda (a b) (string<? (vector-ref (cdr a) 0) (vector-ref (cdr b) 0))) entries))) (tabulated-list-set-entries! buf sorted) - ;; Render (let ((text (tabulated-list-refresh! buf))) (when text (sci-send ed SCI_SETREADONLY 0) (qt-plain-text-edit-set-text! ed text) (qt-text-document-set-modified! (buffer-doc-pointer buf) #f) (sci-send ed SCI_SETREADONLY 1) - ;; Position cursor on first data line (let ((pos (sci-send ed SCI_POSITIONFROMLINE tabulated-list-header-lines 0))) (qt-plain-text-edit-set-cursor-position! ed pos)) - ;; Brighter caret line for row selection (sci-send ed SCI_SETCARETLINEBACK (rgb->sci #x2a #x2a #x4a)))))))) (def (aws-re-render! app) @@ -302,7 +313,6 @@ (qt-plain-text-edit-set-text! ed text) (qt-text-document-set-modified! (buffer-doc-pointer buf) #f) (sci-send ed SCI_SETREADONLY 1) - ;; Restore cursor, clamped to valid range (let* ((count (tabulated-list-entry-count buf)) (max-line (+ tabulated-list-header-lines (max 0 (- count 1)))) (target (min line max-line)) @@ -414,10 +424,8 @@ Opens a terminal buffer and types the SSH command, then executes it." (term-buf (current-qt-buffer app)) (ts (and term-buf (hash-get *terminal-state* term-buf)))) (when ts - ;; Insert the SSH command text at current position (end of prompt) (qt-plain-text-edit-move-cursor! term-ed QT_CURSOR_END) (qt-plain-text-edit-insert-text! term-ed ssh-cmd) - ;; Execute it by dispatching terminal-send (execute-command! app 'terminal-send) (echo-message! echo (string-append "SSH: " ssh-target))))))))))) new file mode 120000 --- /dev/null +++ b/vendor/chez-https @@ -0,0 +1 @@ +/home/jafourni/mine/chez-https \ No newline at end of file new file mode 100644 --- /dev/null +++ b/vendor/chez-https-compile-libs.ss @@ -0,0 +1,5 @@ +#!chezscheme +;; Compile chez-https library +(import (chezscheme)) +(compile-imported-libraries #t) +(import (chez-https)) new file mode 120000 --- /dev/null +++ b/vendor/chez-ssl @@ -0,0 +1 @@ +/home/jafourni/mine/chez-ssl \ No newline at end of file new file mode 100644 --- /dev/null +++ b/vendor/chez-ssl-compile-libs.ss @@ -0,0 +1,5 @@ +#!chezscheme +;; Compile chez-ssl library +(import (chezscheme)) +(compile-imported-libraries #t) +(import (chez-ssl)) new file mode 100644 --- /dev/null +++ b/vendor/chez-ssl-static.sls @@ -0,0 +1,253 @@ +#!chezscheme +;;; (chez-ssl) — static build variant: guards load-shared-object for JEMACS_STATIC. +;;; Copied from ~/mine/chez-ssl/src/chez-ssl.sls with the only change being +;;; that load-shared-object calls are skipped when JEMACS_STATIC=1 (the +;;; symbols are registered at link time via Sforeign_symbol instead). + +(library (chez-ssl) + (export ssl-init! ssl-cleanup! + ;; Client-side TLS + ssl-connect ssl-write ssl-write-string + ssl-read ssl-read-all ssl-close + ssl-connection? + ;; Plain TCP + tcp-connect tcp-listen tcp-accept tcp-close + tcp-read tcp-write tcp-read-all tcp-write-string + tcp-set-timeout + ;; Server-side TLS + ssl-server-ctx ssl-server-ctx-free ssl-server-accept + ;; Unified connection (works for both plain TCP and TLS) + conn-wrap conn-write conn-write-string conn-read) + (import (chezscheme)) + + (define load-libs + (let ([static (getenv "JEMACS_STATIC")]) + (if (and static (not (string=? static "")) (not (string=? static "0"))) + (void) ;; static build: symbols registered via Sforeign_symbol + (begin + (load-shared-object "libssl.so") + (load-shared-object "libcrypto.so") + (load-shared-object "chez_ssl_shim.so"))))) + + ;; ================================================================ + ;; C FFI bindings — Client + ;; ================================================================ + + (define c-ssl-init (foreign-procedure "chez_ssl_init" () void)) + (define c-ssl-cleanup (foreign-procedure "chez_ssl_cleanup" () void)) + (define c-ssl-connect (foreign-procedure "chez_ssl_connect" (string int u8* int) void*)) + (define c-ssl-write (foreign-procedure "chez_ssl_write" (void* u8* int) int)) + (define c-ssl-read (foreign-procedure "chez_ssl_read" (void* u8* int) int)) + (define c-ssl-read-all (foreign-procedure "chez_ssl_read_all" (void* void*) void*)) + (define c-ssl-close (foreign-procedure "chez_ssl_close" (void*) void)) + (define c-ssl-free-buf (foreign-procedure "chez_ssl_free_buf" (void*) void)) + (define c-ssl-memcpy (foreign-procedure "chez_ssl_memcpy" (u8* void* size_t) void)) + + ;; ================================================================ + ;; C FFI bindings — Plain TCP + ;; ================================================================ + + (define c-tcp-connect (foreign-procedure "chez_tcp_connect" (string int u8* int) int)) + (define c-tcp-listen (foreign-procedure "chez_tcp_listen" (int int u8* int) int)) + (define c-tcp-accept (foreign-procedure "chez_tcp_accept" (int u8* int u8* int) int)) + (define c-tcp-close (foreign-procedure "chez_tcp_close" (int) void)) + (define c-tcp-read (foreign-procedure "chez_tcp_read" (int u8* int) int)) + (define c-tcp-write (foreign-procedure "chez_tcp_write" (int u8* int) int)) + (define c-tcp-read-all (foreign-procedure "chez_tcp_read_all" (int void*) void*)) + (define c-tcp-set-timeout (foreign-procedure "chez_tcp_set_timeout" (int int int) int)) + + ;; ================================================================ + ;; C FFI bindings — Server TLS + ;; ================================================================ + + (define c-ssl-server-ctx + (foreign-procedure "chez_ssl_server_ctx" (string string u8* int) void*)) + (define c-ssl-server-accept + (foreign-procedure "chez_ssl_server_accept" (void* int u8* int) void*)) + (define c-ssl-server-ctx-free + (foreign-procedure "chez_ssl_server_ctx_free" (void*) void)) + + ;; ================================================================ + ;; C FFI bindings — Unified connection + ;; ================================================================ + + (define c-tcp-conn-wrap (foreign-procedure "chez_tcp_conn_wrap" (int) void*)) + (define c-conn-write (foreign-procedure "chez_conn_write" (void* u8* int) int)) + (define c-conn-read (foreign-procedure "chez_conn_read" (void* u8* int) int)) + + ;; ================================================================ + ;; Connection tracking + ;; ================================================================ + + (define *live-connections* '()) + + (define (ssl-connection? obj) + (and (memq obj *live-connections*) #t)) + + ;; ================================================================ + ;; SSL init/cleanup + ;; ================================================================ + + (define (ssl-init!) (c-ssl-init)) + (define (ssl-cleanup!) (c-ssl-cleanup)) + + ;; ================================================================ + ;; Client-side TLS + ;; ================================================================ + + (define (ssl-connect hostname port) + (let ([err-buf (make-bytevector 256 0)]) + (let ([conn (c-ssl-connect hostname port err-buf 256)]) + (if (zero? conn) + (error 'ssl-connect + (utf8->string (bytevector-trim-nuls err-buf)) + hostname port) + (begin + (set! *live-connections* (cons conn *live-connections*)) + conn))))) + + (define (ssl-write conn bv) + (let ([rc (c-ssl-write conn bv (bytevector-length bv))]) + (unless (= rc 0) + (error 'ssl-write "write failed")))) + + (define (ssl-write-string conn str) + (ssl-write conn (string->utf8 str))) + + (define (ssl-read conn buf len) + (c-ssl-read conn buf len)) + + (define (ssl-read-all conn) + (let ([len-buf (foreign-alloc 8)]) + (let ([ptr (c-ssl-read-all conn len-buf)]) + (if (zero? ptr) + (begin (foreign-free len-buf) + (error 'ssl-read-all "read failed")) + (let* ([len (foreign-ref 'size_t len-buf 0)] + [result (make-bytevector len)]) + (c-ssl-memcpy result ptr len) + (c-ssl-free-buf ptr) + (foreign-free len-buf) + result))))) + + (define (ssl-close conn) + (set! *live-connections* (remq conn *live-connections*)) + (c-ssl-close conn)) + + ;; ================================================================ + ;; Plain TCP + ;; ================================================================ + + (define (tcp-connect hostname port) + (let ([err-buf (make-bytevector 256 0)]) + (let ([fd (c-tcp-connect hostname port err-buf 256)]) + (when (< fd 0) + (error 'tcp-connect + (utf8->string (bytevector-trim-nuls err-buf)) + hostname port)) + fd))) + + (define (tcp-listen port . args) + (let ([backlog (if (null? args) 128 (car args))]) + (let ([err-buf (make-bytevector 256 0)]) + (let ([fd (c-tcp-listen port backlog err-buf 256)]) + (when (< fd 0) + (error 'tcp-listen + (utf8->string (bytevector-trim-nuls err-buf)) + port)) + fd)))) + + (define (tcp-accept listen-fd) + (let ([addr-buf (make-bytevector 128 0)] + [err-buf (make-bytevector 256 0)]) + (let ([fd (c-tcp-accept listen-fd addr-buf 128 err-buf 256)]) + (cond + [(= fd -2) (values #f #f)] + [(< fd 0) + (error 'tcp-accept + (utf8->string (bytevector-trim-nuls err-buf)))] + [else + (values fd (utf8->string (bytevector-trim-nuls addr-buf)))])))) + + (define (tcp-close fd) (c-tcp-close fd)) + + (define (tcp-read fd buf len) (c-tcp-read fd buf len)) + + (define (tcp-write fd bv) + (let ([rc (c-tcp-write fd bv (bytevector-length bv))]) + (unless (= rc 0) (error 'tcp-write "write failed")))) + + (define (tcp-write-string fd str) (tcp-write fd (string->utf8 str))) + + (define (tcp-set-timeout fd read-secs write-secs) + (c-tcp-set-timeout fd read-secs write-secs)) + + (define (tcp-read-all fd) + (let ([len-buf (foreign-alloc 8)]) + (let ([ptr (c-tcp-read-all fd len-buf)]) + (if (zero? ptr) + (begin (foreign-free len-buf) + (error 'tcp-read-all "read failed")) + (let* ([len (foreign-ref 'size_t len-buf 0)] + [result (make-bytevector len)]) + (c-ssl-memcpy result ptr len) + (c-ssl-free-buf ptr) + (foreign-free len-buf) + result))))) + + ;; ================================================================ + ;; Server-side TLS + ;; ================================================================ + + (define (ssl-server-ctx cert-file key-file) + (let ([err-buf (make-bytevector 256 0)]) + (let ([ctx (c-ssl-server-ctx cert-file key-file err-buf 256)]) + (when (zero? ctx) + (error 'ssl-server-ctx + (utf8->string (bytevector-trim-nuls err-buf)) + cert-file key-file)) + ctx))) + + (define (ssl-server-ctx-free ctx) (c-ssl-server-ctx-free ctx)) + + (define (ssl-server-accept ctx client-fd) + (let ([err-buf (make-bytevector 256 0)]) + (let ([conn (c-ssl-server-accept ctx client-fd err-buf 256)]) + (when (zero? conn) + (error 'ssl-server-accept + (utf8->string (bytevector-trim-nuls err-buf)))) + (set! *live-connections* (cons conn *live-connections*)) + conn))) + + ;; ================================================================ + ;; Unified connection + ;; ================================================================ + + (define (conn-wrap fd) + (let ([conn (c-tcp-conn-wrap fd)]) + (when (zero? conn) (error 'conn-wrap "malloc failed")) + (set! *live-connections* (cons conn *live-connections*)) + conn)) + + (define (conn-write conn bv) + (let ([rc (c-conn-write conn bv (bytevector-length bv))]) + (unless (= rc 0) (error 'conn-write "write failed")))) + + (define (conn-write-string conn str) (conn-write conn (string->utf8 str))) + + (define (conn-read conn buf len) (c-conn-read conn buf len)) + + ;; ================================================================ + ;; Helpers + ;; ================================================================ + + (define (bytevector-trim-nuls bv) + (let loop ([i 0]) + (if (or (= i (bytevector-length bv)) + (= (bytevector-u8-ref bv i) 0))