total overhaul of client implementation
This commit is contained in:
287
client.rkt
287
client.rkt
@@ -3,7 +3,8 @@
|
||||
(provide client%)
|
||||
|
||||
(require (prefix-in net: "net.rkt")
|
||||
(prefix-in gmi: "gmi.rkt"))
|
||||
(prefix-in gmi: "gmi.rkt")
|
||||
(prefix-in txt: "txt.rkt"))
|
||||
|
||||
(require net/url-string)
|
||||
|
||||
@@ -21,65 +22,255 @@
|
||||
(53 . "proxy request refused")
|
||||
(59 . "bad request")))
|
||||
|
||||
(struct exn:status:input-required exn ()
|
||||
#:extra-constructor-name make-exn:status:input-required
|
||||
#:transparent)
|
||||
|
||||
(struct exn:status:redirect exn ()
|
||||
#:extra-constructor-name make-exn:status:redirect
|
||||
#:transparent)
|
||||
|
||||
(struct exn:status:temporary-failure exn (errno)
|
||||
#:extra-constructor-name make-exn:status:temporary-failure
|
||||
#:transparent)
|
||||
|
||||
(struct exn:status:permanent-failure exn (errno)
|
||||
#:extra-constructor-name make-exn:status:permanent-failure
|
||||
#:transparent)
|
||||
|
||||
(struct exn:status:certificate-required exn ()
|
||||
#:extra-constructor-name make-exn:status:certificate-required
|
||||
#:transparent)
|
||||
;;; CLIENT
|
||||
|
||||
(define client%
|
||||
(class object%
|
||||
(define document-object '())
|
||||
(define document-buffer '())
|
||||
(define current-url '())
|
||||
(define history '())
|
||||
|
||||
(super-new)
|
||||
|
||||
(define/private (get-document url)
|
||||
(with-handlers
|
||||
;; exceptions which may be raised by net:request
|
||||
([exn:fail:network? (λ (exn) (displayln (exn-message exn)))]
|
||||
[net:exn:fail:response? (λ (exn) (displayln (exn-message exn)))])
|
||||
;;;
|
||||
;;; client commands
|
||||
;;;
|
||||
|
||||
(let-values ([(status meta body-port) (net:request url)])
|
||||
(cond
|
||||
;; clients MUST reject status codes outside of the 10-69 range
|
||||
[(or (< status 10) (> status 69))
|
||||
(void)]
|
||||
;; 'go <url>' to go to a specific page
|
||||
(define/public (go-cmd destination-string)
|
||||
;; the 'go' command is the only command with any sort of URL
|
||||
;; processing that isn't strictly RFC3986. Specifically, the
|
||||
;; user MAY omit the scheme. Rackets 'url' module will interpret
|
||||
;; the domain as part of the path in lieu of a scheme, and
|
||||
;; performing this operation on an existing url struct is
|
||||
;; non-trivial.
|
||||
(when (not (string-contains? destination-string "://"))
|
||||
(set! destination-string
|
||||
(string-append "gemini://" destination-string)))
|
||||
|
||||
;; 10-19 INPUT REQUIRED
|
||||
[(and (>= status 10) (<= status 19))
|
||||
(void)]
|
||||
(get-document (string->url destination-string)))
|
||||
|
||||
;; 20-29 SUCCESS
|
||||
[(and (>= status 20) (<= status 29))
|
||||
(void)]
|
||||
;; 'next' to display the next page
|
||||
(define/public (next-cmd)
|
||||
(when (null? document-buffer)
|
||||
(raise-user-error
|
||||
'next-cmd
|
||||
"there is currently no visited document"))
|
||||
|
||||
;; 30-39 REDIRECT
|
||||
[(and (>= status 30) (<= status 39))
|
||||
(void)]
|
||||
;; displays remaining buffer content, maximum of 10 lines.
|
||||
(define (iter depth)
|
||||
(when (and (> depth 0)
|
||||
(> (pipe-content-length document-buffer) 0))
|
||||
(let ()
|
||||
(displayln (read-line document-buffer))
|
||||
(iter (sub1 depth)))))
|
||||
|
||||
;; 40-49 TEMPORARY FAILURE
|
||||
[(and (>= status 40) (<= status 49))
|
||||
(void)]
|
||||
(let ()
|
||||
(iter 10)
|
||||
(newline)
|
||||
(let ([remaining (pipe-content-length document-buffer)])
|
||||
(printf "~a bytes remaining\n" remaining))))
|
||||
|
||||
;; 50-59 PERMANENT FAILURE
|
||||
[(and (>= status 50) (<= status 59))
|
||||
(void)]
|
||||
;; 'visit {n}' to visit a link in the page
|
||||
(define/public (visit-cmd id)
|
||||
(when (not (gmi:document? document-object))
|
||||
(raise-user-error
|
||||
'visit-cmd
|
||||
"currently visited document is not a gemini document"))
|
||||
|
||||
;; 60-69 CERTIFICATE REQUIRED
|
||||
[(and (>= status 60) (<= status 69))]))))
|
||||
(get-document
|
||||
(gmi:match-link document-object id)))
|
||||
|
||||
;; 'url [n]' to get current url or links url
|
||||
(define/public (url-cmd (id #f))
|
||||
(if id
|
||||
(if (gmi:document? document-object)
|
||||
(displayln (url->string
|
||||
(absolutise-url
|
||||
(gmi:match-link document-object id))))
|
||||
(raise-user-error
|
||||
'url-cmd
|
||||
"currently visited document is not a gemini document"))
|
||||
(displayln (url->string (car history)))))
|
||||
|
||||
;; 'back' to go back one in history
|
||||
(define/public (back-cmd)
|
||||
(when (< (length history) 2)
|
||||
(raise-user-error
|
||||
'back-cmd
|
||||
"cannot go any further back in history!"))
|
||||
|
||||
;; drop current page
|
||||
(set! history (cdr history))
|
||||
(let ([visiting (car history)])
|
||||
;; drop the page before that, too, since get-document will add
|
||||
;; it
|
||||
(set! history (cdr history))
|
||||
|
||||
(get-document visiting)))
|
||||
|
||||
;; 'up' to go up one directory
|
||||
(define/public (up-cmd)
|
||||
(when (null? history)
|
||||
(error 'no-where))
|
||||
|
||||
(when (string=? (path->string
|
||||
(simplify-path
|
||||
(url->path (car history))))
|
||||
"/")
|
||||
|
||||
(error 'at-root))
|
||||
|
||||
(let ([parent
|
||||
(simplify-path
|
||||
(build-path (url->path (car history)) 'up)
|
||||
#f)])
|
||||
(get-document
|
||||
(struct-copy url (car history)
|
||||
[path (url-path (path->url parent))]))))
|
||||
|
||||
;;;
|
||||
;;; MIME handling
|
||||
;;;
|
||||
|
||||
(define/private (mime/handle parse render body-port)
|
||||
(set! document-object (parse body-port))
|
||||
|
||||
(let-values ([(input output) (make-pipe #f)])
|
||||
(parameterize ([current-output-port output])
|
||||
(gmi:render document-object))
|
||||
|
||||
(set! document-buffer input)))
|
||||
|
||||
(define/private (mime/handle-gmi body-port)
|
||||
(mime/handle gmi:parse gmi:render body-port))
|
||||
|
||||
(define/private (mime/handle-txt body-port)
|
||||
(mime/handle txt:parse txt:render body-port))
|
||||
|
||||
;;;
|
||||
;;; document fetching
|
||||
;;;
|
||||
|
||||
(define/private (absolutise-url partial)
|
||||
(combine-url/relative (car history)
|
||||
(url->string partial)))
|
||||
|
||||
(define/public (get-document destination (redirect-depth 0))
|
||||
;; handle urls which are relative to currently visited document
|
||||
(when (not (null? history))
|
||||
(set! destination (absolutise-url destination)))
|
||||
|
||||
(when (not (string=? (url-scheme destination) "gemini"))
|
||||
(raise-user-error
|
||||
'get-document
|
||||
(string-append "unsupported scheme: ~a~n"
|
||||
" url: ~a~n")
|
||||
(url-scheme destination) destination))
|
||||
|
||||
(define-values (status meta body-port)
|
||||
(net:request destination))
|
||||
|
||||
;; if net:request does not raise an exception, then status
|
||||
;; meta and body-port are necessarily valid
|
||||
(cond
|
||||
;; clients MUST reject status codes outside of the 10-69
|
||||
;; range
|
||||
[(or (< status 10) (> status 69))
|
||||
(raise-user-error
|
||||
'get-document
|
||||
(string-append "server returned out of range status: ~a~n"
|
||||
" valid range: [10, 69]~a~n"
|
||||
" url: ~a~n")
|
||||
status (url->string destination))]
|
||||
|
||||
;;
|
||||
;; 10-19 INPUT REQUIRED
|
||||
;;
|
||||
[(and (>= status 10) (<= status 19))
|
||||
(displayln "input requested")
|
||||
(display "? ")
|
||||
|
||||
(get-document
|
||||
(struct-copy
|
||||
url
|
||||
destination
|
||||
[query `((,(string->symbol (read-line)) . #f))]))]
|
||||
|
||||
;;
|
||||
;; 20-29 SUCCESS
|
||||
;;
|
||||
[(and (>= status 20) (<= status 29))
|
||||
;; SUCCESS only has a single defined status in this
|
||||
;; group. All actions are necessarily default
|
||||
|
||||
;; This client does not use the lang MIME parameter for
|
||||
;; anything.
|
||||
(match (car (string-split meta ";"))
|
||||
["text/gemini" (mime/handle-gmi body-port)]
|
||||
["text/plaintext" (mime/handle-txt body-port)]
|
||||
[else
|
||||
(raise-user-error
|
||||
'get-document
|
||||
(string-append "unsupported mime ~a~n"
|
||||
" url: ~a~n")
|
||||
meta destination)])
|
||||
|
||||
;; If the document failed to be fetched (parser error,
|
||||
;; unsupported mime, so on and so forth) this would not
|
||||
;; ever be reached.
|
||||
(set! history (cons destination history))]
|
||||
|
||||
;;
|
||||
;; 30-39 REDIRECT
|
||||
;;
|
||||
[(and (>= status 30) (<= status 39))
|
||||
(if (> redirect-depth 5)
|
||||
(raise-user-error
|
||||
'get-document
|
||||
(string-append "maximum redirect depth exceeded. "
|
||||
"bailing"))
|
||||
(get-document (string->url meta)
|
||||
(add1 redirect-depth)))]
|
||||
|
||||
;;
|
||||
;; 40-49 TEMPORARY FAILURE
|
||||
;;
|
||||
[(and (>= status 40) (<= status 49))
|
||||
(raise-user-error
|
||||
'get-document
|
||||
(string-append "server reports temporary failure: ~a~n"
|
||||
" url: ~a~n"
|
||||
" explanation: ~a~n")
|
||||
status
|
||||
(string->url destination)
|
||||
(dict-ref temporary-failures
|
||||
status
|
||||
"temporary failure"))]
|
||||
|
||||
;;
|
||||
;; 50-59 PERMANENT FAILURE
|
||||
;;
|
||||
[(and (>= status 50) (<= status 59))
|
||||
(raise-user-error
|
||||
'get-document
|
||||
(string-append "server reports permanent failure: ~a~n"
|
||||
" url: ~a~n"
|
||||
" explanation: ~a~n")
|
||||
status
|
||||
(string->url destination)
|
||||
(dict-ref permanent-failures
|
||||
status
|
||||
"temporary failure"))]
|
||||
|
||||
;;
|
||||
;; 60-69 CERTIFICATE REQUIRED
|
||||
;;
|
||||
[(and (>= status 60) (<= status 69))
|
||||
(raise-user-error
|
||||
'get-document
|
||||
(string-append "resource requires a client certificate, "
|
||||
"which this client does not yet support~a~n"
|
||||
" url: ~a~n"))])
|
||||
|
||||
(next-cmd)))
|
||||
|
||||
Reference in New Issue
Block a user