;;;
;;; debug-loop.lisp
;;;
;;; Debug event monitoring loop.
;;;

(cl:defpackage :remote-debug
  (:use :common-lisp :sb-alien)
  ;(:export #:*message-function*)
  )

(cl:in-package :remote-debug)


;;; Process creation flags.

(defconstant +create-breakaway-from-job+        #x01000000)
(defconstant +create-default-error-mode+        #x04000000)
(defconstant +create-new-console+               #x00000010)
(defconstant +create-new-process-group+         #x00000200)
(defconstant +create-no-window+                 #x08000000)
(defconstant +create-protected-process+         #x00040000)
(defconstant +create-preserve-code-authz-level+ #x02000000)
(defconstant +create-separate-wow-vdm+          #x00000800)
(defconstant +create-shared-wow-vdm+            #x00001000)
(defconstant +create-suspended+                 #x00000004)
(defconstant +create-unicode-environment+       #x00000400)
(defconstant +debug-only-this-process+          #x00000002)
(defconstant +debug-process+                    #x00000001)
(defconstant +detached-process+                 #x00000008)
(defconstant +extended-startupinfo-present+     #x00080000)


;;; Startup Information Flags.

(defconstant +startf-forceofffeedback+ 128)
(defconstant +startf-forceonfeedback+   64)
(defconstant +startf-runfullscreen+     32)
(defconstant +startf-usecountchars+      8)
(defconstant +startf-usefillattribute+  16)
(defconstant +startf-useposition+        4)
(defconstant +startf-useshowwindow+      1)
(defconstant +startf-usesize+            2)
(defconstant +startf-usestdhandles+    256)


;;; Typedefs.

(define-alien-type word unsigned-short)
(define-alien-type dword unsigned-long)


;;; Structures.

(define-alien-type nil
    (struct process-information
	    (hprocess sb-win32:handle)
	    (hthread sb-win32:handle)
	    (dwprocessid dword)
	    (dwthreadid dword)))

(define-alien-type nil
    (struct startupinfo
	    (cb dword)
	    (lpreserved sb-win32::system-string)
	    (lpdesktop sb-win32::system-string)
	    (lptitle sb-win32::system-string)
	    (dwx dword)
	    (dwy dword)
	    (dwxsize dword)
	    (dwysize dword)
	    (dwxcountchars dword)
	    (dwycountchars dword)
	    (dwfillattribute dword)
	    (dwflags dword)
	    (wshowwindow word)
	    (cbreserved2 word)
	    (lpreserved2 (* t))
	    (hstdinput sb-win32:handle)
	    (hstdoutput sb-win32:handle)
	    (hstderror sb-win32:handle)))


(defun start-debuggee-process ()
  (with-alien ((s-i (struct startupinfo))
	       (p-i (struct process-information)))
    (setf (slot s-i 'cb) 68
	  (slot s-i 'lpreserved) nil
	  (slot s-i 'lpdesktop) nil
	  (slot s-i 'lptitle) nil
	  (slot s-i 'dwflags) 0
	  (slot s-i 'cbreserved2) 0
	  (slot s-i 'lpreserved2) nil)
    (alien-funcall (extern-alien "CreateProcessW"
				 (function int
					   sb-win32::system-string
					   sb-win32::system-string
					   (* t)
					   (* t)
					   int
					   dword
					   (* t)
					   sb-win32::system-string
					   (* (struct startupinfo))
					   (* (struct process-information))))
		   "c:/windows/system32/notepad.exe" nil nil nil 0
		   (logior +create-new-console+
			   +debug-process+
			   +debug-only-this-process+
			   )
		   nil nil (addr s-i) (addr p-i))
    (format t "process: ~A [~A]~%thread: ~A [~A]~%"
	    (slot p-i 'hprocess) (slot p-i 'dwprocessid)
	    (slot p-i 'hthread) (slot p-i 'dwthreadid))))


(defconstant +exception-maximum-parameters+ 15)

(define-alien-type nil
    (struct exception-record
	    (exceptioncode dword)
	    (exceptionflags dword)
	    (exceptionrecord (* (struct exception-record)))
	    (exceptionaddress (* t))
	    (numberparameters dword)
	    (exceptioninformation (array dword 15 #|+exception-maximum-parameters+|#))))

(defconstant +create-process-debug-event+ 3)
(defconstant +create-thread-debug-event+ 2)
(defconstant +exception-debug-event+ 1)
(defconstant +exit-process-debug-event+ 5)
(defconstant +exit-thread-debug-event+ 4)
(defconstant +load-dll-debug-event+ 6)
(defconstant +output-debug-string-debug-event+ 8)
(defconstant +rip-event+ 9)
(defconstant +unload-dlll-debug-event+ 7)

(define-alien-type nil
    (struct create-process-debug-info
	    (hfile sb-win32:handle)
	    (hprocess sb-win32:handle)
	    (hthread sb-win32:handle)
	    (lpbaseofimage (* t))
	    (dwdebuginfofileoffset dword)
	    (ndebuginfosize dword)
	    (lpthreadlocalbase (* t))
	    (lpstartaddress (* t))
	    (lpimagename (* t))
	    (funicode word)))

(define-alien-type nil
    (struct create-thread-debug-info
	    (hthread sb-win32:handle)
	    (lpthreadlocalbase (* t))
	    (lpstartaddress (* t))))

(define-alien-type nil
    (struct exit-process-debug-info
	    (dwexitcode dword)))

(define-alien-type nil
    (struct exit-thread-debug-info
	    (dwexitcode dword)))

(define-alien-type nil
    (struct exception-debug-info
	    (exceptionrecord (struct exception-record))
	    (dwfirstchance dword)))

(define-alien-type nil
    (struct load-dll-debug-info
	    (hfile sb-win32:handle)
	    (lpbaseofdll (* t))
	    (dwdebuginfofileoffset dword)
	    (ndebuginfosize dword)
	    (lpimagename (* t))
	    (funicode word)))

(define-alien-type nil
    (struct output-debug-string-info
	    (lpdebugstringdata dword)
	    (funicode word)
	    (ndebugstringlength word)))

(define-alien-type nil
    (struct unload-dll-debug-info
	    (baseofdll (* t))))

(define-alien-type nil
    (struct rip-info
	    (dwerror dword)
	    (dwtype dword)))

(define-alien-type nil
    (struct debug-event
	    (dwdebugeventcode dword)
	    (dwprocessid dword)
	    (dwthreadid dword)
	    (u (union nil
		      (exception (struct exception-debug-info))
		      (createthread (struct create-thread-debug-info))
		      (createprocessinfo (struct create-process-debug-info))
		      (exitthread (struct exit-thread-debug-info))
		      (exitprocess (struct exit-process-debug-info))
		      (loaddll (struct load-dll-debug-info))
		      (unloaddll (struct unload-dll-debug-info))
		      (debugstring (struct output-debug-string-info))
		      (ripinfo (struct rip-info))))))


(defparameter *debug-event-code-plist*
  '(1 +exception-debug-event+
    2 +create-thread-debug-event+
    3 +create-process-debug-event+
    4 +exit-thread-debug-event+
    5 +exit-process-debug-event+
    6 +load-dll-debug-event+
    7 +unload-dlll-debug-event+
    8 +output-debug-string-debug-event+
    9 +rip-event+))


(defun get-debug-event ()
  (with-alien ((de (struct debug-event)))
    (if (zerop (alien-funcall
		(extern-alien "WaitForDebugEvent"
			      (function int (* (struct debug-event)) dword))
		(addr de) 0))
	(format t "failed: ~A~%" (sb-win32::get-last-error-message
				  (sb-win32:get-last-error)))
	(progn
	  (format t "code: ~A~%process: ~A~%thread: ~A~%"
		  (getf *debug-event-code-plist* (slot de 'dwdebugeventcode))
		  (slot de 'dwprocessid)
		  (slot de 'dwthreadid))
	  (continue-debug-event (slot de 'dwprocessid) (slot de 'dwthreadid))
	  (labels
	      ((foo (event)
		 (let ((fields (sb-alien-internals:alien-record-type-fields
				(sb-alien-internals:alien-value-type event))))
		   (loop for field in fields
			 for field-name = (sb-alien-internals:alien-record-field-name field)
			 for field-value = (slot event field-name)
			 do (if (and (typep field-value 'sb-alien-internals:alien-value)
				     (typep (sb-alien-internals:alien-value-type field-value)
					    'sb-alien-internals:alien-record-type))
				(progn
				  (format t "~A: --~%" field-name)
				  (foo field-value)
				  (format t "--~%"))
				(format t "~A: ~A~%" field-name field-value))))))
	    (case (slot de 'dwdebugeventcode)
	      (#.+exception-debug-event+
	       (foo (slot (slot de 'u) 'exception)))
	      (#.+create-thread-debug-event+
	       (foo (slot (slot de 'u) 'createthread)))
	      (#.+create-process-debug-event+
	       (foo (slot (slot de 'u) 'createprocessinfo)))
	      (#.+exit-thread-debug-event+
	       (foo (slot (slot de 'u) 'exitthread)))
	      (#.+exit-process-debug-event+
	       (foo (slot (slot de 'u) 'exitprocess)))
	      (#.+load-dll-debug-event+
	       (foo (slot (slot de 'u) 'loaddll)))
	      (#.+unload-dlll-debug-event+
	       (foo (slot (slot de 'u) 'unloaddll)))
	      (#.+output-debug-string-debug-event+
	       (foo (slot (slot de 'u) 'debugstring)))
	      (#.+rip-event+
	       (foo (slot (slot de 'u) 'ripinfo)))))))))

(defun continue-debug-event (processid threadid)
  (when (zerop (alien-funcall (extern-alien "ContinueDebugEvent"
					    (function int dword dword dword))
			      processid threadid #x10002))
    (format t "failed: ~A~%" (sb-win32::get-last-error-message
			      (sb-win32:get-last-error)))))

(declaim (inline close-handle))
(defun close-handle (handle)
  (alien-funcall (extern-alien "CloseHandle" (function int sb-win32:handle))
		 handle))


;;; Memory access.

(define-alien-type nil
    (struct memory-basic-information
	    (base-address dword)
	    (allocation-base dword)
	    (allocation-size dword)
	    (region-size dword)
	    (state dword)
	    (protect dword)
	    (type dword)))

(declaim (inline virtual-query-ex))
(defun virtual-query-ex (hprocess lpaddress)
  (with-alien ((mbi (struct memory-basic-information)))
    (unless
	(zerop (alien-funcall
		(extern-alien "VirtualQueryEx"
			      (function int sb-win32:handle dword
					(* (struct memory-basic-information))
					dword))
		hprocess lpaddress (addr mbi)
		(alien-size (struct memory-basic-information))))

      (let ((fields (sb-alien-internals:alien-record-type-fields
		     (sb-alien-internals:alien-value-type mbi))))
	(loop for field in fields
	      for field-name = (sb-alien-internals:alien-record-field-name field)
	      for field-value = (slot mbi field-name)
	      do (format t "~A: ~A~%" field-name field-value))))))


;;; Context access.

(defconstant +context-i386+ #x10000)

(defconstant +context-control+            (logior +context-i386+ #x01))
(defconstant +context-integer+            (logior +context-i386+ #x02))
(defconstant +context-segments+           (logior +context-i386+ #x04))
(defconstant +context-floating-point+     (logior +context-i386+ #x08))
(defconstant +context-debug-registers+    (logior +context-i386+ #x10))
(defconstant +context-extended-registers+ (logior +context-i386+ #x20))

(defconstant +context-full+ (logior +context-control+ +context-integer+
				    +context-segments+))

(defconstant +maximum-supported-extension+ 512)

(define-alien-type nil
    (struct floating-save-area
	    (control-word dword)
	    (status-word dword)
	    (tag-word dword)
	    (error-offset dword)
	    (error-selector dword)
	    (data-offset dword)
	    (data-selector dword)
	    (register-area (array unsigned-char 80))
	    (cr0-npx-state dword)))

(define-alien-type nil
    (struct context
	    (context-flags dword)
	    (dr0 dword)
	    (dr1 dword)
	    (dr2 dword)
	    (dr3 dword)
	    (dr6 dword)
	    (dr7 dword)
	    (float-save (struct floating-save-area))
	    (seg-gs dword)
	    (seg-fs dword)
	    (seg-es dword)
	    (seg-ds dword)
	    (edi dword)
	    (esi dword)
	    (ebx dword)
	    (edx dword)
	    (ecx dword)
	    (eax dword)
	    (ebp dword)
	    (eip dword)
	    (seg-cs dword)
	    (eflags dword)
	    (esp dword)
	    (seg-ss dword)
	    (extended-registers (array unsigned-char 512 #| +maximum-supported-extension+ |#))))

(defun formatify (alien)
  (let ((fields (sb-alien-internals:alien-record-type-fields
		 (sb-alien-internals:alien-value-type alien))))
    (loop for field in fields
	  for field-name = (sb-alien-internals:alien-record-field-name field)
	  for field-value = (slot alien field-name)
	  do (format t "~A: ~X~%" field-name field-value))))

(defun display-thread-context (thread)
  (with-alien ((context (struct context)))
    (setf (slot context 'context-flags) +context-full+)
    (alien-funcall (extern-alien "GetThreadContext"
				 (function int sb-win32:handle (* (struct context))))
		   thread (addr context))
    (formatify context)))


;;; EOF