Automatic binary file patcher.

inotify.scm

(require-extension inotify)
(require-extension posix)
(require-extension srfi-37)

;;; Utility functions.

(define (negate fn)
  (lambda (a)
    (not (fn a))))

(define (curry fn a)
  (lambda (b)
    (fn a b)))

(define (curry-3 fn a)
  (lambda (b c)
    (fn a b c)))

(define (on-pairs fn)
  (lambda (ab)
    (fn (car ab) (cdr ab))))

(define (thunk-2 fn a b)
  (lambda ()
    (fn a b)))

(define (flip fn)
  (lambda (b a)
    (fn a b)))

(define (either fn a b)
  (if (fn a) a b))

(define (between-inclusively? a b n)
  (and (<= n a)
       (>= n b)))

(define (read-file-as-stream path)
  (string->list (with-input-from-file path read-string)))

;;; Patch code format parser code.

(define (hexadecimal-char? n)
  (member n (string->list "0123456789abcdefABCDEF")))

(define (whitespace? n)
  (member n '(#\space #\tab)))

(define (start-of-comment? n)
  (eq? n #\;))

(define (newline? n)
  (member n '(#\newline #\return)))

(define (skip-whitespace tk)
  (if (or (null? tk)
	  (not (whitespace? (car tk))))
      (cons (cons #t '()) tk)
      (skip-whitespace (cdr tk))))

(define (parse-whitespace tk)
  (if (or (null? tk)
	  (not (whitespace? (car tk))))
      (cons #f "Expected whitespace.")
      (skip-whitespace (cdr tk))))

(define (hex-value n)
  (case n
    ((#\0) 0)
    ((#\1) 1)
    ((#\2) 2)
    ((#\3) 3)
    ((#\4) 4)
    ((#\5) 5)
    ((#\6) 6)
    ((#\7) 7)
    ((#\8) 8)
    ((#\9) 9)
    ((#\a) 10)
    ((#\A) 10)
    ((#\b) 11)
    ((#\B) 11)
    ((#\c) 12)
    ((#\C) 12)
    ((#\d) 13)
    ((#\D) 13)
    ((#\e) 14)
    ((#\E) 14)
    ((#\f) 15)
    ((#\F) 15)
    (else (error "Unknown hexadecimal digit."))))

(define (produce-number tk)
  (let loop ((tkn tk) (p 1) (r 0))
    (if (null? tkn)
	r
	(loop (cdr tkn) (* 16 p) (+ (* p (hex-value (car tkn))) r)))))

(define (parse-hexadecimal-number tk)
  (let loop ((tkn tk) (r (list)))
    (if (or (null? tkn)
	    (not (hexadecimal-char? (car tkn))))
	(if (null? r)
	    (cons #f "Expected hexadecimal number.")
	    (cons (cons #t (produce-number r)) tkn))
	(loop (cdr tkn) (cons (car tkn) r)))))

(define (chain-parsers p)
  (lambda (tk)
    (let loop ((rs (list)) (pn p) (tkn tk))
      (if (or (null? pn)
	      (null? tkn))
	  (cons (cons #t (reverse (map cdr rs))) tkn)
	  (let ((rtk ((car pn) tkn)))
	    (if (not (car rtk))
		rtk
		(loop (cons (car rtk) rs) (cdr pn) (cdr rtk))))))))

(define (alternate-parser pa pb)
  (lambda (tk)
    (let ((r (pa tk)))
      (if (caar r)
	  r
	  (pb tk)))))

(define (skip-until-newline-or-eof tk)
  (let loop ((tkn tk))
    (cond ((null? tkn) tkn)
	  ((newline? (car tkn)) tkn)
	  (else (loop (cdr tkn))))))

(define (parse-comment tk)
  (if (start-of-comment? (car tk))
      (cons (cons #t '()) (skip-until-newline-or-eof (cdr tk)))
      (cons (cons #f "Expected comment.") tk)))

(define (produce-line tk)
  (cons (cons #t
	      (cons (second (car tk))
		    (fourth (car tk))))
	(cdr tk)))

(define parse-line
  (alternate-parser parse-comment
		    (chain-parsers (list parse-hexadecimal-number
					 parse-whitespace
					 parse-hexadecimal-number))))

(define (parse-file tk)
  (let loop ((tkn tk) (r (list)) (cl 1))
    (if (null? tkn)
	(produce-file r)
	(let ((rtk (parse-line tkn)))
	  (if (caar rtk)
	      (
	      
  

(define (monitor-file path thunk)
  (add-watch! path '(modify))
  (let loop ()
    (next-events!)
    (display (format "Modification of file ~A detected.\n" path))
    (thunk)
    (next-events!) ; Clear the event queue of events caused by own modification.
    (loop)))

;;; Patch a byte value in the file handle at offset.

(define (patch-byte handle offset value)
  (display (format "Patching byte ~X with value ~X\n" offset value))
  (set-file-position! handle offset)
  (file-write handle (string (integer->char (max 0 (min 255 value)))) 1))

(define (patch-bytes handle ln)
  (map (on-pairs (curry-3 patch-byte handle)) ln))

(define (patch-file path ln)
  (display (string-append "Patching file: " path))
  (newline)
  (let ((handle (file-open path open/wronly)))
    (patch-bytes handle ln)
    (file-close handle)))

(define patch-test-file "test-patch-file")

(define patch-data-file "patchdata")

(define (main)
  (inotify#init!)
  (on-exit inotify#clean-up!)
  (if (> 3 (length (argv)))
      (begin
	(display (format "Usage: <file to monitor and patch> <file with patch codes>\n"))
	(exit))
      (let ((arguments (cdr (argv))))
	(let ((monitored-file (first arguments))
	      (patch-code-file (second arguments)))
	  (let ((patch-data (with-input-from-file patch-code-file read)))
	    (monitor-file monitored-file (thunk-2 patch-file monitored-file patch-data)))))))

; (main)