accept strings directly, fix incomplete urls (without scheme, port, etc)

This commit is contained in:
kiefac 2024-09-26 21:22:05 -04:00
parent 6e37ad0396
commit a8114b6512
2 changed files with 53 additions and 11 deletions

View file

@ -1,8 +1,4 @@
#lang racket/gui #lang racket/gui
(require "request-page.rkt") (require "request-page.rkt")
(define port 1965) (displayln (request-url-str "gemini://geminiprotocol.net/"))
(define target "geminiprotocol.net")
(define request "gemini://geminiprotocol.net/\r\n")
(displayln (request-uri target port request))

View file

@ -1,10 +1,55 @@
#lang racket/gui #lang racket/gui
(require openssl) (require openssl net/url-string)
(require "strings.rkt") (require "strings.rkt")
(provide request-uri) (provide request-url request-url-str)
(define (request-uri target port request) (define (path/params->str list)
(let-values ([(in out) (ssl-connect/enable-break target port)]) (let ([result ""])
(for ([i list])
(set! result (~a result "/" (path/param-path i))))
result))
(define (queries->str list)
(let ([result ""]
[sep "?"])
(for ([i list])
(set! result (~a result sep (car i)))
(when (cdr i)
(set! result (~a result "=" (cdr i))))
(set! sep "&"))
result))
(define (fix-url url)
(if (url-scheme url)
(if (url-port url)
url
((λ () (set-url-port! url 1965)
url)))
(let* ([path-first (first (url-path url))]
[path-rest (if (empty? (url-path url))
#f
(rest (url-path url)))]
[query (queries->str (url-query url))]
[fragment (url-fragment url)]
[url-str (~a "gemini://"
(path/param-path path-first)
":1965")])
(when path-rest
(set! url-str (~a url-str (path/params->str path-rest))))
(when query
(set! url-str (~a url-str query)))
(when fragment
(set! url-str (~a url-str "#" fragment)))
(string->url url-str))))
(define (format-request url)
(~a (url->string url) "\r\n"))
(define (request-url-str url-str)
(let ([url (fix-url (string->url url-str))])
(request-url (url-host url) (url-port url) (format-request url))))
(define (request-url host port request)
(let-values ([(in out) (ssl-connect/enable-break host port)])
(file-stream-buffer-mode out 'none) (file-stream-buffer-mode out 'none)
(display request out) (display request out)
(flush-output out) (flush-output out)
@ -28,8 +73,9 @@
[else (~a unhandled-mimetype info)])] [else (~a unhandled-mimetype info)])]
[(3) (case status-last [(3) (case status-last
[(1) (~a permanently-redirecting info)] [(1) (displayln (~a permanently-redirecting info))]
[else (~a temporarily-redirecting info)])] [else (displayln (~a temporarily-redirecting info))])
(request-url-str info)]
[(4) (case status-last [(4) (case status-last
[(1) (~a server-unavailable info)] [(1) (~a server-unavailable info)]