docker/protocol.lisp

(in-package #:nekod.docker)

;;; Incremental HTTP/1.1 parser for Docker Engine API over Unix socket

(defvar *max-header-size* (* 64 1024))
(defvar *connection-policy* :close)

(defstruct http-response
  (version "" :type string)
  (status 0 :type integer)
  (reason "" :type string)
  (headers nil :type list)
  (body #() :type (vector (unsigned-byte 8))))

(defstruct http-parser-state
  (buffer (make-array 4096 :element-type '(unsigned-byte 8)
                           :adjustable t :fill-pointer 0))
  (header-complete nil :type boolean)
  (content-length nil)
  (chunked nil :type boolean)
  (body-bytes-read 0 :type integer)
  (complete nil :type boolean))

;;; --- HTTP request building ---

(defun build-http-request (method path &optional body)
  "Build an HTTP/1.1 request string for the Docker API."
  (let* ((body-octets (if body
                          (nekod.docker::string-to-octets body)
                          #()))
         (content-length (length body-octets))
         (connection (if (eq *connection-policy* :keep-alive) "keep-alive" "close")))
    (format nil "~a ~a HTTP/1.1\r\nHost: localhost\r\nContent-Type: application/json\r\nContent-Length: ~a\r\nConnection: ~a\r\n\r\n~@[~a~]"
            method path content-length connection body)))

;;; --- Incremental HTTP response parsing ---

(defun parse-status-line (line)
  "Parse 'HTTP/1.1 200 OK' into (values version status reason)."
  (let* ((sp1 (position #\Space line))
         (sp2 (and sp1 (position #\Space line :start (1+ sp1)))))
    (unless (and sp1 sp2)
      (error 'nekod:http-protocol-error
             :message (format nil "Malformed status line: ~a" line)))
    (values (subseq line 0 sp1)
            (parse-integer (subseq line (1+ sp1) sp2))
            (subseq line (1+ sp2)))))

(defun parse-http-headers (header-text)
  "Parse header block into alist of (name . value)."
  (let ((headers nil)
        (lines (remove "" (mapcar (lambda (l) (string-trim '(#\Return) l))
                                  (uiop:split-string header-text :separator '(#\Newline)))
                       :test #'string=)))
    (dolist (line lines)
      (let ((colon (position #\: line)))
        (when colon
          (push (cons (string-downcase (subseq line 0 colon))
                      (string-trim '(#\Space) (subseq line (1+ colon))))
                headers))))
    (nreverse headers)))

(defun header-value (headers name)
  "Get header value by lowercase name from alist."
  (cdr (assoc name headers :test #'string=)))

(defun decode-chunk-size (line)
  "Decode hex chunk size from a chunk header line."
  (parse-integer (string-trim '(#\Return #\Newline #\Space) line)
                 :radix 16 :junk-allowed t))

;;; --- Body reading strategies ---

(defun read-content-length-body (sock content-length)
  "Read exactly content-length bytes from socket."
  (let ((body (make-array content-length :element-type '(unsigned-byte 8)))
        (total-read 0))
    (loop while (< total-read content-length)
          do (let ((n (socket-read-octets sock body
                                          :start total-read
                                          :end content-length)))
               (when (<= n total-read)
                 (error 'nekod:http-body-truncated
                        :message "Connection closed before body complete"
                        :expected content-length
                        :received total-read))
               (setf total-read n)))
    body))

(defun read-chunked-body (sock)
  "Read chunked transfer-encoding body incrementally."
  (let ((result (make-array 0 :element-type '(unsigned-byte 8)
                              :adjustable t :fill-pointer 0)))
    (loop
      (let* ((size-line-octets (socket-read-until sock (format nil "~c~c" #\Return #\Newline)))
             (size-line (nekod.docker::octets-to-string size-line-octets :external-format :utf-8))
             (chunk-size (decode-chunk-size size-line)))
        (when (or (null chunk-size) (zerop chunk-size))
          (socket-read-until sock (format nil "~c~c" #\Return #\Newline))
          (return result))
        (let ((chunk (make-array chunk-size :element-type '(unsigned-byte 8)))
              (read-so-far 0))
          (loop while (< read-so-far chunk-size)
                do (let ((n (socket-read-octets sock chunk
                                                :start read-so-far
                                                :end chunk-size)))
                     (when (<= n read-so-far)
                       (error 'nekod:http-body-truncated
                              :message "Chunk truncated"
                              :expected chunk-size
                              :received read-so-far))
                     (setf read-so-far n)))
          (loop for b across chunk do (vector-push-extend b result))
          (socket-read-until sock (format nil "~c~c" #\Return #\Newline)))))
    result))

;;; --- Full response reader ---

(defun read-http-response (sock)
  "Read a complete HTTP response from socket. Handles fragmented reads."
  (let* ((header-octets (socket-read-until sock (format nil "~c~c~c~c"
                                                        #\Return #\Newline
                                                        #\Return #\Newline)
                                           :max-bytes *max-header-size*))
         (header-text (nekod.docker::octets-to-string header-octets :external-format :utf-8))
         (header-end (search (format nil "~c~c~c~c" #\Return #\Newline #\Return #\Newline)
                             header-text))
         (status-end (position #\Newline header-text))
         (status-line (subseq header-text 0 (and status-end
                                                  (if (and status-end
                                                           (> status-end 0)
                                                           (char= (char header-text (1- status-end)) #\Return))
                                                      (1- status-end)
                                                      status-end))))
         (header-block (if header-end
                           (subseq header-text (1+ status-end) header-end)
                           "")))
    (multiple-value-bind (version status reason) (parse-status-line status-line)
      (let* ((headers (parse-http-headers header-block))
             (cl-val (header-value headers "content-length"))
             (te-val (header-value headers "transfer-encoding"))
             (content-length (and cl-val (parse-integer cl-val :junk-allowed t)))
             (chunked-p (and te-val (search "chunked" te-val)))
             (body (cond
                     ((member status '(204 304 101))
                      (make-array 0 :element-type '(unsigned-byte 8)))
                     (chunked-p
                      (read-chunked-body sock))
                     (content-length
                      (read-content-length-body sock content-length))
                     (t
                      (make-array 0 :element-type '(unsigned-byte 8))))))
        (make-http-response :version version
                            :status status
                            :reason reason
                            :headers headers
                            :body body)))))

;;; --- Convenience API (backward compatible) ---

(defun parse-http-response (raw)
  "Legacy: Parse HTTP response string. Extract status code and body."
  (let* ((header-end (search (format nil "~c~c~c~c" #\Return #\Newline #\Return #\Newline) raw))
         (status-line (subseq raw 0 (position #\Return raw)))
         (sp1 (position #\Space status-line))
         (sp2 (and sp1 (position #\Space status-line :start (1+ sp1))))
         (status-code (and sp1 sp2 (parse-integer (subseq status-line (1+ sp1) sp2)
                                                  :junk-allowed t)))
         (body (if header-end (subseq raw (+ header-end 4)) "")))
    (values (or status-code 0) body)))

(defun docker-request (sock method path &optional body)
  "Send HTTP request and read full response via real socket transport.
   Returns http-response struct."
  (let ((req (build-http-request method path body)))
    (socket-write sock req)
    (read-http-response sock)))

(defun docker-get (sock path)
  "GET request to Docker API. Returns (values status body-string)."
  (let ((resp (docker-request sock "GET" path)))
    (values (http-response-status resp)
            (nekod.docker::octets-to-string (http-response-body resp)
                                     :external-format :utf-8))))

(defun docker-post (sock path &optional body)
  "POST request to Docker API. Returns (values status body-string)."
  (let ((resp (docker-request sock "POST" path body)))
    (values (http-response-status resp)
            (nekod.docker::octets-to-string (http-response-body resp)
                                     :external-format :utf-8))))

(defun docker-delete (sock path)
  "DELETE request to Docker API. Returns (values status body-string)."
  (let ((resp (docker-request sock "DELETE" path)))
    (values (http-response-status resp)
            (nekod.docker::octets-to-string (http-response-body resp)
                                     :external-format :utf-8))))