Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Snippets/PNL Libraries/MyTraceroute.p

Text File | 1996-11-04 | 9.8 KB | 402 lines | [TEXT/CWIE]

unit MyTraceroute;

{ based on Quinn's DTS sample code }

interface

    uses
        Types, OpenTransport, OpenTptInternet;

    type
        ICMPRecordedInformation = record
            sent_time: UnsignedWide;
            arrival_time: UnsignedWide;
            remote_ip: InetHost;
            typecode: integer;
            ttl: integer;
            udp_remote_port: InetPort;
        end;

    const
        max_icmp_results = 100;
        null_traceroute_index = -1;

    var
        icmp_results: array[1..max_icmp_results] of ICMPRecordedInformation;
        traceroutes_in_progress: longint;

    procedure StartupMyTraceroute;

    function StartTraceroute: OSStatus; { Start & Stop may be nested and must be paired }
    procedure StopTraceroute;

    function FindFreeResultIndex: integer;
    procedure FreeResultIndex( var index: integer );

    function SendTraceroutePacket( dest: InetHost; index: integer; ttl: longint ): OSStatus;

implementation

    uses
        Events, Timer,
        MyCStrings, MyLookFreeOT, MyTransport, MyStartup, MyMemory;

    const
        min_remote_port = 33434;
        max_remote_port = 34433;

    var
        udp_ep, rawip_ep: EndpointRef;
        udp_local_port: InetPort;
        next_udp_remote_port: InetPort;

    procedure InitResults;
        var
            i: integer;
    begin
        for i := 1 to max_icmp_results do begin
            icmp_results[i].udp_remote_port := 0;
        end;
    end;

    function FindResultIndex( port: InetPort ): integer;
        var
            i: integer;
            result: integer;
    begin
        result := null_traceroute_index;
        if (min_remote_port <= port) & (port <= max_remote_port) then begin
            for i := 1 to max_icmp_results do begin
                if icmp_results[i].udp_remote_port = port then begin
                    result := i;
                    leave;
                end;
            end;
        end;
        FindResultIndex := result;
    end;

    procedure FreeResultIndex( var index: integer );
    begin
        if index <> null_traceroute_index then begin
            icmp_results[index].udp_remote_port := 0;
            index := null_traceroute_index;
        end;
    end;

    function FindFreeResultIndex: integer;
        var
            i: integer;
            result: integer;
    begin
        result := null_traceroute_index;
        for i := 1 to max_icmp_results do begin
            if icmp_results[i].udp_remote_port = 0 then begin
                icmp_results[i].remote_ip := 0;
                icmp_results[i].udp_remote_port := next_udp_remote_port;
                next_udp_remote_port := next_udp_remote_port + 1;
                if next_udp_remote_port > max_remote_port then begin
                    next_udp_remote_port := min_remote_port;
                end;
                result := i;
                leave;
            end;
        end;
        FindFreeResultIndex := result;
    end;

    procedure RawIPEventHandler ( ep: EndpointRef; event: OTEventCode; result: OTResult; cookie: univ Ptr);
        type
            UDPReplyData = packed record
                local_port: InetPort;
                remote_port: InetPort;
                len: integer;
                checksum: integer;
            end;
            UDPReplyDataPtr = ^UDPReplyData;
        var
            err: OSStatus;
            packet:packed array[0..1023] of Byte;
            udata: TUnitData;
            src_addr: InetAddress;
            header1_size, header2_size: integer;
            udp: UDPReplyDataPtr;
            index: integer;
            flags: OTFlags;
    begin
{$unused(cookie, result)}
        case event of
            T_DATA, T_GODATA: begin
                while true do begin
                    udata.addr.buf := @src_addr;
                    udata.addr.maxlen := SizeOf(src_addr);
                    udata.opt.buf := nil;
                    udata.opt.maxlen := 0;
                    udata.udata.buf := @packet;
                    udata.udata.maxlen := SizeOf(packet);
                    err := OTRcvUData( ep, @udata, flags );
                    if err <> noErr then begin
                        leave;
                    end;
                    header1_size := band(packet[0], $0F)*4;
                    if (packet[header1_size+0] = 3) | (packet[header1_size+0] = 11) then begin
                        header2_size := band(packet[header1_size+8],$0F)*4;
                        udp := @packet[header1_size+8+header2_size];
                        if udp^.local_port = udp_local_port then begin
                            index := FindResultIndex( udp^.remote_port );
                            if (index > 0) & (icmp_results[index].remote_ip = 0) then begin
                                Microseconds( icmp_results[index].arrival_time );
                                icmp_results[index].ttl := band( packet[8], $FF );
                                icmp_results[index].remote_ip := LongIntPtr( @packet[12] )^;
                                icmp_results[index].typecode := IntegerPtr( @packet[header1_size+0] )^;
                                icmp_results[index].udp_remote_port := udp^.remote_port;
                            end;
                        end;
                    end;
                end;
            end;
            kOTProviderIsClosed, kOTProviderWillClose: begin
                if rawip_ep <> nil then begin
                    err := OTCloseProvider( ep );
                    rawip_ep := nil;
                end;
            end;
            otherwise
                ;
        end;
    end;

    procedure UDPEventHandler ( ep: EndpointRef; event: OTEventCode; result: OTResult; cookie: univ Ptr);
        var
            err: OSStatus;
    begin
{$unused(cookie, result)}
        case event of
            kOTProviderIsClosed, kOTProviderWillClose: begin
                if udp_ep <> nil then begin
                    err := OTCloseProvider( ep );
                    udp_ep := nil;
                end;
            end;
            otherwise
                ;
        end;
    end;

    function OTOpenUDP( var ep: EndpointRef; var port: InetPort ): OSStatus;
        var
            err, junk: OSStatus;
            retsin:InetAddress;
            ret:TBind;
    begin
        ep := OTOpenEndpoint( OTCreateConfiguration( "udp" ), 0, nil, err );
        if err = noErr then begin
            err:=OTInstallNotifier( ep, @UDPEventHandler, ep );
            if err = noErr then begin
                MZero(@ret, sizeof(ret));
                ret.addr.maxlen := SizeOf(InetAddress);
                ret.addr.buf := @retsin;
                err := OTBind( ep, nil, @ret );
                port := retsin.fPort;
            end;
            if err <> noErr then begin
                junk := OTCloseProvider( ep );
            end;
        end;
        if err <> noErr then begin
            ep := nil;
        end;
        OTOpenUDP := noErr;
    end;

    function OTOpenRawip( var ep: EndpointRef; proc: ProcPtr ): OSStatus;
        var
            err, junk: OSStatus;
    begin
        ep := OTOpenEndpoint( OTCreateConfiguration( "rawip" ), 0, nil, err );
        if err = noErr then begin
            if proc <> nil then begin
                err:=OTInstallNotifier( ep, proc, ep );
            end;
            if err = noErr then begin
                err := OTBind( ep, nil, nil );
            end;
            if err = noErr then begin
                err := OTSetAsynchronous( ep );
            end;
            if err <> noErr then begin
                junk := OTCloseProvider( ep );
            end;
        end;
        if err <> noErr then begin
            ep := nil;
        end;
        OTOpenRawip := noErr;
    end;

{
    // According to the XTI spec, IP_TTL is an INET_IP level option that
    //  determines the TTL of an IP packet.  The value of this option is
    //  a UInt8.  This routine simply negotiates that option on the ep
    //  endpoint.
}
    function DoNegotiateIP_TTLOption( ep: EndpointRef; ttl: longint): OSStatus;
        var
            err: OSStatus;
            opt: TOption;
            req: TOptMgmt;
            ret: TOptMgmt;
    begin
        opt.level := INET_IP;
        opt.optName := IP_TTL;
        opt.len := kOTOneByteOptionSize;
        opt.status := 0;
        Ptr(@opt.value)^ := ttl;

        req.opt.buf := @opt;
        req.opt.len := kOTOneByteOptionSize;
        req.flags := T_NEGOTIATE;

        ret.opt.buf := @opt;
        req.opt.maxlen := SizeOf(opt);

        err := OTOptionManagement(ep, @req, @ret);

        if (err = noErr) & (opt.status <> T_SUCCESS) then begin
            err := opt.status;
        end;

        DoNegotiateIP_TTLOption := err;
    end;

{
        // 33434 is the default port for unix traceroute.
        //  It was chosen because it's unlikely that anyone will be listening on this
        //  port.  Hence any packets that make it through will generate an ICMP
        //  port unreachable error.
        // [PNL - except that OT starts anonymous ports at 32768..]
}

{
        // The act of sending (OTSndUData) is a little more complicated than it should be.
        //  Basically the ICMP errors that come back from all these bogus (short TTL)
        //  packets that I send, end up as datagram errors on the sending endpoint.
        //  If you attempt to send with a T_UDERR sitting on the endpoint, you get
        //  a kOTLookErr which must be dealt with
}
    function SendUDPWithTTL( dest: InetHost; index: integer; ttl: longint; data: Ptr; datalen: longint ): OSStatus;
        var
            err: OSStatus;
            dest_addr: InetAddress;
            udata: TUnitData;
    begin
        err := noErr;
        if     udp_ep = nil then begin
            err := -1;
        end;
        if err = noErr then begin
            err := DoNegotiateIP_TTLOption( udp_ep, ttl );
        end;
        if err = noErr then begin
            OTInitInetAddress(dest_addr, icmp_results[index].udp_remote_port, dest);

            udata.addr.len := SizeOf(dest_addr);
            udata.addr.buf := @dest_addr;

            udata.opt.len := 0;
            udata.opt.buf := nil;

            udata.udata.len := datalen;
            udata.udata.buf := data;

            Microseconds( icmp_results[index].sent_time );
            err := OTLFSndUData( udp_ep, udata );
        end;

        SendUDPWithTTL := err;
    end;

    function SendTraceroutePacket( dest: InetHost; index: integer; ttl: longint ): OSStatus;
        type
            UDPPacket = record
                    ttl: longint;
                end;
        var
            packet: UDPPacket;
    begin
        packet.ttl := ttl;
        SendTraceroutePacket := SendUDPWithTTL( dest, index, ttl, @packet, SizeOf(packet) );
    end;

    procedure CloseEndpoints;
        var
            junk: OSErr;
            tmp: EndpointRef;
    begin
        if udp_ep <> nil then begin
            tmp := udp_ep;
            udp_ep := nil;
            junk := OTCloseProvider( tmp );
        end;
        if rawip_ep <> nil then begin
            tmp := rawip_ep;
            rawip_ep := nil;
            junk := OTCloseProvider( tmp );
        end;
    end;

    function StartTraceroute: OSStatus;
        var
            err: OSStatus;
    begin
        if (traceroutes_in_progress > 0) & (udp_ep <> nil) & (rawip_ep <> nil) then begin
            err := noErr;
        end else begin
            err := OpenTransportSystem;
            if (err = noErr) & (udp_ep = nil) then begin
                err := OTOpenUDP( udp_ep, udp_local_port);
            end;
            if (err = noErr) & (rawip_ep = nil) then begin
                err := OTOpenRawip( rawip_ep, @RawIPEventHandler );
            end;
        end;
        if err = noErr then begin
            Inc(traceroutes_in_progress);
        end else begin
            CloseEndpoints;
        end;
        StartTraceroute := err;
    end;

    procedure StopTraceroute;
    begin
        Dec(traceroutes_in_progress);
        if traceroutes_in_progress = 0 then begin
            CloseEndpoints;
        end;
    end;

    function InitMyTraceroute( var msg: integer ): OSStatus;
    begin
{$unused(msg)}
        udp_ep := nil;
        rawip_ep := nil;
        traceroutes_in_progress := 0;
        next_udp_remote_port := min_remote_port;
        InitResults;
        InitMyTraceroute := noErr;
    end;

    procedure FinishMytraceroute;
    begin
        CloseEndpoints;
    end;

    procedure StartupMyTraceroute;
    begin
        StartupTransport;
        SetStartup( InitMyTraceroute, nil, 0, FinishMytraceroute );
    end;

end.