;;
;; Definitions common to CGI and FCGI.
;;
;; TODO: Should this be a module?

(define (environmentize str)
  (conc "HTTP_" (string-upcase (string-translate str "-" "_"))))

(define (alist->envlist alist)
  (map (lambda (entry)
         (conc (car entry) "=" (or (cdr entry) "")))
       alist))

(define (create-header-env headers)
  (fold
   (lambda (h result)
     ;; As per RFC 3875, section 4.1.18, remove all redundant information
     ;; all information related to authentication.
     ;; Avoid "httpoxy" attack which is enabled by "Proxy" header
     ;; being used for outbound proxy by CGI scripts via HTTP_PROXY.
     (if (member (car h) '(content-type content-length authorization proxy))
         result
         (append! (map (lambda (x)
                         (cons (environmentize (symbol->http-name (car h))) x))
                       (unparse-header (car h) (cdr h))) result)))
   '() (headers->list headers)))

(define (cgi-standard-server-env req)
  `( ;; TODO: Enable and find a script that requires auth, then test it!
    #;("AUTH_TYPE" . ,(header-value 'authorization
    (request-headers req)))
    ;; Username MUST be available when AUTH_TYPE is set
    #;("REMOTE_USER" . ,(header-value ... ))
    ;; We're not supposed to send CONTENT_LENGTH to an Authorizer.
    ("CONTENT_LENGTH" . ,(header-value 'content-length
                                       (request-headers req)))
    ("CONTENT_TYPE" . ,(and-let* ((contents (header-contents
                                             'content-type
                                             (request-headers req))))
                         (car (unparse-header 'content-type contents))))
    ;; We're not supposed to send PATH_INFO to an Authorizer.
    ;; This doesn't seem to work anyway.
    ("PATH_INFO" . ,(and (current-pathinfo)
                         (string-join (current-pathinfo) "/")))
    ;; This isn't in the CGI spec, but lots of scripts expect to see it.
    ("REQUEST_URI" . ,(string-append "/"
                                     (string-join (cdr (uri-path (request-uri req))) "/")
                                     (or (and-let* ((query-string
                                                     (generic:uri-query
                                                      (uri->uri-generic (request-uri req)))))
                                           (string-append
                                            "?"
                                            query-string)) "")))
    ("QUERY_STRING" . ,(generic:uri-query
                        (uri->uri-generic (request-uri req))))
    ("REMOTE_ADDR" . ,(remote-address))
    ;; This should really be the FQDN of the remote address
    ("REMOTE_HOST" . ,(remote-address))
    ("REQUEST_METHOD" . ,(request-method req))
    ("SERVER_NAME" . ,(uri-host (request-uri req)))
    ("SERVER_PORT" . ,(server-port)) ; OK?
    ("SERVER_PROTOCOL" . ,(sprintf "HTTP/~A.~A" ; protocol, NOT scheme
                            (request-major req)
                            (request-minor req)))
    ("SERVER_SOFTWARE" . ,(and-let* ((contents (header-contents
                                                'server
                                                (response-headers
                                                 (current-response)))))
                            (car (unparse-header 'server contents))))
    ;; RFC 3875, section 4.1.6:
    ;; "The value is derived in this way irrespective of whether
    ;; it maps to a valid repository location."
    ;; ie, this value does not always make sense
    ;; We're not supposed to send PATH_TRANSLATED to an Authorizer.
    ;; This doesn't seem to work anyway.
    ("PATH_TRANSLATED" . ,(and (current-pathinfo)
                               (not (null? (current-pathinfo)))
                               (make-pathname
                                (root-path)
                                (string-join (current-pathinfo) "/"))))
    ;; PHP _always_ wants the REDIRECT_STATUS "for security",
    ;; so just initialize it unconditionally.
    ;; See http://php.net/security.cgi-bin
    ("REDIRECT_STATUS" . ,(response-code (current-response)))
    ;; Nonstandard but reasonably widely used Apache extension
    ("HTTPS" . ,(and (secure-connection?) "on"))))

;; "the server retains its responsibility to the client to conform to the
;;  relevant network protocol even if the CGI script fails to conform to
;;  this specification." -- RFC 3875, Section 3.1
;; The simplest way to ensure that the client conforms to the protocol
;; is to discard any content-length headers and simply close the connection.
(define (sanitize-headers script-headers)
  (headers '((connection close))
           (remove-header 'content-length script-headers)))

(define (status-parser str)
  (cond
   ((irregex-match "([0-9]+) (.+)" str) =>
    (lambda (m) (cons (string->number (irregex-match-substring m 1))
                      (irregex-match-substring m 2))))
    (else
     (signal (make-composite-condition
              (make-property-condition 'cgi)
              (make-property-condition 'status-error)
              (make-property-condition 'exn
                                       'message "Bad (F)CGI status line"
                                       'arguments (list str)))))))

;; This is slightly different from intarweb's read-headers: It knows
;; about the special "status" header, and it allows CR-only line
;; endings, as allowed by the CGI spec.  Intarweb strictly follows the
;; HTTP spec, which allows only CRLF.  We also don't enforce header
;; size limits here because this not coming from an untrusted client.
(define (read-cgi-headers i)
  (let lp ((h (headers '()))
           (ln (read-line i)))
    (if (or (eof-object? ln) (string=? "" ln))
        h
        (lp (parse-header-line ln h) (read-line i)))))

(define (parse-cgi-header name contents)
  (if (eq? name 'status)
      ((single status-parser) contents)
      (let* ((default unknown-header-parser)
             (parser (alist-ref name (header-parsers) eq? default)))
        (parser contents))))

;; Copied from intarweb.  That's a bit unfortunate.
(define (parse-header-line line headers)
  (or
   (and-let* ((colon-idx   (string-index line #\:))
              (header-name (http-name->symbol (string-take line colon-idx)))
              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
     (handle-exceptions
         exn
         ((header-parse-error-handler) header-name contents headers exn)
       (update-header-contents!
        header-name (parse-cgi-header header-name contents) headers)))
   (signal (make-composite-condition
            (make-property-condition 'cgi)
            (make-property-condition 'header-error)
            (make-property-condition 'exn
                                     'message "Bad (F)CGI header line"
                                     'arguments (list line))))))