mirror of https://codeberg.org/cage/tinmop/
- fixed 'fs:split-path-elements'
- before: (fs:split-path-elements "/a/b") ;=> ("" "a" "b") (fs:split-path-elements "/a/b") ;=> ("a" "b") - [gopher] added 'client:request'.
This commit is contained in:
parent
6196810bbb
commit
a393b0ba88
|
@ -251,15 +251,16 @@
|
||||||
(nix:s-isdir (nix:stat-mode (nix:stat path))))))
|
(nix:s-isdir (nix:stat-mode (nix:stat path))))))
|
||||||
|
|
||||||
(defun split-path-elements (path)
|
(defun split-path-elements (path)
|
||||||
(cl-ppcre:split *directory-sep-regexp* path))
|
(let ((splitted (cl-ppcre:split *directory-sep-regexp* path)))
|
||||||
|
(substitute *directory-sep* "" splitted :test #'string=)))
|
||||||
|
|
||||||
(defun path-last-element (path)
|
(defun path-last-element (path)
|
||||||
(let ((elements (cl-ppcre:split *directory-sep-regexp* path)))
|
(let ((elements (split-path-elements path)))
|
||||||
(and elements
|
(and elements
|
||||||
(last-elt elements))))
|
(last-elt elements))))
|
||||||
|
|
||||||
(defun path-first-element (path)
|
(defun path-first-element (path)
|
||||||
(let ((elements (cl-ppcre:split *directory-sep-regexp* path)))
|
(let ((elements (split-path-elements path)))
|
||||||
(and elements
|
(and elements
|
||||||
(first-elt elements))))
|
(first-elt elements))))
|
||||||
|
|
||||||
|
|
|
@ -15,3 +15,110 @@
|
||||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(in-package :gopher-client)
|
(in-package :gopher-client)
|
||||||
|
|
||||||
|
(a:define-constant +request-terminal+ (format nil "~a~a" #\Return #\Newline) :test #'string=)
|
||||||
|
|
||||||
|
(a:define-constant +response-terminal+ (format nil ".~a~a" #\Return #\Newline) :test #'string=)
|
||||||
|
|
||||||
|
(a:define-constant +response-read-buffer-size+ 4096 :test #'=)
|
||||||
|
|
||||||
|
(defun make-collect-fn (collected)
|
||||||
|
(lambda (buffer)
|
||||||
|
(loop for b across buffer do
|
||||||
|
(vector-push-extend b collected 1024))))
|
||||||
|
|
||||||
|
(defun %request (host &key
|
||||||
|
(port 70)
|
||||||
|
(selector "")
|
||||||
|
(terminate-strategy :response-teminal)
|
||||||
|
(collect-fn (lambda (data) (format t "~a" (to-s data)))))
|
||||||
|
(flet ((open-socket (hostname port)
|
||||||
|
(usocket:socket-connect hostname
|
||||||
|
port
|
||||||
|
:element-type '(unsigned-byte 8)))
|
||||||
|
(end-response-p (read-so-far buffer)
|
||||||
|
(if (< read-so-far (length buffer))
|
||||||
|
t
|
||||||
|
(let ((maybe-terminal-data (subseq buffer
|
||||||
|
(- read-so-far
|
||||||
|
(length +response-terminal+))
|
||||||
|
read-so-far)))
|
||||||
|
(and (eq terminate-strategy :response-terminal)
|
||||||
|
(string= (to-s maybe-terminal-data)
|
||||||
|
+response-terminal+))))))
|
||||||
|
(let* ((socket (open-socket host port))
|
||||||
|
(stream (usocket:socket-stream socket)))
|
||||||
|
(write-sequence (babel:string-to-octets (format nil
|
||||||
|
"~a~a"
|
||||||
|
selector
|
||||||
|
+request-terminal+))
|
||||||
|
stream)
|
||||||
|
(finish-output stream)
|
||||||
|
(let* ((buffer (misc:make-fresh-array +response-read-buffer-size+
|
||||||
|
0
|
||||||
|
'(unsigned-byte 8)
|
||||||
|
t))
|
||||||
|
(first-chunk-size (read-sequence buffer stream)))
|
||||||
|
(funcall collect-fn (subseq buffer 0 first-chunk-size))
|
||||||
|
(loop for read-so-far = first-chunk-size
|
||||||
|
while (not (end-response-p read-so-far buffer))
|
||||||
|
do
|
||||||
|
(format t "~a~%" read-so-far)
|
||||||
|
(funcall collect-fn (subseq buffer 0 read-so-far)))))))
|
||||||
|
|
||||||
|
(defmacro gen-request-function (return-types strategies)
|
||||||
|
`(defun ,(format-fn-symbol t "request")
|
||||||
|
(host response-type
|
||||||
|
&key
|
||||||
|
(port 70)
|
||||||
|
(selector "")
|
||||||
|
(collect-fn (lambda (data) (format t "~a" (to-s data)))))
|
||||||
|
(cond
|
||||||
|
,@(append
|
||||||
|
(loop for return-type in return-types
|
||||||
|
for strategy in strategies
|
||||||
|
collect
|
||||||
|
`((string= response-type ,return-type)
|
||||||
|
(%request host
|
||||||
|
:port port
|
||||||
|
:selector selector
|
||||||
|
:terminate-strategy ,strategy
|
||||||
|
:collect-fn collect-fn)))
|
||||||
|
`(((string= response-type +line-type-uri+)
|
||||||
|
(open-message-link-window:open-message-link selector nil)))
|
||||||
|
`((t
|
||||||
|
(error 'conditions:not-implemented-error
|
||||||
|
:text (format nil (_ "This line type ~s in not supported") response-type))))))))
|
||||||
|
|
||||||
|
(gen-request-function (+line-type-file+
|
||||||
|
+line-type-dir+
|
||||||
|
+line-type-error+
|
||||||
|
+line-type-mac-hex-file+
|
||||||
|
+line-type-dos-archive-file+
|
||||||
|
+line-type-uuencoded-file+
|
||||||
|
+line-type-index-search+
|
||||||
|
+line-type-binary-file+
|
||||||
|
+line-type-gif-image-file+
|
||||||
|
+line-type-image-file+
|
||||||
|
+line-type-info+)
|
||||||
|
(:response-teminal
|
||||||
|
:response-teminal
|
||||||
|
:response-teminal
|
||||||
|
nil
|
||||||
|
nil
|
||||||
|
nil
|
||||||
|
:response-teminal
|
||||||
|
nil
|
||||||
|
nil
|
||||||
|
nil
|
||||||
|
:response-teminal))
|
||||||
|
|
||||||
|
(defun request-from-iri (iri &optional (collect-function (lambda (data)
|
||||||
|
(format t "~a" (to-s data)))))
|
||||||
|
(multiple-value-bind (host port type selector)
|
||||||
|
(parse-iri iri)
|
||||||
|
(request host
|
||||||
|
type
|
||||||
|
:port port
|
||||||
|
:selector selector
|
||||||
|
:collect-fn collect-function)))
|
||||||
|
|
|
@ -25,6 +25,7 @@
|
||||||
:misc)
|
:misc)
|
||||||
(:local-nicknames (:a :alexandria))
|
(:local-nicknames (:a :alexandria))
|
||||||
(:export
|
(:export
|
||||||
|
:+gopher-scheme+
|
||||||
:+line-type-file+
|
:+line-type-file+
|
||||||
:+line-type-dir+
|
:+line-type-dir+
|
||||||
:+line-type-cso+
|
:+line-type-cso+
|
||||||
|
@ -35,7 +36,10 @@
|
||||||
:+line-type-index-search+
|
:+line-type-index-search+
|
||||||
:+line-type-telnet-session+
|
:+line-type-telnet-session+
|
||||||
:+line-type-binary-file+
|
:+line-type-binary-file+
|
||||||
:+gopher-scheme+
|
:+line-type-gif-image-file+
|
||||||
|
:+line-type-image-file+
|
||||||
|
:+line-type-info+
|
||||||
|
:+line-type-uri+
|
||||||
:line-file
|
:line-file
|
||||||
:line-dir
|
:line-dir
|
||||||
:line-cso
|
:line-cso
|
||||||
|
@ -50,6 +54,7 @@
|
||||||
:line-tn3270-session
|
:line-tn3270-session
|
||||||
:line-gif-file
|
:line-gif-file
|
||||||
:line-image-file
|
:line-image-file
|
||||||
|
:line-uri
|
||||||
:line-file-p
|
:line-file-p
|
||||||
:line-dir-p
|
:line-dir-p
|
||||||
:line-cso-p
|
:line-cso-p
|
||||||
|
@ -64,18 +69,21 @@
|
||||||
:line-tn3270-session-p
|
:line-tn3270-session-p
|
||||||
:line-gif-file-p
|
:line-gif-file-p
|
||||||
:line-image-file-p
|
:line-image-file-p
|
||||||
:parse-menu))
|
:line-image-uri-p
|
||||||
|
:parse-menu
|
||||||
|
:parse-iri))
|
||||||
|
|
||||||
(defpackage gopher-client
|
(defpackage gopher-client
|
||||||
(:use
|
(:use
|
||||||
:cl
|
:cl
|
||||||
:cl-ppcre
|
:cl-ppcre
|
||||||
:esrap
|
|
||||||
:config
|
:config
|
||||||
:constants
|
:constants
|
||||||
:text-utils
|
:text-utils
|
||||||
:misc
|
:misc
|
||||||
:gemini-constants)
|
:gopher-parser)
|
||||||
(:local-nicknames (:a :alexandria))
|
(:local-nicknames (:a :alexandria)
|
||||||
|
(:parser :gopher-parser))
|
||||||
(:export
|
(:export
|
||||||
:+gopher-scheme+))
|
:request
|
||||||
|
:request-from-iri))
|
||||||
|
|
|
@ -40,7 +40,9 @@
|
||||||
(redundant-server "+" "identifier for a redundant server")
|
(redundant-server "+" "identifier for a redundant server")
|
||||||
(tn3270-session "T" "identifier for a tn3270 session")
|
(tn3270-session "T" "identifier for a tn3270 session")
|
||||||
(gif-image-file "g" "identifier for an image in GIF")
|
(gif-image-file "g" "identifier for an image in GIF")
|
||||||
(image-file "I" "identifier for an image file")))
|
(image-file "I" "identifier for an image file")
|
||||||
|
(info "i" "information line")
|
||||||
|
(uri "h" "hyperlink")))
|
||||||
|
|
||||||
(a:define-constant +gopher-scheme+ "gopher" :test #'string=)
|
(a:define-constant +gopher-scheme+ "gopher" :test #'string=)
|
||||||
|
|
||||||
|
@ -80,6 +82,10 @@
|
||||||
|
|
||||||
(%gen-check-line-predicate image-file +line-type-image-file+)
|
(%gen-check-line-predicate image-file +line-type-image-file+)
|
||||||
|
|
||||||
|
(%gen-check-line-predicate info +line-type-info+)
|
||||||
|
|
||||||
|
(%gen-check-line-predicate uri +line-type-uri+)
|
||||||
|
|
||||||
(defclass gopher-line ()
|
(defclass gopher-line ()
|
||||||
((username
|
((username
|
||||||
:initarg :username
|
:initarg :username
|
||||||
|
@ -143,6 +149,10 @@
|
||||||
|
|
||||||
(gen-selector-class line-image-file)
|
(gen-selector-class line-image-file)
|
||||||
|
|
||||||
|
(gen-selector-class line-info)
|
||||||
|
|
||||||
|
(gen-selector-class line-uri)
|
||||||
|
|
||||||
(defun check-line-type (data reference)
|
(defun check-line-type (data reference)
|
||||||
(typep data reference))
|
(typep data reference))
|
||||||
|
|
||||||
|
@ -179,6 +189,10 @@
|
||||||
|
|
||||||
(gen-check-line-predicate image-file 'line-image-file)
|
(gen-check-line-predicate image-file 'line-image-file)
|
||||||
|
|
||||||
|
(gen-check-line-predicate info 'line-info)
|
||||||
|
|
||||||
|
(gen-check-line-predicate uri 'line-uri)
|
||||||
|
|
||||||
(defrule line-separator (and #\Return #\Newline)
|
(defrule line-separator (and #\Return #\Newline)
|
||||||
(:constant :line-separator))
|
(:constant :line-separator))
|
||||||
|
|
||||||
|
@ -273,9 +287,22 @@
|
||||||
((%line-type-gif-file-p line-type)
|
((%line-type-gif-file-p line-type)
|
||||||
(make-instance 'line-gif-file))
|
(make-instance 'line-gif-file))
|
||||||
((%line-type-image-file-p line-type)
|
((%line-type-image-file-p line-type)
|
||||||
(make-instance 'line-image-file)))))
|
(make-instance 'line-image-file))
|
||||||
|
((%line-type-info-p line-type)
|
||||||
|
(make-instance 'line-info))
|
||||||
|
((%line-type-uri-p line-type)
|
||||||
|
(make-instance 'line-uri)))))
|
||||||
(setf (username instance) (getf entry :user-name)
|
(setf (username instance) (getf entry :user-name)
|
||||||
(selector instance) (getf entry :selector)
|
(selector instance) (getf entry :selector)
|
||||||
(host instance) (getf entry :host)
|
(host instance) (getf entry :host)
|
||||||
(port instance) (getf entry :port))
|
(port instance) (getf entry :port))
|
||||||
instance))))
|
instance))))
|
||||||
|
|
||||||
|
(defun parse-iri (iri)
|
||||||
|
(let* ((parsed (iri:iri-parse iri))
|
||||||
|
(host (uri:host parsed))
|
||||||
|
(port (uri:port parsed))
|
||||||
|
(path (uri:path parsed))
|
||||||
|
(type (second (fs:split-path-elements path)))
|
||||||
|
(selector (subseq path (+ 2 (length type)))))
|
||||||
|
(values host port type selector)))
|
||||||
|
|
Loading…
Reference in New Issue