diff --git a/examples/cl-repl/app.asd b/examples/cl-repl/app.asd index 3d09f44..a5de27b 100644 --- a/examples/cl-repl/app.asd +++ b/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"))) diff --git a/examples/cl-repl/lisp/editor.lisp b/examples/cl-repl/lisp/editor.lisp index 1f893d9..f67cdd9 100644 --- a/examples/cl-repl/lisp/editor.lisp +++ b/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) diff --git a/examples/cl-repl/lisp/upload-download.lisp b/examples/cl-repl/lisp/upload-download.lisp new file mode 100644 index 0000000..9166f1b --- /dev/null +++ b/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)) diff --git a/examples/cl-repl/make.lisp b/examples/cl-repl/make.lisp index 425f68d..5d9774f 100644 --- a/examples/cl-repl/make.lisp +++ b/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*))) diff --git a/examples/cl-repl/patch/readme.md b/examples/cl-repl/patch/readme.md new file mode 100644 index 0000000..a8484e2 --- /dev/null +++ b/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`. diff --git a/examples/cl-repl/patch/zip.diff b/examples/cl-repl/patch/zip.diff new file mode 100644 index 0000000..e3f4b7a --- /dev/null +++ b/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)) diff --git a/examples/cl-repl/qml/ext/Help.qml b/examples/cl-repl/qml/ext/Help.qml index f1d4c86..19f0623 100644 --- a/examples/cl-repl/qml/ext/Help.qml +++ b/examples/cl-repl/qml/ext/Help.qml @@ -45,6 +45,12 @@ Rectangle {
[Home]/uploads/.
+
+