#lang racket/base

(provide random-hex-string
         extend-url-string-query
         web-respond/status!
         web-request!
         web-post/form-parameters!
         analyze-response
         parse-link-headers
         link-header-ref
         maybe-link-header
         vh
         canonical-url)

(require racket/dict)
(require racket/match)
(require racket/string)
(require (only-in file/sha1 bytes->hex-string))
(require (only-in racket/random crypto-random-bytes))
(require net/url)
(require net/uri-codec)
(require syndicate/actor)
(require syndicate/drivers/timer)
(require syndicate/drivers/web)

(module+ test (require rackunit))

(define (random-hex-string half-length)
  (bytes->hex-string (crypto-random-bytes half-length)))

(define (extend-url-string-query urlstr extension)
  (define u (string->url urlstr))
  (url->string (struct-copy url u [query (append (url-query u) extension)])))

(module+ test
  (check-equal? (extend-url-string-query "http://localhost/" '((a . "hi")))
                "http://localhost/?a=hi")
  (check-equal? (extend-url-string-query "http://localhost/" '())
                "http://localhost/")
  (check-equal? (extend-url-string-query "http://localhost?foo=bar" '())
                "http://localhost?foo=bar")
  (check-equal? (extend-url-string-query "http://localhost/?foo=bar" '())
                "http://localhost/?foo=bar")
  (check-equal? (extend-url-string-query "http://localhost?foo=bar" '((a . "hi")))
                "http://localhost?foo=bar&a=hi")
  (check-equal? (extend-url-string-query "http://localhost/?foo=bar" '((a . "hi")))
                "http://localhost/?foo=bar&a=hi"))

(define (web-respond/status! id code message [body #""])
  (web-respond/bytes! id
                      #:header (web-response-header
                                #:code code
                                #:message message
                                #:headers '())
                      body))

(define (web-request! verb urlstr
                      #:body [request-body #""]
                      #:headers [headers '()]
                      #:redirect-budget [redirect-budget 0])
  (define req-id (gensym 'req))
  (define u (string->url urlstr))
  (define res (url->resource u))
  (define-values (resp response-body)
    (react/suspend (k)
      (on-start
       (log-info "~a --> ~a ~a ~v" req-id verb urlstr request-body)
       (send! (web-request req-id
                           'outbound
                           (web-request-header verb res headers (url-query u))
                           request-body)))
      (stop-when (message (web-response-complete req-id $resp $response-body))
                 (log-info "~a <-- ~v ~v" req-id resp response-body)
                 (k resp response-body))))
  (define location (and resp (dict-ref (web-response-header-headers resp) 'location #f)))
  (if (and resp
           (eq? (web-response-header-code-type resp) 'redirection)
           (positive? redirect-budget)
           location)
      (web-request! verb location
                    #:body request-body
                    #:headers headers
                    #:redirect-budget (- redirect-budget 1))
      (values resp response-body)))

(define (web-post/form-parameters! urlstr query-alist
                                   #:headers [headers '()]
                                   #:redirect-budget [redirect-budget 0])
  (web-request! 'post urlstr
                #:headers (cons (cons 'content-type "application/x-www-form-urlencoded") headers)
                #:body (string->bytes/utf-8 (alist->form-urlencoded query-alist))))

(define (analyze-response req-thunk k-successful k-unsuccessful)
  (define-values (resp response-body) (req-thunk))
  (if (web-response-successful? resp)
      (k-successful)
      (k-unsuccessful resp response-body)))

(define (parse-link-headers headers)
  (define rel-dict-reverse-order
    (for/fold [(seed (hasheq))] [(header headers)]
      (if (eq? (car header) 'link)
          (parse-link-header-value (cdr header) seed)
          seed)))
  (for/hasheq [((rel urls-rev) (in-hash rel-dict-reverse-order))]
    (values rel (reverse urls-rev))))

(define (link-header-ref parsed-link-headers rel default)
  (match (hash-ref parsed-link-headers rel '())
    [(cons v _) v]
    ['() default]))

(define (parse-link-header-value link-header seed)
  ;; This is not adequate with respect to the RFC 5988 grammar, which
  ;; includes a wide variety of link-params other than "rel".
  (define pieces
    (append (regexp-match* #rx"(<([^>]+)>; +rel=([^\"][^,]*))" link-header #:match-select values)
            (regexp-match* #rx"(<([^>]+)>; +rel=\"([^\"]+)\")" link-header #:match-select values)))
  (for/fold [(rel-dict seed)] [(piece pieces)]
    (match-define (list _ _ url rels-str) piece)
    (for/fold [(rel-dict rel-dict)] [(rel-str (string-split rels-str))]
      (define rel (string->symbol rel-str))
      (hash-set rel-dict rel (cons url (hash-ref rel-dict rel '()))))))

(module+ test
  (define combined "<http://phubb.cweiske.de/hub.php>; rel=\"hub\", <http://push-tester.cweiske.de/feed.php>; rel=\"self\"")
  (define separate "<http://localhost:7827/hub>; rel=hub")
  (check-equal? (parse-link-header-value combined (hasheq))
                (hasheq 'hub (list "http://phubb.cweiske.de/hub.php")
                        'self (list "http://push-tester.cweiske.de/feed.php")))
  (check-equal? (parse-link-header-value separate (hasheq))
                (hasheq 'hub (list "http://localhost:7827/hub")))
  (check-equal? (parse-link-headers (list (cons 'link combined)
                                          (cons 'content-type "text/plain")
                                          (cons 'link separate)))
                (hasheq 'hub (list "http://phubb.cweiske.de/hub.php"
                                   "http://localhost:7827/hub")
                        'self (list "http://push-tester.cweiske.de/feed.php"))))

(define (maybe-link-header urlstr rel)
  (if urlstr
      (list (cons 'link (format "<~a>; rel=~a" urlstr rel)))
      '()))

(define (vh host-name port) (web-virtual-host "http" host-name port))

(define (canonical-url canonical-host-name cport path)
  (url->string (resource->url (web-resource (vh canonical-host-name cport) path))))