#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 (current-input-port)
                                  'any)) . #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 (url->string 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
          (url->string 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
          (url->string 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))))