Add zip translator.

3 files changed, 108 insertions, 0 deletions

diff --git a/zip-translator.asd b/zip-translator.asd
new file mode 100644
index 000000000..560c4932e
--- /dev/null
+++ b/zip-translator.asd
@@ -0,0 +1,18 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+(defpackage #:zip-translator-asd
+  (:use :cl :asdf))
+
+(in-package :zip-translator-asd)
+
+(defsystem zip-translator
+  :name "zip-translator"
+  :version "0.0.0"
+  :maintainer "Flavio Cruz"
+  :author "Flavio Cruz"
+  :license "GPL v3.0"
+  :description "Simple, yet functional zip translator."
+  :depends-on (:zip :hurd-translator)
+  :components ((:module zip-translator
+                        :components ((:file "zip-translator")))))
+
diff --git a/zip-translator/zip-translator.lisp b/zip-translator/zip-translator.lisp
new file mode 100644
index 000000000..39872b2b9
--- /dev/null
+++ b/zip-translator/zip-translator.lisp
@@ -0,0 +1,80 @@
+
+(defpackage :zip-translator
+  (:use :cl :hurd-common :mach
+        :hurd :hurd-translator
+        :zip))
+
+(in-package :zip-translator)
+
+(defclass zip-translator (translator)
+  ()
+  (:documentation "Zip translators zips the target directory and exposes the translated node as a zip file."))
+
+(defun temporary-file-name ()
+  (format nil "zip-translator-~A.zip" (random 50000)))
+
+(defconstant +target-dir+ (first ext:*args*))
+(defconstant +zip-file+ (temporary-file-name))
+(defconstant +zip-file-path+ (concatenate-string "/tmp/" +zip-file+))
+
+;; Zip target target directory.
+(warn "Zipping directory ~A to ~A" +target-dir+ +zip-file+)
+(zip +zip-file-path+ +target-dir+)
+(warn "Zip of directory ~A done." +target-dir+)
+
+(defvar *zip-port* (file-name-lookup +zip-file-path+ :flags '(:read)))
+
+;; Remove file when clisp exits.
+(push (lambda ()
+        (port-deallocate *zip-port*)
+        (with-port-deallocate (port (file-name-lookup "/tmp" :flags '(:read)))
+          (dir-unlink port +zip-file+)))
+      custom:*fini-hooks*)
+
+(define-callback allow-open-p zip-translator
+                 (node user flags is-new-p)
+  (declare (ignore is-new-p))
+  (when (flag-is-p flags :write)
+    (return-from allow-open-p nil))
+  (when (flag-is-p flags :read)
+    (unless (has-access-p node user :read)
+      (return-from allow-open-p nil)))
+  t)
+
+(define-callback report-access zip-translator
+                 (node user)
+  (let ((ret))
+    (when (has-access-p node user :read)
+      (push :read ret))
+    ret))
+
+(define-callback read-file zip-translator
+                 (node user start amount stream)
+  (when (has-access-p node user :read)
+    (let ((data (io-read *zip-port*
+                         :amount amount
+                         :offset start)))
+      (when data
+        (write-sequence data stream)
+        t))))
+
+(define-callback make-root-node zip-translator
+                 (underlying-node underlying-stat)
+  (declare (ignore underlying-node))
+  (let ((mode (make-mode :perms '((:owner :read)
+                                  (:group :read)
+                                  (:others :read))
+                         :type :reg))
+        (stat (io-stat *zip-port*)))
+    (make-instance 'node
+                   :stat (make-stat underlying-stat
+                                    :mode mode
+                                    :size (stat-get stat 'st-size)))))
+
+(defun main ()
+  (run-translator (make-instance 'zip-translator
+                                 :name "zip-translator"
+                                 :version (list 0 0 1))))
+
+(main)
+
diff --git a/zip-translator/zip.lisp b/zip-translator/zip.lisp
new file mode 100755
index 000000000..65d8220fc
--- /dev/null
+++ b/zip-translator/zip.lisp
@@ -0,0 +1,10 @@
+#!/usr/bin/run-lisp-trans
+
+; settrans -ac foo ./zip.lisp zip-file.zip
+;
+
+(unless (= (length ext:*args*) 1)
+  (error "You must pass the target directory path to zip."))
+
+(asdf:operate 'asdf:load-op 'zip-translator)
+