w6vvn/gem300
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

rip a ton of stuff out. clear my head a bit.

Browse Source
This commit is contained in:
w6vvn
2025-09-06 19:29:13 -07:00
parent 759c66889c
commit b05dc90e70
1 changed files with 47 additions and 134 deletions
Download Patch File Download Diff File Expand all files Collapse all files

181
client.rkt
View File

@@ -21,6 +21,26 @@
(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)
(define client%
(class object%
(define document-object '())
@@ -29,144 +49,37 @@
(super-new)
(define/public (up-cmd)
(if (null? current-url)
(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)))])
(displayln "you need to 'go' somewhere first!")
(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)]
(if (string=? (path->string
(simplify-path
(url->path current-url)))
"/")
;; 10-19 INPUT REQUIRED
[(and (>= status 10) (<= status 19))
(void)]
(displayln "already at root!")
;; 20-29 SUCCESS
[(and (>= status 20) (<= status 29))
(void)]
(let ([parent
(simplify-path
(build-path (url->path current-url) 'up)
#f)])
(get (struct-copy url current-url
[path (url-path (path->url parent))]))))))
;; 30-39 REDIRECT
[(and (>= status 30) (<= status 39))
(void)]
(define/public (go-cmd url-string)
(if (non-empty-string? url-string)
(let ()
(when (not (string-contains? url-string "://"))
(set! url-string (string-append "gemini://" url-string)))
;; 40-49 TEMPORARY FAILURE
[(and (>= status 40) (<= status 49))
(void)]
(get (string->url url-string)))
;; 50-59 PERMANENT FAILURE
[(and (>= status 50) (<= status 59))
(void)]
(displayln "go where?")))
(define/public (next-cmd)
(define (iter depth)
(when (and (> depth 0)
(> (pipe-content-length document-buffer) 0))
(let ()
(displayln (read-line document-buffer))
(iter (sub1 depth)))))
(if (null? document-buffer)
(displayln "you need to 'go' somewhere first!")
(let ()
(iter 10)
(newline)
(let ([remaining (pipe-content-length document-buffer)])
(printf "~a bytes remaining\n" remaining)))))
(define/public (visit-cmd line)
(if (null? document-object)
(displayln "you need to 'go' somewhere first!")
(let ([url (gmi:match-link document-object line)])
(get (combine-url/relative current-url (url->string url))))))
(define/public (url-cmd (link-id #f))
(if (null? document-object)
(displayln "you need to 'go' somewhere first!")
(if link-id
(let ([link (gmi:match-link document-object link-id)])
(if link
(displayln (url->string link))
(displayln "no link with that id")))
(displayln (url->string current-url)))))
(define/private (handle-gmi url c-in)
(let-values ([(doc) (gmi:parse (port->lines c-in))]
[(db-in db-out) (make-pipe #f)])
(set! document-object doc)
(set! document-buffer db-in)
(parameterize ([current-output-port db-out])
(gmi:render doc))
(set! current-url url)
(let ([remaining (pipe-content-length db-in)])
(printf "document retrieved. ~a bytes\n" remaining))
(next-cmd)))
(define/private (get url)
(define (iter url depth)
(with-handlers
([exn:fail:network?
(λ (exn)
(displayln (exn-message exn)))]
[net:exn:fail:response?
(λ (exn)
(displayln (exn-message exn)))])
(let-values ([(status meta c-in) (net:request url)])
;; TODO there are bunch of other status codes to deal with for
;; compliance
(cond
;; clients MUST reject status codes outside of the 10-69 range
[(or (< status 10)
(> status 69))
(displayln "WARNING: server returned invalid status code")]
;; 10-19 INPUT REQUIRED
[(and (>= status 10)
(<= status 19))
(display "input requested > ")
(get (string-append url "?" (read-line)))]
;; 20-29 SUCCESS
[(and (>= status 20)
(<= status 29))
(let ([mime (car (string-split meta ";"))])
(cond
[(string=? mime "text/gemini")
(handle-gmi url c-in)]
[else
(printf "unsupported mime type: ~a~n" mime)]))]
;; 30-39 REDIRECT
[(and (>= status 30)
(<= status 39))
(if (> depth 5)
(displayln "WARNING: maximum redirection depth exceeded")
(iter (string->url meta) (sub1 depth)))]
;; 40-49 TEMPORARY FAILURE
[(and (>= status 40)
(<= status 49))
(printf "status ~a: ~a\n" status
(dict-ref temporary-failures status "temporary failure"))]
;; 50-59 PERMANENT FAILURE
[(and (>= status 50)
(<= status 59))
(printf "status ~a: ~a\n" status
(dict-ref permanent-failures status "permanent failure"))]
;; 60-69 CERTIFICATE REQUIRED
[(and (>= status 60)
(<= status 69))
(displayln "certificate handling not yet implemented")]))))
(if (not (string=? (url-scheme url) "gemini"))
(printf "unsupported url: ~a~n" (url->string url))
(iter url 5)))))
;; 60-69 CERTIFICATE REQUIRED
[(and (>= status 60) (<= status 69))]))))