;;;
;;; HTTP client based on libcurl with robust HTTPS support
;;;
;; Copyright (c) 2025, Rolando Abarca
;; BSD-3-Clause license (see LICENSE)
;;

(module http-curl
  (call-with-input-request
   call-with-input-request*
   with-input-from-request
   call-with-response
   max-retry-attempts
   max-redirect-depth
   max-idle-connections
   client-software
   retry-request?
   close-connection!
   close-idle-connections!
   store-cookie!
   delete-cookie!
   get-cookies-for-uri
   http-authenticators
   determine-username/password
   determine-proxy-username/password
   determine-proxy
   determine-proxy-from-environment
   prepare-request
   default-prepare-request
   ;; Internal helper exported for offline tests; not part of the public API.
   %prepare-input-request
   server-connector
   default-server-connector)

(import scheme
        (chicken base)
        (chicken string)
        (chicken io)
        (chicken port)
        (chicken format)
        (chicken foreign)
        (chicken condition)
        (chicken file posix)
        (chicken memory)
        (chicken process-context)
        srfi-1
        srfi-13
        srfi-18
        intarweb
        uri-common)

;; ==================== FFI ====================

(foreign-declare "#include \"curl_helpers.c\"")

(define curl-request-start
  (foreign-lambda c-pointer "curl_request_start"
    c-string      ; url
    c-string      ; method
    c-string      ; headers_str
    scheme-pointer ; body
    size_t        ; body_len
    bool          ; follow_redirects
    long          ; max_redirects
    c-string      ; useragent
    c-string      ; proxy
    c-string))    ; userpwd

(define curl-request-wait-headers
  (foreign-lambda long "curl_request_wait_headers" c-pointer))

(define curl-request-get-headers
  (foreign-lambda c-string "curl_request_get_headers" c-pointer))

(define curl-request-get-body-fd
  (foreign-lambda int "curl_request_get_body_fd" c-pointer))

(define curl-request-finish
  (foreign-lambda int "curl_request_finish" c-pointer))

(define curl-request-get-error
  (foreign-lambda c-string "curl_request_get_error" c-pointer))

;; ==================== Parameters ====================

(define max-retry-attempts (make-parameter 1))
(define max-redirect-depth (make-parameter 5))
(define max-idle-connections (make-parameter 32))
(define client-software (make-parameter "http-curl/0.1"))
(define retry-request? (make-parameter (lambda (req) #t)))

;; Connection management (no-ops — curl manages connections)
(define (close-connection! . args) (void))
(define (close-idle-connections! . args) (void))

;; Cookie stubs
(define (store-cookie! . args) (void))
(define (delete-cookie! . args) (void))
(define (get-cookies-for-uri . args) '())

;; Auth stubs
(define http-authenticators (make-parameter '()))
(define determine-username/password (make-parameter (lambda (uri realm) (values #f #f))))
(define determine-proxy-username/password (make-parameter (lambda (uri realm) (values #f #f))))

;; Proxy
(define (determine-proxy-from-environment uri)
  (let* ((scheme (uri-scheme uri))
         (env-var (case scheme
                    ((https) "https_proxy")
                    (else "http_proxy"))))
    (get-environment-variable env-var)))

(define determine-proxy (make-parameter determine-proxy-from-environment))

;; Request preparation
(define (default-prepare-request req) req)
(define prepare-request (make-parameter default-prepare-request))

;; Server connector (no-op — curl handles connections)
(define (default-server-connector uri proxy) (void))
(define server-connector (make-parameter default-server-connector))

;; ==================== Error helpers ====================

(define (http-client-error loc msg args specific . rest)
  (raise (apply make-composite-condition
          (make-property-condition 'exn 'location loc 'message msg 'arguments args)
          (make-property-condition 'http)
          (list (apply make-property-condition specific rest)))))

;; ==================== Header serialization ====================

(define (serialize-request-headers req)
  ;; Write headers to a string using intarweb's unparse-headers
  (let ((out (open-output-string)))
    (unparse-headers (request-headers req) out)
    (get-output-string out)))

;; ==================== Delimited input port ====================

(define (make-delimited-input-port port len)
  (if (not len)
      port
      (let ((pos 0))
        (make-input-port
         (lambda ()                     ; read-char
           (if (>= pos len) #!eof
               (let ((c (read-char port)))
                 (if (eof-object? c) c
                     (begin (set! pos (add1 pos)) c)))))
         (lambda ()                     ; char-ready?
           (or (>= pos len) (char-ready? port)))
         (lambda ()                     ; close
           (close-input-port port))
         (lambda ()                     ; peek-char
           (if (>= pos len) #!eof
               (peek-char port)))
         (lambda (p bytes buf off)      ; read-string!
           (let* ((bytes (min bytes (- len pos)))
                  (bytes-read (read-string! bytes buf port off)))
             (set! pos (+ pos bytes-read))
             bytes-read))))))

;; ==================== Core implementation ====================

(define (call-with-response req writer reader)
  (let* ((uri (request-uri req))
         (req ((prepare-request) req))
         ;; Serialize the request body
         (body-data
          (if writer
              (let ((out (open-output-string)))
                (writer out)
                (get-output-string out))
              #f))
         ;; Build URL from URI
         (url (uri->string uri))
         ;; Build method string
         (method (string-upcase (symbol->string (request-method req))))
         ;; Serialize headers
         (headers-str (serialize-request-headers req))
         ;; Get proxy
         (proxy-val ((determine-proxy) uri))
         ;; Get user agent
         (ua (client-software))
         ;; Start curl request
         (handle (curl-request-start
                  url
                  method
                  headers-str
                  (if body-data body-data #f)
                  (if body-data (string-length body-data) 0)
                  #t
                  (or (max-redirect-depth) 50)
                  (if (string? ua) ua "")
                  (if (string? proxy-val) proxy-val #f)
                  #f)))
    (unless handle
      (http-client-error 'call-with-response
                         "Failed to initialize curl request"
                         (list url)
                         'curl-error))
    (let ((finished? #f))
      (define (finish-once!)
        (unless finished?
          (set! finished? #t)
          (curl-request-finish handle)))
      (dynamic-wind
        void
        (lambda ()
          (let* ((_ (curl-request-wait-headers handle))
                 (raw-headers (curl-request-get-headers handle))
                 ;; Parse headers using intarweb
                 (response (read-response (open-input-string raw-headers))))
            (unless response
              (let ((err (curl-request-get-error handle)))
                (http-client-error 'call-with-response
                                   (if (and err (> (string-length err) 0))
                                       err
                                       "Failed to get response from server")
                                   (list url)
                                   'premature-disconnection
                                   'uri uri 'request req)))
            ;; Replace the response port with our streaming body port
            (let* ((body-fd (curl-request-get-body-fd handle))
                   (body-port (open-input-file* body-fd))
                   (response (update-response response port: body-port))
                   (data (reader response)))
              (values data uri response))))
        finish-once!))))

(define (%prepare-input-request uri-or-request writer reader)
  (let* ((uri (cond ((uri-reference? uri-or-request) uri-or-request)
                    ((string? uri-or-request) (uri-reference uri-or-request))
                    ((request? uri-or-request) (request-uri uri-or-request))
                    (else #f)))
         (_ (unless (uri? uri)
              (http-client-error
               'call-with-input-request
               (if (uri-reference? uri)
                   "Bad argument: URI must be a proper URI, not a relative reference"
                   "The first argument must be either a URI, request, or URI string")
               (list uri-or-request writer reader)
               'bad-uri 'uri uri-or-request)))
         (req (if (request? uri-or-request)
                  uri-or-request
                  (make-request uri: uri method: (if writer 'POST 'GET))))
         ;; Process writer to get body string and type headers
         (type-headers '())
         (body-str
          (cond
           ((string? writer) writer)
           ((list? writer)
            (set! type-headers '((content-type application/x-www-form-urlencoded)))
            (or (form-urlencode writer separator: "&")
                (http-client-error 'call-with-input-request
                                   "Invalid form data!"
                                   (list writer)
                                   'form-data-error)))
           ((not writer) #f)
           ((procedure? writer) #f) ;; handled below
           (else #f)))
         ;; Add content-type headers if needed
          (req (if (null? type-headers)
                   req
                   (update-request
                    req headers: (headers type-headers (request-headers req))))))
    (values
     req
     uri
     (cond
      (body-str
       (lambda (out) (display body-str out)))
      ((procedure? writer)
       (lambda (out) (writer out)))
      (else (lambda (out) (void)))))))

(define (call-with-input-request* uri-or-request writer reader)
  (let-values (((req uri body-writer)
                (%prepare-input-request uri-or-request writer reader)))
    (call-with-response
     req
     body-writer
     (lambda (response)
       (let* ((content-len (header-value 'content-length
                                          (response-headers response)))
              (port (make-delimited-input-port (response-port response)
                                               content-len)))
         (if (= 200 (response-class response))
             (if reader (reader port response) (void))
             (http-client-error
              'call-with-input-request
              (sprintf (case (response-class response)
                         ((400) "Client error: ~A ~A")
                         ((500) "Server error: ~A ~A")
                         (else "Unexpected server response: ~A ~A"))
                (response-code response) (response-reason response))
              (list (request-method req) (uri->string uri))
              (case (response-class response)
                ((400) 'client-error)
                ((500) 'server-error)
                (else 'unexpected-server-response))
              'response response
              'body (read-string #f port))))))))

(define (call-with-input-request uri-or-request writer reader)
  (call-with-input-request* uri-or-request writer (lambda (p r) (reader p))))

(define (with-input-from-request uri-or-request writer reader)
  (call-with-input-request uri-or-request
                           (if (procedure? writer)
                               (lambda (p) (with-output-to-port p writer))
                               writer)
                           (lambda (p) (with-input-from-port p reader))))

) ;; end module