guile-openai/openai/utils/multipart.scm

;;; guile-openai --- An OpenAI API client for Guile
;;; Copyright © 2023 Andrew Whatson <whatson@tailcall.au>
;;;
;;; This file is part of guile-openai.
;;;
;;; guile-openai is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; guile-openai is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with guile-openai.  If not, see
;;; <https://www.gnu.org/licenses/>.

(define-module (openai utils multipart)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 textual-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (web http)
  #:export (multipart-param
            multipart-file

            multipart-param->tree
            multipart-params->tree

            multipart-tree-fold
            multipart-tree-for-each
            multipart-tree-visit

            write-multipart-tree
            multipart-tree->bytevector))

(define (multipart-piece type key val)
  (if (not (unspecified? val))
      `((,type ,key ,val))
      '()))

(define (multipart-param key val)
  (multipart-piece 'param key val))

(define (multipart-file key val)
  (multipart-piece 'file key val))

(define (multipart-param->tree param boundary)
  "Transform PARAM, a tagged list describing a single form parameter, into
a tree of strings and bytevectors ready for serialization as a
multipart/form-data payload, using BOUNDARY as the part separator."
  (match param
    (('param name value)
     ;; render a simple form parameter
     (list
      "--" boundary "\r\n"
      (call-with-output-string
        (lambda (port)
          (write-headers `((content-disposition form-data
                            (name . ,(symbol->string name))))
                         port)))
      "\r\n"
      (call-with-output-string
        (lambda (port)
          (display value port)))
      "\r\n"))
    (('file name filename type)
     ;; render a file form parameter
     (list
      "--" boundary "\r\n"
      (call-with-output-string
        (lambda (port)
          (write-headers `((content-disposition form-data
                            (name . ,(symbol->string name))
                            (filename . ,(basename filename)))
                           (content-type . ,type))
                         port)))
      "\r\n"
      (call-with-input-file filename
        (lambda (port)
          (get-bytevector-all port)))
      "\r\n"))
    (('file name filename)
     ;; provide a default content-type for files
     ;; TODO try to identify the correct mimetype
     (let ((type '(application/octet-stream)))
       (multipart-param->tree (list 'file name filename type) boundary)))))

(define (multipart-params->tree params boundary)
  "Transform PARAMS, a list of form parameters in tagged list format, into
a tree of strings and bytevectors ready for serialization as a
multipart/form-data payload, using BOUNDARY as the part separator."
  (list
   (map (lambda (param)
          (multipart-param->tree param boundary))
        params)
   "--" boundary "--"))

(define (multipart-tree-fold proc init tree)
  "Fold over the leaves of TREE in depth-first order, calling (PROC LEAF
INIT) on the first leaf, and (PROC LEAF RESULT) on subsequent leaves,
where RESULT is the return value of the previous call to PROC.  Returns
the final RESULT."
  (let loop ((tree tree) (result init))
    (cond ((null? tree)
           result)
          ((not (pair? tree))
           (proc tree result))
          (else
           (loop (cdr tree)
                 (loop (car tree)
                       result))))))

(define (multipart-tree-for-each proc tree)
  "Call (PROC LEAF) on each leaf of TREE in depth-first order."
  (multipart-tree-fold (lambda (elem _)
                         (proc elem)
                         _)
                       *unspecified* tree))

(define (multipart-tree-visit on-string on-bytevector tree)
  "Traverse TREE in depth-first order, calling (ON-STRING LEAF) on string
leaves, and (ON-BYTEVECTOR LEAF) on bytevector leaves."
  (multipart-tree-for-each (match-lambda
                             ((? string? str)
                              (on-string str))
                             ((? bytevector? bv)
                              (on-bytevector bv)))
                           tree))

(define (write-multipart-tree tree port)
  "Serialize TREE into PORT."
  (multipart-tree-visit
   (lambda (str) (put-string port str))
   (lambda (bv) (put-bytevector port bv))
   tree))

(define (multipart-tree->bytevector tree)
  "Serialize TREE into a bytevector."
  (call-with-output-bytevector
   (lambda (port)
     (write-multipart-tree tree port))))