From 4ab97dd9bdcc5602cada19cfea20d4b4efcbfb0c Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Fri, 19 Jun 2015 00:02:05 +0900
Subject: [PATCH] adding experimental --use-curl option

---
 lib/chibi/snow/commands.scm | 30 +++++++++++++++++++++++++++++-
 lib/chibi/snow/utils.scm    |  5 +++++
 lib/chibi/snow/utils.sld    |  3 ++-
 tools/snow-chibi            |  1 +
 4 files changed, 37 insertions(+), 2 deletions(-)

diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm
index 12182dcf..5fdfe5f6 100644
--- a/lib/chibi/snow/commands.scm
+++ b/lib/chibi/snow/commands.scm
@@ -763,9 +763,37 @@
       (make-path (or (conf-get cfg 'host) "http://snow-fort.org")
                  path)))
 
+;; a subset of http-post functionality that can shell out to curl
+;; depending on config
+(define (snow-post cfg uri params)
+  (if (conf-get cfg 'use-curl?)
+      (let ((cmd `(curl --silent
+                        ,@(append-map
+                           (lambda (x)
+                             (cond
+                              ((and (pair? (cdr x)) (assq 'value (cdr x)))
+                               => (lambda (y)
+                                    `("-F" ,(string-append
+                                             (display-to-string (car x)) "="
+                                             (display-to-string (cdr y))))))
+                              ((and (pair? (cdr x)) (assq 'file (cdr x)))
+                               => (lambda (y)
+                                    `("-F" ,(string-append
+                                             (display-to-string (car x)) "=@"
+                                             (display-to-string (cdr y))))))
+                              (else
+                               `("-F" ,(string-append
+                                        (display-to-string (car x)) "="
+                                        (display-to-string (cdr x)))))))
+                           params)
+                        ,(uri->string uri))))
+        (open-input-bytevector (process->bytevector cmd)))
+      (http-post uri params)))
+
 (define (remote-command cfg name path params)
   (let ((uri (remote-uri cfg name path)))
-    (sxml-display-as-text (read (http-post uri (cons '(fmt . "sexp") params))))
+    (sxml-display-as-text
+     (read (snow-post cfg uri (cons '(fmt . "sexp") params))))
     (newline)))
 
 (define (command/reg-key cfg spec)
diff --git a/lib/chibi/snow/utils.scm b/lib/chibi/snow/utils.scm
index a686300c..031bcf08 100644
--- a/lib/chibi/snow/utils.scm
+++ b/lib/chibi/snow/utils.scm
@@ -20,6 +20,11 @@
 (define (write-to-string x)
   (call-with-output-string (lambda (out) (write x out))))
 
+(define (display-to-string x)
+  (call-with-output-string
+    (lambda (out)
+      (if (bytevector? x) (write-bytevector x out) (display x out)))))
+
 (define (resource->bytevector uri)
   (let ((uri (if (uri? uri) uri (string->path-uri 'http uri))))
     (if (uri-host uri)
diff --git a/lib/chibi/snow/utils.sld b/lib/chibi/snow/utils.sld
index 76717ee2..636f590e 100644
--- a/lib/chibi/snow/utils.sld
+++ b/lib/chibi/snow/utils.sld
@@ -1,7 +1,8 @@
 
 (define-library (chibi snow utils)
   (export find-in-path find-sexp-in-path
-          write-to-string resource->bytevector uri-normalize uri-directory
+          write-to-string display-to-string
+          resource->bytevector uri-normalize uri-directory
           version-split version-compare version>? version>=?)
   (import (scheme base)
           (scheme file)
diff --git a/tools/snow-chibi b/tools/snow-chibi
index cef8e3e4..373d100d 100755
--- a/tools/snow-chibi
+++ b/tools/snow-chibi
@@ -88,6 +88,7 @@
     (chibi-path filename "path to chibi-scheme executable")
     (cc string "path to c compiler")
     (cflags string "flags for c compiler")
+    (use-curl? boolean ("use-curl") "use curl for file uploads")
     (sexp? boolean ("sexp") "output information in sexp format")
     ))