(define-module(www mime-multipart)#:export(parse-multipart)#:use-module((www mime-headers)#:select(p-ref parse-type top-typed? parse-headers))#:use-module((ice-9 binary-ports)#:select(get-bytevector-n put-bytevector))#:use-module((srfi srfi-4)#:select(u8vector u8vector-length u8vector-ref)))
(define call-with-ignored-port-encoding(cond-expand(guile-2(lambda(thunk)(with-fluids((%default-port-encoding #f))(thunk))))(else(lambda(thunk)(thunk)))))
(define-macro (ignore-default-port-encoding . body) `(call-with-ignored-port-encoding(lambda() ,@body)))
(define(interesting buf boundary)(set! boundary(string-append "--" boundary))(let*((buf-lim(u8vector-length buf))(boundary-len(string-length boundary))(etc(apply u8vector(map char->integer(string->list boundary))))(beg(u8vector-ref etc 0))(end(u8vector-ref etc(#{1-}# boundary-len))))(define(buf-ref i)(u8vector-ref buf i))(define(find-beg i)(and(< i buf-lim)(if(= beg(buf-ref i))i(find-beg(#{1+}# i)))))(define(rest-all-same i)(let loop((idx(#{1-}# boundary-len)))(or(zero? idx)(let((bx(+ i idx)))(and(< bx buf-lim)(=(buf-ref bx)(u8vector-ref etc idx))(loop(#{1-}# idx)))))))(let loop((acc(list 0))(i 0))(cond((find-beg i)=>(lambda(at)(if(rest-all-same at)(let((h-beg(max 0(- at 2)))(h-end(+ 2 at boundary-len)))(loop(cons* h-end(cons(car acc)h-beg)(cdr acc))h-end))(loop acc(#{1+}# at)))))(else(cdr(reverse!(cdr acc))))))))
(define(parse-multipart type port len)(let*((buf(get-bytevector-n port len))(spans(interesting buf(p-ref type  'boundary)))(eye 0))(define(eye! n)(set! eye n))(define(buf-get-one-char)(let((ch(integer->char(u8vector-ref buf eye))))(eye!(#{1+}# eye))ch))(define(buf-close)(set! buf #f))(define done-with-buf!(let((n(length spans)))(lambda()(set! n(#{1-}# n))(and(zero? n)(buf-close)))))(let((port(ignore-default-port-encoding(make-soft-port(vector #f #f #f buf-get-one-char buf-close)"r"))))(define(port-at n)(eye! n)port)(define(unflatten span)(let*((headers(parse-headers(port-at(car span))))(beg eye)(len(-(cdr span)beg))(buf buf))(define(port-at-body)(port-at beg))(define(ok rv)(set! buf #f)(done-with-buf!)rv)(define(bad-move! reason)(throw  'move-part reason))(define(move to)(or buf(bad-move!  'no-longer-available))(ok(if(port? to)(put-bytevector to buf beg len)(case to((#t)(get-bytevector-n(port-at-body)len))((#f)to)(else(bad-move!  'bad-to))))))(cons(let((type(assq-ref headers  'Content-Type)))(if(top-typed? type  'multipart)(ok(parse-multipart type(port-at-body)len))move))(acons  'Content-Length len headers))))(map unflatten spans))))
