diff --git a/src/9p-client/client.lisp b/src/9p-client/client.lisp deleted file mode 100644 index 3736af3..0000000 --- a/src/9p-client/client.lisp +++ /dev/null @@ -1,613 +0,0 @@ -(in-package :9p-client) - -(define-constant +byte-type+ '(unsigned-byte 8) :test #'equalp) - -(define-constant +version+ "9P2000" :test #'string=) - -(define-constant +message-length-size+ 4 :test #'=) - -(define-constant +message-type-size+ 1 :test #'=) - -(define-constant +message-tag-size+ 2 :test #'=) - -(define-constant +message-string-length-size+ 2 :test #'=) - -(define-constant +nofid+ #xffffffff :test #'=) - -(define-constant +create-for-read+ #x0 :test #'=) - -(define-constant +create-for-write+ #x1 :test #'=) - -(define-constant +create-for-read-write+ #x2 :test #'=) - -(define-constant +create-for-exec+ #x3 :test #'=) - -(define-constant +create-dir+ #x80000000 :test #'=) - -(define-constant +open-truncate+ #x10 :test #'=) - -(define-constant +open-remove-on-clunk+ #x40 :test #'=) - -(define-constant +standard-socket-port+ 564 :test #'=) - -(define-constant +nwname-clone+ 0 :test #'=) - -(defparameter *buffer-size* 252) - -(defparameter *tag* 8) - -(defparameter *fid* #x00000001) - -(defparameter *messages-sent* '()) - -(defun tags-exists-p-clsr (tag-looking-for) - (lambda (a) (octects= tag-looking-for (car a)))) - -(defun fire-response (tag message-type data) - (let ((found (find-if (tags-exists-p-clsr tag) *messages-sent*))) - (if found - (let ((fn (cdr found))) - (setf *messages-sent* (remove-if (tags-exists-p-clsr tag) *messages-sent*)) - (funcall fn message-type data)) - (warn (format nil "received unknown response message tag ~a" tag))))) - -(defun append-tag-callback (tag function) - (setf *messages-sent* (push (cons tag function) *messages-sent*))) - -(defun read-all-pending-message (socket) - (when *messages-sent* - (multiple-value-bind (message-type rtag data) - (restart-case - (read-message socket) - (ignore-error (e) - (values (message-type e) - (tag e) - #()))) - (fire-response rtag message-type data) - (read-all-pending-message socket)))) - -(defun next-tag () - (prog1 - (make-octects *tag* 2) - (incf *tag*))) - -(defun next-fid () - (prog1 - (int32->bytes *fid*) - (incf *fid*))) - -(defun bytes->int (bytes) - (let ((res #x0000000000000000) - (ct 0)) - (map nil - (lambda (a) - (setf res (boole boole-ior - (ash a ct) - res)) - (incf ct 8)) - bytes) - res)) - -(defmacro gen-intn->bytes (bits) - (let ((function-name (alexandria:format-symbol t "~:@(int~a->bytes~)" bits))) - `(defun ,function-name (val &optional (count 0) (res '())) - (if (>= count ,(/ bits 8)) - (reverse res) ; little endian - (,function-name (ash val -8) - (1+ count) - (push (boole boole-and val #x00ff) - res)))))) - -(gen-intn->bytes 8) - -(gen-intn->bytes 16) - -(gen-intn->bytes 32) - -(gen-intn->bytes 64) - -(gen-intn->bytes 512) - -(gen-intn->bytes 416) - -(defun big-endian->little-endian (bytes) - (reverse bytes)) - -(defun vcat (a b) - (concatenate 'vector a b)) - -(defclass octects () - ((value - :initform 0 - :initarg :value - :accessor value) - (size - :initform 0 - :initarg :size - :accessor size))) - -(defgeneric octects= (a b)) - -(defgeneric encode (object)) - -(defgeneric decode (object)) - -(defmethod encode ((object octects)) - (with-accessors ((value value) - (size size)) object - (let ((bytes (ecase size - (1 (int8->bytes value)) - (2 (int16->bytes value)) - (4 (int32->bytes value)) - (8 (int64->bytes value)) - (13 (int416->bytes value)) - (32 (int512->bytes value)))) - (res (make-array size :element-type +byte-type+))) - (loop for i from 0 below size do - (setf (elt res i) (elt bytes i))) - res))) - -(defmethod octects= ((a octects) b) - (= (value a) b)) - -(defmethod octects= ((a number) (b octects)) - (octects= b a)) - -(defmethod octects= ((a number) (b number)) - (= b a)) - -(defun add-size (msg) - (let ((length (int32->bytes (+ +message-length-size+ (length msg))))) - (vcat length msg))) - -(defun start-client (host port) - (usocket:socket-connect host - port - :protocol :stream - :element-type +byte-type+)) - -(defun close-client (socket) - (usocket:socket-close socket)) - -(defun send-message (socket message) - (with-accessors ((stream usocket:socket-stream)) socket - (write-sequence message stream) - (finish-output stream))) - -(defun encode-string (string) - (let* ((bytes (babel:string-to-octets string)) - (size (int16->bytes (length bytes)))) - (vcat size bytes))) - -(defmethod encode ((object string)) - (encode-string object)) - -(defmethod encode ((object list)) - (let ((buffer (make-message-buffer (length object)))) - (loop for i from 0 below (length object) do - (setf (elt buffer i) (elt object i))) - buffer)) - -(defmethod encode (object) - object) - -(defmethod decode-string (data) - (let ((size (bytes->int (subseq data 0 +message-string-length-size+)))) - (babel:octets-to-string (subseq data - +message-string-length-size+ - (+ +message-string-length-size+ size)) - :errorp nil))) - -(defun compose-message (message-type tag &rest params) - (let ((actual-params (reduce #'vcat (mapcar #'encode params)))) - (add-size (reduce #'vcat (list (encode message-type) (encode tag) actual-params))))) - -(defun displace-response (response) - (let ((message-type (subseq response 0 +message-type-size+)) - (message-tag (subseq response - +message-type-size+ - (+ +message-type-size+ - +message-tag-size+))) - (data (subseq response - (+ +message-type-size+ - +message-tag-size+)))) - (values (bytes->int message-type) - (bytes->int message-tag) - data))) - -(defun make-message-buffer (size) - (make-array size :element-type +byte-type+)) - -(defun error-response-p (response) - (multiple-value-bind (message-type x y) - (displace-response response) - (declare (ignore x y)) - (= message-type *rerror*))) - -(defun read-message (socket) - (with-accessors ((stream usocket:socket-stream)) socket - (let ((message-length-buffer (make-message-buffer +message-length-size+))) - (read-sequence message-length-buffer stream) - (let* ((message-length (bytes->int message-length-buffer)) - (buffer (make-message-buffer (- message-length +message-length-size+)))) - (read-sequence buffer stream) - (multiple-value-bind (message-type tag data) - (displace-response buffer) - (if (error-response-p buffer) - (error '9p-error - :message-type message-type - :tag tag - :error-value (decode-string data)) - (values message-type tag data))))))) - -(defun make-octects (number size) - (make-instance 'octects :value number :size size)) - -(defun send-version (socket tag) - (let ((message (compose-message (make-octects *tversion* 1) - tag - (make-octects *buffer-size* 4) - +version+))) - (send-message socket message) - (multiple-value-bind (message-type rtag data) - (read-message socket) - (assert (= message-type *rversion*)) - (if (octects= rtag tag) - (let ((message-size (bytes->int (subseq data 0 4))) - (protocol-version (decode-string (subseq data 4)))) - (setf *buffer-size* message-size) - (values message-size protocol-version)) - (error '9p-initialization-error :tag tag :rtag rtag))))) - -(defmacro with-new-tag ((tag) &body body) - `(let ((,tag (next-tag))) - ,@body)) - -(defmacro with-new-fid ((fid) &body body) - `(let ((,fid (next-fid))) - ,@body)) - -(defun initialize-session (host port) - (with-new-tag (tag) - (let* ((socket (start-client host port))) - (multiple-value-bind (buffer-size protocol-version) - (send-version socket tag) - (values socket protocol-version buffer-size))))) - -(defun decode-quid (data) - (let ((file-type (first-elt data)) - (file-version (subseq data 1 4)) - (file-path (subseq data 1 5))) - (values file-type - (bytes->int file-version) - (bytes->int file-path)))) - -(defun dummy-callback (message-type data) - (declare (ignore message-type data))) - -(defun dump-callback (message-type data) - (format t "reply mtype ~a ~a~%" message-type data)) - -(defun 9p-attach (socket root - &key - (username "nobody") - (callback #'dummy-callback)) - (with-new-tag (tag) - (with-new-fid (root-fid) - (let* ((message (compose-message (make-octects *tattach* 1) - tag - root-fid - (make-octects +nofid+ 4) - username - root))) - (append-tag-callback tag callback) - (send-message socket message) - root-fid)))) - -(defun 9p-create (socket parent-dir-fid path - &key - (callback #'dummy-callback) - (permissions #o640) - (mode +create-for-read-write+)) - "Note: path is relative to root, see attach, - Also note that successfully creating a file will open it." - (with-new-tag (tag) - (let* ((message (compose-message (make-octects *tcreate* 1) - tag - parent-dir-fid - path - (make-octects permissions 4) - (make-octects mode 1)))) - (append-tag-callback tag callback) - (send-message socket message)))) - -(defun 9p-open (socket fid - &key - (callback #'dummy-callback) - (mode +create-for-read+)) - "Note before opening you have to 'walk' the file to get the corresponding fid." - (with-new-tag (tag) - (let* ((message (compose-message (make-octects *topen* 1) - tag - fid - (make-octects mode 1)))) - (append-tag-callback tag callback) - (send-message socket message)))) - -(defgeneric 9p-write (socket fid offset data &key callback)) - -(defmethod 9p-write (socket fid offset (data vector) - &key - (callback #'dummy-callback)) - (let* ((data-chunk-num (floor (/ (length data) *buffer-size*))) - (data-chunk-length (if (> (length data) *buffer-size*) - (* data-chunk-num *buffer-size*) - (length data))) - (remainder (if (> (length data) *buffer-size*) - (- (length data) - (* data-chunk-num *buffer-size*)) - 0))) - (flet ((write-chunk (chunk chunk-offset) - (with-new-tag (tag) - (let* ((message (compose-message (make-octects *twrite* 1) - tag - fid - (make-octects chunk-offset 8) - (make-octects (length chunk) 4) - chunk))) - (append-tag-callback tag callback) - (send-message socket message))))) - (loop for i from 0 below (- (length data) remainder) by data-chunk-length do - (let ((chunk (subseq data i (+ i data-chunk-length)))) - (write-chunk chunk (+ offset i)))) - (when (> remainder 0) - (write-chunk (subseq data (- (length data) remainder)) - (+ offset (- (length data) remainder))))))) - -(defmethod 9p-write (socket fid offset (data string) - &key - (callback #'dummy-callback)) - (9p-write socket fid offset (babel:string-to-octets data) :callback callback)) - -(defun 9p-walk (socket root-fid new-fid new-name &key (callback #'dummy-callback)) - (if (and (numberp new-name) - (= 0 new-name)) - (%9p-walk-self socket root-fid new-fid :callback callback) - (with-new-tag (tag) - (let* ((message (compose-message (make-octects *twalk* 1) - tag - root-fid - new-fid - (make-octects 1 2) - new-name))) - (append-tag-callback tag callback) - (send-message socket message))))) - -(defun %9p-walk-self (socket root-fid new-fid &key (callback #'dummy-callback)) - (with-new-tag (tag) - (let* ((message (compose-message (make-octects *twalk* 1) - tag - root-fid - new-fid - (make-octects 0 2)))) - (append-tag-callback tag callback) - (send-message socket message)))) - -(defun 9p-remove (socket fid &key (callback #'dummy-callback)) - (with-new-tag (tag) - (let* ((message (compose-message (make-octects *tremove* 1) - tag - fid))) - (append-tag-callback tag callback) - (send-message socket message)))) - -(defun 9p-clunk (socket fid &key (callback #'dummy-callback)) - (with-new-tag (tag) - (let* ((message (compose-message (make-octects *tclunk* 1) - tag - fid))) - (append-tag-callback tag callback) - (send-message socket message)))) - -(defun 9p-stat (socket fid &key (callback #'dummy-callback)) - (with-new-tag (tag) - (let* ((message (compose-message (make-octects *tstat* 1) - tag - fid))) - (append-tag-callback tag callback) - (send-message socket message)))) - -(defun 9p-read (socket fid offset chunk-length &key (callback #'dummy-callback)) - (with-new-tag (tag) - (let* ((message (compose-message (make-octects *tread* 1) - tag - fid - (make-octects offset 8) - (make-octects chunk-length 4)))) - (append-tag-callback tag callback) - (send-message socket message)))) - -(defun decode-read-reply (data &optional (as-string nil)) - (let ((count (bytes->int (subseq data 0 4))) - (raw-data (subseq data 4))) - (values (if as-string - (babel:octets-to-string raw-data :errorp nil) - raw-data) - count))) - -(defun encoded-string-offset (decoded-string) - (+ (length decoded-string) - +message-string-length-size+)) - -(defun decode-rstat (data) - (flet ((->int (start end) - (bytes->int (subseq data start end)))) - (let* ((entry-size1 (->int 0 2)) - (entry-size2 (->int 2 4)) - (ktype (->int 4 6)) - (kdev (->int 6 10)) - (entry-type (->int 10 11)) - (version (->int 11 15)) - (path (->int 15 23)) - (mode (->int 23 27)) - (atime (->int 27 31)) - (mtime (->int 31 35)) - (size (->int 35 43)) - (strings-start 43) - (name (decode-string (subseq data strings-start))) - (name-offset (encoded-string-offset name)) - (user-id (decode-string (subseq data - (+ strings-start - name-offset)))) - (user-id-offset (+ strings-start - (encoded-string-offset user-id) - name-offset)) - (group-id (decode-string (subseq data user-id-offset))) - (group-id-offset (+ user-id-offset - (encoded-string-offset group-id))) - (last-modified-from-id (decode-string (subseq data group-id-offset)))) - (values entry-size1 - entry-size2 - ktype - kdev - entry-type - version - path - mode - atime - mtime - size - name - user-id - group-id - last-modified-from-id)))) - -;;; high level routines - -(defun read-all-pending-messages-ignoring-errors (socket) - (handler-bind ((9p-error - (lambda (e) - (invoke-restart 'ignore-error e)))) - (read-all-pending-message socket))) - -(defun create-directory (socket parent-fid directory-name &key (permissions #o760)) - (9p-create socket - parent-fid - directory-name - :permissions (logior +create-dir+ permissions) - :mode +create-for-read+) - (read-all-pending-messages-ignoring-errors socket)) - -(defun create-path (socket parent-fid path &key (file-permissions #o640)) - (let ((fs:*directory-sep-regexp* "\\/") - (path-elements (fs:split-path-elements path)) - (last-is-dir-p (cl-ppcre:scan "\\/$" path))) - (labels ((%create-dirs (path-elements) - (when path-elements - (create-directory socket parent-fid (first path-elements)) - (read-all-pending-messages-ignoring-errors socket) - (%create-dirs (rest path-elements))))) - (%create-dirs (misc:safe-all-but-last-elt path-elements)) - (if last-is-dir-p - (create-directory socket parent-fid (last-elt path-elements)) - (9p-create socket parent-fid (last-elt path-elements) - :permissions file-permissions)) - (read-all-pending-messages-ignoring-errors socket)))) - -(defun mount (host root-path &optional (port +standard-socket-port+)) - (multiple-value-bind (socket version) - (initialize-session host port) - (let* ((root-fid (9p-attach socket root-path))) - (read-all-pending-message socket) - (values socket root-fid version)))) - -(defun open-path (socket root-fid path - &key - (walk-callback #'dummy-callback) - (open-callback #'dummy-callback) - (mode +create-for-read+)) - (let ((fs:*directory-sep-regexp* "\\/") - (path-elements (fs:split-path-elements path))) - (labels ((walk-dirs (path-elements parent-fid) - (with-new-fid (fid) - (if path-elements - (progn - (9p-walk socket - parent-fid - fid - (first path-elements) - :callback walk-callback) - (read-all-pending-message socket) - (walk-dirs (rest path-elements) fid)) - parent-fid)))) - (let ((fid (walk-dirs path-elements root-fid))) - (9p-open socket fid :callback open-callback :mode mode) - (read-all-pending-message socket) - fid)))) - -(defun cat-reply-vector (a b) - (concatenate '(vector (unsigned-byte 8)) a b)) - -(defun slurp-file (socket root-fid path &key (buffer-size *buffer-size*)) - (let ((res (make-array 0 :element-type +byte-type+ :adjustable nil)) - (fid (open-path socket root-fid path))) - (labels ((slurp (offset) - (9p-read socket - fid - offset - buffer-size - :callback (lambda (x reply) - (declare (ignore x)) - (multiple-value-bind (data count) - (decode-read-reply reply nil) - (setf res (cat-reply-vector res data)) - (when (or (= count buffer-size) - (= count *buffer-size*)) - (slurp (+ offset count)))))))) - (slurp 0) - (read-all-pending-message socket) - res))) - -(defun example (path &optional (root (os-utils:getenv "HOME")) (host "localhost") (port 10564)) - (multiple-value-bind (socket root-fid) - (mount host root port) - (with-new-fid (saved-root-fid) - (9p-walk socket root-fid saved-root-fid +nwname-clone+) - (let ((fid (open-path socket root-fid path))) - (9p-read socket fid 0 10 - :callback (lambda (x data) - (declare (ignore x)) - (format t "read: ~a~%" (decode-read-reply data t)))) - (read-all-pending-message socket))))) - -(defun example-slurp (path - &optional (root (os-utils:getenv "HOME")) (host "localhost") (port 10564)) - (let ((*buffer-size* 10)) - (multiple-value-bind (socket root-fid) - (mount host root port) - (babel:octets-to-string (slurp-file socket root-fid path :buffer-size 3) :errorp nil)))) - -(defun example-stat (&optional (root (os-utils:getenv "HOME")) (host "localhost") (port 10564)) - (multiple-value-bind (socket root-fid) - (mount host root port) - (9p-stat socket root-fid - :callback (lambda (x data) - (declare (ignore x)) - (format t "raw ~a~%stat ~a~%" data (multiple-value-list (decode-rstat data))))) - (read-all-pending-message socket))) - -(defun pad-read-dir-reply (data) - (cat-reply-vector #(0 0) data)) - -(defun read-directory (&optional (root (os-utils:getenv "HOME")) (host "localhost") (port 10564)) - (multiple-value-bind (socket root-fid) - (mount host root port) - (9p-open socket root-fid :mode +create-for-read+) - (9p-read socket - root-fid - 0 4 - :callback (lambda (x data) - (declare (ignore x)) - (format t - "raw ~a~%" data))) - (read-all-pending-message socket))) diff --git a/src/9p-client/package.lisp b/src/9p-client/package.lisp deleted file mode 100644 index cacc9e4..0000000 --- a/src/9p-client/package.lisp +++ /dev/null @@ -1,21 +0,0 @@ -;; tinmop: an humble gemini and pleroma client -;; Copyright (C) 2020 cage - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(defpackage :9p-client - (:use - :cl - :alexandria) - (:export)) diff --git a/src/os-utils.lisp b/src/os-utils.lisp index 4ef9148..310bcb3 100644 --- a/src/os-utils.lisp +++ b/src/os-utils.lisp @@ -168,22 +168,25 @@ (defun open-resource-with-external-program (resource give-focus-to-message-window &key (open-for-edit nil)) - (let ((program (swconf:link-regex->program-to-use resource))) - (if program - (cond - ((swconf:use-editor-as-external-program-p program) + (flet ((edit (file) (croatoan:end-screen) - (os-utils:open-with-editor resource)) - ((and (null open-for-edit) - (swconf:use-tinmop-as-external-program-p program)) - (gemini-viewer:load-gemini-url resource - :give-focus-to-message-window - give-focus-to-message-window)) - (t - (os-utils:open-link-with-program program resource :wait open-for-edit))) - (if open-for-edit - (error (_ "No editor program defined in config file")) - (os-utils:xdg-open resource))))) + (os-utils:open-with-editor file))) + (let ((program (swconf:link-regex->program-to-use resource))) + (if program + (cond + ((swconf:use-editor-as-external-program-p program) + (edit resource)) + ((swconf:use-tinmop-as-external-program-p program) + (if open-for-edit + (edit resource) + (gemini-viewer:load-gemini-url resource + :give-focus-to-message-window + give-focus-to-message-window))) + (t + (os-utils:open-link-with-program program resource :wait open-for-edit))) + (if open-for-edit + (error (_ "No program defined in configuration file to edit this kind of files.")) + (os-utils:xdg-open resource)))))) (defun unzip-file (zip-file destination-dir) (cond