[Gd-chatter] r11652 - in trunk/libraries: gui-sniffer packetizer protocols
andreas at gwydiondylan.org
andreas at gwydiondylan.org
Wed Jan 23 00:30:33 CET 2008
Author: andreas
Date: Wed Jan 23 00:30:31 2008
New Revision: 11652
Modified:
trunk/libraries/gui-sniffer/command-line.dylan
trunk/libraries/gui-sniffer/commands.dylan
trunk/libraries/gui-sniffer/gui-sniffer.dylan
trunk/libraries/gui-sniffer/main.dylan
trunk/libraries/gui-sniffer/module.dylan
trunk/libraries/packetizer/module.dylan
trunk/libraries/packetizer/packetizer.dylan
trunk/libraries/packetizer/protocol-definer-macro.dylan
trunk/libraries/protocols/ethernet.dylan
trunk/libraries/protocols/icmp.dylan
trunk/libraries/protocols/ipv4.dylan
trunk/libraries/protocols/protocols-library.dylan
Log:
job: 7299
* property for displaying current key bindings
* refactoring of protocol layer binding using generic functions
* better ICMP support
Modified: trunk/libraries/gui-sniffer/command-line.dylan
==============================================================================
--- trunk/libraries/gui-sniffer/command-line.dylan (original)
+++ trunk/libraries/gui-sniffer/command-line.dylan Wed Jan 23 00:30:31 2008
@@ -85,6 +85,7 @@
editor: editor);
let node = make-empty-section-node(buffer);
add-node!(buffer, node, after: #"start");
+ interval-read-only?(node) := #t;
buffer
end method make-shell;
Modified: trunk/libraries/gui-sniffer/commands.dylan
==============================================================================
--- trunk/libraries/gui-sniffer/commands.dylan (original)
+++ trunk/libraries/gui-sniffer/commands.dylan Wed Jan 23 00:30:31 2008
@@ -79,8 +79,7 @@
close-socket(socket);
end);
connect(socket, response-handler);
- let icmp = icmp-frame(code: 0, icmp-type: 8,
- payload: read-frame(<raw-frame>, "123412341234123412341234123412341234123412341234"));
+ let icmp = icmp-echo-request(icmp-data: read-frame(<raw-frame>, "123412341234123412341234123412341234123412341234"));
send(context.nnv-context.ip-layer, target, icmp);
format(stream, "Ping sent!\n");
end;
@@ -196,6 +195,23 @@
apply-filter(context.nnv-context);
end;
+define class <key-bindings-property> (<command-property>)
+end;
+
+define command-property key-bindings => <key-bindings-property>
+ (summary: "Summary of key bindings",
+ documentation: "Shows a list of all editor key bindings")
+end;
+
+define method show-property
+ (context :: <nnv-context>, property :: <key-bindings-property>)
+ => ()
+ let stream = context.context-server.server-output-stream;
+ let docstrings = compute-key-binding-documentation(frame-command-set(context.nnv-context.nnv-shell-pane));
+ do(curry(write-line, stream), docstrings);
+end;
+
+
define command-group network
(summary: "Networking commands",
documentation: "The set of commands for managing the network.")
@@ -215,6 +231,7 @@
group basic;
group property;
group network;
+ property key-bindings;
end command-group;
define method context-command-group
Modified: trunk/libraries/gui-sniffer/gui-sniffer.dylan
==============================================================================
--- trunk/libraries/gui-sniffer/gui-sniffer.dylan (original)
+++ trunk/libraries/gui-sniffer/gui-sniffer.dylan Wed Jan 23 00:30:31 2008
@@ -631,8 +631,7 @@
define method ping-source (node :: <gui-sniffer-frame>)
let data = current-packet(node);
- let icmp = icmp-frame(code: 0, icmp-type: 8,
- payload: read-frame(<raw-frame>, "123412341234123412341234123412341234123412341234"));
+ let icmp = icmp-echo-request(icmp-data: read-frame(<raw-frame>, "123412341234123412341234123412341234123412341234"));
send(node.ip-layer, data.payload.source-address, icmp);
end;
Modified: trunk/libraries/gui-sniffer/main.dylan
==============================================================================
--- trunk/libraries/gui-sniffer/main.dylan (original)
+++ trunk/libraries/gui-sniffer/main.dylan Wed Jan 23 00:30:31 2008
@@ -16,7 +16,7 @@
format(*standard-output*, "\n\nType 'help' down here to get started.\n");
recenter-window(gui-sniffer.nnv-shell-pane, gui-sniffer.nnv-shell-pane.window-point.bp-line, #"bottom");
start-frame(gui-sniffer);
-end;
+end function main;
main()
Modified: trunk/libraries/gui-sniffer/module.dylan
==============================================================================
--- trunk/libraries/gui-sniffer/module.dylan (original)
+++ trunk/libraries/gui-sniffer/module.dylan Wed Jan 23 00:30:31 2008
@@ -56,7 +56,7 @@
use prism2, import: { <prism2-frame> };
use ipv4, import: { <ipv4-frame>, <udp-frame>, source-port, destination-port,
acknowledgement-number, sequence-number, ipv4-address, <ipv4-address> };
- use icmp, import: { <icmp-frame>, icmp-frame };
+ use icmp, import: { <icmp-frame>, icmp-echo-request };
use dhcp, import: { <dhcp-message>, <dhcp-subnet-mask>, <dhcp-router-option>, subnet-mask, addresses, your-ip-address };
use cidr;
use tcp;
Modified: trunk/libraries/packetizer/module.dylan
==============================================================================
--- trunk/libraries/packetizer/module.dylan (original)
+++ trunk/libraries/packetizer/module.dylan Wed Jan 23 00:30:31 2008
@@ -117,9 +117,8 @@
destination-address, destination-address-setter,
payload-type,
container-frame-size,
- get-protocol-magic, layer-magic,
- layer,
- reverse-layer, recursive-reverse-layer;
+ layer-magic,
+ lookup-layer, reverse-lookup-layer;
export <header-frame>,
<unparsed-header-frame>,
Modified: trunk/libraries/packetizer/packetizer.dylan
==============================================================================
--- trunk/libraries/packetizer/packetizer.dylan (original)
+++ trunk/libraries/packetizer/packetizer.dylan Wed Jan 23 00:30:31 2008
@@ -234,12 +234,6 @@
define open generic decoded-class (type :: subclass(<container-frame>))
=> (class :: <class>);
-define open generic layer (type :: subclass(<container-frame>))
- => (res :: false-or(<table>));
-
-define open generic reverse-layer (type :: subclass(<container-frame>))
- => (res :: false-or(<table>));
-
define open generic layer-magic (frame :: <container-frame>) => (res);
define method layer-magic (frame :: <container-frame>) => (res)
@@ -251,30 +245,22 @@
slot parent :: false-or(<container-frame>) = #f, init-keyword: parent:;
end;
-define method stack-protocol (bottom-layer :: <type>, upper-layer :: <type>, magic)
- layer(bottom-layer)[magic] := upper-layer;
- reverse-layer(bottom-layer)[decoded-class(upper-layer)] := magic;
-end;
-
define function payload-type (frame :: <container-frame>) => (res :: <type>)
- let table = layer(frame.object-class);
- element(table, frame.layer-magic, default: <raw-frame>);
+ lookup-layer(frame.object-class, frame.layer-magic) | <raw-frame>;
end;
-define open generic recursive-reverse-layer (frame) => (res :: false-or(<table>));
+define open generic lookup-layer (frame :: subclass(<frame>), value :: <integer>) => (class :: false-or(<class>));
+
+define method lookup-layer (frame :: subclass(<frame>), value :: <integer>) => (false == #f) #f end;
+
+define open generic reverse-lookup-layer (frame :: subclass(<frame>), payload :: <frame>) => (value :: <integer>);
-define inline method recursive-reverse-layer (frame) => (res :: false-or(<table>))
- #f
-end;
define inline method fixup-protocol-magic (frame :: <header-frame>) => (magic)
- get-protocol-magic(frame, frame.payload);
+ reverse-lookup-layer(frame.object-class, frame.payload);
end;
define inline method fixup-protocol-magic (frame :: <container-frame>) => (magic)
- let res = choose(rcurry(instance?, <variably-typed-field>), fields(frame));
- if (res.size = 1)
- get-protocol-magic(frame, res[0].getter(frame));
- end;
+ reverse-lookup-layer(frame.object-class, frame);
end;
define class <inline-layering-error> (<error>)
@@ -283,29 +269,6 @@
define class <missing-inline-layering-error> (<error>)
end;
-define inline method fixup-protocol-magic (frame :: <variably-typed-container-frame>) => (magic)
- let layer-table = recursive-reverse-layer(frame.object-class);
- if (layer-table)
- let res = element(layer-table, frame.object-class, default: #f);
- if (res)
- res
- else
- signal(make(<inline-layering-error>));
- end;
- else
- signal(make(<missing-inline-layering-error>));
- end;
-end;
-
-
-define inline method get-protocol-magic (frame :: <container-frame>, payload :: <frame>) => (magic)
- let reverse-layering = reverse-layer(frame.object-class);
- let res = element(reverse-layering, decoded-class(payload.object-class), default: #f);
- unless (res)
- error("don't know how to layer %= over %=", payload.frame-name, frame.frame-name);
- end;
- res;
-end;
define method initialize (frame :: <decoded-container-frame>,
#rest rest, #key, #all-keys)
@@ -391,7 +354,6 @@
//can't specify type because unparsed-getter can't return false-or(<frame>)!
define open generic payload (frame :: <header-frame>) => (payload);
-define open generic get-protocol-magic (frame :: <container-frame>, payload :: <frame>);
define method payload (frame :: <header-frame>) => (payload)
error("No payload specified");
end;
Modified: trunk/libraries/packetizer/protocol-definer-macro.dylan
==============================================================================
--- trunk/libraries/packetizer/protocol-definer-macro.dylan (original)
+++ trunk/libraries/packetizer/protocol-definer-macro.dylan Wed Jan 23 00:30:31 2008
@@ -87,22 +87,6 @@
$protocols[?#"name"] := "$" ## ?name ## "-fields";
end;
end;
- define constant "$" ## ?name ## "-layering" = make(<table>);
- define inline method layer (frame :: subclass(?name)) => (res :: false-or(<table>))
- "$" ## ?name ## "-layering";
- end;
- define constant "$" ## ?name ## "-reverse-layering" = make(<table>);
- define inline method reverse-layer (frame :: subclass(?name)) => (res :: false-or(<table>))
- "$" ## ?name ## "-reverse-layering"
- end;
- define inline method recursive-reverse-layer (frame :: subclass(?name), #next next-method)
- => (res :: false-or(<table>))
- if ("$" ## ?name ## "-reverse-layering".size > 0)
- "$" ## ?name ## "-reverse-layering"
- else
- next-method()
- end;
- end;
define constant "$" ## ?name ## "-layer-bonding"
= begin
let res = choose(rcurry(instance?, <layering-field>), "$" ## ?name ## "-fields");
@@ -491,14 +475,12 @@
packet :: <byte-sequence>,
#key parent :: false-or(<container-frame>),
default = <raw-frame>)
- if (layer(frame-type) & layer(frame-type).size > 0)
- let superprotocol-frame = next-method();
- let real-type = element(layer(frame-type),
- layer-magic(superprotocol-frame),
- default: default);
+ let superprotocol-frame = next-method();
+ let real-type = lookup-layer(frame-type, layer-magic(superprotocol-frame));
+ if (real-type & (real-type ~== frame-type))
parse-frame(real-type, packet, parent: parent);
else
- next-method()
+ superprotocol-frame
end;
end;
@@ -586,7 +568,8 @@
end } =>
{
define ?attrs protocol ?name (?superprotocol) ?fields end;
- stack-protocol(?super, "<" ## ?name ## ">", ?magic);
+ define method lookup-layer (frame :: subclass(?super), value == ?magic) => (class :: <class>) "<" ## ?name ## ">" end;
+ define method reverse-lookup-layer (frame :: subclass(?super), payload :: "<" ## ?name ## ">") => (value :: <integer>) ?magic end;
}
{ define ?attrs:* protocol ?:name (?superprotocol:name)
Modified: trunk/libraries/protocols/ethernet.dylan
==============================================================================
--- trunk/libraries/protocols/ethernet.dylan (original)
+++ trunk/libraries/protocols/ethernet.dylan Wed Jan 23 00:30:31 2008
@@ -67,7 +67,7 @@
field organization-code :: <3byte-big-endian-unsigned-integer> = 0;
layering field type-code :: <2byte-big-endian-unsigned-integer>;
variably-typed-field payload,
- type-function: element(<ethernet-frame>.layer, frame.type-code, default: <raw-frame>);
+ type-function: lookup-layer(<ethernet-frame>, frame.type-code) | <raw-frame>;
end;
define protocol vlan-tag (header-frame)
@@ -78,7 +78,7 @@
field vlan-id :: <12bit-unsigned-integer>;
layering field type-code :: <2byte-big-endian-unsigned-integer>;
variably-typed-field payload,
- type-function: element(<ethernet-frame>.layer, frame.type-code, default: <raw-frame>);
+ type-function: lookup-layer(<ethernet-frame>, frame.type-code) | <raw-frame>;
end;
define protocol stp-identifier (container-frame)
Modified: trunk/libraries/protocols/icmp.dylan
==============================================================================
--- trunk/libraries/protocols/icmp.dylan (original)
+++ trunk/libraries/protocols/icmp.dylan Wed Jan 23 00:30:31 2008
@@ -1,19 +1,132 @@
module: icmp
-define protocol icmp-frame (header-frame)
+define abstract protocol icmp-frame (variably-typed-container-frame)
summary "ICMP type %= code %=", icmp-type, code;
over <ipv4-frame> 1;
over <ipv6-frame> #x3a;
- field icmp-type :: <unsigned-byte>;
- field code :: <unsigned-byte>;
- field checksum :: <2byte-big-endian-unsigned-integer> = 0;
- field payload :: <raw-frame>;
+ layering field icmp-type :: <unsigned-byte>;
end;
+//XXX!
+define constant <ip-frame> = <ipv4-frame>;
+
define method fixup! (frame :: <unparsed-icmp-frame>,
#next next-method)
frame.checksum := calculate-checksum(frame.packet, frame.packet.size);
next-method();
end;
+define protocol icmp-destination-unreachable (icmp-frame)
+ over <icmp-frame> 3;
+ enum field code :: <unsigned-byte>,
+ mappings: { 0 <=> #"net unreachable",
+ 1 <=> #"host unreachable",
+ 2 <=> #"protocol unreachable",
+ 3 <=> #"port unreachable",
+ 4 <=> #"fragmentation needed and df set",
+ 5 <=> #"source route failed",
+ 6 <=> #"destination network unknown",
+ 7 <=> #"destination host unknown",
+ 8 <=> #"source host isolated",
+ 9 <=> #"network administratively prohibited",
+ 10 <=> #"host administratively prohibited",
+ 11 <=> #"network unreachable for type of service",
+ 12 <=> #"host unreachable for type of service",
+ 13 <=> #"communication administratively prohibited",
+ 14 <=> #"host precedence violation",
+ 15 <=> #"precedence cutoff in effect" };
+ field checksum :: <2byte-big-endian-unsigned-integer> = 0;
+ field unused :: <raw-frame>, static-length: 32;
+ field original-data :: <ip-frame>;
+end;
+
+define protocol icmp-time-exceeded (icmp-frame)
+ over <icmp-frame> 11;
+ enum field code :: <unsigned-byte>,
+ mappings: { 0 <=> #"time to live exceeded in transit",
+ 1 <=> #"fragment reassembly time exceeded" };
+ field checksum :: <2byte-big-endian-unsigned-integer> = 0;
+ field unused :: <raw-frame>, static-length: 32;
+ field original-data :: <ip-frame>;
+end;
+
+define protocol icmp-parameter-problem (icmp-frame)
+ over <icmp-frame> 12;
+ enum field code :: <unsigned-byte>,
+ mappings: { 0 <=> #"pointer indicates error" };
+ field checksum :: <2byte-big-endian-unsigned-integer> = 0;
+ field pointer :: <unsigned-byte>;
+ field unused :: <raw-frame>, static-length: 24;
+ field original-data :: <ip-frame>;
+end;
+
+define protocol icmp-source-quench (icmp-frame)
+ over <icmp-frame> 4;
+ field code :: <unsigned-byte> = 0;
+ field checksum :: <2byte-big-endian-unsigned-integer> = 0;
+ field unused :: <raw-frame>, static-length: 32;
+ field original-data :: <ip-frame>;
+end;
+
+define protocol icmp-redirect (icmp-frame)
+ over <icmp-frame> 5;
+ enum field code :: <unsigned-byte>,
+ mappings: { 0 <=> #"redirect for network",
+ 1 <=> #"redirect for host",
+ 2 <=> #"redirect for type of service and network",
+ 3 <=> #"redirect for type of service and host" };
+ field checksum :: <2byte-big-endian-unsigned-integer> = 0;
+ field gateway-address :: <ipv4-address>;
+ field original-data :: <ip-frame>;
+end;
+
+define abstract protocol icmp-echo-message (icmp-frame)
+ field code :: <unsigned-byte> = 0;
+ field checksum :: <2byte-big-endian-unsigned-integer> = 0;
+ field identifier :: <2byte-big-endian-unsigned-integer> = 42;
+ field sequence-number :: <2byte-big-endian-unsigned-integer> = 0;
+ field icmp-data :: <raw-frame>;
+end;
+
+define protocol icmp-echo-request (icmp-echo-message)
+ over <icmp-frame> 8;
+end;
+
+define protocol icmp-echo-reply (icmp-echo-message)
+ over <icmp-frame> 0;
+end;
+
+define abstract protocol icmp-timestamp (icmp-frame)
+ field code :: <unsigned-byte> = 0;
+ field checksum :: <2byte-big-endian-unsigned-integer> = 0;
+ field identifier :: <2byte-big-endian-unsigned-integer> = 42;
+ field sequence-number :: <2byte-big-endian-unsigned-integer> = 0;
+ field originate-timestamp :: <big-endian-unsigned-integer-4byte>;
+ field receive-timestamp :: <big-endian-unsigned-integer-4byte>;
+ field transmit-timestamp :: <big-endian-unsigned-integer-4byte>;
+end;
+
+define protocol icmp-timestamp-request (icmp-timestamp)
+ over <icmp-frame> 13;
+end;
+
+define protocol icmp-timestamp-reply (icmp-timestamp)
+ over <icmp-frame> 14;
+end;
+
+define abstract protocol icmp-information-message (icmp-frame)
+ field code :: <unsigned-byte> = 0;
+ field checksum :: <2byte-big-endian-unsigned-integer> = 0;
+ field identifier :: <2byte-big-endian-unsigned-integer> = 42;
+ field sequence-number :: <2byte-big-endian-unsigned-integer> = 0;
+end;
+
+define protocol icmp-information-request (icmp-information-message)
+ over <icmp-frame> 15;
+end;
+
+define protocol icmp-information-reply (icmp-information-message)
+ over <icmp-frame> 16;
+end;
+
Modified: trunk/libraries/protocols/ipv4.dylan
==============================================================================
--- trunk/libraries/protocols/ipv4.dylan (original)
+++ trunk/libraries/protocols/ipv4.dylan Wed Jan 23 00:30:31 2008
@@ -115,7 +115,7 @@
define function my-payload-type (frame :: <udp-frame>)
let res = payload-type(frame);
if (res == <raw-frame>)
- element(layer(frame.object-class), frame.source-port, default: <raw-frame>);
+ lookup-layer(frame.object-class, frame.source-port) | <raw-frame>;
else
res;
end;
Modified: trunk/libraries/protocols/protocols-library.dylan
==============================================================================
--- trunk/libraries/protocols/protocols-library.dylan (original)
+++ trunk/libraries/protocols/protocols-library.dylan Wed Jan 23 00:30:31 2008
@@ -300,7 +300,7 @@
use streams-protocol;
use format;
- use ipv4, import: { <ipv4-frame>, calculate-checksum };
+ use ipv4, import: { <ipv4-frame>, <ipv4-address>, calculate-checksum };
use ipv6, import: { <ipv6-frame> };
export <icmp-frame>, icmp-frame,
@@ -308,6 +308,7 @@
code, code-setter,
checksum, checksum-setter;
+ export icmp-echo-request;
end;
define module dhcp
use common-dylan;
More information about the chatter
mailing list