small-cl-src

small-cl-src@common-lisp.net

44 discussions

[Small-cl-src] Pattern matching in function headers
by Julian Stecklina 05 Jun '04

05 Jun '04

Hello, I had the idea to do pattern matching in function definitions as Haskell allows. Any comments are welcome. Regards, -- Julian Stecklina Signed and encrypted mail welcome. Key-Server: pgp.mit.edu Key-ID: 0xD65B2AB5 FA38 DCD3 00EC 97B8 6DD8 D7CC 35D8 8D0E D65B 2AB5 Any sufficiently complicated C or Fortran program contains an ad hoc informally-specified bug-ridden slow implementation of half of Common Lisp. - Greenspun's Tenth Rule of Programming

1 0

[Small-cl-src] prefork-client.lisp
by Thomas F. Burdick 04 Jun '04

04 Jun '04

;;;; prefork-client.lisp ;;;; ;;;; A very simple SBCL network client for use in testing the servers in ;;;; prefork-example-simple.lisp and prefork-example-realistic.lisp. ;;;; Copyright (C) 2004, Thomas F. Burdick ;;;; ;;;; Permission is hereby granted, free of charge, to any person obtaining a ;;;; copy of this software and associated documentation files (the "Software"), ;;;; to deal in the Software without restriction, including without limitation ;;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;;;; and/or sell copies of the Software, and to permit persons to whom the ;;;; Software is furnished to do so, subject to the following conditions: ;;;; ;;;; The above copyright notice and this permission notice shall be included in ;;;; all copies or substantial portions of the Software. ;;;; ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;;; IN THE SOFTWARE. (in-package :cl-user) (eval-when (:load-toplevel :compile-toplevel :execute) (require :sb-posix) (require :sb-bsd-sockets) (use-package :sb-bsd-sockets)) ;;; The client is broken across many functions in order to make it easier to ;;; poke at the server. ;;; ;;; We send a line identifying ourselves, then an s-expression. The server ;;; identifies itself, then sends our s-expression back to us. (defvar *socket* nil) (defvar *stream* nil) (defun client (&optional object) "Return the echo from the server as multiple values." (client-connect) (client-herald) (client-write (with-output-to-string (s) (print object s))) (multiple-value-prog1 (client-results) (socket-close *socket*))) ;;; ;;; Easily hang server processes ;;; (defvar *hung* (queue)) (defun hang (&optional (n 1)) "Send N partial requests to the server, causing the processes to hang." (dotimes (i n) (let (*socket* *stream*) (client-connect) (client-herald) (client-write "(:hang ") (queue-add (cons *socket* *stream*) *hung*)))) (defun release (&optional (n 1)) "Send the rest of a proper request to N hung servers." (loop repeat n for pair = (queue-pop *hung*) when pair collect (destructuring-bind (*socket* . *stream*) pair (client-write ":release) ") (client-results)))) ;;; ;;; The guts ;;; (defun client-connect () (setf *socket* (make-instance 'inet-socket :type :stream :protocol :tcp)) (socket-connect *socket* (make-inet-address "127.0.0.1") 1978) (setf *stream* (socket-make-stream *socket* :input t :output t))) (defun client-herald () (format *stream* "PID ~D~%" (sb-posix:getpid)) (finish-output *stream*)) (defun client-write (string) "Send STRING to the server. If this is an incomplete sexp, it can be used to hang the server." (write-string string *stream*) (finish-output *stream*)) (defun client-results () (values (read-line *stream*) (read *stream*))) ;;; ;;; Misc utils ;;; (defstruct (queue (:constructor %make-queue (list tail))) (list nil :type list) (tail nil :type list)) (defun queue (&rest elements) (make-queue elements)) (defun make-queue (&optional list) (%make-queue list (last list))) (defun queue-add (item queue) (if (null (queue-tail queue)) (setf (queue-list queue) (list item) (queue-tail queue) (queue-list queue)) (setf (cdr (queue-tail queue)) (list item) (queue-tail queue) (cdr (queue-tail queue)))) queue) (defun queue-pop (queue) (prog1 (pop (queue-list queue)) (when (null (queue-list queue)) (setf (queue-tail queue) nil))))

1 0

[Small-cl-src] prefork-example-simple.lisp
by Thomas F. Burdick 04 Jun '04

04 Jun '04

;;;; prefork-example-simple.lisp ;;;; ;;;; This is a simple example of writing a preforking Unix server using SBCL. ;;;; This file was written to demonstrate the basic techniques of writing a ;;;; preforking server for educational purposes. For a more nuanced example, ;;;; see prefork-example-realistic.lisp ;;;; ;;;; Because it uses fork(2) and waitpid(2), this file requires a ;;;; patched version of the sb-posix contrib module for SBCL. A patch ;;;; against SBCL-0.8.8 is available separately. ;;;; ;;;; We also assumes a BSD-like system, due to its use of flock(2) for ;;;; serialization. ;;;; Copyright (C) 2004, Thomas F. Burdick ;;;; ;;;; Permission is hereby granted, free of charge, to any person obtaining a ;;;; copy of this software and associated documentation files (the "Software"), ;;;; to deal in the Software without restriction, including without limitation ;;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;;;; and/or sell copies of the Software, and to permit persons to whom the ;;;; Software is furnished to do so, subject to the following conditions: ;;;; ;;;; The above copyright notice and this permission notice shall be included in ;;;; all copies or substantial portions of the Software. ;;;; ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;;; IN THE SOFTWARE. (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix) (require :sb-bsd-sockets)) (defpackage :prefork-example-simple (:use :cl :sb-bsd-sockets)) (in-package :prefork-example-simple) ;;; In this simple example, the parent sets up a server socket, forks ;;; +NCHILDREN+ child processes, then just sits there, and periodically reaps ;;; and reforks any child processes that die. ;;; ;;; The child processes wait for incoming connections. Not all Unixes serialize ;;; `accept's in the kernel, so we need to handle this ourselves. We do this by ;;; acquiring an exclusive file lock around the call to accept(2). We use ;;; flock(2) to do this, but we could just as well use fcntl(2) or SysV ;;; semaphores. ;;; ;;; The Parent ;;; (defconstant +nchildren+ 8) (defconstant +backlog+ 16) (declaim (type (simple-array (or integer null)) *children*)) (defvar *children* (make-array +nchildren+ :initial-element nil) "the PIDs of our children") (defvar *childp* nil "True in child processes.") (defvar *server-socket* nil) (defvar *lock* nil) (defun start-server () "The main loop of the parent process." (setup) (unwind-protect (progn (fork-children) (loop ;; We call SERVE-EVENT here to let other Lisp applications ;; run, eg, SLIME. (sb-sys:serve-event 60) ;; Periodically reap any dead processes. (reap-children))) (unless *childp* (stop-server)))) (defun stop-server () (kill-children) (teardown-lock) (socket-close *server-socket*)) (defun setup () "Set up sockets and locks so the parent can begin forking." (setup-lock) (setup-parent-signal-handlers) (when *server-socket* (socket-close *server-socket*)) (setf *server-socket* (make-instance 'inet-socket :type :stream :protocol :tcp)) (setf (sockopt-reuse-address *server-socket*) t) (socket-bind *server-socket* (make-inet-address "127.0.0.1") 1978) (socket-listen *server-socket* +backlog+)) ;;; ;;; The child ;;; (defun child-main () "Get in the queue to accept, serve the request, loop." (setup-child-signal-handlers) (loop for socket = (serial-accept *server-socket*) for stream = (socket-make-stream socket :input t :output t) for client-id = (read-line stream) for message = (read stream) do (format stream "Hello ~A, this is PID ~D~%~S" client-id (sb-posix:getpid) message) (finish-output stream) (socket-close socket))) ;;; ;;; Forking and reaping ;;; (defun fork-children () (dotimes (i +nchildren+) (fork-one-child i))) (defun fork-one-child (index) (labels ((child () (unwind-protect (progn (setf *children* (vector) *childp* t) (child-main)) (sb-ext:quit))) (parent (pid) (setf (aref *children* index) pid))) (let ((pid (sb-posix:fork))) (if (zerop pid) (child) (parent pid))))) (defun reap-children () "Unix is sick." (when (every #'null *children*) (return-from reap-children)) (loop for pid = (ignore-errors (sb-posix:waitpid 0 sb-posix::wnohang)) while pid do (let ((index (position pid *children*))) (when index (warn "Reaping child process ~D" pid) (fork-one-child index))))) (defun kill-children () "Unix is sick." (unless *childp* (loop for pid across *children* for index upfrom 0 when pid do (handler-case (sb-posix:kill pid sb-posix::sigterm) (sb-posix:syscall-error (error) (warn "Could not kill PID ~D: ~A" pid error) (setf (aref *children* index) nil)))) (loop for pid across *children* for index upfrom 0 when pid do (ignore-errors (sb-posix:waitpid pid 0)) (setf (aref *children* index) nil)))) ;;; ;;; Signals ;;; (defun setup-child-signal-handlers () (sb-sys:enable-interrupt sb-unix:sigterm (signal-handler 'sb-ext:quit)) (sb-sys:ignore-interrupt sb-unix:sigint)) (defun setup-parent-signal-handlers () (sb-sys:enable-interrupt sb-unix:sigterm (signal-handler 'terminate-gracefully))) (defun terminate-gracefully () (kill-children) (sb-ext:quit)) (defun signal-handler (function) "Return a signal hander function that will funcall FUNCTION." (check-type function (or function symbol)) (lambda (signal code scp) (declare (ignore signal code scp)) (funcall function))) ;;; Locking ;;; ;;; We serialize the child processes access to the server socket by acquiring an ;;; exclusive file lock around the call to accept. The advantage of this is ;;; it's really simple and the kernel takes care of everything for us. The ;;; disadvantage is that the parent process doesn't know what's happening, so it ;;; can't intervene to add or remove child processes. (defmacro with-lock (fd-spec &body forms) (let ((=fd (gensym))) `(let ((,=fd ,fd-spec)) (unwind-protect (progn (flock ,=fd :exclusive) ,@forms) (flock ,=fd :unlock))))) (defun serial-accept (socket) (with-lock *lock* (socket-accept socket))) (defun setup-lock () (let ((lock-file (format nil "/tmp/~D.lock" (sb-posix:getpid)))) (unless *lock* (setf *lock* (open lock-file :if-does-not-exist :create))))) (defun teardown-lock () (when *lock* (delete-file *lock*) (close *lock*) (setf *lock* nil))) ;; I didn't patch SB-POSIX to add flock(2) because it isn't POSIX, it's just a ;; convenient BSD function. (defmacro defconstant-once (name form &optional doc) `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,form) ,doc)) (defconstant-once +flock-table+ #((:shared 1) (:exclusive 2) (:nonblocking 4) (:unlock 8))) (defun flock (fd-spec &rest options) "Perform flock(2) on the FD or FILE-STREAM given as FD-SPEC. OPTIONS are taken from +FLOCK-TABLE+" (let* ((options (reduce #'logior options :key (lambda (option) (or (second (find option +flock-table+ :key #'first)) (error "Unknown flock option: ~S" option))) :initial-value 0)) (fd (etypecase fd-spec (sb-alien:int fd-spec) (file-stream (sb-sys:fd-stream-fd fd-spec))))) (sb-alien:alien-funcall (sb-alien:extern-alien "flock" (function sb-alien:int sb-alien:int sb-alien:int)) fd options)))

1 0

[Small-cl-src] fork, wait, and waitpid for SBCL-0.8.8
by Thomas F. Burdick 04 Jun '04

04 Jun '04

--- sb-posix/interface.lisp.~1.13.~ Thu Feb 19 23:47:27 2004 +++ sb-posix/interface.lisp Mon May 10 17:13:46 2004 @@ -112,6 +112,7 @@ ;;; processes, signals (define-call "alarm" int never-fails (seconds unsigned)) +(define-call "fork" sb-posix::pid-t minusp) (define-call "getpgid" sb-posix::pid-t minusp (pid sb-posix::pid-t)) (define-call "getpid" sb-posix::pid-t never-fails) (define-call "getppid" sb-posix::pid-t never-fails) @@ -123,6 +124,36 @@ (define-call "setpgid" int minusp (pid sb-posix::pid-t) (pgid sb-posix::pid-t)) (define-call "setpgrp" int minusp) + +;; FIXME: The status code we get from the wait functions is only +;; useful in combination with the macros that let us examine it. + +(export 'sb-posix::wait :sb-posix) +(declaim (inline sb-posix::wait)) +(defun sb-posix::wait (&optional statusptr) + (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr)) + (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) + (pid (alien-funcall + (extern-alien "wait" (function sb-posix::pid-t (* int))) + (sb-sys:vector-sap ptr)))) + (if (minusp pid) + (syscall-error) + (values pid (aref ptr 0))))) + +(export 'sb-posix::waitpid :sb-posix) +(declaim (inline sb-posix::waitpid)) +(defun sb-posix::waitpid (pid options &optional statusptr) + (declare (type (sb-alien:alien sb-posix::pid-t) pid) + (type (sb-alien:alien int) options) + (type (or null (simple-array (signed-byte 32) (1))) statusptr)) + (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) + (pid (alien-funcall + (extern-alien "waitpid" (function sb-posix::pid-t + sb-posix::pid-t (* int) int)) + pid (sb-sys:vector-sap ptr) options))) + (if (minusp pid) + (syscall-error) + (values pid (aref ptr 0))))) ;;; mmap, msync (define-call "mmap" sb-sys:system-area-pointer

1 0

[Small-cl-src] Funcallable macros
by Lars Brinkhoff 25 May '04

25 May '04

;;; Lisp apprentice's wet dream: funcallable macros. ;;; Probable newbie usage example: (reduce #`and '(t t t nil t t)) ;;; Two implementations are provided: one trivial using eval, and one ;;; that memoizes compiled functions. (defun funcallable-macro (name) (lambda (&rest args) (eval (cons name args)))) (defun funcallable-macro (name) (let ((table (make-hash-table :test #'eql))) (lambda (&rest args) (let ((n (length args))) (apply (or (gethash n table) (setf (gethash n table) (make-funcallable-macro-function name n))) args))))) (defun make-funcallable-macro-function (name n) (let ((args nil)) (dotimes (i n) (push (gensym) args)) (compile nil `(lambda ,args ,(macroexpand `(,name ,@args)))))) (set-dispatch-macro-character #\# #\` (lambda (s c n) `(funcallable-macro ',(read s t nil t))))

1 0

[Small-cl-src] time-utils.lisp
by Helmut Eller 24 May '04

24 May '04

;;; time-utils.lisp --- libc style time formatting functions ;;; ;;; Written by Helmut Eller in May 2004. ;;; ;;; This file provides a two functions: one to parse time strings and ;;; an another to print time values to strings. The interface is ;;; similar to the Emacs functions `format-time-string' and ;;; `parse-time-string'. ;;; ;;; Not the most lispy implementation but it gets the job done. The ;;; code runs in CMUCL. Porting it to another implementation would be ;;; a major pain. ;;; (defpackage :date-utils (:use :cl :unix :alien :c-call) (:export :format-time-string :parse-time-string)) (in-package :date-utils) ;;;; Alien utilities ;;; ;;; I prefer to work with SAPs (system area pointers) over alien ;;; values. Aliens are only used as convenient way to express ;;; offsets in structures. Aliens are never passed to or returned from ;;; functions (too consy). ;;; (def-alien-type tm (struct unix::tm)) (def-alien-type time-t unix::time-t) (def-alien-type sap system-area-pointer) (defmacro memcpy (to from nbytes) `(kernel:system-area-copy ,from 0 ,to 0 (* ,nbytes vm:byte-bits))) (defun malloc (size) (let ((sap (alien-funcall (extern-alien "malloc" (function sap unsigned)) size))) (when (zerop (sys:sap-int sap)) (unix::unix-get-errno) (error "malloc failed: ~S" (unix:get-unix-error-msg))) sap)) (defun free (sap) (alien-funcall (extern-alien "free" (function void sap)) sap)) (defmacro with-growing-buffer ((buffer size &key (initial-size 1024)) &body body) "Execute BODY repeatedly with BUFFER bound to a sap pointing to a block of memory of size SIZE. SIZE is doubled on each iteration. An implicit block named nil surrounds the entire form; body can be terminated by returning to nil." `(block nil (flet ((try (,buffer ,size) ,@body)) (let ((size ,initial-size)) (with-alien ((buffer (array char ,initial-size))) (try (alien-sap (addr buffer)) ,initial-size)) (loop named #:noname do (setf size (* 2 size)) (let ((buffer (malloc size))) (unwind-protect (try buffer size) (free buffer)))))))) (defun format-time-string (format-string &key time universal unix-epoch) "Use FORMAT-STRING to format the time-value TIME. The return value is a copy of FORMAT-STRING, but with certain constructs replaced by text that describes the specified date and time in TIME. (See strftime(3) for details.) TIME is an integer representing the number of seconds since 1900 (or since 1970 if UNIX-EPOCH is true). TIME defaults to the current time. If UNIVERSAL is true, describe TIME as Universal Time; nil means describe TIME in the local time zone." (with-alien ((utime time-t) (brokentime tm) (c/time (function time-t sap) :extern "time") (c/gmtime_r (function sap (* time-t) (* tm)) :extern "gmtime_r") (c/localtime_r (function sap (* time-t) (* tm)) :extern "localtime_r") (c/strftime (function int sap int c-string (* tm)) :extern "strftime")) ;; Compute the Unixy time value (setf utime (cond ((and time unix-epoch) time) (time (- time #.(encode-universal-time 0 0 0 1 1 1970 0))) (t (let ((time (alien-funcall c/time (sys:int-sap 0)))) (if (= time -1) (error "c/time failed: ~A" (get-unix-error-msg)) time))))) ;; break it up (let ((result (if universal (alien-funcall c/gmtime_r (addr utime) (addr brokentime)) (alien-funcall c/localtime_r (addr utime) (addr brokentime))))) (unless (sys:sap= result (alien-sap (addr brokentime))) (error "format-time-string failed"))) ;; print it (with-growing-buffer (buffer size) (setf (sys:sap-ref-8 buffer 0) 1) (let ((count (alien-funcall c/strftime buffer size format-string (addr brokentime)))) (when (or (plusp count) (and (zerop count) (= (sys:sap-ref-8 buffer 0) 0))) (let ((string (make-string count))) (memcpy (sys:vector-sap string) buffer count) (return string))))))) (defun parse-time-string (format-string string &key junk-allowed time-zone) "Parse the time-string STRING into a universal time value. The return values can be used with decode-universal-time." (declare (type string string format-string)) (with-alien ((tm tm) (c/strptime (function sap c-string c-string (* tm)) :extern "strptime")) (vm::system-area-fill 0 (alien-sap (addr tm)) 0 (alien-size tm :bits)) (sys:without-gcing (let ((result (alien-funcall c/strptime string format-string (addr tm)))) (when (zerop (sys:sap-int result)) (error "parse-time-string failed: ~A ~A" string format-string)) (unless (or junk-allowed (= (length string) (sys:sap- result (sys:vector-sap string)))) (error "There is junk in this string: ~A" string)))) (encode-universal-time (slot tm 'unix::tm-sec) (slot tm 'unix::tm-min) (slot tm 'unix::tm-hour) (slot tm 'unix::tm-mday) (1+ (slot tm 'unix::tm-mon)) (+ 1900 (slot tm 'unix::tm-year)) time-zone))) ;;;; Examples: #| (format-time-string "%a, %d %b %Y %H:%M:%S %Z %z") (parse-time-string "%a, %d %b %Y %H:%M:%S " ; ? why doesn't this fail (format-time-string "%a, %d %b %Y %H:%M:%S")) ;; test print/read consistency (let* ((format "%a, %d %b %Y %H:%M:%S") (string1 (format-time-string format)) (time (parse-time-string format string1)) (string2 (format-time-string format :time time))) (assert (equal string2 string1)) string2) |# ;;; time-utils.lisp ends here.

1 0

[Small-cl-src] format-time.lisp
by Zach Beane 24 May '04

24 May '04

;;; ;;; Usage example: ;;; ;;; (format-time nil "~{Dayname}, ~{Monthname} ~:@{Date}") => ;;; "Monday, May 24th" ;;; (defpackage :format-time (:use :cl) (:export :format-time :time-formatter)) (in-package :format-time) ;;; Errors (define-condition format-time-error (error) ((complaint :reader format-time-error-complaint :initarg :complaint) (control-string :reader format-time-error-control-string :initarg :control-string) (offset :reader format-time-error-offset :initarg :offset)) (:report report-format-time-error)) (define-condition format-time-dumb-error (error) ((complaint :initarg :complaint :reader format-time-dumb-error-complaint)) (:report (lambda (condition stream) (write-string (format-time-dumb-error-complaint condition) stream)))) (defun report-format-time-error (condition stream) (format stream "error in time-format: ~A~% ~A~% ~v@T^~%" (format-time-error-complaint condition) (format-time-error-control-string condition) (format-time-error-offset condition))) ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *day-of-week-names* #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) (defvar *month-names* #("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) (defvar *number-suffixes* #("th" "st" "nd" "rd" "th" "th" "th" "th" "th" "th")) (defvar *decoded-time-values* '(second minute hour date month year day daylight-p zone)) (defvar *date-formatters* (make-hash-table :test 'eq))) (defun number-suffix (number) (svref *number-suffixes* (mod number 10))) (defmacro def-date-formatter (name (directive type) args &body body) "Create a format-time directive processor implemented with a function called NAME that processes a directive of type TYPE (one of :STRING OR :NUMERIC) named by DIRECTIVE. ARGS must only consist of symbols in *DECODED-TIME-VALUES*." (assert (subsetp args *decoded-time-values*)) (assert (member type '(:string :numeric))) (let ((ignore-list (set-difference *decoded-time-values* args))) (setf (gethash directive *date-formatters*) name) (setf (get directive 'strftime-type) type) `(defun ,name (,@*decoded-time-values*) (declare (ignore ,@ignore-list)) ,@body))) (def-date-formatter format-dayname (dayname :string) (day) (svref *day-of-week-names* day)) (def-date-formatter format-monthname (monthname :string) (month) (svref *month-names* (1- month))) (def-date-formatter format-day (day :numeric) (day) day) (def-date-formatter format-date (date :numeric) (date) date) (def-date-formatter format-year (year :numeric) (year) year) (def-date-formatter format-yy (yy :numeric) (year) (mod year 100)) (def-date-formatter format-hh (hh :numeric) (hour) hour) (def-date-formatter format-hh12 (hh12 :numeric) (hour) (let ((12hour (mod hour 12))) (if (zerop 12hour) 12 12hour))) (def-date-formatter format-mm (mm :numeric) (minute) minute) (def-date-formatter format-ss (ss :numeric) (second) second) (def-date-formatter format-am (am :string) (hour) (if (< hour 12) "am" "pm")) ;;; parsing the control string (defun make-directive-printer (directive colonp atp) (ecase (get directive 'strftime-type :error) (:string (cond ((not (or colonp atp)) (lambda (arg stream) (write-string arg stream))) ((not colonp) (lambda (arg stream) (write-string (string-upcase arg) stream))) ((not atp) (lambda (arg stream) (dotimes (i 3) (write-char (schar arg i) stream)))) (t (lambda (arg stream) (dotimes (i 3) (write-char (char-upcase (schar arg i)) stream)))))) (:numeric (cond ((not (or colonp atp)) (lambda (arg stream) (princ arg stream))) ((not colonp) (lambda (arg stream) (format stream "~2,'0D" arg))) ((not atp) (lambda (arg stream) (format stream "~2,' D" arg))) (t (lambda (arg stream) (format stream "~D~A" arg (number-suffix arg)))))) (:error (error 'format-time-dumb-error :complaint "unknown format-time directive")))) (defun make-directive-function (name-string colonp atp) (let* ((name (intern (string-upcase name-string) (find-package "FORMAT-TIME"))) (result-func (gethash name *date-formatters*)) (format-func (make-directive-printer name colonp atp))) (lambda (stream second minute hour date month year day daylight-p zone) (funcall format-func (funcall result-func second minute hour date month year day daylight-p zone) stream)))) (defun tokenize-control-string (string) "Convert the control string STRING to a list of constant strings and printing functions. Signals FORMAT-TIME-ERROR if there is a problem with the control string." (declare (string string)) (let ((pos 0) (end (length string)) (results nil)) (loop (when (>= pos end) (return (nreverse results))) (let ((directive (position #\~ string :start pos))) (cond ((null directive) (push (if (zerop pos) string (subseq string pos)) results) (return (nreverse results))) (t (when (< pos directive) (push (subseq string pos directive) results)) (multiple-value-bind (func new-pos) (parse-directive string directive) (push func results) (setf pos new-pos)))))))) (defun parse-directive (string start) "Convert a single directive from STRING starting at START into a processing function." (declare (string string) (fixnum start)) (let ((colonp nil) (atp nil) (posn (1+ start)) (end (length string))) (labels ((pos-error (message &optional (pos posn)) (error 'format-time-error :complaint message :control-string string :offset (1- pos))) (get-char () (if (= posn end) (pos-error "string ended before directive was found") (prog1 (schar string posn) (incf posn))))) (loop (let ((char (get-char))) (case char ((#\:) (if colonp (pos-error "too many colons supplied") (setf colonp t))) ((#\@) (if atp (pos-error "too many at-signs supplied") (setf atp t))) ((#\{) (let ((name-end (position #\} string :start posn))) (if name-end (return (values (handler-case (make-directive-function (subseq string posn name-end) colonp atp) (format-time-dumb-error (condition) (pos-error (format-time-dumb-error-complaint condition) (1+ posn)))) (1+ name-end))) (pos-error "no corresponding close brace")))))))))) ;;; user interface (defun %format-time (stream control-string tz time) (multiple-value-bind (second minute hour date month year day daylight-p zone) (decode-universal-time time tz) (dolist (item (tokenize-control-string control-string)) (etypecase item (string (write-string item stream)) (function (funcall item stream second minute hour date month year day daylight-p zone)))))) (defun format-time (stream-designator control-string &key (tz 0) (time (get-universal-time))) "Format a universal time into a human-readable time." (etypecase stream-designator (null (with-output-to-string (stream) (%format-time stream control-string tz time))) (string (with-output-to-string (stream stream-designator) (%format-time stream control-string tz time))) ((member t) (%format-time *standard-output* control-string tz time)) (stream (%format-time stream-designator control-string tz time)))) (defun time-formatter-form (item) (if (stringp item) `(write-string ,item) `(funcall ,item *standard-output* second minute hour date month year day daylight-p zone))) (defun %time-formatter-body (control-string) (let* ((items (tokenize-control-string control-string)) (forms (mapcar #'time-formatter-form items))) `(lambda (*standard-output* &key (tz 0) (time (get-universal-time))) ,@(if (every #'stringp items) `((declare (ignore tz time)) ,@forms) `((multiple-value-bind (second minute hour date month year day daylight-p zone) (decode-universal-time time tz) ,@forms)))))) (defmacro time-formatter (control-string) `#',(%time-formatter-body control-string))

1 0

[Small-cl-src] packet.lisp, version 1
by Luke Gorrie 24 May '04

24 May '04

;;; packet.lisp -- Decode TCP/IP packets (version 1) ;;; Written by Luke Gorrie <luke(a)bluetail.com> in May of 2004. ;;; ;;; A PDF version of this source file can be found at: ;;; http://www.bluetail.com/~luke/misc/lisp/packet.pdf ;;; ;;;# Introduction ;;; ;;; This is a program for decoding the packet headers of some TCP/IP ;;; family protocols. It takes a packet (represented as a vector), ;;; decodes all the headers it can, and returns the results in either ;;; association-lists or strucutres. ;;; ;;; This program is a library; it's not very useful in itself. ;;; ;;; Written for recent snapshots of CMUCL. I've used some minor ;;; non-portable features: `ext:collect', `slot-value' on structures, ;;; and (cons T1 T2) type specifiers. (defpackage :packet (:use :common-lisp)) (in-package :packet) ;;;# Top-level interface ;;; ;;; The input for this program is a `buffer' containing an ethernet ;;; frame. ;;; (deftype buffer () "A network packet represented as a vector of octets." '(array octet (*))) (deftype octet () "An unsigned 8-bit byte." '(unsigned-byte 8)) ;;; The program's output is a list of headers that have been decoded ;;; from a buffer. Headers can be represented either as structures or ;;; as association lists, depending on what you'd like. ;;; (deftype header () "A decoded protocol header." '(or structure-header alist-header)) ;;; The structure definition for each protocol header is defined down ;;; below in the same section of code that does the decoding. ;;; (deftype structure-header () "A decoded protocol header represented as a structure." '(or ethernet-header arp-header ipv4-header udp-header)) (deftype alist-header () "A decoded protocol header with fields in an alist. The format is (TYPE-NAME ALIST). TYPE-NAME is the name of the corresponding structure-header." '(cons symbol cons)) ;;; The function `decode' takes a buffer containing a frame and ;;; returns a list of the headers it was able to decode. ;;; (defun decode (buffer format) "Decode headers from BUFFER and return them in a list. The headers are decoded into FORMAT, which can be either :STRUCTURE or :ALIST. Any remaining undecoded data is included as a vector at the end of the list." (grab-headers buffer format)) ;;;# Low-level data-grabbing machinery (declaim (type (or null buffer) *buffer*)) (defvar *buffer* nil "Buffer containing the packet currently being decoded.") (defvar *buffer-position* nil "Current bit-position in *BUFFER*.") (defmacro with-buffer (buffer &body body) "Execute BODY, grabbing input from the beginning of BUFFER." `(let ((*buffer* ,buffer) (*buffer-position* 0)) ,@body)) (defun bit-octet (bit &optional (check-alignment t)) "Convert from bit position to octet position." (multiple-value-bind (quotient remainder) (truncate bit 8) (when (and check-alignment (plusp remainder)) (error "Bit-position ~S is not octet-aligned." bit)) quotient)) (defun octet-bit (octet) "Convert from octet position to bit position." (* 8 octet)) ;;; "Grab" functions consume input from `*buffer*' and advance ;;; `*buffer-position*'. (defun grab-octets (num) "Grab a vector of NUM octets." (let ((start (bit-octet *buffer-position*))) (incf *buffer-position* (* num 8)) (subseq *buffer* start (+ num start)))) (defun grab-ethernet-address () (make-ethernet-address :octets (grab-octets 6))) (defun grab-ipv4-address () (make-ipv4-address :octets (grab-octets 4))) (defun grab-rest () "Grab the rest of the buffer into an octet vector." (prog1 (subseq *buffer* (bit-octet *buffer-position*)) (setf *buffer-position* (octet-bit (length *buffer*))))) ;;; I've written this function countless times but it always comes out ;;; ugly. What's the right way? (defun grab-bits (bits) "Grab a BITS-long unsigned integer" (let ((accumulator 0) (remaining bits)) (flet ((accumulate-byte () ;; Accumulate the relevant part of the current byte and ;; advance to the next one. (let* ((size (min remaining (- 8 (rem *buffer-position* 8)))) (offset (rem (- 8 (rem (+ *buffer-position* size) 8)) 8)) (value (ldb (byte size offset) (aref *buffer* (bit-octet *buffer-position* nil))))) (decf remaining size) (setf accumulator (dpb value (byte size remaining) accumulator)) (incf *buffer-position* size)))) (loop while (plusp remaining) do (accumulate-byte)) accumulator))) (defun grab-bitflag () "Grab a single bit. Return T if it's 1 and NIL if it's 0." (= (grab-bits 1) 1)) ;;;# Protocol implementations ;;; ;;; The interface to each protocol is `(map-<protocol>-header ;;; FUNCTION)'. Function takes two arguments: a header name and its ;;; value. The function is called for each decoded header. It can ;;; accumulate the values any way it likes. (defvar *resolve-protocols* t "When non-nil protocol numbers are resolved to symbolic names. Unrecognised numbers are left as numbers.") (defvar *verify-checksums* t "When non-nil verify checksums in packets.") (deftype checksum-ok-p () "The status of a packet's checksum. T means the checksum is correct, NIL means it is wrong, and :UNKNOWN means it hasn't been checked." '(member t nil :unknown)) (defun lookup (key alist &key (errorp t) (reversep nil)) "Lookup the value of KEY in ALIST. If the key is not present and ERRORP is true then an error is signalled; if ERRORP is nil then the key itself is returned." (let ((entry (funcall (if reversep #'rassoc #'assoc) key alist))) (cond (entry (funcall (if reversep #'car #'cdr) entry)) (errorp (error "Key ~S is not present in ~A." key alist)) (t key)))) ;;;## Ethernet ;;;### ethernet-address ;;; ;;; This big `eval-when' is needed to define the read-syntax for ;;; `ethernet-address' such that it can be used in this file. ;;; ;;; The read syntax is `#e"ff:00:1:2:3:4'. ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (ethernet-address (:conc-name #:ethernet-address.) (:print-function print-ethernet-address)) "48-bit Ethernet MAC address." (octets (ext:required-argument) :type (array octet (6)))) (defun read-ethernet-address (stream &optional c n) "Read an ethernet address in colon-separated syntax. Example: #e\"1:2:3:4:5:6\"" (declare (ignore c n)) (let ((value-stream (make-string-input-stream (read stream t nil t))) (*readtable* (copy-readtable)) (*read-base* 16)) (set-syntax-from-char #\: #\Space) (let ((vec (make-array '(6) :element-type 'octet))) (dotimes (i 6) (let ((octet (read value-stream t nil t))) (unless *read-suppress* (setf (elt vec i) octet)))) (unless *read-suppress* (make-ethernet-address :octets vec))))) (set-dispatch-macro-character #\# #\e 'read-ethernet-address) (defun print-ethernet-address (address stream depth) "Print ethernet addresses as in #e\"0:ff:1:2:3:4\"." (declare (ignore depth)) (format stream "#e\"~{~16,2,'0R~^:~}\"" (coerce (ethernet-address.octets address) 'list))) (defmethod make-load-form ((s ethernet-address) &optional env) (make-load-form-saving-slots s :environment env))) ;;;### Decoder (defstruct (ethernet-header (:conc-name #:ethernet-header.)) (dest nil :type (or null ethernet-address)) (source nil :type (or null ethernet-address)) (protocol nil :type (or null (unsigned-byte 16) symbol))) (defvar ethernet-protocol-names '((#x0806 . :arp) (#x0800 . :ipv4)) "Mapping from ethernet protocol numbers to symbolic names.") (defun map-ethernet-header (function) "Grab an ethernet header and call FUNCTION with each part." (flet ((header (name value) (funcall function name value))) (header 'dest (grab-ethernet-address)) (header 'source (grab-ethernet-address)) (header 'protocol (ethernet-protocol-name (grab-bits 16))))) (defun ethernet-protocol-name (number) "Return the symbolic protocol name of NUMBER, if appropriate." (if *resolve-protocols* (lookup number ethernet-protocol-names :errorp nil) number)) ;;;## ARP (defstruct (arp-header (:conc-name #:arp-header.)) (hardware-type nil :type (or null (unsigned-byte 16))) (protocol-type nil :type (or null (unsigned-byte 16))) (hardware-length nil :type (or null (unsigned-byte 8))) (protocol-length nil :type (or null (unsigned-byte 8))) (operation nil :type (or null symbol (unsigned-byte 16))) (sender-ha nil :type (or null ethernet-address)) (sender-ip nil :type (or null ipv4-address)) (target-ha nil :type (or null ethernet-address)) (target-ip nil :type (or null ipv4-address))) (defun map-arp-header (function) "Grab an ARP header and call FUNCTION with each part." (flet ((header (name value) (funcall function name value))) (header 'hardware-type (grab-bits 16)) (header 'protocol-type (grab-bits 16)) (header 'hardware-length (grab-bits 8)) (header 'protocol-length (grab-bits 8)) (header 'operation (arp-operation (grab-bits 16))) (header 'sender-ha (grab-ethernet-address)) (header 'sender-ip (grab-ipv4-address)) (header 'target-ha (grab-ethernet-address)) (header 'target-ip (grab-ipv4-address)))) (defvar arp-operation-names '((1 . :request) (2 . :response)) "Mapping between ARP operation numbers and their symbolic names.") (defun arp-operation (operation) "Return the symbolic name for OPERATION, if appropriate." (if *resolve-protocols* (lookup operation arp-operation-names :errorp nil) operation)) ;;;## IPv4 ;;; ;;; The Internet Protocol is described in RFC791. ;;; ;;;### ipv4-address ;;; ;;; IP addresses also have a special read-syntax: `(a)10.0.0.1'. ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (ipv4-address (:conc-name #:ipv4-address.) (:print-function print-ipv4-address)) (octets (ext:required-argument) :type (array octet (4)))) (defun read-ipv4-address (stream &optional c n) "Read an IPv4 address in dotted-quad format. Example: @192.168.0.1" (declare (ignore c n)) (let ((*readtable* (copy-readtable))) (set-syntax-from-char #\. #\Space) (let ((vec (make-array '(4) :element-type 'octet))) (dotimes (i 4) (let ((octet (read stream t nil t))) (unless *read-suppress* (setf (elt vec i) octet)))) (unless *read-suppress* (make-ipv4-address :octets vec))))) (set-macro-character #\@ 'read-ipv4-address t) (defun print-ipv4-address (address stream depth) "Print IPv4 addresses as in @192.168.0.1." (declare (ignore depth)) (format stream "@~{~A~^.~}" (coerce (ipv4-address.octets address) 'list))) (defmethod make-load-form ((s ipv4-address) &optional env) (make-load-form-saving-slots s :environment env))) ;;;### decoder (defstruct (ipv4-header (:conc-name #:ipv4-header.)) (version nil :type (or null (unsigned-byte 4))) (hlen nil :type (or null (unsigned-byte 4))) (tos nil :type (or null (unsigned-byte 8))) (total-len nil :type (or null (unsigned-byte 16))) (id nil :type (or null (unsigned-byte 16))) (flags nil :type (or null (unsigned-byte 3))) (fragment-offset nil :type (or null (unsigned-byte 13))) (ttl nil :type (or null (unsigned-byte 8))) (protocol nil :type (or null symbol (unsigned-byte 8))) (checksum nil :type (or null (unsigned-byte 16))) (source nil :type (or null ipv4-address)) (dest nil :type (or null ipv4-address)) ;; Synthetic: (checksum-ok-p nil :type checksum-ok-p)) (defconstant ipv4-min-hlen 5 "The header length (in 32-bit words) of an IPv4 packet with no options.") (defun map-ipv4-header (function) (flet ((header (name value) (funcall function name value))) (let ((header-start-pos (bit-octet *buffer-position*)) hlen checksum) (header 'version (grab-bits 4)) (header 'hlen (setf hlen (grab-bits 4))) (header 'tos (grab-bits 8)) (header 'total-len (grab-bits 16)) (header 'id (grab-bits 16)) (header 'flags (grab-bits 3)) (header 'fragment-offset (grab-bits 13)) (header 'ttl (grab-bits 8)) (header 'protocol (if *resolve-protocols* (ipv4-protocol (grab-bits 8)) (grab-bits 8))) (header 'checksum (setf checksum (grab-bits 16))) (header 'source (grab-ipv4-address)) (header 'dest (grab-ipv4-address)) ;; FIXME (unless (= hlen ipv4-min-hlen) (error "Can't decode options in IPv4 packets.")) (if *verify-checksums* (let* ((initial (- checksum)) (header-octets (* hlen 4)) (computed-checksum (checksum *buffer* header-start-pos header-octets initial))) (header 'checksum-ok-p (eql checksum computed-checksum))) (header 'checksum-ok-p :unknown))))) (defvar ipv4-protocol-names '((1 . :icmp) (6 . :tcp) (17 . :udp)) "Mapping between IPv4 protocol numbers and their symbolic names.") (defun ipv4-protocol (number) "Return the symbolic name for protocol NUMBER, if appropriate." (if *resolve-protocols* (lookup number ipv4-protocol-names :errorp nil) number)) ;;;## UDP ;;; RFC 768 (defstruct (udp-header (:conc-name #:udp-header.)) (src-port nil :type (or null (unsigned-byte 16))) (dest-port nil :type (or null (unsigned-byte 16))) (length nil :type (or null (unsigned-byte 16))) (checksum nil :type (or null (unsigned-byte 16))) (checksum-ok-p nil :type checksum-ok-p)) (defun map-udp-header (function &optional src-ip dest-ip) "Grab a UDP header and call FUNCTION with each part. The checksum can only be checked if the SRC-IP and DEST-IP fields from the IPv4 header are supplied." (flet ((header (name value) (funcall function name value))) (let ((header-start (bit-octet *buffer-position*)) checksum length) (header 'src-port (grab-bits 16)) (header 'dest-port (grab-bits 16)) (header 'length (setf length (grab-bits 16))) (header 'checksum (setf checksum (grab-bits 16))) (if (and *verify-checksums* src-ip dest-ip) (or (zerop checksum) ; checksum is optional (let ((init (- (udp-pseudo-header-checksum-acc src-ip dest-ip length) checksum))) (header 'checksum-ok-p (= checksum (checksum *buffer* header-start length init))))) (header 'checksum-ok-p :unknown))))) (defun udp-pseudo-header-checksum-acc (src-ip dest-ip udp-length) (+ (checksum-acc-ipv4-address src-ip) (checksum-acc-ipv4-address dest-ip) (lookup :udp ipv4-protocol-names :reversep t) udp-length)) ;;;# Checksum computation ;;; ;;; The TCP/IP protocols use 16-bit ones-complement checksums. See ;;; RFC1071 for details. (defun checksum (buffer &optional (position 0) (length (length buffer)) (initial 0)) "Compute the checksum of a region in BUFFER. POSITION and LENGTH are both in octets. INITIAL is the initial checksum value as a normal integer." (finish-checksum (compute-checksum buffer position length initial))) (defun compute-checksum (buffer &optional (position 0) (length (length buffer)) (initial 0)) "Compute a checksum using normal twos-complement arithmetic. The buffer is treated as a sequence of 16-bit big-endian numbers." (declare (type buffer buffer)) (let ((last-pos (+ position (1- length))) (acc initial)) (do ((msb-pos position (+ msb-pos 2)) (lsb-pos (1+ position) (+ lsb-pos 2))) ((> lsb-pos last-pos) acc) (let ((lsb (aref buffer lsb-pos)) (msb (if (> msb-pos last-pos) 0 (aref buffer msb-pos)))) (incf acc (dpb msb (byte 8 8) lsb)))))) (defun checksum-acc-ipv4-address (address) "Return the partial checksum accumulated from an IPv4 address." (compute-checksum (ipv4-address.octets address))) (defun finish-checksum (n) "Convert N into an unsigned 16-bit ones-complement number. The result is a bit-pattern also represented as an integer." (let* ((acc (+ (ldb (byte 16 16) n) (ldb (byte 16 0) n))) (acc (+ acc (ldb (byte 16 16) acc)))) (logxor #xFFFF (ldb (byte 16 0) acc)))) ;;;# Creating headers (defun grab-header-into-alist (type) "Grab a header of TYPE into an `alist-header'." (ext:collect ((fields)) (funcall (mapping-function type) (lambda (header value) (fields (cons header value)))) (fields))) (defun grab-header-into-structure (type) "Grab a header of TYPE into a `structure-header'." (let ((structure (make-instance type))) (funcall (mapping-function type) (lambda (slot value) (setf (slot-value structure slot) value))) structure)) ;;;# Header-decoding driver (defvar *format* nil "Which format to decode headers in, either :STRUCTURE or :ALIST.") (defvar *previous-header* nil "Bound to the previously decoded header. Some protocols (e.g. UDP) need to retrieve fields from their enclosing protocol's header.") (defun grab-headers (buffer format) "Return a list of decoded headers from BUFFER in FORMAT." (with-buffer buffer (let* ((*format* format) (headers (grab-more-headers (grab-header :ethernet))) (rest (grab-rest))) (if (zerop (length rest)) headers (append headers (list rest)))))) (defun grab-more-headers (header) "Accumulate HEADER and continue decoding the rest." (let ((*previous-header* header)) (if (member (header-type header) '(ethernet-header ipv4-header)) (let ((inner-protocol (get-header-field header 'protocol))) (cons header (grab-more-headers (grab-header inner-protocol)))) ;; This is the last header we know how to decode. (list header)))) (defun grab-header (protocol) "Grab and return the header of PROTOCOL." (let ((type (structure-type-for-protocol protocol))) (ecase *format* (:alist (make-alist-header type (grab-header-into-alist type))) ((:structure) (grab-header-into-structure type))))) (defun make-alist-header (type fields-alist) "Make an `alist-header'." (list type fields-alist)) (defvar protocol-header-types '((:ethernet . ethernet-header) (:ipv4 . ipv4-header) (:arp . arp-header) (:udp . udp-header)) "Association list matching protocol names with their header types.") (defun structure-type-for-protocol (protocol) "Lookup the header type for PROTOCOL." (lookup protocol protocol-header-types)) (defun header-type (header) "Return the type of HEADER. This is the name of the corresponding structure-type, even if the header is in alist format." (etypecase header (alist-header (first header)) (structure-header (type-of header)))) (defun get-header-field (header field) "Return the value of FIELD in HEADER." (declare (type header header)) (etypecase header (alist-header (cdr (assoc field (second header)))) (structure-header (slot-value header field)))) (defun mapping-function (type) "Return the appropriate field-mapping function for TYPE." (ecase type (ethernet-header #'map-ethernet-header) (arp-header #'map-arp-header) (ipv4-header #'map-ipv4-header) (udp-header ;; Pass on the IP addresses for checksum computation. (let ((src-ip (get-header-field *previous-header* 'source)) (dest-ip (get-header-field *previous-header* 'dest))) (lambda (function) (map-udp-header function src-ip dest-ip)))))) ;;;# Sample packets (defvar arp-packet (coerce #(255 255 255 255 255 255 0 8 116 228 110 188 8 6 0 1 8 0 6 4 0 1 0 8 116 228 110 188 192 168 128 44 0 0 0 0 0 0 192 168 128 1) 'buffer) "An ethernet frame containing an ARP request.") (defvar udp-packet (coerce #(255 255 255 255 255 255 0 8 116 228 110 188 8 0 69 0 0 124 0 0 64 0 64 17 183 244 192 168 128 44 192 168 128 255 128 117 0 111 0 104 5 206 20 15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0 2 0 0 0 5 0 0 0 1 0 0 0 24 64 158 126 39 0 0 0 4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0 0 0 12 98 108 117 101 116 97 105 108 46 99 111 109) 'buffer) "An ethernet frame containing a UDP packet.") (defun test () "Test that the sample packets are decoded correctly." (let ((alist-arp (decode arp-packet :alist)) (alist-udp (decode udp-packet :alist)) (struct-arp (decode arp-packet :structure)) (struct-udp (decode udp-packet :structure))) (assert (equalp alist-arp '((ETHERNET-HEADER ((DEST . #e"FF:FF:FF:FF:FF:FF") (SOURCE . #e"00:08:74:E4:6E:BC") (PROTOCOL . :ARP))) (ARP-HEADER ((HARDWARE-TYPE . 1) (PROTOCOL-TYPE . 2048) (HARDWARE-LENGTH . 6) (PROTOCOL-LENGTH . 4) (OPERATION . :REQUEST) (SENDER-HA . #e"00:08:74:E4:6E:BC") (SENDER-IP . @192.168.128.44) (TARGET-HA . #e"00:00:00:00:00:00") (TARGET-IP . @192.168.128.1)))))) (assert (equalp alist-udp `((ETHERNET-HEADER ((DEST . #e"FF:FF:FF:FF:FF:FF") (SOURCE . #e"00:08:74:E4:6E:BC") (PROTOCOL . :IPV4))) (IPV4-HEADER ((VERSION . 4) (HLEN . 5) (TOS . 0) (TOTAL-LEN . 124) (ID . 0) (FLAGS . 2) (FRAGMENT-OFFSET . 0) (TTL . 64) (PROTOCOL . :UDP) (CHECKSUM . 47092) (SOURCE . @192.168.128.44) (DEST . @192.168.128.255) (CHECKSUM-OK-P . T))) (UDP-HEADER ((SRC-PORT . 32885) (DEST-PORT . 111) (LENGTH . 104) (CHECKSUM . 1486) (CHECKSUM-OK-P . T))) ,(coerce #(20 15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0 2 0 0 0 5 0 0 0 1 0 0 0 24 64 158 126 39 0 0 0 4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0 0 0 12 98 108 117 101 116 97 105 108 46 99 111 109) 'buffer)))) (assert (equivalentp alist-arp struct-arp)) (assert (equivalentp alist-udp struct-udp)) t)) (defun equivalentp (alist-headers structure-headers) "Do ALIST-HEADERS and STRUCTURE-HEADERS have the same slot values?" (if (and (null alist-headers) (null structure-headers)) t (destructuring-bind ((ah &rest arest) (sh &rest srest)) (list alist-headers structure-headers) (and (cond ((and (typep ah 'buffer) (typep sh 'buffer)) (equalp ah sh)) ((eq (header-type ah) (header-type sh)) (loop for (key . value) in (second ah) always (equalp (slot-value sh key) value)))) (equivalentp arest srest)))))

1 0

[Small-cl-src] Transforming recursion into dynamic programming
by Darius Bacon 18 May '04

18 May '04

;;; Everyone's seen Lisp code to automatically memoize a function. ;;; This is a bit different: it changes the evaluation order from ;;; top-down to bottom-up. A recursive call turns into a direct ;;; reference into the memo table, with no check for whether that ;;; part of the table has been computed yet. See the discussion at ;;; http://lambda.weblogs.com/discuss/msgReader$6437 defmacro defun-recurrence (name params inits &body body) "Define a recursive function that's evaluated by dynamic programming, bottom-up from the INITS values to the PARAMS values." (let ((tabulate-name (concat-symbol "TABULATE-" name)) (table `(make-array (list ,@(mapcar (lambda (p) `(+ ,p 1)) params)))) (ranges (mapcar (lambda (p init) `(for ,p from ,init to ,p)) params inits))) `(progn (defun ,tabulate-name ,params (tabulate ,name ,table ,ranges ,@body)) (defun ,name ,params (aref (,tabulate-name ,@params) ,@params))))) (defmacro tabulate (name table-exp ranges &body body) "Evaluate a recursive function by dynamic programming, returning the memo-table." (let ((table (gensym)) (vars (mapcar #'second ranges))) `(let ((,table ,table-exp)) ,(nest-loops ranges `(setf (aref ,table ,@vars) (flet ((,name ,vars (aref ,table ,@vars))) ,@body))) ,table))) (defun nest-loops (ranges body-exp) "Build a nested LOOP form." (if (null ranges) body-exp `(loop ,@(car ranges) do ,(nest-loops (cdr ranges) body-exp)))) (defun concat-symbol (&rest parts) "Concatenate symbols or strings to form an interned symbol." (intern (format nil "~{~a~}" parts)))

1 0

[Small-cl-src] serve-event-tricky.lisp
by Luke Gorrie 14 May '04

14 May '04

;;; There was a recent threads on comp.lang.lisp about SERVE-EVENT. I ;;; was having trouble articulating some issues, so I wrote this small ;;; demonstration program to clear my thinking. ;;; ;;; More examples are possible. Post 'em if you find 'em! ;;; serve-event-tricky.lisp -- Tricky examples of SERVE-EVENT ;;; First version, written by Luke Gorrie in May 2004. ;;; ;;; A nice pretty PDF version of this program can be downloaded from: ;;; http://www.bluetail.com/~luke/misc/lisp/serve-event-tricky.pdf ;;; ;;;# Introduction ;;; ;;; This is a small example to show some tricky aspects of using the ;;; `SERVE-EVENT' framework in CMUCL. First we define a simple server ;;; program, then we write some small clients to provoke it into ;;; behaving badly. (in-package :cl-user) (defvar port 10000 "The TCP port for the server.") ;;; We will often want to print short messages, so here is a helpful ;;; little utility: (defun say (format &rest args) "Print a formatted message to standard-output on a fresh line." (format t "~&~?~%" format args) (force-output)) ;;;# The server ;;; ;;; The server binds a listening socket and loops accepting ;;; connections. For each connection it calls READ, prints the result, ;;; and closes the socket. All I/O scheduling is driven by ;;; `SERVE-EVENT'. ;;; ;;; The server reports abnormal exits and unhandled conditions from ;;; handlers. (defun run-server () "Run the server in a loop until aborted." (let ((listen-socket (start-server))) (unwind-protect (server-loop) (stop-server listen-socket)))) (defun start-server () "Start the server." (let ((socket (ext:create-inet-listener port :stream :reuse-address t)) (nr-connections 0)) (sys:add-fd-handler socket :input (lambda (s) (server-accept (incf nr-connections) s))) socket)) (defun server-loop () "Loop serving requests until aborted. If an error is raised then it is printed and the loop continues." (with-simple-restart (stop-server "Stop the example server.") (handler-case (loop (sys:serve-all-events)) (error (err) (say "Continuing after error: ~A" (type-of err)))))) (defun stop-server (socket) (sys:invalidate-descriptor socket) (close-socket socket)) (defun server-accept (nr listen-socket) "Accept new connection number NR from LISTEN-SOCKET. This is a callback for when SERVE-EVENT detects a new connection." (sys:add-fd-handler (accept-tcp-connection listen-socket) :input (lambda (socket) (server-handle-connection nr socket)))) (defun server-handle-connection (number socket) "Handle connection NUMBER on SOCKET. Try to READ one sexp from the socket and print it. Also print a message if we lose control (the stack unwinds) unexpectedly. This is a callback for when SERVE-EVENT detects available data." (let ((stream (sys:make-fd-stream socket :input t)) (successful nil)) (unwind-protect (with-standard-io-syntax (say "Connection #~D read ~A" number (read stream)) (setq successful t)) (close-connection stream) (unless successful (say "Connection #~D aborted!" number))))) (defun close-connection (stream) (sys:invalidate-descriptor (sys:fd-stream-fd stream)) (when (open-stream-p stream) (close stream))) ;;;# The client ;;; ;;; The client part is just a few utilities for opening sockets and ;;; sending strings. (defun make-client () "Connect to the server and return the (unbuffered) output stream." (let ((fd (connect-to-inet-socket "localhost" port))) (sys:make-fd-stream fd :output t :buffering :none))) (defmacro with-clients ((&rest variables) &body body) "Bind VARIABLES to new connections to the server and execute BODY. Ensure the connections are closed before returning." `(let ,(mapcar (lambda (var) (list var '(make-client))) variables) (unwind-protect (progn ,@body) (dolist (client (list ,@variables)) (close-connection client))))) (defun send (client string) "Send STRING to CLIENT and pause a moment to let the server process it." (princ string client) (sleep 0.1)) ;;;# Test cases ;;; ;;; Our task now is to write clients that provoke undesirable ;;; behaviour from the server. To test the programs you should start ;;; two Lisp systems and load this file in both. Then in one you do ;;; `(run-server)' and in the other you can call the exploit functions ;;; defined below. ;;; ;;; An important tool is being able to make the server enter calls to ;;; `READ' and choosing when to allow them to exit. We can do this by ;;; sending a SEXP in two parts -- the first causes the server to ;;; start reading, and it can't finish until we send the rest. (defparameter first-half "(foo" "The first half of a SEXP.") (defparameter second-half "bar)" "The other half of the SEXP.") ;;;## Delay exploit ;;; ;;; Clients can case delays for each other. Here is a case with two ;;; clients, A and B, where A must wait for B to finish a request ;;; before being able to proceed, even though all of A's data is ;;; available to the server. (defun delay () (with-clients (a b) (send a first-half) (send b first-half) (send a second-half) (sleep 5) (send b second-half))) ;;; The expected output is for the server to say nothing for a few ;;; seconds, and then print: ;; Connection #2 read (FOOBAR) ;; Connection #1 read (FOOBAR) ;;; Here's why: ;;; ;;; Both clients connect and send half of a request, with A sending ;;; first. The server enters "blocking" `READ's, first for A and then ;;; for B, and awaits more input. The relevant parts of the server's ;;; Lisp stack look like this: ;;; ;; (SERVE-EVENT) ;; (READ B) ;; (SERVE-EVENT) ;; (READ A) ;; (SERVE-EVENT) ;; (SERVER-LOOP) ;;; ;;; Next A sends the rest of his request. But what can we do with it? ;;; Nothing yet: we cannot return from `(READ A)' without first ;;; returning from `(READ B)', and B is still blocking. A must wait ;;; for B's request to complete. In the test case this takes a few ;;; seconds. ;;; ;;; This case can occur if the network fails between client and ;;; server, and it's easy to trigger deliberately (maliciously). A ;;; timeout of some kind is required to break out of the problem. ;;;## Error propagation exploit ;;; ;;; Another issue presents itself from looking at the previous stack ;;; diagram. What if an unhandled condition is signalled in the `READ' ;;; of B? With our server it will propagate right up the stack and be ;;; handled by `SERVER-LOOP'. That means that an error triggered by ;;; client B will cause client A's handler to be unwound from the ;;; stack, aborting his connection in the process. (defun error-propagation () (with-clients (a b) (send a first-half) (send b "#@ <- illegal read syntax: will trigger an error.") (ignore-errors (send a second-half)))) ;;; The expected output on the server is: ;; Connection #2 aborted! ;; Connection #1 aborted! ;; Continuing after error: READER-ERROR ;;;# Conclusion ;;; ;;; `SERVE-EVENT' presents a simple interface and makes it easy to ;;; write common server programs. However, you have to be thoughtful ;;; about how you use it, and be aware of what's on the ;;; stack. Otherwise you could be eaten alive on the big bad internet.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

small-cl-src