gem300/client.rkt

#lang racket

(provide client%)

(require (prefix-in net: "net.rkt")
         (prefix-in gmi: "gmi.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")))

(define client%
  (class object%
    (define document-object '())
    (define document-buffer '())
    (define current-url '())

    (super-new)

    (define/public (up-cmd)
      (if (null? current-url)

          (displayln "you need to 'go' somewhere first!")

          (if (string=?  (path->string
                          (simplify-path
                           (url->path current-url)))
                         "/")

              (displayln "already at root!")

              (let ([parent
                     (simplify-path
                      (build-path (url->path current-url) 'up)
                      #f)])
                (get (struct-copy url current-url
                                  [path (url-path (path->url parent))]))))))

    (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)))

            (get (string->url url-string)))

          (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/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)))))