commit 34719c284b43ad4dbfd5ed53af233caafccc939f from: cage date: Fri Dec 31 11:12:19 2021 UTC - [regress-extra] removed client's code. commit - 5e8a17ecaa9c66227bbebeb4693241b0c1213044 commit + 34719c284b43ad4dbfd5ed53af233caafccc939f blob - 64b7b5355b4707cca6b656798089c014b59bc3a5 blob + 8a7898910e9035a2bfd02527e0a68a0fa4175730 --- regress/lisp/9p-test/9p-test.asd +++ regress/lisp/9p-test/9p-test.asd @@ -21,21 +21,12 @@ :version "0.0.1" :serial t :depends-on (:alexandria - :cl-ppcre - :osicat :cl+ssl :clunit2 :usocket :babel - :uiop) + :uiop + :9p-client) :components ((:file "package") - (:file "text-utils") - (:file "misc-utils") - (:file "filesystem-utils") - (:file "conditions") - (:file "message-types") - (:file "client") - (:module tests - :components ((:file "package") - (:file "all-tests") - (:file "kami-tests"))))) + (:file "all-tests") + (:file "kami-tests"))) blob - 3694302a78c07ac89a56bc281f3674da48acc231 (mode 644) blob + /dev/null --- regress/lisp/9p-test/client.lisp +++ /dev/null @@ -1,732 +0,0 @@ -;; test stuite for kami -;; Copyright (C) 2021 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 . - -(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 +stat-type-dir+ #x80 :test #'= - :documentation "mode bit for directories") - -(define-constant +stat-type-append+ #x40 :test #'= - :documentation "mode bit for append only files") - -(define-constant +stat-type-excl+ #x20 :test #'= - :documentation "mode bit for exclusive use files") - -(define-constant +stat-type-mount+ #x10 :test #'= - :documentation "mode bit for mounted channel") - -(define-constant +stat-type-auth+ #x08 :test #'= - :documentation "mode bit for authentication file") - -(define-constant +stat-type-tmp+ #x04 :test #'= - :documentation "mode bit for non-backed-up files") - -(define-constant +stat-type-symlink+ #x02 :test #'= - :documentation "mode bit for non-backed-up files") - -(define-constant +stat-type-file+ #x00 :test #'= - :documentation "mode bit for non-backed-up files") - -(define-constant +file-types+ (list (cons +stat-type-dir+ :directory) - (cons +stat-type-append+ :append-only) - (cons +stat-type-excl+ :executable) - (cons +stat-type-mount+ :mount) - (cons +stat-type-auth+ :auth ) - (cons +stat-type-tmp+ :tmp) - (cons +stat-type-symlink+ :symlink) - (cons +stat-type-file+ :file)) - :test #'equalp) - -(defun file-type-number->symbol (key) - (cdr (assoc key +file-types+))) - -;; modes - -(define-constant +stat-type-read+ #x4 :test #'= - :documentation "mode bit for read permission") - -(define-constant +stat-type-write+ #x2 :test #'= - :documentation "mode bit for write permission") - -(define-constant +stat-type-exec+ #x1 :test #'= - :documentation "mode bit for execute permission") - -(define-constant +standard-socket-port+ 564 :test #'=) - -(define-constant +nwname-clone+ 0 :test #'=) - -(defparameter *buffer-size* (* 4 1024 1024)) - -(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 (stream) - (when *messages-sent* - (multiple-value-bind (message-type rtag data) - (restart-case - (read-message stream) - (ignore-error (e) - (values (message-type e) - (tag e) - #()))) - (fire-response rtag message-type data) - (read-all-pending-message stream)))) - -(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 close-ssl-socket (socket) - (usocket:socket-close socket)) - -(defun close-client (socket) - (close-ssl-socket socket)) - -(defun send-message (stream message) - (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 (stream) - (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 (stream tag) - (let ((message (compose-message (make-octects *tversion* 1) - tag - (make-octects *buffer-size* 4) - +version+))) - (send-message stream message) - (multiple-value-bind (message-type rtag data) - (read-message stream) - (assert (= message-type *rversion*)) - (if (octects= rtag tag) - (let ((message-size (bytes->int (subseq data 0 4))) - (protocol-version (decode-string (subseq data 4)))) - (if (string= protocol-version +version+) - (progn - (setf *buffer-size* message-size) - (values message-size protocol-version)) - (error '9p-error - :message-type message-type - :tag tag - :error-value (format nil - "Version mismatch: ~s instead of ~s" - protocol-version - +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 (stream) - (with-new-tag (tag) - (multiple-value-bind (buffer-size protocol-version) - (send-version stream tag) - (values 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)) - -(defgeneric 9p-attach (stream root &key username callback)) - -(defmethod 9p-attach (stream (root string) - &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 stream message) - root-fid)))) - -(defun 9p-create (stream 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 stream message)))) - -(defun 9p-open (stream 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 stream message)))) - -(defgeneric 9p-write (stream fid offset data &key callback)) - -(defmethod 9p-write (stream 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 stream 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 (stream fid offset (data string) - &key - (callback #'dummy-callback)) - (9p-write stream fid offset (babel:string-to-octets data) :callback callback)) - -(defun 9p-walk (stream root-fid new-fid new-name &key (callback #'dummy-callback)) - (if (and (numberp new-name) - (= 0 new-name)) - (%9p-walk-self stream 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 stream message))))) - -(defun %9p-walk-self (stream 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 stream message)))) - -(defun 9p-remove (stream 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 stream message)))) - -(defun 9p-clunk (stream 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 stream message)))) - -(defun 9p-stat (stream 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 stream message)))) - -(defun 9p-read (stream 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 stream 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+)) - -(defstruct stat - (entry-size) - (ktype) - (kdev) - (entry-type) - (version) - (path) - (mode) - (atime) - (mtime) - (size) - (name) - (user-id) - (group-id) - (last-modified-from-id)) - -(defun decode-rstat (data) - (flet ((->int (start end) - (bytes->int (subseq data start end)))) - (let* ((entry-size (->int 0 2)) - (ktype (->int 2 4)) - (kdev (->int 4 8)) - (entry-type (->int 8 9)) - (version (->int 9 13)) - (path (->int 13 21)) - (mode (->int 21 25)) - (atime (->int 25 29)) - (mtime (->int 29 33)) - (size (->int 33 41)) - (strings-start 41) - (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)))) - (make-stat :entry-size entry-size - :ktype ktype - :kdev kdev - :entry-type (file-type-number->symbol entry-type) - :version version - :path path - :mode mode - :atime atime - :mtime mtime - :size size - :name name - :user-id user-id - :group-id group-id - :last-modified-from-id last-modified-from-id)))) - -;;; high level routines - -(defun read-all-pending-messages-ignoring-errors (stream) - (handler-bind ((9p-error - (lambda (e) - (invoke-restart 'ignore-error e)))) - (read-all-pending-message stream))) - -(defun clone-fid (stream fid) - (with-new-fid (saved-fid) - (9p-walk stream fid saved-fid +nwname-clone+) - (read-all-pending-message stream) - saved-fid)) - -(defun create-directory (stream parent-fid directory-name &key (permissions #o760)) - (with-new-fid (saved-parent-dir) - (9p-walk stream parent-fid saved-parent-dir +nwname-clone+) - (read-all-pending-message stream) - (9p-create stream - parent-fid - directory-name - :permissions (logior +create-dir+ permissions) - :mode +create-for-read+) - (read-all-pending-message stream) - (with-new-fid (new-dir-fid) - (9p-walk stream saved-parent-dir new-dir-fid directory-name) - (read-all-pending-message stream) - new-dir-fid))) - -(defun create-path (stream parent-fid path &key (file-permissions #o640)) - (let ((fs:*directory-sep-regexp* "\\/") - (path-elements (remove "/" - (fs:split-path-elements path) - :test #'string=)) - (last-is-dir-p (cl-ppcre:scan "\\/$" path)) - (last-dir-fid nil)) - (labels ((%create-dirs (parent-dir-fid path-elements) - (when path-elements - (let ((new-dir-fid (create-directory stream - parent-dir-fid - (first path-elements)))) - (read-all-pending-message stream) - (setf last-dir-fid new-dir-fid) - (%create-dirs new-dir-fid (rest path-elements)))))) - (%create-dirs parent-fid (misc:safe-all-but-last-elt path-elements)) - (if last-is-dir-p - (create-directory stream last-dir-fid (last-elt path-elements)) - (progn - (9p-create stream - last-dir-fid - (last-elt path-elements) - :permissions file-permissions) - (read-all-pending-messages-ignoring-errors stream) - last-dir-fid))))) - -(defun mount (stream root-path) - (let ((protocol-version (initialize-session stream)) - (root-fid (9p-attach stream root-path))) - (read-all-pending-message stream) - (values root-fid protocol-version))) - -(defun open-path (stream root-fid path - &key - (walk-callback #'dummy-callback) - (open-callback #'dummy-callback) - (mode +create-for-read+)) - (let ((fs:*directory-sep-regexp* "\\/") - (path-elements (remove "/" - (fs:split-path-elements path) - :test #'string=))) - (labels ((walk-dirs (path-elements parent-fid) - (with-new-fid (fid) - (if path-elements - (progn - (9p-walk stream - parent-fid - fid - (first path-elements) - :callback walk-callback) - (9p-clunk stream parent-fid) - (read-all-pending-message stream) - (walk-dirs (rest path-elements) fid)) - parent-fid)))) - (let ((fid (walk-dirs path-elements root-fid))) - (read-all-pending-message stream) - (9p-open stream fid :callback open-callback :mode mode) - (read-all-pending-message stream) - fid)))) - -(defun cat-reply-vector (a b) - (concatenate '(vector (unsigned-byte 8)) a b)) - -(defun slurp-file (stream root-fid path &key (buffer-size *buffer-size*)) - (let ((res (make-array 0 :element-type +byte-type+ :adjustable nil)) - (fid (open-path stream root-fid path))) - (labels ((slurp (offset) - (9p-read stream - 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 stream) - res))) - -(defun remove-path (stream root-fid path) - (let* ((saved-root-fid (clone-fid stream root-fid)) - (path-fid (open-path stream saved-root-fid path))) - (9p-remove stream path-fid) - (read-all-pending-message stream))) - - -(defun open-directory (stream root-fid path) - (let* ((root-fid-cloned (clone-fid stream root-fid)) - (path-fid (open-path stream root-fid-cloned path))) - path-fid)) - -(defun read-directory (stream dir-fid &optional (offset 0)) - (let* ((stat-size nil) - (stat-size-bytes nil) - (rstat nil)) - (9p-read stream - dir-fid - offset 2 - :callback (lambda (x data) - (declare (ignore x)) - (setf stat-size-bytes (subseq data 4)) - (setf stat-size (9p-client::bytes->int stat-size-bytes)))) - (read-all-pending-message stream) - (when (> stat-size 0) - (9p-read stream - dir-fid - (+ offset 2) stat-size - :callback (lambda (x data) - (declare (ignore x)) - (setf rstat (decode-rstat (concatenate '(vector (unsigned-byte 8)) - stat-size-bytes - (subseq data 4)))))) - (read-all-pending-message stream) - (values dir-fid rstat (+ offset 2 stat-size))))) - -(defun sort-dir-stats (data &optional (fn (lambda (a b) (string< (stat-name a) (stat-name b))))) - (sort data fn)) - -(defun collect-directory-children (stream root-fid path) - (let* ((dir-fid (open-directory stream root-fid path)) - (dir-stats '())) - (loop named collecting-loop - with stat-size = 0 - do - (multiple-value-bind (next-dir-fid stat next-stat-size) - (read-directory stream dir-fid stat-size) - (if next-dir-fid - (progn - (push stat dir-stats) - (setf stat-size next-stat-size)) - (return-from collecting-loop t)))) - (sort-dir-stats dir-stats))) blob - /dev/null blob + 4cf8f46d1a1d91cb741a9c27cd73279eea436091 (mode 644) --- /dev/null +++ regress/lisp/9p-test/all-tests.lisp @@ -0,0 +1,73 @@ +;; test stuite for kami +;; Copyright (C) 2021 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 . + +(in-package :all-tests) + +(defparameter *client-certificate* "") + +(defparameter *certificate-key* "") + +(defparameter *host* "localhost") + +(defparameter *port* 10564) + +(defun open-tls-socket (host port) + (flet ((open-socket (hostname) + (usocket:socket-connect hostname + port + :element-type '(unsigned-byte 8)))) + (or (ignore-errors (open-socket host)) + (open-socket host)))) + +(defmacro with-open-ssl-stream ((ssl-stream socket host port + client-certificate + certificate-key) + &body body) + (alexandria:with-gensyms (tls-context socket-stream ssl-hostname) + `(let ((,tls-context (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+))) + (cl+ssl:with-global-context (,tls-context :auto-free-p t) + (let* ((,socket (open-tls-socket ,host ,port)) + (,socket-stream (usocket:socket-stream ,socket)) + (,ssl-hostname ,host) + (,ssl-stream + (cl+ssl:make-ssl-client-stream ,socket-stream + :certificate ,client-certificate + :key ,certificate-key + :external-format nil ; unsigned byte 8 + :unwrap-stream-p t + :verify nil + :hostname ,ssl-hostname))) + ,@body))))) + +(defsuite all-suite ()) + +(defun exit-program (&optional (exit-code 0)) + (uiop:quit exit-code)) + +(defun run-all-tests (&key (use-debugger t)) + (setf *client-certificate* (uiop:getenv "REGRESS_CERT") + *certificate-key* (uiop:getenv "REGRESS_KEY") + *host* (uiop:getenv "REGRESS_HOSTNAME") + *port* (parse-integer (uiop:getenv "REGRESS_PORT"))) + (handler-bind ((error (lambda (e) + (declare (ignore e)) + (exit-program 1))) + (clunit::assertion-failed (lambda (e) + (declare (ignore e)) + (exit-program 2)))) + (progn + (clunit:run-suite 'all-suite :use-debugger use-debugger :report-progress t) + (exit-program 0)))) blob - 5c7a3780fb7a4bc3c8bc89d9ef974ae6600b9ddb (mode 644) blob + /dev/null --- regress/lisp/9p-test/conditions.lisp +++ /dev/null @@ -1,48 +0,0 @@ -;; test stuite for kami -;; Copyright (C) 2021 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 . - -(in-package :9p-client) - -(define-condition 9p-error (error) - ((error-value - :initarg :error-value - :reader error-value) - (message-type - :initarg :message-type - :reader message-type) - (tag - :initarg :tag - :reader tag)) - (:report (lambda (condition stream) - (format stream - "message-type ~a tag ~a: ~a" - (message-type condition) - (tag condition) - (error-value condition)))) - (:documentation "Error for 9p protocol")) - - -(define-condition 9p-initialization-error (error) - ((tag - :initarg :tag - :reader tag) - (rtag - :initarg :rtag - :reader rtag)) - (:report (lambda (condition stream) - (format stream "error initialization tag sent ~a, got ~a instead" - (tag condition) (rtag condition)))) - (:documentation "Error for 9p protocol")) blob - /dev/null blob + 537f11697492638f62aba0af7f8eaa2653307dae (mode 644) --- /dev/null +++ regress/lisp/9p-test/kami-tests.lisp @@ -0,0 +1,385 @@ +;; test suite for kami +;; Copyright (C) 2021 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 [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]]. + +(in-package :kami-tests) + +(defparameter *remote-test-file* "test-file") ; note: missing "/" is intentional + +(defparameter *remote-test-path* "/test-file") + +(defparameter *remote-test-path-write* "/dir/subdir/test-file-write") + +(defparameter *remote-test-path-contents* (format nil "qwertyuiopasdfghjklòàù è~%")) + +(alexandria:define-constant +remote-test-path-ovewrwrite-data+ "12" :test #'string=) + +(defsuite kami-suite (all-suite)) + +(defun start-non-tls-socket (host port) + (usocket:socket-connect host + port + :protocol :stream + :element-type +byte-type+)) + +(defun example-mount (&optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let ((*messages-sent* '()) + (root-fid (mount stream root))) + (9p-clunk stream root-fid) + (read-all-pending-message stream) + (9p-attach stream root) + (read-all-pending-message stream) + t))) + +(deftest test-mount (kami-suite) + (assert-true (ignore-errors (example-mount)))) + +(defun example-walk (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + + (let ((*messages-sent* '()) + (root-fid (mount stream root))) + (with-new-fid (path-fid) + (9p-walk stream root-fid path-fid path) + (read-all-pending-message stream) + t)))) + +(deftest test-walk (kami-suite) + (assert-true (ignore-errors (example-walk *remote-test-file*)))) + +(defun example-open-path (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let ((*messages-sent* '()) + (root-fid (mount stream root))) + (with-new-fid (saved-root-fid) + (9p-walk stream root-fid saved-root-fid +nwname-clone+) + (open-path stream root-fid path) + (read-all-pending-message stream) + t)))) + +(deftest test-open-path (kami-suite) + (assert-true (ignore-errors (example-open-path *remote-test-path*)))) + +(defun example-read (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let ((*messages-sent* ()) + (*buffer-size* 256) + (root-fid (mount stream root))) + (with-new-fid (path-fid) + (9p-walk stream root-fid path-fid path) + (9p-open stream path-fid) + (9p-read stream path-fid 0 10) + (read-all-pending-message stream) + t)))) + +(deftest test-read ((kami-suite) (test-walk)) + (assert-true (ignore-errors (example-open-path *remote-test-file*)))) + +(defun example-slurp (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let ((*messages-sent* ()) + (*buffer-size* 256) + (root-fid (mount stream root))) + (babel:octets-to-string (slurp-file stream + root-fid path + :buffer-size 3) + :errorp nil)))) + +(deftest test-slurp-file ((kami-suite) (test-read)) + (assert-equality #'string= + *remote-test-path-contents* + (example-slurp *remote-test-path*))) + +(defun example-write (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (*buffer-size* 256) + (root-fid (mount stream root)) + (fid (open-path stream root-fid path :mode +create-for-read-write+))) + (9p-write stream fid 0 *remote-test-path-contents*) + (read-all-pending-message stream) + t))) + +(deftest test-write ((kami-suite) (test-open-path test-read)) + (assert-true (ignore-errors (example-write *remote-test-path-write*)))) + +(defun example-write-2-3 (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (*buffer-size* 256) + (root-fid (mount stream root))) + (with-new-fid (saved-root-fid) + (9p-walk stream root-fid saved-root-fid +nwname-clone+) + (let ((fid (open-path stream root-fid path :mode +create-for-read-write+))) + (9p-write stream fid 2 +remote-test-path-ovewrwrite-data+) + (read-all-pending-message stream) + (babel:octets-to-string (slurp-file stream saved-root-fid path))))))) + +(defun read-entire-file-as-string (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (*buffer-size* 256) + (root-fid (mount stream root))) + (babel:octets-to-string (slurp-file stream root-fid path))))) + +(deftest test-example-write-2-3 ((kami-suite) (test-write)) + (example-write-2-3 *remote-test-path-write*) + (let* ((expected-sequence (copy-seq *remote-test-path-contents*)) + (file-sequence (read-entire-file-as-string *remote-test-path-write*))) + (setf (subseq expected-sequence 2 4) +remote-test-path-ovewrwrite-data+) + (assert-equality #'string= file-sequence expected-sequence))) + +(defun example-write-fails (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (*buffer-size* 256) + (root-fid (mount stream root)) + (fid (open-path stream root-fid path :mode +create-for-read-write+))) + (9p-write stream fid 0 *remote-test-path-contents*) + (read-all-pending-message stream)))) + +(deftest test-write-on-directory-fails ((kami-suite) (test-write)) + (assert-condition 9p-error (example-write-fails "/"))) + +(defun example-stat (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (*buffer-size* 256) + (root-fid (mount stream root)) + (fid (open-path stream root-fid path :mode +create-for-read+)) + (results nil)) + (9p-stat stream fid + :callback (lambda (x data) + (declare (ignore x)) + (setf results (decode-rstat data)))) + (read-all-pending-message stream) + results))) + +(deftest test-stat (kami-suite) + (assert-true (ignore-errors (example-stat "/"))) + (assert-true (ignore-errors (example-stat *remote-test-path*))) + (assert-eq :directory + (stat-entry-type (example-stat "/"))) + (assert-eq :file + (stat-entry-type (example-stat *remote-test-path*)))) + +(defun example-create-file (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (root-fid (mount stream root))) + (with-new-fid (saved-root-fid) + (9p-walk stream root-fid saved-root-fid +nwname-clone+) + (9p-create stream root-fid path) + (read-all-pending-message stream) + (9p-clunk stream root-fid) + (open-path stream saved-root-fid path) + (read-all-pending-message stream) + t)))) + +(alexandria:define-constant +create-file+ "test-file-create" :test #'string=) + +(defun example-create-directory (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (root-fid (mount stream root))) + (create-directory stream root-fid path) + t))) + +(alexandria:define-constant +create-directory+ "test-dir-create" :test #'string=) + +(defun example-create-path (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (root-fid (mount stream root)) + (saved-root-fid (clone-fid stream root-fid)) + (new-path-fid (create-path stream root-fid path))) + (9p-write stream new-path-fid 0 *remote-test-path-contents*) + (read-all-pending-message stream) + (9p-clunk stream new-path-fid) + (read-all-pending-message stream) + (babel:octets-to-string (slurp-file stream saved-root-fid path))))) + +(alexandria:define-constant +create-path+ "/a/totaly/new/path/new-file" :test #'string=) + +(deftest test-create ((kami-suite) (test-open-path)) + (assert-true (ignore-errors (example-create-file +create-file+))) + (assert-true (ignore-errors (example-create-directory +create-directory+))) + (assert-equality #'string= + *remote-test-path-contents* + (ignore-errors (example-create-path +create-path+)))) + +(defun close-parent-fid (&optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (root-fid (mount stream root))) + (with-new-fid (dir-fid) + (9p-walk stream root-fid dir-fid "dir") + (read-all-pending-message stream) + (9p-clunk stream root-fid) + (read-all-pending-message stream) + (with-new-fid (subdir-fid) + (9p-walk stream dir-fid subdir-fid "subdir") + (read-all-pending-message stream) + (9p-clunk stream dir-fid) + (read-all-pending-message stream) + (with-new-fid (file-fid) + (9p-walk stream subdir-fid file-fid "test-file-write") + (read-all-pending-message stream) + (9p-clunk stream subdir-fid) + (read-all-pending-message stream) + (9p-open stream file-fid) + (read-all-pending-message stream) + t)))))) + +(deftest test-close-parent-fid ((kami-suite) (test-walk)) + (assert-true (ignore-errors (close-parent-fid)))) + +(defun %remove-path (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + + (let* ((*messages-sent* ()) + (root-fid (mount stream root))) + (remove-path stream root-fid path) + t))) + +(deftest test-remove-file ((kami-suite) (test-create)) + (assert-true (ignore-errors (%remove-path +create-path+)))) + +(defun parent-dir-path (path) + (let ((position-backslash (position #\/ path :from-end t :test #'char=))) + (subseq path 0 position-backslash))) + +(deftest test-remove-directory ((kami-suite) (test-remove-file)) + (assert-true + (ignore-errors (%remove-path (parent-dir-path +create-path+))))) + +(defun read-dir-same-offset (dir-path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (root-fid (mount stream root)) + (root-fid-cloned (clone-fid stream root-fid)) + (dir-fid (open-path stream root-fid-cloned dir-path)) + (res-read-1 nil) + (res-read-2 nil)) + (9p-read stream + dir-fid + 0 10 + :callback (lambda (x data) + (declare (ignore x)) + (setf res-read-1 data))) + (9p-read stream + dir-fid + 0 10 + :callback (lambda (x data) + (declare (ignore x)) + (setf res-read-2 data))) + (read-all-pending-message stream) + (not (mismatch res-read-1 res-read-2))))) + +(defun example-directory-children (path &optional (root "/")) + (with-open-ssl-stream (stream + socket + *host* + *port* + *client-certificate* + *certificate-key*) + (let* ((*messages-sent* ()) + (root-fid (mount stream root))) + (collect-directory-children stream root-fid path)))) + +(deftest collect-dir-root-children ((kami-suite) (test-read)) + (assert-true (example-directory-children "/"))) blob - 43ee5f51e424eefe264bdd3177bf63cc007abd30 (mode 644) blob + /dev/null --- regress/lisp/9p-test/filesystem-utils.lisp +++ /dev/null @@ -1,141 +0,0 @@ -;; test stuite for kami -;; Copyright (C) 2021 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 . - -(in-package :filesystem-utils) - -(define-constant +preprocess-include+ "^%include" :test #'string=) - -(define-constant +file-path-regex+ "[\\p{L},\\/,\\\\,\\.]+" :test 'string=) - -(defparameter *directory-sep-regexp* - #+windows "\\" - #-windows "\\/") - -(defparameter *directory-sep* - #+windows "\\" - #-windows "/") - -(defun cat-parent-dir (parent direntry) - (format nil "~a~a~a" parent *directory-sep* direntry)) - -(defmacro do-directory ((var) root &body body) - (with-gensyms (dir) - `(let ((,dir (nix:opendir ,root))) - (unwind-protect - (handler-case - (do ((,var (cat-parent-dir ,root (nix:readdir ,dir)) - (cat-parent-dir ,root (nix:readdir ,dir)))) - ((cl-ppcre:scan "NIL$" ,var)) - ,@body) - (nix::enotdir () 0) - (nix:eacces () 0) - (nix:eloop () 0)) - (nix:closedir ,dir))))) - -(defun collect-children (parent-dir) - (let ((all-paths ())) - (do-directory (path) parent-dir - (push path all-paths)) - (setf all-paths (sort all-paths #'string<)) - all-paths)) - -(defun getenv (name) - (nix:getenv name)) - -(defun pwd () - (getenv "PWD")) - -(defgeneric prepend-pwd (object)) - -(defmethod prepend-pwd ((object string)) - (if (cl-ppcre:scan "^\\." object) - (text-utils:strcat (pwd) (subseq object 1)) - object)) - -(defmethod prepend-pwd ((object sequence)) - (map 'list #'prepend-pwd object)) - -(defun regular-file-p (path) - (nix:s-isreg (nix:stat-mode (nix:stat path)))) - -(defun dirp (path) - (ignore-errors - (and (nix:stat path) - (nix:s-isdir (nix:stat-mode (nix:stat path)))))) - -(defun split-path-elements (path) - (let ((splitted (cl-ppcre:split *directory-sep-regexp* path))) - (substitute *directory-sep* "" splitted :test #'string=))) - -(defun path-last-element (path) - (let ((elements (cl-ppcre:split *directory-sep-regexp* path))) - (and elements - (last-elt elements)))) - -(defun path-first-element (path) - (let ((elements (cl-ppcre:split *directory-sep-regexp* path))) - (and elements - (first-elt elements)))) - -(defun path-to-hidden-file-p (path) - "unix-like only" - (let ((last-element (path-last-element path))) - (and path (cl-ppcre:scan "^\\." last-element)))) - -(defun strip-dirs-from-path (p) - (multiple-value-bind (all registers) - (cl-ppcre:scan-to-strings (concatenate 'string - *directory-sep* - "([^" - *directory-sep* - "]+)$") - p) - (declare (ignore all)) - (and (> (length registers) 0) - (elt registers 0)))) - -(defun parent-dir-path (path) - (let ((splitted (remove-if #'(lambda (a) (string= "" a)) - (split-path-elements path)))) - (cond - ((> (length splitted) 1) - (let ((res (if (string= (string (elt path 0)) *directory-sep*) - (concatenate 'string *directory-sep* (first splitted)) - (first splitted)))) - (loop for i in (subseq splitted 1 (1- (length splitted))) do - (setf res (concatenate 'string res *directory-sep* i))) - (setf res (concatenate 'string res *directory-sep*)) - res)) - ((or (= (length splitted) 1) - (null splitted)) - *directory-sep*) - (t - path)))) - -(defun file-exists-p (f) - (uiop:file-exists-p f)) - -(defun directory-exists-p (d) - (uiop:directory-exists-p d)) - -(defun delete-file-if-exists (f) - (uiop:delete-file-if-exists f)) - -(defun home-dir (&key (add-separator-ends nil)) - (let ((home (getenv "HOME"))) - (if add-separator-ends - (text-utils:strcat home *directory-sep*) - home))) blob - cf9a8fc944733fc117390e9c25446dde72f9bf76 (mode 644) blob + /dev/null --- regress/lisp/9p-test/message-types.lisp +++ /dev/null @@ -1,69 +0,0 @@ -;; test stuite for kami -;; Copyright (C) 2021 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 . - -(in-package :9p-client) - -(defparameter *tversion* 100) - -(defparameter *rversion* 101) - -(defparameter *tauth* 102) - -(defparameter *rauth* 103) - -(defparameter *tattach* 104) - -(defparameter *rattach* 105) - -(defparameter *terror* 106) ; there is no terror - -(defparameter *rerror* 107) - -(defparameter *tflush* 108) - -(defparameter *rflush* 108) - -(defparameter *twalk* 110) - -(defparameter *rwalk* 109) - -(defparameter *topen* 112) - -(defparameter *ropen* 113) - -(defparameter *tcreate* 114) - -(defparameter *rcreate* 115) - -(defparameter *tread* 116) - -(defparameter *rread* 117) - -(defparameter *twrite* 118) - -(defparameter *rwrite* 119) - -(defparameter *tclunk* 120) - -(defparameter *rclunk* 121) - -(defparameter *tremove* 122) - -(defparameter *rremove* 123) - -(defparameter *tstat* 124) - -(defparameter *rstat* 125) blob - e899746e6d882f0329bb4421a66b42f7baebac50 (mode 644) blob + /dev/null --- regress/lisp/9p-test/misc-utils.lisp +++ /dev/null @@ -1,96 +0,0 @@ -;; test stuite for kami -;; Copyright (C) 2021 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 . - -;; uses code from - -;; niccolo': a chemicals inventory -;; Copyright (C) 2016 Universita' degli Studi di Palermo - -;; 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, 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 . - -(in-package :misc-utils) - -(defmacro defcond (type) - `(define-condition ,(alexandria:format-symbol t "TEXT-~a" (string-upcase type)) - (,type) - ((text - :initarg :text - :reader text)) - (:documentation "Error that set text"))) - -(defcond error) - -(define-condition out-of-bounds (error) - ((seq - :initarg :seq - :reader seq) - (idx - :initarg :idx - :reader idx)) - (:documentation "Error when you go out of bound")) - -(defgeneric delete@ (sequence position)) - -(defgeneric safe-delete@ (sequence position) - (:documentation "Return sequence if position is out of bound")) - -(defmacro gen-delete@ ((sequence position) &body body) - `(if (and (>= ,position 0) - (< ,position (length ,sequence))) - ,@body - (error 'out-of-bounds :seq sequence :idx position))) - -(defmethod delete@ ((sequence list) position) - (gen-delete@ - (sequence position) - (append (subseq sequence 0 position) - (and (/= position (- (length sequence) 1)) - (subseq sequence (1+ position)))))) - -(defmethod delete@ ((sequence vector) position) - (gen-delete@ - (sequence position) - (make-array (1- (length sequence)) - :fill-pointer (1- (length sequence)) - :adjustable t - :initial-contents (concatenate 'vector (subseq sequence 0 position) - (and (/= position (- (length sequence) 1)) - (subseq sequence (1+ position))))))) - -(defmethod safe-delete@ ((sequence sequence) position) - (restart-case - (delete@ sequence position) - (return-nil () nil) - (return-whole () sequence) - (new-index (i) (safe-delete@ sequence i)))) - -(defun safe-all-but-last-elt (sequence) - (handler-bind ((out-of-bounds - #'(lambda (c) - (declare (ignore c)) - (invoke-restart 'return-nil)))) - (safe-delete@ sequence (1- (length sequence))))) blob - e093d2591e9e2646b980e5c57f1738978d10ace4 blob + 1cdc73fe4a93394f54343870245345911d1ea5cb --- regress/lisp/9p-test/package.lisp +++ regress/lisp/9p-test/package.lisp @@ -14,98 +14,22 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . -(defpackage :text-utils - (:use - :cl) +(defpackage :all-tests + (:use :cl + :clunit + :cl+ssl) (:export - :strcat)) + :*client-certificate* + :*certificate-key* + :*host* + :*port* + :with-open-ssl-stream + :all-suite + :run-all-tests)) -(defpackage :misc-utils - (:use :cl) - (:nicknames :misc) - (:export - :safe-all-but-last-elt)) - -(defpackage :filesystem-utils - (:use - :cl - :alexandria) - (:nicknames :fs) - (:export - :*directory-sep-regexp* - :getenv - :cat-parent-dir - :parent-dir-path - :split-path-elements - :collect-children - :prepend-pwd)) - -(defpackage :9p-client - (:use - :cl - :alexandria) - (:export - :+byte-type+ - :+version+ - :+nofid+ - :+create-for-read+ - :+create-for-write+ - :+create-for-read-write+ - :+create-for-exec+ - :+create-dir+ - :+open-truncate+ - :+open-remove-on-clunk+ - :+standard-socket-port+ - :+nwname-clone+ - :*buffer-size* - :*messages-sent* - :9p-error - :read-all-pending-message - :close-client - :encode-string - :decode-string - :encode - :decode - :read-message - :initialize-session - :with-new-tag - :with-new-fid - :dummy-callback - :dump-callback - :9p-attach - :9p-create - :9p-open - :9p-write - :9p-remove - :9p-clunk - :9p-stat - :9p-read - :9p-walk - :decode-read-reply - :stat-entry-size - :stat-ktype - :stat-kdev - :stat-entry-type - :stat-version - :stat-path - :stat-mode - :stat-atime - :stat-mtime - :stat-size - :stat-name - :stat-user-id - :stat-group-id - :stat-last-modified-from-id - :decode-rstat - :read-all-pending-messages-ignoring-errors - :clone-fid - :create-directory - :create-path - :mount - :open-path - :slurp-file - :remove-path - :open-directory - :read-directory - :sort-dir-stats - :collect-directory-children)) +(defpackage :kami-tests + (:use :cl + :clunit + :9p-client + :all-tests) + (:export)) blob - 6e374bc1ea91e8371c23a32a65e720a9c04ad795 (mode 644) blob + /dev/null --- regress/lisp/9p-test/tests/all-tests.lisp +++ /dev/null @@ -1,73 +0,0 @@ -;; test stuite for kami -;; Copyright (C) 2021 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 . - -(in-package :all-tests) - -(defparameter *client-certificate* "") - -(defparameter *certificate-key* "") - -(defparameter *host* "localhost") - -(defparameter *port* 10564) - -(defun open-tls-socket (host port) - (flet ((open-socket (hostname) - (usocket:socket-connect hostname - port - :element-type '(unsigned-byte 8)))) - (or (ignore-errors (open-socket host)) - (open-socket host)))) - -(defmacro with-open-ssl-stream ((ssl-stream socket host port - client-certificate - certificate-key) - &body body) - (alexandria:with-gensyms (tls-context socket-stream ssl-hostname) - `(let ((,tls-context (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+))) - (cl+ssl:with-global-context (,tls-context :auto-free-p t) - (let* ((,socket (open-tls-socket ,host ,port)) - (,socket-stream (usocket:socket-stream ,socket)) - (,ssl-hostname ,host) - (,ssl-stream - (cl+ssl:make-ssl-client-stream ,socket-stream - :certificate ,client-certificate - :key ,certificate-key - :external-format nil ; unsigned byte 8 - :unwrap-stream-p t - :verify nil - :hostname ,ssl-hostname))) - ,@body))))) - -(defsuite all-suite ()) - -(defun exit-program (&optional (exit-code 0)) - (uiop:quit exit-code)) - -(defun run-all-tests (&key (use-debugger t)) - (setf *client-certificate* (fs:getenv "REGRESS_CERT") - *certificate-key* (fs:getenv "REGRESS_KEY") - *host* (fs:getenv "REGRESS_HOSTNAME") - *port* (parse-integer (fs:getenv "REGRESS_PORT"))) - (handler-bind ((error (lambda (e) - (declare (ignore e)) - (exit-program 1))) - (clunit::assertion-failed (lambda (e) - (declare (ignore e)) - (exit-program 2)))) - (progn - (clunit:run-suite 'all-suite :use-debugger use-debugger :report-progress t) - (exit-program 0)))) blob - 1aa043ca7cf17ea54c056ec6e78bae762a5754d5 (mode 644) blob + /dev/null --- regress/lisp/9p-test/tests/kami-tests.lisp +++ /dev/null @@ -1,381 +0,0 @@ -;; test suite for kami -;; Copyright (C) 2021 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 [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]]. - -(in-package :kami-tests) - -(defparameter *remote-test-file* "test-file") ; note: missing "/" is intentional - -(defparameter *remote-test-path* "/test-file") - -(defparameter *remote-test-path-write* "/dir/subdir/test-file-write") - -(defparameter *remote-test-path-contents* (format nil "qwertyuiopasdfghjklòàù è~%")) - -(alexandria:define-constant +remote-test-path-ovewrwrite-data+ "12" :test #'string=) - -(defsuite kami-suite (all-suite)) - -(defun start-non-tls-socket (host port) - (usocket:socket-connect host - port - :protocol :stream - :element-type +byte-type+)) - -(defun example-mount (&optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let ((*messages-sent* '()) - (root-fid (mount stream root))) - (9p-clunk stream root-fid) - (read-all-pending-message stream) - (9p-attach stream root) - (read-all-pending-message stream) - t))) - -(deftest test-mount (kami-suite) - (assert-true (ignore-errors (example-mount)))) - -(defun example-walk (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - - (let ((*messages-sent* '()) - (root-fid (mount stream root))) - (with-new-fid (path-fid) - (9p-walk stream root-fid path-fid path) - (read-all-pending-message stream) - t)))) - -(deftest test-walk (kami-suite) - (assert-true (ignore-errors (example-walk *remote-test-file*)))) - -(defun example-open-path (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let ((*messages-sent* '()) - (root-fid (mount stream root))) - (with-new-fid (saved-root-fid) - (9p-walk stream root-fid saved-root-fid +nwname-clone+) - (open-path stream root-fid path) - (read-all-pending-message stream) - t)))) - -(deftest test-open-path (kami-suite) - (assert-true (ignore-errors (example-open-path *remote-test-path*)))) - -(defun example-read (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let ((*messages-sent* ()) - (*buffer-size* 256) - (root-fid (mount stream root))) - (with-new-fid (path-fid) - (9p-walk stream root-fid path-fid path) - (9p-open stream path-fid) - (9p-read stream path-fid 0 10) - (read-all-pending-message stream) - t)))) - -(deftest test-read ((kami-suite) (test-walk)) - (assert-true (ignore-errors (example-open-path *remote-test-file*)))) - -(defun example-slurp (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let ((*messages-sent* ()) - (*buffer-size* 256) - (root-fid (mount stream root))) - (babel:octets-to-string (slurp-file stream - root-fid path - :buffer-size 3) - :errorp nil)))) - -(deftest test-slurp-file ((kami-suite) (test-read)) - (assert-equality #'string= - *remote-test-path-contents* - (example-slurp *remote-test-path*))) - -(defun example-write (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (*buffer-size* 256) - (root-fid (mount stream root)) - (fid (open-path stream root-fid path :mode +create-for-read-write+))) - (9p-write stream fid 0 *remote-test-path-contents*) - (read-all-pending-message stream) - t))) - -(deftest test-write ((kami-suite) (test-open-path test-read)) - (assert-true (ignore-errors (example-write *remote-test-path-write*)))) - -(defun example-write-2-3 (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (*buffer-size* 256) - (root-fid (mount stream root))) - (with-new-fid (saved-root-fid) - (9p-walk stream root-fid saved-root-fid +nwname-clone+) - (let ((fid (open-path stream root-fid path :mode +create-for-read-write+))) - (9p-write stream fid 2 +remote-test-path-ovewrwrite-data+) - (read-all-pending-message stream) - (babel:octets-to-string (slurp-file stream saved-root-fid path))))))) - -(defun read-entire-file-as-string (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (*buffer-size* 256) - (root-fid (mount stream root))) - (babel:octets-to-string (slurp-file stream root-fid path))))) - -(deftest test-example-write-2-3 ((kami-suite) (test-write)) - (example-write-2-3 *remote-test-path-write*) - (let* ((expected-sequence (copy-seq *remote-test-path-contents*)) - (file-sequence (read-entire-file-as-string *remote-test-path-write*))) - (setf (subseq expected-sequence 2 4) +remote-test-path-ovewrwrite-data+) - (assert-equality #'string= file-sequence expected-sequence))) - -(defun example-write-fails (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (*buffer-size* 256) - (root-fid (mount stream root)) - (fid (open-path stream root-fid path :mode +create-for-read-write+))) - (9p-write stream fid 0 *remote-test-path-contents*) - (read-all-pending-message stream)))) - -(deftest test-write-on-directory-fails ((kami-suite) (test-write)) - (assert-condition 9p-error (example-write-fails "/"))) - -(defun example-stat (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (*buffer-size* 256) - (root-fid (mount stream root)) - (fid (open-path stream root-fid path :mode +create-for-read+)) - (results nil)) - (9p-stat stream fid - :callback (lambda (x data) - (declare (ignore x)) - (setf results (decode-rstat data)))) - (read-all-pending-message stream) - results))) - -(deftest test-stat (kami-suite) - (assert-true (ignore-errors (example-stat "/"))) - (assert-true (ignore-errors (example-stat *remote-test-path*))) - (assert-eq :directory - (stat-entry-type (example-stat "/"))) - (assert-eq :file - (stat-entry-type (example-stat *remote-test-path*)))) - -(defun example-create-file (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (root-fid (mount stream root))) - (with-new-fid (saved-root-fid) - (9p-walk stream root-fid saved-root-fid +nwname-clone+) - (9p-create stream root-fid path) - (read-all-pending-message stream) - (9p-clunk stream root-fid) - (open-path stream saved-root-fid path) - (read-all-pending-message stream) - t)))) - -(alexandria:define-constant +create-file+ "test-file-create" :test #'string=) - -(defun example-create-directory (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (root-fid (mount stream root))) - (create-directory stream root-fid path) - t))) - -(alexandria:define-constant +create-directory+ "test-dir-create" :test #'string=) - -(defun example-create-path (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (root-fid (mount stream root)) - (saved-root-fid (clone-fid stream root-fid)) - (new-path-fid (create-path stream root-fid path))) - (9p-write stream new-path-fid 0 *remote-test-path-contents*) - (read-all-pending-message stream) - (9p-clunk stream new-path-fid) - (read-all-pending-message stream) - (babel:octets-to-string (slurp-file stream saved-root-fid path))))) - -(alexandria:define-constant +create-path+ "/a/totaly/new/path/new-file" :test #'string=) - -(deftest test-create ((kami-suite) (test-open-path)) - (assert-true (ignore-errors (example-create-file +create-file+))) - (assert-true (ignore-errors (example-create-directory +create-directory+))) - (assert-equality #'string= - *remote-test-path-contents* - (ignore-errors (example-create-path +create-path+)))) - -(defun close-parent-fid (&optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (root-fid (mount stream root))) - (with-new-fid (dir-fid) - (9p-walk stream root-fid dir-fid "dir") - (read-all-pending-message stream) - (9p-clunk stream root-fid) - (read-all-pending-message stream) - (with-new-fid (subdir-fid) - (9p-walk stream dir-fid subdir-fid "subdir") - (read-all-pending-message stream) - (9p-clunk stream dir-fid) - (read-all-pending-message stream) - (with-new-fid (file-fid) - (9p-walk stream subdir-fid file-fid "test-file-write") - (read-all-pending-message stream) - (9p-clunk stream subdir-fid) - (read-all-pending-message stream) - (9p-open stream file-fid) - (read-all-pending-message stream) - t)))))) - -(deftest test-close-parent-fid ((kami-suite) (test-walk)) - (assert-true (ignore-errors (close-parent-fid)))) - -(defun %remove-path (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - - (let* ((*messages-sent* ()) - (root-fid (mount stream root))) - (remove-path stream root-fid path) - t))) - -(deftest test-remove-file ((kami-suite) (test-create)) - (assert-true (ignore-errors (%remove-path +create-path+)))) - -(deftest test-remove-directory ((kami-suite) (test-remove-file)) - (assert-true - (ignore-errors (%remove-path (filesystem-utils:parent-dir-path +create-path+))))) - -(defun read-dir-same-offset (dir-path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (root-fid (mount stream root)) - (root-fid-cloned (clone-fid stream root-fid)) - (dir-fid (open-path stream root-fid-cloned dir-path)) - (res-read-1 nil) - (res-read-2 nil)) - (9p-read stream - dir-fid - 0 10 - :callback (lambda (x data) - (declare (ignore x)) - (setf res-read-1 data))) - (9p-read stream - dir-fid - 0 10 - :callback (lambda (x data) - (declare (ignore x)) - (setf res-read-2 data))) - (read-all-pending-message stream) - (not (mismatch res-read-1 res-read-2))))) - -(defun example-directory-children (path &optional (root "/")) - (with-open-ssl-stream (stream - socket - *host* - *port* - *client-certificate* - *certificate-key*) - (let* ((*messages-sent* ()) - (root-fid (mount stream root))) - (collect-directory-children stream root-fid path)))) - -(deftest collect-dir-root-children ((kami-suite) (test-read)) - (assert-true (example-directory-children "/"))) blob - 4ad03c4694fdcf0be60667c3e8e5751eec2c9c9f (mode 644) blob + /dev/null --- regress/lisp/9p-test/tests/package.lisp +++ /dev/null @@ -1,37 +0,0 @@ -;; test stuite for kami -;; Copyright (C) 2021 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 :all-tests - (:use :cl - :clunit - :cl+ssl) - (:export - :*client-certificate* - :*certificate-key* - :*host* - :*port* - :with-open-ssl-stream - :all-suite - :run-all-tests)) - -(defpackage :kami-tests - (:use :cl - :clunit - :misc - :text-utils - :9p-client - :all-tests) - (:export)) blob - 9c04d17f6d53dcc1025c18dfb010320d402c576b (mode 644) blob + /dev/null --- regress/lisp/9p-test/text-utils.lisp +++ /dev/null @@ -1,43 +0,0 @@ -;; test stuite for kami -;; Copyright (C) 2021 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 . - -;; derived from - -;; niccolo': a chemicals inventory -;; Copyright (C) 2016 Universita' degli Studi di Palermo - -;; 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, 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 . - -(in-package :text-utils) - -(defun strcat (&rest chunks) - (declare (optimize (debug 0) (safety 0) (speed 3))) - (strcat* chunks)) - -(defun strcat* (chunks) - (declare (optimize (debug 0) (safety 0) (speed 3))) - (reduce (lambda (a b) (concatenate 'string a b)) chunks))