BitTorrent で使われる bencoding 形式のデータのパーサと構築器

bencoding.sld

(define-library (bencoding)
  (import (scheme base))
  (export bencoding-parse bencoding-construct)
  (begin

    (define-syntax let1
      (syntax-rules ()
        ((_ var expr body0 body1 ...)
         (let ((var expr)) body0 body1 ...))))

    (define-syntax rlet1
      (syntax-rules ()
        ((_ var expr body0 body1 ...)
         (let ((var expr)) body0 body1 ... var))))

    (define (call-with-output-string procedure)
      (let1 ostr (open-output-string)
        (call-with-port ostr
          (lambda(x)
            (procedure x)
            (get-output-string x)))))

    (define (bencoding-parse-string first-ch port)
      (let1 size
          (string->number
           (call-with-output-string
             (lambda(out)
               (write-char (integer->char first-ch) out)
               (unless
                   (eqv? 58 (do ((ch (read-u8 port) (read-u8 port)))
                                ((not (<= 48 ch 57)) ch)
                              (write-char (integer->char ch) out)))
                 (error "Invalid bencoding string in bencoding-parse")))))
        (read-bytevector size port)))

    (define (bencoding-parse-integer port)
      (string->number
       (call-with-output-string
         (lambda(out)
           (let1 ch (read-u8 port)
             (if (eqv? 45 ch)
                 (begin
                   (write-char (integer->char ch) out)
                   (let1 ch (read-u8 port)
                     (if (<= 49 ch 57)
                         (write-char (integer->char ch) out)
                         (error "Invalid bencoding integer in bencoding-parse"))))
                 (if (<= 49 ch 57)
                     (write-char (integer->char ch) out)
                     (error "Invalid bencoding integer in bencoding-parse")))
             (unless
                 (eqv? 101 (do ((ch (read-u8 port) (read-u8 port)))
                               ((not (<= 48 ch 57)) ch)
                             (write-char (integer->char ch) out)))
               (error "Invalid bencoding integer in bencoding-parse")))))))

    (define (bencoding-parse-dictionary port depth)
      (let1 key (bencoding-parse-object port depth)
        (if (eof-object? key)
            '()
            (begin
              (when (not (bytevector? key))
                (error "Invalid bencoding dictionary in bencoding-parse"))
              (let1 value (bencoding-parse-object port depth)
                (cons (cons (utf8->string key) value)
                      (bencoding-parse-dictionary port depth)))))))

    (define (bencoding-parse-list result port depth)
      (let1 elm (bencoding-parse-object port depth)
        (if (eof-object? elm)
            (list->vector (reverse result))
            (bencoding-parse-list (cons elm result) port depth))))

    (define (bencoding-parse-object port depth)
      (let1 ch (read-u8 port)
        (cond
         ((eof-object? ch) '())
         ((eqv? ch 100) (bencoding-parse-dictionary port (+ 1 depth)))
         ((eqv? ch 101) (if (zero? depth)
                            (error "Invalid bencoding in bencoding-parse")
                            (eof-object)))
         ((eqv? ch 105) (bencoding-parse-integer port))
         ((eqv? ch 108) (bencoding-parse-list '() port (+ 1 depth)))
         ((<= 48 ch 57) (bencoding-parse-string ch port))
         (error "Invalid bencoding type in bencoding-parse" ch))))

    (define (bencoding-parse port)
      (bencoding-parse-object port 0))

    (define (key< x y)
      (let* ((x1 (car x))
             (y1 (car y))
             (x2 (if (string? x1) (string->utf8 x1) x1))
             (y2 (if (string? y1) (string->utf8 y1) y1))
             (x-size (bytevector-length x2))
             (y-size (bytevector-length x2))
             (limit (if (< x-size y-size) x-size y-size))
             (ind (do ((i 0 (+ i 1)))
                      ((or (<= i limit)
                           (not (= (bytevector-u8-ref x2 i)
                                   (bytevector-u8-ref y2 i))))
                        i)
                    (write-string (number->string i)))))
        (if (= ind limit)
            (< x-size y-size)
            (< (bytevector-u8-ref x2 ind)
               (bytevector-u8-ref y2 ind)))))

    (define (partition pred lis)
      (let loop ((lis lis))
        (if (null? lis)
            (values lis lis)
            (let ((elt (car lis))
                  (tail (cdr lis)))
              (let-values (((in out) (loop tail)))
                (if (pred elt)
                    (values (if (pair? out) (cons elt in) lis) out)
                    (values in (if (pair? in) (cons elt out) lis))))))))

    (define (sort f ls)
      (if (null? ls)
          '()
          (let ((p (car ls)))
            (let-values (((a b) (partition (lambda (x) (f x p)) (cdr ls))))
              (append (sort f a)
                      (cons p (sort f b)))))))

    (define (bencoding-construct-dictionary obj port)
      (write-u8 100 port)
      (for-each (lambda(x)
                  (bencoding-construct (car x) port)
                  (bencoding-construct (cdr x) port))
                (sort key< obj))
      (write-u8 101 port))

    (define (bencoding-construct-list obj port)
      (write-u8 108 port)
      (vector-for-each (lambda(x) (bencoding-construct x port)) obj)
      (write-u8 101 port))

    (define (bencoding-construct-integer obj port)
      (write-u8 105 port)
      (write-bytevector (string->utf8 (number->string obj)) port)
      (write-u8 101 port))

    (define (bencoding-construct-string obj port)
      (write-bytevector
       (string->utf8 (number->string (bytevector-length obj)))
       port)
      (write-u8 58 port)
      (write-bytevector obj port))

    (define (bencoding-construct obj port)
      (cond
       ((list? obj)   (bencoding-construct-dictionary obj port))
       ((vector? obj) (bencoding-construct-list obj port))
       ((integer? obj)(bencoding-construct-integer obj port))
       ((string? obj) (bencoding-construct-string (string->utf8 obj) port))
       ((bytevector? obj) (bencoding-construct-string obj port))
       (else (error "Attempt invalid object convert to bencoding"))))

    ))

test.scm

(import (scheme file))
(import (scheme base))
(import (scheme write))
(import (bencoding))

(let ((x (call-with-port (open-binary-input-file "foo.torrent")
           bencoding-parse)))
  (call-with-port (open-binary-output-file "foo.copy.torrent")
     (lambda(port) (bencoding-construct x port))))