277 lines
8.3 KiB
Racket
277 lines
8.3 KiB
Racket
#lang racket
|
|
|
|
(provide client%)
|
|
|
|
(require (prefix-in net: "net.rkt")
|
|
(prefix-in gmi: "gmi.rkt")
|
|
(prefix-in txt: "txt.rkt"))
|
|
|
|
(require net/url-string)
|
|
|
|
(define temporary-failures
|
|
'((40 . "temporary failure")
|
|
(41 . "server unavailable")
|
|
(42 . "CGI error")
|
|
(43 . "proxy error")
|
|
(44 . "slow down")))
|
|
|
|
(define permanent-failures
|
|
'((50 . "permanent failure")
|
|
(51 . "not found")
|
|
(52 . "gone")
|
|
(53 . "proxy request refused")
|
|
(59 . "bad request")))
|
|
|
|
;;; CLIENT
|
|
|
|
(define client%
|
|
(class object%
|
|
(define document-object '())
|
|
(define document-buffer '())
|
|
(define history '())
|
|
|
|
(super-new)
|
|
|
|
;;;
|
|
;;; client commands
|
|
;;;
|
|
|
|
;; '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)))
|
|
|
|
(get-document (string->url destination-string)))
|
|
|
|
;; '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"))
|
|
|
|
;; 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)))))
|
|
|
|
(let ()
|
|
(iter 10)
|
|
(newline)
|
|
(let ([remaining (pipe-content-length document-buffer)])
|
|
(printf "~a bytes remaining\n" remaining))))
|
|
|
|
;; '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"))
|
|
|
|
(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)))
|