commit - 3a2c53f506aa2d07eaf0e8540f87054c622304fb
commit + 8c3973d8b52685b5fb439202ea0e648bc7a739d0
blob - /dev/null
blob + 64b7b5355b4707cca6b656798089c014b59bc3a5 (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/9p-test.asd
+;; test-suite for kamid
+;; 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/]].
+
+(defsystem :9p-test
+ :author "cage"
+ :license "GPLv3"
+ :version "0.0.1"
+ :serial t
+ :depends-on (:alexandria
+ :cl-ppcre
+ :osicat
+ :cl+ssl
+ :clunit2
+ :usocket
+ :babel
+ :uiop)
+ :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")))))
blob - /dev/null
blob + da745b2ac762597812a4b5d4d3ac22311ed8e111 (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/client.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+(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+ #x80000000 :test #'=
+ :documentation "mode bit for directories")
+
+(define-constant +stat-type-append+ #x40000000 :test #'=
+ :documentation "mode bit for append only files")
+
+(define-constant +stat-type-excl+ #x20000000 :test #'=
+ :documentation "mode bit for exclusive use files")
+
+(define-constant +stat-type-mount+ #x10000000 :test #'=
+ :documentation "mode bit for mounted channel")
+
+(define-constant +stat-type-auth+ #x08000000 :test #'=
+ :documentation "mode bit for authentication file")
+
+(define-constant +stat-type-tmp+ #x04000000 :test #'=
+ :documentation "mode bit for non-backed-up files")
+
+(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+))
+
+(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 (stream)
+ (handler-bind ((9p-error
+ (lambda (e)
+ (invoke-restart 'ignore-error e))))
+ (read-all-pending-message stream)))
+
+(defun create-directory (stream parent-fid directory-name &key (permissions #o760))
+ (9p-create stream
+ parent-fid
+ directory-name
+ :permissions (logior +create-dir+ permissions)
+ :mode +create-for-read+)
+ (read-all-pending-messages-ignoring-errors stream))
+
+(defun create-path (stream 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 stream parent-fid (first path-elements))
+ (read-all-pending-messages-ignoring-errors stream)
+ (%create-dirs (rest path-elements)))))
+ (%create-dirs (misc:safe-all-but-last-elt path-elements))
+ (if last-is-dir-p
+ (create-directory stream parent-fid (last-elt path-elements))
+ (9p-create stream parent-fid (last-elt path-elements)
+ :permissions file-permissions))
+ (read-all-pending-messages-ignoring-errors stream))))
+
+(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)
+ (read-all-pending-message stream)
+ (walk-dirs (rest path-elements) fid))
+ parent-fid))))
+ (let ((fid (walk-dirs path-elements root-fid)))
+ (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)))
blob - /dev/null
blob + 5c7a3780fb7a4bc3c8bc89d9ef974ae6600b9ddb (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/conditions.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+(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 + 43ee5f51e424eefe264bdd3177bf63cc007abd30 (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/filesystem-utils.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+(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 - /dev/null
blob + cf9a8fc944733fc117390e9c25446dde72f9bf76 (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/message-types.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+(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 - /dev/null
blob + e899746e6d882f0329bb4421a66b42f7baebac50 (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/misc-utils.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+(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 - /dev/null
blob + ade03a9c22ae86586fea6b6f4f2fa005635e7845 (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/package.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+(defpackage :text-utils
+ (:use
+ :cl)
+ (:export
+ :strcat))
+
+(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
+ :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*
+ :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
+ :decode-rstat
+ :read-all-pending-messages-ignoring-errors
+ :create-directory
+ :create-path
+ :mount
+ :open-path
+ :slurp-file))
blob - /dev/null
blob + 598ecedc0ac2742c734e6bcf87aeb4388ea95b15 (mode 755)
--- /dev/null
+++ regress/lisp/9p-test/run-tests.sh
+#!/bin/sh
+
+#export REGRESS_CERT="$HOME/lisp/kamid.cert"
+#export REGRESS_KEY="$HOME/lisp/kamid.key"
+#export REGRESS_HOSTNAME="localhost"
+#export REGRESS_PORT=10564
+
+sbcl --eval "(require 'asdf)" --eval "(push \"$(pwd)/\" asdf:*central-registry*)" --eval "(asdf:make \"9p-test\")" --eval "(all-tests:run-all-tests)"
blob - /dev/null
blob + 506342c62c223ffdfdcf1eb07df1aa754d93aa2a (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/tests/all-tests.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+(in-package :all-tests)
+
+(defparameter *client-certificate* "")
+
+(defparameter *certificate-key* "")
+
+(defparameter *host* "localhost")
+
+(defparameter *port* 10564)
+
+(defparameter *remote-test-file* "test-file") ; note: missing "/" is intentional
+
+(defparameter *remote-test-path* "/test-file")
+
+(defparameter *remote-test-path-write* "/dir/subdir/file/test-file-write")
+
+(defparameter *remote-test-path-contents* (format nil "qwertyuiopasdfghjklòàù è~%"))
+
+(alexandria:define-constant +remote-test-path-ovewrwrite-data+ "12" :test #'string=)
+
+(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 - /dev/null
blob + d7b4cf5b0675fe5df18c40ef67c5ab9f8ec4e76b (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/tests/kami-tests.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+(in-package :kami-tests)
+
+(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)
+ (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)
+ (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))
+ (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 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)))
blob - /dev/null
blob + 27c56b9a5a1fdab10a0c5004ffd0c61a9946c1b0 (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/tests/package.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+(defpackage :all-tests
+ (:use :cl
+ :clunit
+ :cl+ssl)
+ (:export
+ :*client-certificate*
+ :*certificate-key*
+ :*host*
+ :*port*
+ :*remote-test-file*
+ :*remote-test-path*
+ :*remote-test-path-write*
+ :*remote-test-path-contents*
+ :+remote-test-path-ovewrwrite-data+
+ :with-open-ssl-stream
+ :all-suite
+ :run-all-tests))
+
+(defpackage :kami-tests
+ (:use :cl
+ :clunit
+ :misc
+ :text-utils
+ :9p-client
+ :all-tests)
+ (:export))
blob - /dev/null
blob + 9c04d17f6d53dcc1025c18dfb010320d402c576b (mode 644)
--- /dev/null
+++ regress/lisp/9p-test/text-utils.lisp
+;; 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 <http://www.gnu.org/licenses/>.
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+(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))
