Add jerboa-aws: pure R6RS AWS SDK with CLI and 16 services
ober
b9598ad0422c0e65488d8f52b851354e8aaaa783
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +*.so +*.wpo +*.boot +*.o +!jerboa-aws-main.c +/jerboa-aws new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,41 @@ +SCHEME ?= scheme +JERBOA ?= $(HOME)/mine/jerboa/lib +GHERKIN ?= $(HOME)/mine/gherkin/src +LIBDIRS = lib:$(JERBOA):$(GHERKIN) +COMPILE = $(SCHEME) -q --libdirs $(LIBDIRS) --compile-imported-libraries + +.PHONY: all compile binary build run clean help test + +all: compile + +compile: + @echo "=== Compiling .sls → .so ===" + $(COMPILE) < build-all.ss + +build: binary + +binary: compile + @echo "=== Building standalone binary ===" + $(SCHEME) -q --libdirs $(LIBDIRS) --program build-binary.ss + +run: + $(SCHEME) --libdirs $(LIBDIRS) --program aws.ss $(ARGS) + +test: + @echo "=== Running tests ===" + $(SCHEME) --libdirs $(LIBDIRS) --script test/test-all.ss + +clean: + find lib -name '*.so' -o -name '*.wpo' | xargs rm -f 2>/dev/null || true + rm -f jerboa-aws jerboa-aws-main.o + rm -f jerboa_aws_program.h jerboa_aws_petite_boot.h + rm -f jerboa_aws_scheme_boot.h jerboa_aws_app_boot.h + rm -f jerboa-aws-all.so aws.so aws.wpo jerboa-aws.boot + +help: + @echo "Targets:" + @echo " all - Compile all modules" + @echo " build - Build standalone binary (./jerboa-aws)" + @echo " run - Run interpreted (ARGS='ec2 describe-instances')" + @echo " test - Run tests" + @echo " clean - Remove build artifacts" new file mode 100644 --- /dev/null +++ b/aws.ss @@ -0,0 +1,20 @@ +#!chezscheme +;; Entry point for jerboa-aws +(import (chezscheme) + (jerboa-aws cli main)) + +;; Get args from AWS_ARGC/AWS_ARGn env vars (set by jerboa-aws-main.c) +;; or fall back to (command-line) for interpreted mode. +(define (get-real-args) + (let ((argc-str (getenv "AWS_ARGC"))) + (if argc-str + (let ((argc (string->number argc-str))) + (let loop ((i 0) (acc '())) + (if (>= i argc) + (reverse acc) + (let ((val (getenv (format "AWS_ARG~a" i)))) + (loop (+ i 1) (cons (or val "") acc)))))) + (let ((cmdline (command-line))) + (if (pair? cmdline) (cdr cmdline) '()))))) + +(apply main (get-real-args)) new file mode 100644 --- /dev/null +++ b/build-all.ss @@ -0,0 +1,90 @@ +#!chezscheme +;; Build driver: imports all modules to trigger Chez compilation + +(import + ;; Core + (jerboa-aws creds) + (jerboa-aws crypto) + (jerboa-aws sigv4) + (jerboa-aws uri) + (jerboa-aws time) + (jerboa-aws xml) + (jerboa-aws json) + (jerboa-aws request) + (jerboa-aws api) + (jerboa-aws json-api) + ;; EC2 + (jerboa-aws ec2 xml) + (jerboa-aws ec2 params) + (jerboa-aws ec2 api) + (jerboa-aws ec2 instances) + (jerboa-aws ec2 security-groups) + (jerboa-aws ec2 vpcs) + (jerboa-aws ec2 subnets) + (jerboa-aws ec2 volumes) + (jerboa-aws ec2 snapshots) + (jerboa-aws ec2 addresses) + (jerboa-aws ec2 network-interfaces) + (jerboa-aws ec2 key-pairs) + (jerboa-aws ec2 images) + (jerboa-aws ec2 regions) + (jerboa-aws ec2 tags) + (jerboa-aws ec2 route-tables) + (jerboa-aws ec2 internet-gateways) + (jerboa-aws ec2 nat-gateways) + (jerboa-aws ec2 launch-templates) + ;; S3 + (jerboa-aws s3 xml) + (jerboa-aws s3 api) + (jerboa-aws s3 buckets) + (jerboa-aws s3 objects) + ;; STS + (jerboa-aws sts api) + (jerboa-aws sts operations) + ;; IAM + (jerboa-aws iam api) + (jerboa-aws iam users) + (jerboa-aws iam groups) + (jerboa-aws iam roles) + (jerboa-aws iam policies) + (jerboa-aws iam access-keys) + ;; Lambda + (jerboa-aws lambda api) + (jerboa-aws lambda functions) + ;; CloudWatch Logs + (jerboa-aws logs api) + (jerboa-aws logs operations) + ;; DynamoDB + (jerboa-aws dynamodb api) + (jerboa-aws dynamodb operations) + ;; SNS + (jerboa-aws sns api) + (jerboa-aws sns operations) + ;; SQS + (jerboa-aws sqs api) + (jerboa-aws sqs operations) + ;; CloudFormation + (jerboa-aws cfn api) + (jerboa-aws cfn stacks) + ;; CloudWatch + (jerboa-aws cloudwatch api) + (jerboa-aws cloudwatch operations) + ;; RDS + (jerboa-aws rds api) + (jerboa-aws rds db-instances) + ;; ELBv2 + (jerboa-aws elbv2 api) + (jerboa-aws elbv2 operations) + ;; SSM + (jerboa-aws ssm api) + (jerboa-aws ssm operations) + ;; Compute Optimizer + (jerboa-aws compute-optimizer api) + (jerboa-aws compute-optimizer operations) + ;; Cost Optimization Hub + (jerboa-aws cost-optimization-hub api) + (jerboa-aws cost-optimization-hub operations) + ;; CLI + (jerboa-aws cli format) + (jerboa-aws cli main) +) new file mode 100644 --- /dev/null +++ b/build-binary.ss @@ -0,0 +1,192 @@ +#!chezscheme +;; Build a native jerboa-aws binary. +;; +;; Usage: cd jerboa-aws && make binary + +(import (chezscheme)) + +;; --- Helper: generate C header from binary file --- +(define (file->c-header input-path output-path array-name size-name) + (let* ((port (open-file-input-port input-path)) + (data (get-bytevector-all port)) + (size (bytevector-length data))) + (close-port port) + (call-with-output-file output-path + (lambda (out) + (fprintf out "/* Auto-generated */~n") + (fprintf out "static const unsigned char ~a[] = {~n" array-name) + (let loop ((i 0)) + (when (< i size) + (when (= 0 (modulo i 16)) (fprintf out " ")) + (fprintf out "0x~2,'0x" (bytevector-u8-ref data i)) + (when (< (+ i 1) size) (fprintf out ",")) + (when (= 15 (modulo i 16)) (fprintf out "~n")) + (loop (+ i 1)))) + (fprintf out "~n};~n") + (fprintf out "static const unsigned int ~a = ~a;~n" size-name size)) + 'replace) + (printf " ~a: ~a bytes~n" output-path size))) + +;; --- Locate Chez install directory --- +(define chez-dir + (or (getenv "CHEZ_DIR") + (let* ((mt (symbol->string (machine-type))) + (home (getenv "HOME")) + (lib-dir (format "~a/.local/lib" home)) + (csv-dir + (let lp ((dirs (guard (e (#t '())) (directory-list lib-dir)))) + (cond + ((null? dirs) #f) + ((and (> (string-length (car dirs)) 3) + (string=? "csv" (substring (car dirs) 0 3))) + (format "~a/~a/~a" lib-dir (car dirs) mt)) + (else (lp (cdr dirs))))))) + (and csv-dir + (file-exists? (format "~a/main.o" csv-dir)) + csv-dir)))) + +(unless chez-dir + (display "Error: Cannot find Chez install dir. Set CHEZ_DIR.\n") + (exit 1)) + +;; --- Locate gherkin runtime --- +(define gherkin-dir + (or (getenv "GHERKIN_DIR") + (let ((home (getenv "HOME"))) + (format "~a/mine/gherkin/src" home)))) + +(unless (file-exists? (format "~a/compat/types.so" gherkin-dir)) + (printf "Error: Cannot find gherkin runtime at ~a~n" gherkin-dir) + (exit 1)) + +(printf "Chez dir: ~a~n" chez-dir) +(printf "Gherkin dir: ~a~n" gherkin-dir) + +(printf " +[1/6] Compiling all modules... +") +(parameterize ([compile-imported-libraries #t]) + (compile-program "aws.ss")) + +(printf "[2/6] Using compiled program... +") +(system "cp aws.so jerboa-aws-all.so") + +(printf "[3/6] Creating libs-only boot file... +") +(apply make-boot-file "jerboa-aws.boot" '("scheme" "petite") + (append + (list + ;; Gherkin runtime + (format "~a/compat/types.so" gherkin-dir) + (format "~a/runtime/util.so" gherkin-dir) + (format "~a/runtime/table.so" gherkin-dir) + (format "~a/runtime/c3.so" gherkin-dir) + (format "~a/runtime/mop.so" gherkin-dir) + (format "~a/runtime/error.so" gherkin-dir) + (format "~a/runtime/hash.so" gherkin-dir) + (format "~a/runtime/syntax.so" gherkin-dir) + (format "~a/runtime/eval.so" gherkin-dir) + (format "~a/reader/reader.so" gherkin-dir) + (format "~a/compiler/compile.so" gherkin-dir) + (format "~a/boot/gherkin.so" gherkin-dir) + ) + ;; Core modules + (map (lambda (m) (format "lib/jerboa-aws/~a.so" m)) + '(creds crypto sigv4 uri time xml json request api json-api)) + ;; EC2 + (map (lambda (m) (format "lib/jerboa-aws/ec2/~a.so" m)) + '(xml params api instances security-groups vpcs subnets + volumes snapshots addresses network-interfaces key-pairs + images regions tags route-tables internet-gateways + nat-gateways launch-templates)) + ;; S3 + (map (lambda (m) (format "lib/jerboa-aws/s3/~a.so" m)) + '(xml api buckets objects)) + ;; STS + (map (lambda (m) (format "lib/jerboa-aws/sts/~a.so" m)) + '(api operations)) + ;; IAM + (map (lambda (m) (format "lib/jerboa-aws/iam/~a.so" m)) + '(api users groups roles policies access-keys)) + ;; Lambda + (map (lambda (m) (format "lib/jerboa-aws/lambda/~a.so" m)) + '(api functions)) + ;; Logs + (map (lambda (m) (format "lib/jerboa-aws/logs/~a.so" m)) + '(api operations)) + ;; DynamoDB + (map (lambda (m) (format "lib/jerboa-aws/dynamodb/~a.so" m)) + '(api operations)) + ;; SNS + (map (lambda (m) (format "lib/jerboa-aws/sns/~a.so" m)) + '(api operations)) + ;; SQS + (map (lambda (m) (format "lib/jerboa-aws/sqs/~a.so" m)) + '(api operations)) + ;; CloudFormation + (map (lambda (m) (format "lib/jerboa-aws/cfn/~a.so" m)) + '(api stacks)) + ;; CloudWatch + (map (lambda (m) (format "lib/jerboa-aws/cloudwatch/~a.so" m)) + '(api operations)) + ;; RDS + (map (lambda (m) (format "lib/jerboa-aws/rds/~a.so" m)) + '(api db-instances)) + ;; ELBv2 + (map (lambda (m) (format "lib/jerboa-aws/elbv2/~a.so" m)) + '(api operations)) + ;; SSM + (map (lambda (m) (format "lib/jerboa-aws/ssm/~a.so" m)) + '(api operations)) + ;; Compute Optimizer + (map (lambda (m) (format "lib/jerboa-aws/compute-optimizer/~a.so" m)) + '(api operations)) + ;; Cost Optimization Hub + (map (lambda (m) (format "lib/jerboa-aws/cost-optimization-hub/~a.so" m)) + '(api operations)) + ;; CLI + (map (lambda (m) (format "lib/jerboa-aws/cli/~a.so" m)) + '(format main)))) + +(printf "[4/6] Embedding boot files + program as C headers... +") +(file->c-header "jerboa-aws-all.so" "jerboa_aws_program.h" + "jerboa_aws_program_data" "jerboa_aws_program_size") +(file->c-header (format "~a/petite.boot" chez-dir) "jerboa_aws_petite_boot.h" + "petite_boot_data" "petite_boot_size") +(file->c-header (format "~a/scheme.boot" chez-dir) "jerboa_aws_scheme_boot.h" + "scheme_boot_data" "scheme_boot_size") +(file->c-header "jerboa-aws.boot" "jerboa_aws_app_boot.h" + "jerboa_aws_app_boot_data" "jerboa_aws_app_boot_size") + +(printf "[5/6] Compiling and linking... +") +(let ((cmd (format "gcc -c -O2 -o jerboa-aws-main.o jerboa-aws-main.c -I~a -I. -Wall 2>&1" chez-dir))) + (unless (= 0 (system cmd)) + (display "Error: C compilation failed\n") + (exit 1))) +(let ((cmd (format "gcc -rdynamic -o jerboa-aws jerboa-aws-main.o -L~a -lkernel -llz4 -lz -lm -ldl -lpthread -luuid -lncurses -Wl,-rpath,~a" + chez-dir chez-dir))) + (printf " ~a~n" cmd) + (unless (= 0 (system cmd)) + (display "Error: Link failed\n") + (exit 1))) + +(printf "[6/6] Cleaning up... +") +(for-each (lambda (f) + (when (file-exists? f) (delete-file f))) + '("jerboa-aws-main.o" "jerboa_aws_program.h" + "jerboa_aws_petite_boot.h" "jerboa_aws_scheme_boot.h" "jerboa_aws_app_boot.h" + "jerboa-aws-all.so" "aws.so" "aws.wpo" "jerboa-aws.boot")) + +(printf " +======================================== +") +(printf "Build complete! + +") +(printf " Binary: ./jerboa-aws (~a KB) +" + (quotient (file-length (open-file-input-port "jerboa-aws")) 1024)) new file mode 100644 --- /dev/null +++ b/jerboa-aws-main.c @@ -0,0 +1,54 @@ +/* + * jerboa-aws-main.c — Custom entry point for jerboa-aws. + * + * Boot files (petite.boot, scheme.boot, app.boot) are embedded as C byte + * arrays and registered via Sregister_boot_file_bytes. + * + * Threading workaround: Programs in boot files cannot create threads + * (Chez bug). The program is loaded separately via Sscheme_script on a memfd. + */ + +#define _GNU_SOURCE +#include <stdlib.h> +#include <string.h> +#include <stdio.h> +#include <unistd.h> +#include <sys/mman.h> +#include "scheme.h" +#include "jerboa_aws_program.h" +#include "jerboa_aws_petite_boot.h" +#include "jerboa_aws_scheme_boot.h" +#include "jerboa_aws_app_boot.h" + +int main(int argc, char *argv[]) { + char countbuf[32]; + snprintf(countbuf, sizeof(countbuf), "%d", argc - 1); + setenv("AWS_ARGC", countbuf, 1); + + for (int i = 1; i < argc; i++) { + char name[32]; + snprintf(name, sizeof(name), "AWS_ARG%d", i - 1); + setenv(name, argv[i], 1); + } + + int fd = memfd_create("jerboa-aws-program", MFD_CLOEXEC); + if (fd < 0) { perror("memfd_create"); return 1; } + if (write(fd, jerboa_aws_program_data, jerboa_aws_program_size) != (ssize_t)jerboa_aws_program_size) { + perror("write memfd"); close(fd); return 1; + } + char prog_path[64]; + snprintf(prog_path, sizeof(prog_path), "/proc/self/fd/%d", fd); + + Sscheme_init(NULL); + Sregister_boot_file_bytes("petite", (void*)petite_boot_data, petite_boot_size); + Sregister_boot_file_bytes("scheme", (void*)scheme_boot_data, scheme_boot_size); + Sregister_boot_file_bytes("app", (void*)jerboa_aws_app_boot_data, jerboa_aws_app_boot_size); + + Sbuild_heap(NULL, NULL); + const char *script_args[] = { argv[0] }; + int status = Sscheme_script(prog_path, 1, script_args); + + close(fd); + Sscheme_deinit(); + return status; +} new file mode 100644 --- /dev/null +++ b/lib/jerboa-aws/api.sls @@ -0,0 +1,143 @@ +#!chezscheme +;;; (jerboa-aws api) -- AWS Query API client +;;; Used by EC2, STS, IAM, SNS, CloudFormation, RDS, ELBv2, CloudWatch + +(library (jerboa-aws api) + (export make-aws-client aws-client? + aws-client-endpoint aws-client-access-key aws-client-secret-key + aws-client-region aws-client-token aws-client-service + aws-client-api-version + aws-query-request aws-query-action aws-query-action/hash + AWSClient AWSClientError) + + (import (except (chezscheme) hashtable?) + (jerboa-aws creds) + (jerboa-aws crypto) + (jerboa-aws sigv4) + (jerboa-aws uri) + (jerboa-aws time) + (jerboa-aws xml) + (jerboa-aws json) + (jerboa-aws request)) + + ;; --- Client record --- + (define-record-type aws-client + (fields endpoint access-key secret-key region token + service api-version) + (protocol + (lambda (new) + (lambda (endpoint access-key secret-key region token + service api-version) + (new endpoint access-key secret-key region token + service api-version))))) + + ;; Client factory with credential resolution + (define (AWSClient . args) + (let ([service (kw-ref args 'service: #f)] + [endpoint (kw-ref args 'endpoint: #f)] + [api-version (kw-ref args 'api-version: "")] + [profile (kw-ref args 'profile: #f)] + [access-key (kw-ref args 'access-key: #f)] + [secret-key (kw-ref args 'secret-key: #f)] + [region (kw-ref args 'region: #f)] + [token (kw-ref args 'token: #f)]) + (unless service + (error 'AWSClient "service is required")) + (let-values ([(r-ak r-sk r-region r-token) + (aws-resolve-credentials profile)]) + (let ([ak (or access-key r-ak)] + [sk (or secret-key r-sk)] + [reg (or region r-region)] + [tok (or token r-token)]) + (unless ak (error 'AWSClient "access key is required")) + (unless sk (error 'AWSClient "secret key is required")) + (make-aws-client + (or endpoint (string-append service "." reg ".amazonaws.com")) + ak sk reg tok service api-version))))) + + ;; Error type + (define (AWSClientError message . irritants) + (apply error 'AWSClientError message irritants)) + + ;; --- Query API request --- + (define (aws-query-request client action params) + (let* ([all-params (cons (cons "Action" action) + (if (> (string-length (aws-client-api-version client)) 0) + (cons (cons "Version" (aws-client-api-version client)) + params) + params))] + [body-str (form-url-encode all-params)] + [body-bytes (string->utf8 body-str)] + [body-hash (sha256 body-bytes)] + [ts (aws-timestamp)] + [ds (aws-datestamp)] + [host (aws-client-endpoint client)] + [headers (list (cons "Host" host) + (cons "x-amz-date" ts) + (cons "Content-Type" "application/x-www-form-urlencoded"))] + [headers (if (aws-client-token client) + (append headers + (list (cons "X-Amz-Security-Token" + (aws-client-token client)))) + headers)] + [auth (sigv4-sign "POST" "/" "" + headers body-hash + (aws-client-region client) + (aws-client-service client) + (aws-client-access-key client) + (aws-client-secret-key client) + ts ds)] + [all-headers (cons (cons "Authorization" auth) headers)] + [url (string-append "https://" host "/")] + [req (http-post url 'headers: all-headers 'data: body-str)] + [status (request-status req)]) + (if (and (>= status 200) (< status 300)) + (let ([body (request-text req)]) + (request-close req) + body) + (let ([body (request-text req)]) + (request-close req) + (let ([parsed (guard (e [#t #f]) + (aws-response->hash body))]) + (if (and parsed (hashtable? parsed)) + (let ([err-code (ht-ref parsed 'Code "Unknown")] + [err-msg (ht-ref parsed 'Message body)]) + (error 'AWSClientError + (string-append err-code ": " err-msg) + status)) + (error 'AWSClientError + (string-append "HTTP " (number->string status)) + body))))))) + + ;; Execute a Query API action and return raw XML text + (define (aws-query-action client action . params) + (aws-query-request client action + (if (null? params) '() (car params)))) + + ;; Execute a Query API action and return parsed hash table + (define (aws-query-action/hash client action . params) + (let ([xml-text (apply aws-query-action client action params)]) + (aws-response->hash xml-text))) + + ;; --- Helpers --- + + (define (kw-ref args key default) + (let loop ([rest args]) + (cond + [(null? rest) default] + [(and (pair? (cdr rest)) (eq? (car rest) key)) + (cadr rest)] + [else (loop (cdr rest))]))) + + (define (ht-ref ht key default) + (if (hashtable? ht) + (let ([v (hashtable-ref ht key #f)]) + (or v default)) + default)) + + (define (hashtable? x) + (guard (e [#t #f]) + (hashtable-size x) + #t)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-aws/cfn/api.sls @@ -0,0 +1,21 @@ +#!chezscheme +;;; (jerboa-aws cfn api) -- CloudFormation Query API client + +(library (jerboa-aws cfn api) + (export CFNClient cfn-action cfn-action/hash) + (import (chezscheme) + (jerboa-aws api)) + + (define (CFNClient . args) + (apply AWSClient + 'service: "cloudformation" + 'api-version: "2010-05-15" + args)) + + (define (cfn-action client action . params) + (apply aws-query-action client action params)) + + (define (cfn-action/hash client action . params) + (apply aws-query-action/hash client action params)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-aws/cfn/stacks.sls @@ -0,0 +1,130 @@ +#!chezscheme +;;; (jerboa-aws cfn stacks) -- CloudFormation Stack operations + +(library (jerboa-aws cfn stacks) + (export list-stacks describe-stacks create-stack update-stack + delete-stack get-template) + (import (chezscheme) + (jerboa-aws cfn api)) + + (define (list-stacks client . args) + (let ([stack-status-filter (kw-ref args 'stack-status-filter: '())] + [next-token (kw-ref args 'next-token: #f)]) + (cfn-action/hash client "ListStacks" + (append + (let loop ([ss stack-status-filter] [i 1] [acc '()]) + (if (null? ss) + (reverse acc) + (loop (cdr ss) (+ i 1) + (cons (cons (string-append "StackStatusFilter.member." + (number->string i)) + (car ss)) + acc)))) + (if next-token (list (cons "NextToken" next-token)) '()))))) + + (define (describe-stacks client . args) + (let ([stack-name (kw-ref args 'stack-name: #f)] + [next-token (kw-ref args 'next-token: #f)]) + (cfn-action/hash client "DescribeStacks" + (append + (if stack-name (list (cons "StackName" stack-name)) '()) + (if next-token (list (cons "NextToken" next-token)) '()))))) + + (define (create-stack client stack-name . args) + (let ([template-body (kw-ref args 'template-body: #f)] + [template-url (kw-ref args 'template-url: #f)] + [parameters (kw-ref args 'parameters: '())] + [capabilities (kw-ref args 'capabilities: '())] + [on-failure (kw-ref args 'on-failure: #f)] + [tags (kw-ref args 'tags: '())]) + (cfn-action/hash client "CreateStack" + (append + (list (cons "StackName" stack-name)) + (if template-body (list (cons "TemplateBody" template-body)) '()) + (if template-url (list (cons "TemplateURL" template-url)) '()) + (let loop ([ps parameters] [i 1] [acc '()]) + (if (null? ps) + (reverse acc) + (loop (cdr ps) (+ i 1) + (cons (cons (string-append "Parameters.member." + (number->string i) ".ParameterValue") + (cdar ps)) + (cons (cons (string-append "Parameters.member." + (number->string i) ".ParameterKey") + (caar ps)) + acc))))) + (let loop ([cs capabilities] [i 1] [acc '()]) + (if (null? cs) + (reverse acc) + (loop (cdr cs) (+ i 1) + (cons (cons (string-append "Capabilities.member." + (number->string i)) + (car cs)) + acc)))) + (if on-failure (list (cons "OnFailure" on-failure)) '()) + (let loop ([ts tags] [i 1] [acc '()]) + (if (null? ts) + (reverse acc) + (loop (cdr ts) (+ i 1) + (cons (cons (string-append "Tags.member." + (number->string i) ".Value") + (cdar ts)) + (cons (cons (string-append "Tags.member." + (number->string i) ".Key") + (caar ts)) + acc))))))))) + + (define (update-stack client stack-name . args) + (let ([template-body (kw-ref args 'template-body: #f)] + [template-url (kw-ref args 'template-url: #f)] + [parameters (kw-ref args 'parameters: '())] + [capabilities (kw-ref args 'capabilities: '())]) + (cfn-action/hash client "UpdateStack" + (append + (list (cons "StackName" stack-name)) + (if template-body (list (cons "TemplateBody" template-body)) '()) + (if template-url (list (cons "TemplateURL" template-url)) '()) + (let loop ([ps parameters] [i 1] [acc '()]) + (if (null? ps) + (reverse acc) + (loop (cdr ps) (+ i 1) + (cons (cons (string-append "Parameters.member." + (number->string i) ".ParameterValue") + (cdar ps)) + (cons (cons (string-append "Parameters.member." + (number->string i) ".ParameterKey") + (caar ps)) + acc))))) + (let loop ([cs capabilities] [i 1] [acc '()]) + (if (null? cs) + (reverse acc) + (loop (cdr cs) (+ i 1) + (cons (cons (string-append "Capabilities.member." + (number->string i)) + (car cs)) + acc)))))))) + + (define (delete-stack client stack-name) + (cfn-action client "DeleteStack" + (list (cons "StackName" stack-name))) + (void)) + + (define (get-template client stack-name . args) + (let ([template-stage (kw-ref args 'template-stage: #f)]) + (cfn-action/hash client "GetTemplate" + (append + (list (cons "StackName" stack-name)) + (if template-stage + (list (cons "TemplateStage" template-stage)) + '()))))) + + ;; --- Helpers --- + (define (kw-ref args key default) + (let loop ([rest args]) + (cond + [(null? rest) default] + [(and (pair? (cdr rest)) (eq? (car rest) key)) + (cadr rest)] + [else (loop (cdr rest))]))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-aws/cli/format.sls @@ -0,0 +1,160 @@ +#!chezscheme +;;; (jerboa-aws cli format) -- Output formatting (json pretty-print) + +(library (jerboa-aws cli format) + (export format-output format-json format-text pretty-json) + (import (chezscheme) + (jerboa-aws json)) + + ;; Dispatch to the appropriate formatter + (define (format-output mode data) + (cond + ((string=? mode "json") (format-json data)) + ((string=? mode "text") (format-text data)) + (else (format-json data)))) + + ;; JSON output -- pretty-printed + (define (format-json data) + (cond + ((hashtable? data) + (display (pretty-json data)) + (newline)) + ((list? data) + (display (pretty-json data)) + (newline)) + (else + (display data) + (newline)))) + + ;; Text output -- key: value pairs + (define (format-text data) + (cond + ((hashtable? data) + (format-text-hashtable data "")) + ((list? data) + (let loop ((items data) (first? #t)) + (unless (null? items) + (unless first? (display "---\n")) + (cond + ((hashtable? (car items)) + (format-text-hashtable (car items) "")) + (else (display (car items)) (newline))) + (loop (cdr items) #f)))) + (else + (display data) + (newline)))) + + (define (->string x) + (cond + ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (format "~a" x)))) + + (define (format-text-hashtable ht prefix) + (let-values (((keys vals) (hashtable-entries ht))) + (let ((kv-list (let loop ((i 0) (acc '())) + (if (= i (vector-length keys)) + (list-sort (lambda (a b) (string<? (->string (car a)) (->string (car b)))) acc) + (loop (+ i 1) (cons (cons (vector-ref keys i) + (vector-ref vals i)) + acc)))))) + (for-each + (lambda (kv) + (let ((k (->string (car kv))) (v (cdr kv))) + (cond + ((hashtable? v) + (display prefix) (display k) (display ":") (newline) + (format-text-hashtable v (string-append prefix " "))) + ((list? v) + (display prefix) (display k) (display ":") (newline) + (for-each + (lambda (item) + (cond + ((hashtable? item) + (display prefix) (display " -") (newline) + (format-text-hashtable item (string-append prefix " "))) + (else + (display prefix) (display " - ") (display item) (newline)))) + v)) + (else + (display prefix) (display k) (display "\t") (display v) (newline))))) + kv-list)))) + + ;; Pretty-print a JSON value with indentation + (define (pretty-json val) + (let ((port (open-output-string))) + (pretty-json-value val port 0) + (get-output-string port))) + + (define (pretty-json-value val port indent) + (cond + ((hashtable? val) (pretty-json-object val port indent)) + ((list? val) (pretty-json-array val port indent)) + ((vector? val) (pretty-json-array (vector->list val) port indent)) + ((string? val) (json-write-string val port)) + ((and (integer? val) (exact? val)) + (put-string port (number->string val))) + ((number? val) (put-string port (number->string (inexact val)))) + ((eq? val #t) (put-string port "true")) + ((eq? val #f) (put-string port "false")) + ((eq? val 'null) (put-string port "null")) + ((null? val) (put-string port "null")) + (else (put-string port (format "~a" val))))) + + (define (pretty-json-object ht port indent) + (let-values (((keys vals) (hashtable-entries ht))) + (if (= (vector-length keys) 0) + (put-string port "{}") + (let ((sorted (list-sort + (lambda (a b) (string<? (->string (car a)) (->string (car b)))) + (let loop ((i 0) (acc '())) + (if (= i (vector-length keys)) + acc + (loop (+ i 1) (cons (cons (vector-ref keys i) + (vector-ref vals i)) + acc))))))) + (put-string port "{\n") + (let loop ((pairs sorted) (first? #t)) + (unless (null? pairs) + (unless first? (put-string port ",\n")) + (put-string port (make-string (+ indent 2) #\space)) + (json-write-string (->string (caar pairs)) port) + (put-string port ": ") + (pretty-json-value (cdar pairs) port (+ indent 2)) + (loop (cdr pairs) #f))) + (put-string port "\n") + (put-string port (make-string indent #\space)) + (put-string port "}"))))) + + (define (pretty-json-array lst port indent) + (if (null? lst) + (put-string port "[]") + (begin + (put-string port "[\n") + (let loop ((items lst) (first? #t)) + (unless (null? items) + (unless first? (put-string port ",\n")) + (put-string port (make-string (+ indent 2) #\space)) + (pretty-json-value (car items) port (+ indent 2)) + (loop (cdr items) #f))) + (put-string port "\n") + (put-string port (make-string indent #\space)) + (put-string port "]")))) + + (define (json-write-string str port) + (put-char port #\") + (do ((i 0 (+ i 1))) ((= i (string-length str))) + (let ((c (string-ref str i))) + (cond + ((char=? c #\") (put-string port "\\\"")) + ((char=? c #\\) (put-string port "\\\\")) + ((char=? c #\newline) (put-string port "\\n")) + ((char=? c #\return) (put-string port "\\r")) + ((char=? c #\tab) (put-string port "\\t")) + ((< (char->integer c) #x20) + (put-string port (format "\\u~4,'0x" (char->integer c)))) + (else (put-char port c))))) + (put-char port #\")) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-aws/cli/main.sls @@ -0,0 +1,590 @@ +#!chezscheme +;;; (jerboa-aws cli main) -- CLI entry point with subcommand dispatch + +(library (jerboa-aws cli main) + (export main) + (import (chezscheme) + (jerboa-aws json) + (jerboa-aws cli format) + ;; EC2 + (jerboa-aws ec2 api) + (jerboa-aws ec2 instances) + (jerboa-aws ec2 security-groups) + (jerboa-aws ec2 vpcs) + (jerboa-aws ec2 subnets) + (jerboa-aws ec2 volumes) + (jerboa-aws ec2 snapshots) + (jerboa-aws ec2 addresses) + (jerboa-aws ec2 network-interfaces) + (jerboa-aws ec2 key-pairs) + ;; S3 + (except (jerboa-aws s3 api) make-s3-client) + (jerboa-aws s3 buckets) + (jerboa-aws s3 objects) + ;; STS + (jerboa-aws sts api) + (jerboa-aws sts operations) + ;; IAM + (jerboa-aws iam api) + (jerboa-aws iam users) + (jerboa-aws iam groups) + (jerboa-aws iam roles) + (jerboa-aws iam policies) + (jerboa-aws iam access-keys)) + + ;; ---- Keyword argument helpers ---- + + (define (kw-ref args key default) + (let loop ((rest args)) + (cond + ((null? rest) default) + ((null? (cdr rest)) default) + ((eq? (car rest) key) (cadr rest)) + (else (loop (cddr rest)))))) + + ;; ---- Argument parsing ---- + ;; Parse CLI args into: (values subcommand action rest-args global-opts) + ;; Global options: --profile, --region, --output + + (define (parse-global-opts args) + ;; Returns (values remaining-args profile region output-format) + (let loop ((rest args) (acc '()) (profile #f) (region #f) (output "json")) + (cond + ((null? rest) + (values (reverse acc) profile region output)) + ((and (string=? (car rest) "--profile") (pair? (cdr rest))) + (loop (cddr rest) acc (cadr rest) region output)) + ((and (string=? (car rest) "-p") (pair? (cdr rest))) + (loop (cddr rest) acc (cadr rest) region output)) + ((and (string=? (car rest) "--region") (pair? (cdr rest))) + (loop (cddr rest) acc profile (cadr rest) output)) + ((and (string=? (car rest) "-r") (pair? (cdr rest))) + (loop (cddr rest) acc profile (cadr rest) output)) + ((and (string=? (car rest) "--output") (pair? (cdr rest))) + (loop (cddr rest) acc profile region (cadr rest))) + ((and (string=? (car rest) "-o") (pair? (cdr rest))) + (loop (cddr rest) acc profile region (cadr rest))) + (else + (loop (cdr rest) (cons (car rest) acc) profile region output))))) + + ;; Extract a named option from positional args: --name value + (define (get-opt args name) + (let loop ((rest args)) + (cond + ((null? rest) #f) + ((null? (cdr rest)) #f) + ((string=? (car rest) name) (cadr rest)) + (else (loop (cdr rest)))))) + + ;; Extract a flag from positional args: --flag + (define (get-flag args name) + (let loop ((rest args)) + (cond + ((null? rest) #f) + ((string=? (car rest) name) #t) + (else (loop (cdr rest)))))) + + ;; Parse comma-separated string into list + (define (parse-csv str) + (if (or (not str) (string=? str "")) + '() + (string-split str #\,))) + + ;; Parse "name=val1,val2;name2=val3" into filter list + (define (parse-filters str) + (if (or (not str) (string=? str "")) + '() + (map (lambda (f) + (let ((parts (string-split f #\=))) + (if (>= (length parts) 2) + (cons (car parts) (string-split (cadr parts) #\,)) + (cons (car parts) '())))) + (string-split str #\;)))) + + ;; Split string by character + (define (string-split str ch) + (let loop ((i 0) (start 0) (acc '())) + (cond + ((= i (string-length str)) + (reverse (cons (substring str start i) acc))) + ((char=? (string-ref str i) ch) + (loop (+ i 1) (+ i 1) (cons (substring str start i) acc))) + (else + (loop (+ i 1) start acc))))) + + ;; ---- Client constructors ---- + + (define (make-ec2-client profile region) + (apply EC2Client + (append + (if profile (list 'profile: profile) '())