From 790782fc873e23f031a5e7d8be2f5e6a5d7e39be Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonyg@leastfixedpoint.com>
Date: Tue, 13 Jul 2021 15:58:05 +0200
Subject: [PATCH] Hex and Base64 encodings in preserves-tool

---
 .../racket/preserves/preserves/tool.rkt       | 59 +++++++++++++++++--
 1 file changed, 53 insertions(+), 6 deletions(-)

diff --git a/implementations/racket/preserves/preserves/tool.rkt b/implementations/racket/preserves/preserves/tool.rkt
index 88fd6e2..83e7a29 100644
--- a/implementations/racket/preserves/preserves/tool.rkt
+++ b/implementations/racket/preserves/preserves/tool.rkt
@@ -3,15 +3,24 @@
 (require "main.rkt")
 (require racket/match)
 (require racket/port)
+(require file/sha1)
+(require net/base64)
+(require racket/exn)
 
 (module+ main
   (require racket/cmdline)
+  (define input-encoding 'none)
   (define input-format 'any)
   (define output-format 'text)
+  (define output-encoding 'none)
   (define indent? #t)
   (define annotations? #t)
   (define count +inf.0)
   (command-line #:once-each
+                [("--ie" "--input-encoding") encoding "Input encoding: none, base64, or hex"
+                 (set! input-encoding (string->symbol encoding))]
+                [("--oe" "--output-encoding") encoding "Output encoding: none, base64, or hex"
+                 (set! output-encoding (string->symbol encoding))]
                 ["--atob" "Text to binary"
                  (begin (set! input-format 'text)
                         (set! output-format 'binary))]
@@ -43,6 +52,37 @@
                 ["--no-annotations" "Strip annotations"
                  (set! annotations? #f)])
 
+  (void
+   (match input-encoding
+     ['none (void)]
+     ['hex (let-values (((i o) (make-pipe)))
+             (define wrapped (current-input-port))
+             (current-input-port i)
+             (thread (lambda ()
+                       (with-handlers [(values (lambda (e)
+                                                 (displayln (exn->string e) (current-error-port))
+                                                 (exit 1)))]
+                         (let loop ()
+                           (match (read-line wrapped)
+                             [(? eof-object?)
+                              (close-output-port o)]
+                             [line
+                              (write-bytes (hex-string->bytes line) o)
+                              (flush-output o)
+                              (loop)]))))))]
+     ['base64 (let-values (((i o) (make-pipe)))
+                (define wrapped (current-input-port))
+                (current-input-port i)
+                (thread (lambda ()
+                          (with-handlers [(values (lambda (e)
+                                                    (displayln (exn->string e) (current-error-port))
+                                                    (exit 1)))]
+                            (let loop ()
+                              (if (eof-object? (peek-byte wrapped))
+                                  (close-output-port o)
+                                  (begin (base64-decode-stream wrapped o)
+                                         (loop))))))))]))
+
   (let loop ((count count))
     (when (positive? count)
       (define v ((if annotations? values strip-annotations)
@@ -51,11 +91,18 @@
                    ['text (read-preserve/text #:read-syntax? #t #:decode-embedded values #:source "<stdin>")]
                    ['binary (read-preserve/binary #:decode-embedded values #:read-syntax? #t)])))
       (when (not (eof-object? v))
-        (void (match output-format
-                ['text
-                 (write-preserve/text v #:indent indent? #:encode-embedded values)
-                 (newline)]
-                ['binary
-                 (write-preserve/binary v #:encode-embedded values #:write-annotations? #t)]))
+        (define bs
+          (call-with-output-bytes
+           (lambda (p)
+             (match output-format
+               ['text
+                (write-preserve/text v p #:indent indent? #:encode-embedded values)
+                (newline)]
+               ['binary
+                (write-preserve/binary v p #:encode-embedded values #:write-annotations? #t)]))))
+        (match output-encoding
+          ['none (write-bytes bs)]
+          ['hex (writeln (bytes->hex-string bs))]
+          ['base64 (writeln (base64-encode bs #""))])
         (flush-output)
         (loop (- count 1))))))