;BENCODING - Provide a package for trivial bencoding support, with the advantage of stream decoding. ;Copyright (C) 2023 Prince Trippy . ;This program is free software: you can redistribute it and/or modify it under the terms of the ;GNU Affero General Public License version 3 as published by the Free Software Foundation. ;This program 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 this program. ;If not, see . (cl:defpackage #:bencoding (:use #:common-lisp) (:export #:decode #:decode-from-string #:encode #:encode-to-string) (:documentation "This package implements permissive bencoding as used by BitTorrent.")) (cl:in-package #:bencoding) (defun read-character-delimited-list (character &optional (stream *standard-input*)) "Read from the stream until the listed character is read." ;This function should've been standard. (loop :for char := (read-char stream) :until (char= char character) :collecting char)) (defun decode-integer (string) "Read an integer from a string and not a stream. See the function READ-CHARACTER-DELIMITED-LIST." (loop (assert (not (zerop (length string))) (string) "An empty string can't encode an integer.") (let ((first (char string 0)) ;Using SUBSEQ now would make a copy of the rest of the string. (subseq (make-array (1- (length string)) :element-type 'character :displaced-to string :displaced-index-offset 1))) (restart-case (if (and (every 'digit-char-p subseq) (or (digit-char-p first) (char= #\- first)) (or (= 1 (length string)) (char/= #\0 first) (prog1 t (cerror "Ignore leading zeroes." "Integer ~A has leading zeroes." string)))) (return) (error "An invalid integer was used: ~S" string)) (store-value (use-value) :report "Provide a new integer string." :interactive (lambda (&aux *read-eval*) (list (read-line *query-io*))) (setq string use-value))))) (cond ((string= string "-0") (prog1 0 (cerror "Treat the negative zero as zero." "Negative zero was given."))) (t (nth-value 0 (parse-integer string))))) (defun encode-integer (integer &optional (stream *standard-output*)) ;I ignore a negative zero here. "Write an integer to the stream." ;I could place a CHECK-TYPE here, but misuse warrants its fruit. (write-char #\i) (write integer :stream stream :base 10 :radix nil :pretty nil) (write-char #\e)) (defun decode-list (&optional (stream *standard-input*)) "Read a list from the stream." (loop :if (eql #\e (peek-char nil stream nil)) :do (read-char stream) (loop-finish) :end :collecting (decode stream t))) (defun encode-list (list &optional (stream *standard-output*) &aux (*standard-output* stream)) "Write a list to the stream." (write-char #\l) (mapc 'encode list) (write-char #\e)) (defun decode-string (&optional (stream *standard-input*) &aux (length (coerce (read-character-delimited-list #\: stream) 'string))) "Read a string from the stream; this function features a particularly unrecoverable failure case." (assert (and (not (zerop (length length))) (every 'digit-char-p length)) (length) "An invalid string length was used: ~S" length) (and (string/= "0" length) (char= #\0 (char length 0)) (cerror "Use it anyway." "The string length had unnecessary leading zeroes: ~S" length)) (let ((string (make-array (parse-integer length) :element-type 'character))) (prog1 string (or (= (length string) (read-sequence string stream)) (error "There were insufficient characters to wholly fill a string."))))) (defun encode-string (string &optional (stream *standard-output*)) "Write a string to the stream." (write (length string) :stream stream :base 10 :radix nil :pretty nil) (write-char #\: stream) (write-sequence string stream)) ;I wanted to implement the dictionary as a trie, alongside a list of keys, but this is unreasonable. ;Anyone using this would expect a hash-table, even though they're a particularly poor choice for it. ;I leave an efficient and intelligent implementation which can truly hide details to the coming Ada. (defun decode-dictionary (&optional (stream *standard-input*) &aux (last "") ;These parameters are informed by common BitTorrent usages. (hash-table (make-hash-table :test 'equal :rehash-size 4 :rehash-threshold 0.9 :size 4))) "Read a dictionary from the stream." (loop (cond ((eql #\e (peek-char nil stream nil)) (read-char stream) (return hash-table))) (let ((string (decode stream t))) (loop :do (restart-case (progn (if (not (stringp string)) (error "A dictionary key wasn't a string: ~S" string)) (if (gethash string hash-table) (cerror "Use it anyway." "A dictionary key was used more than once: ~S" string)) (if (string> last string) (cerror "Ignore this problem." "A dictionary key is unordered: ~S" string)) (loop-finish)) (store-value (use-value) :report "Provide a new dictionary key." :interactive (lambda (&aux *read-eval*) (list (read-line *query-io*))) (setq string use-value)))) (setf (gethash string hash-table) (decode stream t) last string)))) (defun encode-dictionary (hash-table &optional (stream *standard-output*) &aux list (*standard-output* stream)) "Write a dictionary to the stream. This is a function featuring a particularly bad failure case." (write-char #\d) (with-hash-table-iterator (hash-table hash-table) (loop (destructuring-bind (continue string) (multiple-value-list (hash-table)) (or continue (return)) (if (not (stringp string)) (cerror "Ignore this key." "A hash table key isn't a string: ~S" string) (push string list))))) (setq list (sort list 'string<)) (mapc (lambda (string) (if (typep #0=(gethash string hash-table) '(or integer list string hash-table)) (encode #0#) (cerror "Ignore this key." "A hash table value isn't an integer, list, string, or another hash table: ~S" string))) list) (write-char #\e)) (defun decode (&optional (stream *standard-input*) recursivep &aux return) "Return the bencoded value held in the stream. The RECURSIVEP parameter is akin to that of READ." (check-type stream stream) (let ((*standard-input* stream)) (setq return (ecase (peek-char nil) ;These decode functions are most useful if they ignore the header. (#\i (read-char) (decode-integer (coerce (read-character-delimited-list #\e) 'string))) (#\l (read-char) (decode-list)) (#\d (read-char) (decode-dictionary)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (decode-string)))) (cond (recursivep return) (t (prog1 return (if (listen) (cerror "Ignore them." "The input had superfluous characters."))))))) (defun encode (encode &optional (stream *standard-output*)) "Send a bencoded value to the stream, returning nothing. The value naturally must be bencodable." (check-type stream stream) (let ((*standard-output* stream)) (etypecase encode (integer (encode-integer encode)) (list (encode-list encode)) (hash-table (encode-dictionary encode)) (string (encode-string encode)))) (values)) (defun decode-from-string (string) "This function is as DECODE, but from a string." (with-input-from-string (*standard-input* string) (decode))) (defun encode-to-string (encode) "This function is as ENCODE, but to a string." (with-output-to-string (*standard-output*) (encode encode))) .