#lang syndicate/actor
;; More general web driver: supports normal HTTP as well as websockets.

(provide (struct-out web-virtual-host)
         (struct-out web-resource)
         url->resource

         (struct-out web-request)
         (struct-out web-request-header)

         (rename-out [web-response-header <web-response-header>])
         (struct-out/defaults [make-web-response-header web-response-header])
         (struct-out web-response-complete)
         (struct-out web-response-chunked)
         (rename-out [web-response-websocket <web-response-websocket>])
         (struct-out/defaults [make-web-response-websocket web-response-websocket])

         (struct-out web-response-chunk)
         (struct-out websocket-message)

         web-request-incoming
         web-request-get
         websocket-connection-closed
         websocket-message-recv
         websocket-message-send!
         web-respond/bytes!
         web-respond/xexpr!

         spawn-web-driver)

(require net/url)
(require net/rfc6455)
(require net/rfc6455/conn-api)
(require net/rfc6455/dispatcher)
(require net/http-client)
(require racket/exn)
(require racket/tcp)
(require racket/set)
(require racket/async-channel)
(require (only-in racket/bytes bytes-join))
(require (only-in racket/list flatten))
(require (only-in racket/port port->bytes))
(require web-server/http/bindings)
(require web-server/http/request)
(require web-server/http/request-structs)
(require web-server/http/response)
(require web-server/http/response-structs)
(require web-server/private/connection-manager)
(require (only-in web-server/private/util lowercase-symbol!))
(require web-server/dispatchers/dispatch)
(require struct-defaults)
(require xml)

(require/activate "timer.rkt")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(struct web-virtual-host (scheme name port) #:prefab)
(struct web-resource (virtual-host path) #:prefab)

(struct web-request (id direction header* body) #:prefab)
(struct web-request-header (method resource headers query) #:prefab)

(struct web-response-header (code message last-modified-seconds mime-type headers) #:prefab)
(struct web-response-complete (id header body) #:prefab)
(struct web-response-chunked (id header) #:prefab)
(struct web-response-websocket (id headers) #:prefab)

(struct web-response-chunk (id bytes) #:prefab)
(struct websocket-message (id direction body) #:prefab)

(begin-for-declarations
  (define-struct-defaults make-web-response-header web-response-header
    (#:code [web-response-header-code 200]
     #:message [web-response-header-message #"OK"]
     #:last-modified-seconds [web-response-header-last-modified-seconds (current-seconds)]
     #:mime-type [web-response-header-mime-type #"text/html"]
     #:headers [web-response-header-headers '()]))
  (define-struct-defaults make-web-response-websocket web-response-websocket
    (#:headers [web-response-websocket-headers '()])))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Ground-level communication messages

(struct web-raw-request (id port connection req control-ch) #:prefab)
(struct web-raw-client-conn (id connection) #:prefab)
(struct web-incoming-message (id message) #:prefab)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-event-expander web-request-incoming
  (syntax-rules ()
    [(_ (id req) vh method path)
     (message (web-request ($ id _)
                           'inbound
                           ($ req (web-request-header method (web-resource vh `path) _ _))
                           _))]))

(define-event-expander web-request-get
  (syntax-rules ()
    [(_ (id req) vh path)
     (web-request-incoming (id req) vh 'get path)]))

(define-event-expander websocket-connection-closed
  (syntax-rules ()
    [(_ id)
     (retracted (observe (websocket-message id 'outbound _)))]))

(define-event-expander websocket-message-recv
  (syntax-rules ()
    [(_ id str)
     (message (websocket-message id 'inbound str))]))

(define (websocket-message-send! id str)
  (send! (websocket-message id 'outbound str)))

(define (web-respond/bytes! id #:header [header (make-web-response-header)] body-bytes)
  (send! (web-response-complete id header body-bytes)))

(define (web-respond/xexpr! id
                            #:header [header (make-web-response-header)]
                            #:preamble [preamble #"<!DOCTYPE html>"]
                            body-xexpr)
  (web-respond/bytes! id #:header header
                      (bytes-append preamble
                                    (string->bytes/utf-8 (xexpr->string body-xexpr)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define web-server-max-waiting (make-parameter 511)) ;; sockets
(define web-server-connection-manager (make-parameter #f))
(define web-server-initial-connection-timeout (make-parameter 30)) ;; seconds

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (url->resource u)
  (web-resource (web-virtual-host (url-scheme u)
                                  (url-host u)
                                  (url-port u))
                (format-url-path u)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (spawn-web-driver)
  (actor #:name 'web-server-manager
         (during/actor (web-virtual-host "http" _ $port)
                       #:name (list 'web-server port)
                       (setup-web-server "http"
                                         (or (web-server-connection-manager)
                                             (start-connection-manager))
                                         port)))
  (actor #:name 'web-client-manager
         (on (message (web-request $id 'outbound $req $body))
             (actor #:name (list 'web-client id)
                    (do-client-request id req body)))))

(define (setup-web-server scheme cm port)
  (define listener (tcp-listen port (web-server-max-waiting) #t))
  (define listener-control (make-channel))
  (thread (lambda ()
            (let loop ()
              (sync (handle-evt (tcp-accept-evt listener)
                                (lambda (ports)
                                  (handle-incoming-connection port cm ports)
                                  (loop)))
                    (handle-evt listener-control
                                (match-lambda
                                  ['quit (void)]))))))

  (on-stop (channel-put listener-control 'quit))

  (on (message (inbound (web-raw-request $id port $conn $lowlevel-req $control-ch)))
      (define web-req (web-request id
                                   'inbound
                                   (web-request-header
                                    (string->symbol (string-downcase
                                                     (bytes->string/latin-1
                                                      (request-method lowlevel-req))))
                                    (web-resource (req->virtual-host scheme lowlevel-req port)
                                                  (format-url-path (request-uri lowlevel-req)))
                                    (request-headers lowlevel-req)
                                    (url-query (request-uri lowlevel-req)))
                                   (request-post-data/raw lowlevel-req)))
      (actor #:name (list 'web-req id)
             (on-start (send! (set-timer (list 'web-req id) 100 'relative))
                       (send! web-req))
             (stop-when (message (timer-expired (list 'web-req id) _))
                        (do-response-complete control-ch
                                              id
                                              (make-web-response-header
                                               #:code 404
                                               #:message #"Not found")
                                              '()))
             (stop-when (message (web-response-complete id $rh $body))
                        (do-response-complete control-ch id rh body))
             (stop-when (asserted (web-response-chunked id $rh))
                        (do-response-chunked control-ch id rh))
             (stop-when (asserted (web-response-websocket id $headers))
                        (do-response-websocket control-ch id headers)))))

(define (do-response-complete control-ch id rh constree-of-bytes)
  (match-define (web-response-header code resp-message last-modified-seconds mime-type headers) rh)
  (channel-put control-ch
               (list 'response
                     (response/full code
                                    resp-message
                                    last-modified-seconds
                                    mime-type
                                    (build-headers headers)
                                    (flatten constree-of-bytes)))))

(define (do-response-chunked control-ch id rh)
  (match-define (web-response-header code resp-message last-modified-seconds mime-type headers) rh)
  (define stream-ch (make-async-channel))
  (react (stop-when (retracted (web-response-chunked id rh)))
         (on-stop (async-channel-put stream-ch #f))
         (on (message (web-response-chunk id $chunk))
             (async-channel-put stream-ch (flatten chunk)))
         (on-start (channel-put control-ch
                                (list 'response
                                      (response code
                                                resp-message
                                                last-modified-seconds
                                                mime-type
                                                (build-headers headers)
                                                (lambda (output-port)
                                                  (let loop ()
                                                    (match (async-channel-get stream-ch)
                                                      [#f
                                                       (void)]
                                                      [bss (for [(bs (in-list bss))]
                                                             (write-bytes bs
                                                                          output-port))
                                                           (loop)])))))))))

(define (do-response-websocket control-ch id headers)
  (define ws-ch (make-channel))
  (react (stop-when (retracted (web-response-websocket id headers)))
         (on-start (channel-put control-ch (list 'websocket headers ws-ch)))
         (run-websocket-connection id ws-ch)))

(define (run-websocket-connection id ws-ch)
  (on-stop (channel-put ws-ch 'quit))
  (on (message (websocket-message id 'outbound $body))
      (channel-put ws-ch (list 'send body)))
  (stop-when (message (inbound (web-incoming-message id (? eof-object? _)))))
  (on (message (inbound (web-incoming-message id $body)))
      (unless (eof-object? body) (send! (websocket-message id 'inbound body)))))

(define (req->virtual-host scheme r port)
  (cond [(assq 'host (request-headers r)) =>
         (lambda (h)
           (match (cdr h)
             [(regexp #px"(.*):(\\d+)" (list _ host port))
              (web-virtual-host scheme host (string->number port))]
             [host
              (web-virtual-host scheme host port)]))]
        [else
         (web-virtual-host scheme #f port)]))

(define (format-url-path u)
  (define elements (for/list [(p (in-list (url-path u)))]
                     (match-define (path/param path-element params) p)
                     (list* path-element params)))
  (foldr (lambda (e acc) (append e (list acc))) '() elements))

(define (build-headers hs)
  (for/list ((h (in-list hs)))
    (header (string->bytes/utf-8 (symbol->string (car h)))
            (string->bytes/utf-8 (cdr h)))))

(define (build-http-client-headers hs)
  (for/list ((h (in-list hs)))
    (format "~a: ~a" (car h) (cdr h))))

(define (handle-incoming-connection listen-port cm connection-ports)
  (thread
   (lambda ()
     (match-define (list i o) connection-ports)
     ;; Deliberately construct an empty custodian for the connection. Killing the connection
     ;; abruptly can cause deadlocks since the connection thread communicates with Syndicate
     ;; via synchronous channels.
     (define conn
       (new-connection cm (web-server-initial-connection-timeout) i o (make-custodian) #f))
     (define control-ch (make-channel))
     (let do-request ()
       (define-values (req initial-headers) ;; TODO initial-headers?!?!
         (with-handlers ([exn:fail? (lambda (e) (values #f #f))])
           (read-request conn listen-port tcp-addresses)))
       (when req
         (define id (gensym 'web))
         (send-ground-message (web-raw-request id listen-port conn req control-ch))
         (sync (handle-evt control-ch
                           (match-lambda
                             [(list 'websocket reply-headers ws-ch)
                              (with-handlers ((exn:dispatcher?
                                               (lambda (_e) (bad-request conn req))))
                                ((make-general-websockets-dispatcher
                                  (websocket-connection-main id ws-ch)
                                  (lambda _args (values reply-headers (void))))
                                 conn req))]
                             [(list 'response resp)
                              (output-response/method conn resp (request-method req))])))
         (do-request))))))

;; D-:  uck barf
;; TODO: something to fix this :-/
(define (exn:fail:port-is-closed? e)
  (and (exn:fail? e)
       (regexp-match #px"port is closed" (exn-message e))))

(define ((websocket-connection-main id ws-ch) wsc _ws-connection-state)
  (let loop ()
    (sync (handle-evt wsc
                      (lambda _args
                        (define msg
                          (with-handlers ([exn:fail:network? (lambda (e) eof)]
                                          [exn:fail:port-is-closed? (lambda (e) eof)]
                                          [exn:fail? (lambda (e)
                                                       (log-error "Unexpected ws-recv error: ~a"
                                                                  (exn->string e))
                                                       eof)])
                            (ws-recv wsc #:payload-type 'text)))
                        (send-ground-message (web-incoming-message id msg))
                        (loop)))
          (handle-evt ws-ch
                      (match-lambda
                        ['quit
                         (void)]
                        [(list 'send m)
                         (with-handlers [(exn:fail:port-is-closed?
                                          (lambda (e)
                                            (ws-close! wsc)))]
                           (ws-send! wsc m))
                         (loop)]))))
  (ws-close! wsc))

(define (bad-request conn req)
  (output-response/method conn
                          (response/full 400
                                         #"Bad request"
                                         (current-seconds)
                                         #"text/plain"
                                         (list)
                                         (list))
                          (request-method req)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (do-client-request id req body)
  (react
   (stop-when (asserted (observe (web-response-websocket id _)))
              (do-request-websocket id req))
   (stop-when (asserted (observe (web-response-complete id _ _)))
              (do-request-complete id req body))
   (stop-when (asserted (observe (web-response-chunked id _)))
              (do-request-chunked id req body))))

(define (analyze-outbound-request req)
  (match-define (web-request-header method
                                    (web-resource (web-virtual-host scheme host port) path)
                                    headers
                                    query)
    req)
  (values host
          (or port (match scheme
                     ["http" 80]
                     ["https" 443]
                     [_ #f]))
          method
          (url->string (url scheme
                            #f
                            host
                            port
                            #t
                            (let loop ((p path))
                              (match p
                                ['() '()]
                                [(list d par ... rest)
                                 (cons (path/param d par) (loop rest))]))
                            query
                            #f))
          headers))

(define (do-request-websocket id req)
  (define-values (_host server-port method urlstr headers) (analyze-outbound-request req))
  (define control-ch (make-channel))
  (if (not server-port)
      (send-ground-message (web-raw-client-conn id #f))
      (thread
       (lambda ()
         (log-info "Connecting to ~a ~a" urlstr (current-inexact-milliseconds))
         (define c (with-handlers [(exn? values)]
                     (ws-connect (string->url urlstr) #:headers headers)))
         (when (exn? c)
           (log-info "Connection to ~a failed: ~a" urlstr (exn->string c)))
         (send-ground-message (web-raw-client-conn id c))
         (when (not (exn? c))
           (log-info "Connected to ~a ~a" url (current-inexact-milliseconds))
           ((websocket-connection-main id control-ch) c (void))))))
  (react
   (stop-when (message (inbound (web-raw-client-conn id $c)))
              (react (stop-when (retracted (observe (web-response-websocket id _))))
                     (if (ws-conn? c)
                         (begin (assert (web-response-websocket id (ws-conn-headers c)))
                                (run-websocket-connection id control-ch))
                         (assert (web-response-websocket id #f)))))))

(define (do-request-complete id req body)
  (define-values (host server-port method urlstr headers) (analyze-outbound-request req))
  (thread
   (lambda ()
     (define response
       (with-handlers [(exn? values)]
         (when (not server-port)
           (error 'http-sendrecv "No server port specified"))
         (define-values (first-line header-lines body-port)
           (http-sendrecv host
                          urlstr
                          #:headers (build-http-client-headers headers)
                          #:port server-port
                          #:method (string-upcase (symbol->string method))
                          #:data (bytes-join (flatten body) #"")))
         (match first-line
           [(regexp #px"\\S+\\s(\\d+)\\s(.*)" (list _ codebs msgbs))
            (define code (string->number (bytes->string/latin-1 codebs)))
            (define msg (bytes->string/utf-8 msgbs))
            (define response-headers
              (for/list ((h (in-list (read-headers (open-input-bytes
                                                    (bytes-join header-lines #"\r\n"))))))
                (match-define (header k v) h)
                (cons (lowercase-symbol! (bytes->string/utf-8 k))
                      (bytes->string/utf-8 v))))
            (define response-body (port->bytes body-port))
            (web-response-complete id
                                   (web-response-header code
                                                        msg
                                                        #f ;; TODO: fill in from response-headers
                                                        (cond [(assq 'content-type response-headers)
                                                               => cdr]
                                                              [else #f])
                                                        response-headers)
                                   response-body)]
           [_
            (error 'http-sendrecv "Bad first line: ~v" first-line)])))
     (send-ground-message (web-raw-client-conn id response))))
  (react
   (stop-when (message (inbound (web-raw-client-conn id $r)))
              (react (stop-when (retracted (observe (web-response-complete id _ _))))
                     (if (exn? r)
                         (assert (web-response-websocket id #f #f))
                         (begin (assert r)))))))

(define (do-request-chunked id req body)
  (log-error "do-request-chunked: unimplemented")
  (react (stop-when (retracted (observe (web-response-chunked id _))))
         (assert (web-response-chunked id #f))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(spawn-web-driver)