build: convert raw-Chez .sls library source to src/ .ss with generated .sls wrappers
ober
20d4dd22f6e9866a271694faab58ed5c3742bd86
--- a/.gitignore +++ b/.gitignore @@ -28,3 +28,7 @@ .claude/ .DS_Store support/ffi-symbols.gen + +# Generated .sls wrappers from src/ .ss source +lib/**/*.sls + --- a/Makefile +++ b/Makefile @@ -54,7 +54,10 @@ native-runtime: ensure-jerboa-tools # Standalone native binary via .jerbuild (entry aws.ss -> jerboa-aws). # Two passes: pass 1 cargo-builds jerboa-native into jerbuild's cache; we then # regenerate the FFI symbol list (platform-correct) and relink. -binary: ensure-jerboa-tools +transpile: + python3 support/wrap-ss-to-sls.py src lib + +binary: ensure-jerboa-tools transpile @touch support/ffi-symbols.gen "$(JERBUILD)" build JERBUILD="$(JERBUILD)" sh support/gen-ffi-symbols.sh deleted file mode 100644 --- a/lib/jerboa-aws/api.sls +++ /dev/null @@ -1,146 +0,0 @@ -#!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) - (except (jerboa-aws crypto) bytevector-append) - (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)] - ;; Convert (name . value) pairs to (name :: value) for jerboa-https - [https-headers (map (lambda (h) (list (car h) ':: (cdr h))) - all-headers)] - [url (string-append "https://" host "/")] - [req (http-post url 'headers: https-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 deleted file mode 100644 --- a/lib/jerboa-aws/cfn/api.sls +++ /dev/null @@ -1,21 +0,0 @@ -#!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 deleted file mode 100644 --- a/lib/jerboa-aws/cfn/stacks.sls +++ /dev/null @@ -1,130 +0,0 @@ -#!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 deleted file mode 100644 --- a/lib/jerboa-aws/cli/format.sls +++ /dev/null @@ -1,163 +0,0 @@ -#!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")) - ((or (< (char->integer c) #x20) - (= (char->integer c) #x7f) - (and (>= (char->integer c) #x80) - (<= (char->integer c) #x9f))) - (put-string port (format "\\u~4,'0x" (char->integer c)))) - (else (put-char port c))))) - (put-char port #\")) - - ) ;; end library deleted file mode 100644 --- a/lib/jerboa-aws/cli/main.sls +++ /dev/null @@ -1,900 +0,0 @@ -#!chezscheme -;;; (jerboa-aws cli main) -- CLI entry point with subcommand dispatch - -(library (jerboa-aws cli main) - (export main resolve-ssm-parameter-value) - (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) - ;; SSM - (jerboa-aws ssm api) - (jerboa-aws ssm operations)) - - ;; ---- 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)))))) - - (define MAX-SSM-PARAMETER-VALUE-CHARS 8192) - (define MAX-SSM-PARAMETER-VALUE-BYTES 8192) - - (define (option-count args name) - (let loop ((rest args) (count 0)) - (cond - ((null? rest) count) - ((string=? (car rest) name) - (loop (cdr rest) (+ count 1))) - (else (loop (cdr rest) count))))) - - ;; Read at most one AWS advanced-parameter value. The character limit is - ;; enforced while reading so a hostile pipe cannot force unbounded growth; - ;; the UTF-8 byte limit is then checked against SSM's 8 KiB ceiling. - (define (read-ssm-parameter-value port) - (let ((out (open-output-string))) - (let loop ((count 0)) - (let ((ch (get-char port))) - (cond - ((eof-object? ch) - (let ((value (get-output-string out))) - (when (> (bytevector-length (string->utf8 value)) - MAX-SSM-PARAMETER-VALUE-BYTES) - (error 'ssm - "parameter value from stdin exceeds 8192 UTF-8 bytes")) - value)) - ((>= count MAX-SSM-PARAMETER-VALUE-CHARS) - (error 'ssm - "parameter value from stdin exceeds 8192 characters")) - (else - (put-char out ch) - (loop (+ count 1)))))))) - - ;; Select exactly one secret source. This helper is exported so the source - ;; selection, bounded read, and warning behavior can be regression-tested - ;; without making an AWS request. - (define (resolve-ssm-parameter-value args type input-port warning-port) - (let ((argv-count (option-count args "--value")) - (stdin-count (option-count args "--value-stdin"))) - (when (> argv-count 1) - (error 'ssm "put-parameter accepts --value only once")) - (when (> stdin-count 1) - (error 'ssm "put-parameter accepts --value-stdin only once")) - (when (and (> argv-count 0) (> stdin-count 0)) - (error 'ssm - "put-parameter accepts exactly one of --value or --value-stdin")) - (cond - ((= stdin-count 1) - (read-ssm-parameter-value input-port)) - ((= argv-count 1) - (let ((value (get-opt args "--value"))) - (unless value - (error 'ssm "--value requires an argument")) - (when (string=? type "SecureString") - (display - "Warning: --value exposes SecureString data in argv; use --value-stdin instead.\n" - warning-port)) - value)) - (else - (error 'ssm - "put-parameter requires --value-stdin (recommended) or --value"))))) - - ;; 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) '()) - (if region (list 'region: region) '())))) - - (define (make-s3-client profile region) - (apply S3Client - (append - (if profile (list 'profile: profile) '()) - (if region (list 'region: region) '())))) - - (define (make-sts-client profile region) - (apply STSClient - (append - (if profile (list 'profile: profile) '()) - (if region (list 'region: region) '())))) - - (define (make-iam-client profile region) - (apply IAMClient - (append - (if profile (list 'profile: profile) '()) - (if region (list 'region: region) '())))) - - (define (make-ssm-client profile region) - (apply SSMClient - (append - (if profile (list 'profile: profile) '()) - (if region (list 'region: region) '())))) - - ;; ---- Output helper ---- - - (define (output-result result output-fmt) - (format-output output-fmt result)) - - ;; ---- Usage ---- - - (define (print-usage) - (display "jerboa-aws -- AWS command-line interface - -Usage: jerboa-aws [--profile NAME] [--region REGION] [--output FORMAT] <service> <action> [options] - -Services: - ec2 EC2 instances, VPCs, security groups, etc. - s3 S3 high-level (ls, cp, mv, rm, mb, rb) - s3api S3 low-level API (list-buckets, get-object, etc.) - sts STS identity and session operations - iam IAM users, groups, roles, policies - ssm Systems Manager parameters and commands - -Global options: - --profile, -p NAME AWS profile name - --region, -r REGION AWS region - --output, -o FORMAT Output format: json, text (default: json) - -Run 'jerboa-aws <service> help' for service-specific commands. -") - (exit 0)) - - ;; ---- EC2 subcommands ---- - - (define (ec2-dispatch action args profile region output-fmt) - (let ((client (make-ec2-client profile region))) - (cond - ((string=? action "describe-instances") - (let ((ids (parse-csv (or (get-opt args "--instance-ids") ""))) - (filters (parse-filters (or (get-opt args "--filters") "")))) - (output-result - (describe-instances client 'instance-ids: ids 'filters: filters) - output-fmt))) - ((string=? action "run-instances") - (let ((image-id (or (get-opt args "--image-id") - (error 'ec2 "run-instances requires --image-id"))) - (instance-type (or (get-opt args "--instance-type") "t2.micro")) - (count (or (get-opt args "--count") "1")) - (key-name (get-opt args "--key-name")) - (sg-ids (parse-csv (or (get-opt args "--security-group-ids") ""))) - (subnet-id (get-opt args "--subnet-id"))) - (output-result - (run-instances client image-id instance-type - 'min-count: count 'max-count: count - 'key-name: key-name - 'security-group-ids: sg-ids - 'subnet-id: subnet-id) - output-fmt))) - ((string=? action "start-instances") - (let ((ids (parse-csv (or (get-opt args "--instance-ids") - (error 'ec2 "start-instances requires --instance-ids"))))) - (output-result (start-instances client ids) output-fmt))) - ((string=? action "stop-instances") - (let ((ids (parse-csv (or (get-opt args "--instance-ids") - (error 'ec2 "stop-instances requires --instance-ids")))) - (force? (get-flag args "--force"))) - (output-result (stop-instances client ids 'force: force?) output-fmt))) - ((string=? action "terminate-instances") - (let ((ids (parse-csv (or (get-opt args "--instance-ids") - (error 'ec2 "terminate-instances requires --instance-ids"))))) - (output-result (terminate-instances client ids) output-fmt))) - ((string=? action "reboot-instances") - (let ((ids (parse-csv (or (get-opt args "--instance-ids") - (error 'ec2 "reboot-instances requires --instance-ids"))))) - (output-result (reboot-instances client ids) output-fmt))) - ((string=? action "describe-instance-status") - (let ((ids (parse-csv (or (get-opt args "--instance-ids") "")))) - (output-result (describe-instance-status client 'instance-ids: ids) output-fmt))) - ((string=? action "describe-instance-types") - (output-result (describe-instance-types client) output-fmt)) - ((string=? action "describe-security-groups") - (let ((ids (parse-csv (or (get-opt args "--group-ids") ""))) - (filters (parse-filters (or (get-opt args "--filters") "")))) - (output-result - (describe-security-groups client 'group-ids: ids 'filters: filters) - output-fmt))) - ((string=? action "create-security-group") - (let* ((name (or (get-opt args "--group-name") - (error 'ec2 "create-security-group requires --group-name"))) - (desc (or (get-opt args "--description") name)) - (vpc-id (get-opt args "--vpc-id"))) - (output-result - (create-security-group client name desc 'vpc-id: vpc-id) - output-fmt))) - ((string=? action "delete-security-group") - (let ((id (or (get-opt args "--group-id") - (error 'ec2 "delete-security-group requires --group-id")))) - (output-result (delete-security-group client id) output-fmt))) - ((string=? action "describe-vpcs") - (let ((ids (parse-csv (or (get-opt args "--vpc-ids") ""))) - (filters (parse-filters (or (get-opt args "--filters") "")))) - (output-result - (describe-vpcs client 'vpc-ids: ids 'filters: filters) - output-fmt))) - ((string=? action "create-vpc") - (let ((cidr (or (get-opt args "--cidr-block") - (error 'ec2 "create-vpc requires --cidr-block")))) - (output-result (create-vpc client cidr) output-fmt))) - ((string=? action "delete-vpc") - (let ((id (or (get-opt args "--vpc-id") - (error 'ec2 "delete-vpc requires --vpc-id")))) - (output-result (delete-vpc client id) output-fmt))) - ((string=? action "describe-subnets") - (let ((ids (parse-csv (or (get-opt args "--subnet-ids") ""))) - (filters (parse-filters (or (get-opt args "--filters") "")))) - (output-result - (describe-subnets client 'subnet-ids: ids 'filters: filters) - output-fmt))) - ((string=? action "create-subnet") - (let ((vpc-id (or (get-opt args "--vpc-id") - (error 'ec2 "create-subnet requires --vpc-id"))) - (cidr (or (get-opt args "--cidr-block") - (error 'ec2 "create-subnet requires --cidr-block")))) - (output-result (create-subnet client vpc-id cidr) output-fmt))) - ((string=? action "delete-subnet") - (let ((id (or (get-opt args "--subnet-id") - (error 'ec2 "delete-subnet requires --subnet-id")))) - (output-result (delete-subnet client id) output-fmt))) - ((string=? action "describe-volumes") - (let ((ids (parse-csv (or (get-opt args "--volume-ids") ""))) - (filters (parse-filters (or (get-opt args "--filters") "")))) - (output-result - (describe-volumes client 'volume-ids: ids 'filters: filters) - output-fmt))) - ((string=? action "describe-snapshots") - (let ((ids (parse-csv (or (get-opt args "--snapshot-ids") ""))) - (filters (parse-filters (or (get-opt args "--filters") "")))) - (output-result - (describe-snapshots client 'snapshot-ids: ids 'filters: filters) - output-fmt))) - ((string=? action "describe-addresses") - (output-result (describe-addresses client) output-fmt)) - ((string=? action "describe-key-pairs") - (output-result (describe-key-pairs client) output-fmt)) - ((string=? action "describe-network-interfaces") - (let ((ids (parse-csv (or (get-opt args "--network-interface-ids") ""))) - (filters (parse-filters (or (get-opt args "--filters") "")))) - (output-result - (describe-network-interfaces client 'network-interface-ids: ids 'filters: filters) - output-fmt))) - ((or (string=? action "help") (string=? action "--help")) - (display "jerboa-aws ec2 commands: - describe-instances [--instance-ids IDS] [--filters FILTERS] - run-instances --image-id AMI [--instance-type TYPE] [--count N] - start-instances --instance-ids IDS - stop-instances --instance-ids IDS [--force] - terminate-instances --instance-ids IDS - reboot-instances --instance-ids IDS - describe-instance-status [--instance-ids IDS] - describe-instance-types - describe-security-groups [--group-ids IDS] [--filters FILTERS] - create-security-group --group-name NAME [--description DESC] [--vpc-id VPC] - delete-security-group --group-id ID - describe-vpcs [--vpc-ids IDS] [--filters FILTERS] - create-vpc --cidr-block CIDR - delete-vpc --vpc-id ID - describe-subnets [--subnet-ids IDS] [--filters FILTERS] - create-subnet --vpc-id VPC --cidr-block CIDR - delete-subnet --subnet-id ID - describe-volumes [--volume-ids IDS] [--filters FILTERS] - describe-snapshots [--snapshot-ids IDS] [--filters FILTERS] - describe-addresses - describe-key-pairs - describe-network-interfaces [--network-interface-ids IDS] [--filters FILTERS] -") - (exit 0)) - (else - (display (format "Unknown ec2 action: ~a\nRun 'jerboa-aws ec2 help' for available commands.\n" action)) - (exit 1))))) - - ;; ---- S3 URI helpers ---- - - (define (s3-uri? str) - (and (string? str) - (>= (string-length str) 5) - (string=? (substring str 0 5) "s3://"))) - - ;; Parse "s3://bucket" → (cons "bucket" #f) - ;; Parse "s3://bucket/" → (cons "bucket" "") - ;; Parse "s3://bucket/key/path" → (cons "bucket" "key/path") - (define (parse-s3-uri uri) - (if (s3-uri? uri) - (let* ((rest (substring uri 5 (string-length uri))) - (slash (let loop ((i 0)) - (cond - ((= i (string-length rest)) #f) - ((char=? (string-ref rest i) #\/) i) - (else (loop (+ i 1))))))) - (if slash - (cons (substring rest 0 slash) - (substring rest (+ slash 1) (string-length rest))) - (cons rest #f))) - (error 's3 "expected s3:// URI" uri))) - - ;; ---- S3 high-level subcommands (aws-cli compatible) ---- - - (define (s3-dispatch action args profile region output-fmt) - (let ((client (make-s3-client profile region))) - (cond - ;; ls [s3://BUCKET[/PREFIX]] -- list buckets (no arg) or objects - ((string=? action "ls") - (if (null? args) - (output-result (list-buckets client) output-fmt) - (let* ((uri (car args)) - (parsed (parse-s3-uri uri)) - (bucket (car parsed)) - (prefix (cdr parsed))) - (output-result - (apply list-objects-v2 client bucket - (if (and prefix (> (string-length prefix) 0)) - (list 'prefix: prefix) - '())) - output-fmt)))) - ;; cp <SRC> <DST> -- copy: s3↔local or s3↔s3 - ((string=? action "cp") - (when (< (length args) 2) - (display "usage: aws s3 cp <src> <dst> [--content-type TYPE]\n") - (exit 1)) - (let ((src (car args)) - (dst (cadr args)) - (content-type (or (get-opt (cddr args) "--content-type") - "application/octet-stream"))) - (cond - ;; s3://src → s3://dst (server-side copy) - ((and (s3-uri? src) (s3-uri? dst)) - (let* ((sp (parse-s3-uri src)) - (dp (parse-s3-uri dst))) - (copy-object client (car dp) (cdr dp) - (string-append "/" (car sp) "/" (cdr sp))) - (display (format "copy: ~a to ~a\n" src dst)))) - ;; s3://src → local (download) - ((s3-uri? src) - (let* ((p (parse-s3-uri src)) - (data (get-object client (car p) (cdr p)))) - (if (string=? dst "-") - (display data) - (begin - (call-with-output-file dst - (lambda (port) (display data port)) - 'replace) - (display (format "download: ~a to ~a\n" src dst)))))) - ;; local → s3://dst (upload) - ((s3-uri? dst) - (let* ((p (parse-s3-uri dst)) - (data (call-with-input-file src - (lambda (port) (get-string-all port))))) - (put-object client (car p) (cdr p) data - 'content-type: content-type) - (display (format "upload: ~a to ~a\n" src dst)))) - (else - (error 's3 "cp: at least one argument must be an s3:// URI"))))) - ;; mv <SRC> <DST> -- move: s3↔local or s3↔s3 - ((string=? action "mv") - (when (< (length args) 2) - (display "usage: aws s3 mv <src> <dst>\n") - (exit 1)) - (let ((src (car args)) - (dst (cadr args))) - (cond - ;; s3://src → s3://dst (copy + delete) - ((and (s3-uri? src) (s3-uri? dst)) - (let* ((sp (parse-s3-uri src)) - (dp (parse-s3-uri dst))) - (copy-object client (car dp) (cdr dp) - (string-append "/" (car sp) "/" (cdr sp))) - (delete-object client (car sp) (cdr sp)) - (display (format "move: ~a to ~a\n" src dst)))) - ;; s3://src → local (download + delete) - ((s3-uri? src) - (let* ((p (parse-s3-uri src)) - (data (get-object client (car p) (cdr p)))) - (if (string=? dst "-") - (display data) - (call-with-output-file dst - (lambda (port) (display data port)) - 'replace)) - (delete-object client (car p) (cdr p)) - (display (format "move: ~a to ~a\n" src dst)))) - (else - (error 's3 "mv: at least one argument must be an s3:// URI"))))) - ;; rm <s3://BUCKET/KEY> -- delete object - ((string=? action "rm") - (when (null? args) - (display "usage: aws s3 rm <s3://bucket/key>\n") - (exit 1)) - (let* ((p (parse-s3-uri (car args)))) - (delete-object client (car p) (cdr p)) - (display (format "delete: ~a\n" (car args))))) - ;; mb <s3://BUCKET> -- make bucket