example 'cl-repl': add upload/download of files (wifi), add zip/unzip of files

examples/cl-repl/app.asd

@@ -1,6 +1,8 @@
 (defsystem :app
   :serial t
-  :depends-on (:cl-ppcre)
+  :depends-on (#-:depends-loaded :cl-ppcre
+               #-:depends-loaded :s-http-server
+               #-:depends-loaded :zip)
   :components ((:file "lisp/package")
                (:file "lisp/ui-vars")
                (:file "lisp/qt")
@@ -17,6 +19,7 @@
                (:file "lisp/curl")
                (:file "lisp/dialogs")
                (:file "lisp/editor")
+               (:file "lisp/upload-download")
                (:file "lisp/ini")
                (:file "lisp/main")))
 

examples/cl-repl/lisp/editor.lisp

@@ -679,6 +679,10 @@
                                    "(progn (qml:q! |clear| ui:*output-model*) (values))")
                                   ((cmd "*")
                                    (format nil "(progn~%  (editor::set-clipboard-text (prin1-to-string *))~%  *)"))
+                                  ((cmd ":w")
+                                   "(s-http-server:start)")
+                                  ((cmd ":ws")
+                                   "(s-http-server:stop)")
                                   ((x:starts-with ":? " text*)
                                    (format nil "(editor:find-text ~S)" (subseq text* #.(length ":? ")))))))
                    (setf *ex-cmd* cmd)

examples/cl-repl/lisp/upload-download.lisp

@@ -0,0 +1,116 @@
+;;; web server handler
+
+(in-package :s-http-server)
+
+(defvar *web-server* nil)
+
+(defconstant +buffer-length+ 8192)
+
+(defvar *empty-line* #.(map 'vector 'char-code (list #\Return #\Linefeed
+                                                     #\Return #\Linefeed)))
+
+(defun form-data-filename (data start end)
+  "Searches for 'filename=' in current form data field header."
+  (let ((p1 (search #.(x:string-to-bytes "filename=\"")
+                    data :start2 start :end2 end)))
+    (when p1
+      (incf p1 #.(length "filename=\""))
+      (x:bytes-to-string
+       (subseq data p1 (position #.(char-code #\") data :start p1))))))
+
+(defun save-file (stream content-length boundary)
+  "Saves uploaded file(s) under 'uploads/'. Requires 'multipart/form-data'."
+  ;; read all data into a buffer first
+  (let* ((content (make-array 0 :element-type '(unsigned-byte 8) :adjustable t))
+         (boundary-length (length boundary))
+         (start (+ boundary-length 2)))
+    (loop :with buffer = (make-array +buffer-length+ :element-type '(unsigned-byte 8))
+          :for index = 0 :then (+ index pos)
+          ;; don't read past end, would block http connection
+          :for pos = (read-sequence buffer stream :end (min +buffer-length+
+                                                            (- content-length index)))
+          do (adjust-array content (+ index pos))
+             (replace content buffer :start1 index :end2 pos)
+          :while (< index content-length))
+    ;; loop through all form-data and save file(s)
+    (x:while-it (search boundary content :start2 start)
+      (let ((filename (form-data-filename content (+ start 2) (- x:it 2))))
+        (unless (x:empty-string filename)
+          (let ((pathname (merge-pathnames (x:cc "uploads/" filename))))
+            (ensure-directories-exist pathname)
+            (with-open-file (out pathname :direction :output :if-exists :supersede
+                                          :element-type '(unsigned-byte 8))
+              (write-sequence (subseq content
+                                      (+ 4 (search *empty-line* content :start2 start))
+                                      (- x:it 4))
+                              out)))))
+      (setf start (incf x:it boundary-length)))))
+
+(defun ensure-multipart/form-data (headers)
+  "Searches headers for 'multipart/form-data' and returns its boundary string."
+  (let ((content-type (cdr (assoc :content-type headers))))
+    (when (search "multipart/form-data" content-type)
+      (x:string-to-bytes
+       (subseq content-type (+ (search "boundary=" content-type)
+                               #.(length "boundary=")))))))
+
+(defun static-resource/upload-handler (s-http-server handler http-request stream)
+  "Hosts static resources from a document root. If the http request is POST,
+it saves uploaded files on the server."
+  ;; slightely extended version of 's-http-server:static-resource-handler'
+  ;; (see 'upload' below)
+  (destructuring-bind (context document-root &rest options)
+      handler
+    (let* ((path (get-path http-request))
+           (resource-pathname (compute-real-resource-pathname document-root path context
+                                                              (or (getf options :pathname-builder)
+                                                                  #'make-real-resource-pathname)))
+           (expires-max-age (or (getf options :expires-max-age) (* 60 60))))
+      (if (probe-file resource-pathname)
+          (progn
+            ;; upload
+            (when (eql :post (get-method http-request))
+              (let* ((headers (get-headers http-request))
+                     (boundary (ensure-multipart/form-data headers)))
+                (when boundary
+                  (save-file (get-stream (get-http-connection http-request))
+                             (parse-integer (cdr (assoc :content-length headers)))
+                             boundary))))
+            (logm s-http-server :debug "Serving ~s" resource-pathname)
+            (host-static-resource http-request stream resource-pathname :expires-max-age expires-max-age))
+          (progn
+            (logm s-http-server :error "Failed to find ~s" resource-pathname)
+            (values t 404 (standard-http-html-error-response http-request stream 404 "Resource Not Found" path)))))))
+
+(defun start ()
+  (let ((ini (null *web-server*)))
+    (when ini
+      (setf *web-server* (make-s-http-server)))
+    (start-server *web-server*)
+    (when ini
+      (register-context-handler *web-server* "/" 'static-resource/upload-handler
+                                :arguments (list #+mobile *default-pathname-defaults*
+                                                 #-mobile (merge-pathnames "www/"))))))
+
+(defun stop ()
+  (stop-server *web-server*))
+
+(export (list 'start 'stop))
+
+;;; zip/unzip 
+
+(in-package :qml)
+
+(defun zip (zip-file directory)
+  "Creates a *.zip file of passed directory, _not_ including the directory name."
+  (zip:zip (merge-pathnames zip-file)
+           (probe-file directory)
+           :if-exists :supersede))
+
+(defun unzip (zip-file &optional directory)
+  "Extracts (previously uploaded) *.zip file."
+  (zip:unzip (merge-pathnames zip-file)
+             (probe-file (or directory "."))
+             :if-exists :supersede))
+
+(export (list 'zip 'unzip))

examples/cl-repl/make.lisp

@@ -35,6 +35,7 @@
       (shell (cc "cp -r ../../../slime/src/* " to))))
   (let ((lib (cc (ext:getenv #+android "ECL_ANDROID" #+ios "ECL_IOS")
                  "/lib/ecl-*/")))
+    (shell (cc "cp ../www/index.html " *assets*))
     (unless (probe-file (cc *assets* "encodings"))
       (shell (cc "cp " lib "*.doc " *assets*))
       (shell (cc "cp -r " lib "encodings " *assets*)))

examples/cl-repl/patch/readme.md

@@ -0,0 +1,17 @@
+
+Info
+----
+
+This is a small patch to make `:zip` from Quicklisp work with ECL (or any CL
+implementation, for that matter).
+
+It uses a trivial approach by simply applying a stat of `644` for files, and
+`775` for directories (that is, files with a `pathname-type` of `NIL`).
+
+
+
+HowTo
+-----
+
+Copy project `:zip` from Quicklisp to `~/quicklisp/local-projects/` and patch
+file `zip.lisp` according to `zip.diff`.

examples/cl-repl/patch/zip.diff

@@ -0,0 +1,18 @@
+diff --git a/zip.lisp.orig b/zip.lisp
+index a2f3768..cb1d76a 100644
+--- a/zip.lisp.orig
++++ b/zip.lisp
+@@ -15,8 +15,12 @@
+   #o640
+   #-(or windows mswindows)
+   (progn
+-    #-(or sbcl allegro ccl)
++    #-(or ecl sbcl allegro ccl)
+     (error "ZIP::FILE-MODE not ported")
++    #+ecl
++    (if (pathname-type pathname)
++        #o644
++        #o775)
+     #+ccl
+     (multiple-value-bind (win mode size mtime inode uid blocksize rmtime gid dev)
+         (ccl::%stat (ccl:native-translated-namestring pathname))

examples/cl-repl/qml/ext/Help.qml

@@ -45,6 +45,12 @@ Rectangle {
   <tr>
     <td align=right><b>:k</b></td><td>kill eval thread (long running task)</td>
   </tr>
+  <tr>
+    <td align=right><b>:w</b></td><td>start local web-server for file upload/download, see http://192.168.1.x:1701/</td>
+  </tr>
+  <tr>
+    <td align=right><b>:ws</b></td><td>stop local web-server</td>
+  </tr>
   <tr>
     <td align=right><b>double SPC</b></td><td>auto completion, e.g.<b> m-v-b</b></td>
   </tr>

examples/cl-repl/readme.md

@@ -11,6 +11,10 @@ $ ./copy.sh cl-repl
 See also [../../slime/src/readme-sources](../../slime/src/readme-sources.md) for
 installing the Slime sources where this example can find them.
 
+**Important**: you need to patch library `:zip` from Quicklisp, so copy it in
+your `~/quicklisp/local-projects/` directory, and apply this
+[patch/zip.diff](patch/zip.diff).
+
 
 
 Info
@@ -77,6 +81,46 @@ if they are in the same WiFi and point to the same desktop IP.
 
 
 
+File exchange over WiFi (mobile only)
+-------------------------------------
+
+A simple web-server is integrated here for both downloading saved files to a
+desktop computer, or uploading them to the mobile device.
+
+To start the web-server, enter `:w` in the command line. It will point to the
+`[Home]` directory (`[Home]/Documents/` on iOS).
+
+### Upload
+
+Enter the IP of your mobile device in the desktop browser, using `1701` as
+port (mind the trailing `/`):
+```
+http://192.168.1.x:1701/
+```
+Now you can upload either a whole directory, or a single file. The files will
+be stored in `[Home]/uploads/` (`[Home]/Documents/uploads/` on iOS).
+
+You may also upload a zip file, which can then be unzipped using:
+```
+(unzip "uploads/all.zip" "examples/")
+```
+
+### Download
+
+First create a `*.zip` file like so:
+```
+(zip "all.zip" "examples/")
+```
+Note that the zip file will not contain the passed directory name (this is how
+the zip library from Quicklisp is implemented).
+
+Now you just need to enter the path in your desktop browser, something like:
+```
+http://192.168.1.x:1701/all.zip
+```
+
+
+
 Important notes for mobile
 --------------------------
 

examples/cl-repl/run.lisp

@@ -4,9 +4,15 @@
 
 (require :asdf)
 
+(asdf:load-system :cl-ppcre)
+(asdf:load-system :s-http-server)
+(asdf:load-system :zip)
+
 (push (merge-pathnames "./")
       asdf:*central-registry*)
 
+(push :depends-loaded *features*)
+
 (asdf:operate 'asdf:load-source-op :app)
 
 (qset *quick-view*

examples/cl-repl/www/index.html

@@ -0,0 +1,31 @@
+<!doctype html>
+<html>
+  <head>
+    <meta charset="utf-8">
+    <meta name="viewport" content="width=device-width, initial-scale=1.0"> 
+    <style>
+      body { color: #505050; font-family: sans-serif; margin: 30px 20px; }
+      a:link, a:visited { text-decoration: none; color: blue; }
+      a:hover { text-decoration: underline; }
+    </style>
+  </head>
+  <body>
+    <h3>Upload files to CL REPL app</h3>
+    <form enctype="multipart/form-data" method="post" action="/">
+      <p>
+        <small><b>Whole Directory</b></small>
+        <br>
+        <input name="files[]" type="file" webkitdirectory directory />
+      </p>
+      <p>
+        <small><b>Single File</b></small>
+        <br>
+        <input name="file" type="file" value="Choose file" />
+      </p>
+      <p>
+      <input type="submit" value="Upload" />
+      </p>
+    </form>
+    <small>Files are saved in <code>[Home]/uploads/</code></small>.
+  </body>
+</html>