From 5b1ad78a94e58f78b6f8d7bb25b2bcfa107f4e70 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 4 Jun 2017 09:33:54 -0700 Subject: [PATCH] bughunt --- pitfall/binparser/gif-parse.rkt | 40 +++++++++------ pitfall/binparser/main.rkt | 86 +++++++++++++++++++++++++------- pitfall/binparser/sample.gif | Bin 0 -> 69 bytes 3 files changed, 92 insertions(+), 34 deletions(-) create mode 100644 pitfall/binparser/sample.gif diff --git a/pitfall/binparser/gif-parse.rkt b/pitfall/binparser/gif-parse.rkt index f7fe95fd..7579266e 100644 --- a/pitfall/binparser/gif-parse.rkt +++ b/pitfall/binparser/gif-parse.rkt @@ -1,27 +1,41 @@ #lang br -(require pitfall/binprint binparser) +(require pitfall/binprint binparser racket/dict) ;; http://www.matthewflickinger.com/lab/whatsinagif/bits_and_bytes.asp (define-rule gif (:seq [signature (:bytes 3 #:type string/ascii?)] [version (:bytes 3 #:type string/ascii?)] logical-screen-descriptor - #:type hash?)) + global-color-table + #:type assoc?)) (define-rule logical-screen-descriptor (:seq [width (:bytes 2 #:type integer?)] [height (:bytes 2 #:type integer?)] - [lsd-flags (:bitfield [reserved (:bits 3)] - [disposal (:bits 3 #:type integer?)] - [user-input (:bits 1 #:type boolean?)] - [transparent (:bits 1 #:type boolean?)] - #:type hash?)] + [lsd-flags (:seq [global-color-table-size (:bits 3 #:type integer?)] + [sort (:bits 1 #:type boolean?)] + [resolution (:bits 3 #:type integer?)] + [global-color-table (:bits 1 #:type integer?)] + #:type assoc?)] [bgcolor-idx (:bytes 1 #:type integer?)] [aspect (:bytes 1 #:type integer?)] - #:type hash?)) + #:type assoc?)) -(gif (open-input-file "test.gif")) +(define-rule global-color-table (:repeat 4 (:bytes 3))) -(check-equal? (gif (gif (open-input-file "test.gif"))) (read-bytes 13 (open-input-file "test.gif"))) +#;(define-rule color (:bytes 3 #:type hex?)) + + +(define g (gif (open-input-file "sample.gif"))) + +(define (global-color-quantity) + (define val (dict-ref (dict-ref (dict-ref g 'logical-screen-descriptor) 'lsd-flags) 'global-color-table)) + (expt 2 (add1 val))) + + + +g + +#;(check-equal? (gif (gif (open-input-file "sample.gif"))) (read-bytes 13 (open-input-file "sample.gif"))) (require rackunit) #;(check-equal? (parse-with-template "test.gif" gif) @@ -29,9 +43,3 @@ (make-hasheq (list (cons 'logical-screen-descriptor '(162 162 (#f #t #f #f #f #t #f #t) 0 0)) '(signature . "GIF") '(version . "87a"))))) - - -(define-rule bad-bitfield (:bitfield [reserved (:bits 3)] - [disposal (:bits 3 #:type integer?)])) - -(bad-bitfield (bad-bitfield (open-input-bytes #"A"))) \ No newline at end of file diff --git a/pitfall/binparser/main.rkt b/pitfall/binparser/main.rkt index 9ad7dd86..3f92d47c 100644 --- a/pitfall/binparser/main.rkt +++ b/pitfall/binparser/main.rkt @@ -1,7 +1,7 @@ #lang sugar/debug racket/base (require sugar/debug) (require (for-syntax racket/base br/syntax)) -(require racket/match racket/function racket/port br/define sugar/list racket/list racket/bytes) +(require racket/match racket/function racket/port br/define sugar/list racket/list racket/bytes racket/string) (provide (all-defined-out)) (define string/utf-8? #t) @@ -9,6 +9,8 @@ (define string/ascii? 'string/ascii?) (define bitfield? (λ (x) (and (list? x) (andmap boolean? x)))) +(define (assoc? x) (and (list? x) (andmap pair? x))) + (struct binary-problem (msg val) #:transparent) (define bitfield #f) @@ -38,20 +40,25 @@ [(2 4 8) (integer->integer-bytes x len #f #f)] [else (raise-argument-error 'integer->bytes "byte length 1 2 4 8" len)])) +(require racket/format) +(define (hex? x) (and (list? x) (andmap string? x))) +(define (int->hex int) (~r int #:base 16 #:min-width 2 #:pad-string "0")) +(define (hex->int hex) (string->number hex 16)) + (define (bytes->ascii bs) (list->string (for/list ([b (in-bytes bs)]) - (if (< b 128) - (integer->char b) - (raise (binary-problem "ascii byte < 128" b)))))) + (if (< b 128) + (integer->char b) + (raise (binary-problem "ascii byte < 128" b)))))) (define (ascii->bytes str) (apply bytes (for/list ([c (in-string str)]) - (char->integer c)))) + (char->integer c)))) (define (bytes->bitfield bs) (for*/list ([b (in-bytes bs)] [idx (in-range 8)]) - (bitwise-bit-set? b idx))) + (bitwise-bit-set? b idx))) (define (bitfield->bytes bf) (unless (zero? (modulo (length bf) 8)) @@ -70,7 +77,7 @@ (for/sum ([b (in-list bits)] [pow (in-range 8)] #:when b) - (expt 2 pow))) + (expt 2 pow))) (define (integer->bitfield len int) (define digits (reverse (string->list (number->string int 2)))) @@ -106,8 +113,20 @@ (raise (binary-problem (format "bit string length ~a" count) result))) result))) (gensym 'bits-))) +(define (bytes->hexline bs) + (string-join + (for/list ([b (in-bytes bs)]) + (~r b #:base 16 #:min-width 2 #:pad-string "0")) " ")) + +(define (hexline->bytes hexline) + (apply bytes (map (λ (str) (string->number str 16)) (string-split hexline)))) + +(module+ test + (check-equal? (bytes->hexline #"ABC") "41 42 43") + (check-equal? (hexline->bytes "41 42 43") #"ABC")) -(define (:bytes count #:type [type #f]) + +(define (:bytes count #:type [type bytes?]) (procedure-rename (λ (x) (define-values (input-proc output-proc) @@ -116,7 +135,8 @@ (curry integer->bytes count))] [string/ascii? (values bytes->ascii ascii->bytes)] [bitfield? (values bytes->bitfield bitfield->bytes)] - [list? (values identity identity)] + [bytes? (values identity identity)] + [hex? (values bytes->hexline hexline->bytes)] [else (raise-argument-error ':bytes "not a supported type" type)])) (if (input-port? x) @@ -127,11 +147,14 @@ result))) (gensym 'bytes-))) (define (list->hash-with-keys keys vals) - (make-hash (map cons keys vals))) + (make-hash (list->dict-with-keys keys vals))) (define (hash->list-with-keys keys h) (for/list ([k (in-list keys)]) - (hash-ref h k))) + (hash-ref h k))) + +(define (list->dict-with-keys keys vals) + (map cons keys vals)) (define (procedure-name proc) (string->symbol (cadr (regexp-match #rx"^#$" (with-output-to-string (λ () (display proc))))))) @@ -146,14 +169,14 @@ xs (for/list ([x (in-list xs)] [idx (in-naturals 1)]) - (string->symbol (format "~a-~a" x idx))))) + (string->symbol (format "~a-~a" x idx))))) (define-macro (define-seq-style-rule ID ID-INNER) #'(define-macro (ID ARG (... ...)) (with-pattern ([(ARG (... ...)) (pattern-case-filter #'(ARG (... ...)) [(NAME RULE-PROC) #'(let () (define-rule NAME RULE-PROC) NAME)] [ELSE #'ELSE])]) - #'(ID-INNER ARG (... ...))))) + #'(ID-INNER ARG (... ...))))) (define-seq-style-rule :bitfield bitfield-inner) @@ -166,7 +189,12 @@ (define-seq-style-rule :seq seq-inner) (define (seq-inner #:type [type list?] . rule-procs) - ((make-inner-proc bytes-append* 'seq) type rule-procs)) + ((make-inner-proc bytes-append* ':seq) type rule-procs)) + +(define-seq-style-rule :repeat repeat-inner) + +(define (repeat-inner #:type [type list?] count . rule-procs) + ((make-inner-proc bytes-append* ':repeat) type (append* (make-list count rule-procs)))) (define (make-inner-proc post-proc sym) (λ (type rule-procs) @@ -184,6 +212,16 @@ (λ (x) (unless (and (list? x) (= (length rule-procs) (length x))) (raise (binary-problem (format "list of ~a values" (length rule-procs)) x)))))] + [vector? (values list->vector vector->list + (λ (x) + (unless (and (vector? x) (= (length rule-procs) (vector-length x))) + (raise (binary-problem (format "list of ~a values" (length rule-procs)) x)))))] + [assoc? + (define rule-proc-names (resolve-duplicates (map procedure-name rule-procs))) + (values (curry list->dict-with-keys rule-proc-names) (λ (d) (map cdr d)) + (λ (x) + (unless (and (assoc? x) (= (length rule-procs) (length x))) + (raise (binary-problem (format "list of ~a values" (length rule-procs)) x)))))] [else (raise-argument-error sym "not a supported type" type)])) (match x [(? input-port? p) (input-proc (map (λ (rule-proc) (rule-proc p)) rule-procs))] @@ -192,8 +230,8 @@ (post-proc (map (λ (rp xi) (rp xi)) rule-procs (output-proc x)))])) (gensym sym)))) -(define (:repeat count . rule-procs) - (λ (p) (append-map (λ (i) (map (λ (r-p) (r-p p) rule-procs))) (range count)))) + + (define-macro (define-rule ID RULE-PROC) #'(define (ID [x (current-input-port)]) @@ -207,8 +245,7 @@ (define-macro (define-rules [ID RULE-PROC] ...) #'(begin (define-rule ID RULE-PROC) ...)) -(define-macro (let-rule ([ID RULE-PROC] ...) - . BODY) +(define-macro (let-rule ([ID RULE-PROC] ...) . BODY) #'(let () (define ID RULE-PROC) ... . BODY)) (module+ test @@ -225,6 +262,12 @@ (define-rule foolist (:seq bar zam bar zam)) (check-equal? #"123456" (foolist (foolist (open-input-bytes #"123456"))) (foolist '(49 13106 52 13877))) + (define-rule bam (:bytes 1)) + (define-rule bams (:seq bam bam bam)) + (define-rule rebams (:seq (:bytes 1) (:bytes 1) (:bytes 1))) + (check-equal? (bams (open-input-bytes #"ABC")) (rebams (open-input-bytes #"ABC"))) + + (define-rule hashrule (:seq bar zam bar zam bar #:type hash?)) (check-equal? #"1234567" (hashrule (hashrule (open-input-bytes #"1234567"))) (hashrule '#hash((zam-4 . 13877) (bar-3 . 52) (zam-2 . 13106) (bar-1 . 49) (bar-5 . 55)))) @@ -240,4 +283,11 @@ (define-rule bitint (:bits 8 #:type integer?)) (check-equal? (bitint (open-input-bytes #"A")) 65) (check-equal? (bitint 65) '(#t #f #f #f #f #f #t #f)) + + #| + (reset-bitfield!) + (define-rule rpt (:repeat 3 (:bytes 1))) + (rpt (open-input-bytes #"ABC")) + (rpt (rpt (open-input-bytes #"ABC"))) +|# ) \ No newline at end of file diff --git a/pitfall/binparser/sample.gif b/pitfall/binparser/sample.gif new file mode 100644 index 0000000000000000000000000000000000000000..d89e799a632c939a168557e67984bec554dbfe88 GIT binary patch literal 69 zcmZ?wbhEHb6Al0X literal 0 HcmV?d00001