Add copy directory function

bolt.rkt

@@ -1,6 +1,7 @@
 #lang racket
 
 (require remote-shell/ssh)
+(require "directory.rkt")
 
 (define (strip-first-line st)
   (string-join
@@ -86,8 +87,13 @@
     (format "~a@~a:~a" (user) (remote-host (host)) dest)
     #:mode 'result))
 
-
+(define (copy-dir source dest)
-; TODO copy directories by gzipping them up somehow
+  (define tar-path (compress source))
+  (copy-file tar-path tar-path)
+  (remove-tmp tar-path)
+  (exec (format "mkdir -p ~a" dest))
+  (exec (format "tar -xzvf ~a -C ~a" tar-path dest))
+  (exec (format "rm ~a" tar-path)))
 
 (define ((make-cmd cmd)) (exec cmd))
 
@@ -95,4 +101,4 @@
 (define pwd (make-cmd "pwd"))
 
 (provide
-  (all-defined-out) remote)
+  (all-defined-out) remote compress)

directory.rkt

@@ -0,0 +1,33 @@
+#lang racket
+
+(require racket/system)
+
+(define (clean-path path)
+  (string-replace path "/" "_"))
+
+(define (compress directory)
+  (define tar
+    (find-executable-path "tar"))
+
+  (define path
+    (format "/tmp/~a.tar.gz"
+            (clean-path directory)))
+
+  (system* tar "-zcvf" path directory)
+  path)
+
+(define (remove-tmp path)
+  (define rm
+    (find-executable-path "rm"))
+  (system* rm path))
+
+(define (drop-last-dir path)
+  (define ps (explode-path path))
+  (define paths (take ps (sub1 (length ps))))
+  (path->string
+    (apply build-path paths)))
+
+(provide
+  drop-last-dir
+  compress
+  remove-tmp)