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

Text File | 1996-06-01 | 14.1 KB | 545 lines | [TEXT/CWIE]

unit MyOOSIVC;

interface

    uses
        Types;

    const
        PC_UseSIVC = 'SIVC';
        PC_FirstCheckSIVC = 'SIVd';
        PC_LastCheckSIVCQuantum = 'SICl';
        PC_CheckSIVCPeriod = 'SIVc';
        PC_LastSIVC = 'SIVL';
        PC_SIVCUsers = 'SIVU';

    type
        SIVCNewVersionCallBack = procedure(data:Handle; latest_version:Str31);
        SIVCGetSOCKSServerCallBack = procedure(var server:Str255);
        SIVCManualQueryCallBack = procedure(err:OSErr; newversion:Boolean; data:Handle; latest_version:Str31);

    var
        first_ever_sivc: Boolean; { if this is the first time - warn the user! }

    procedure StartupSIVC;
    procedure ConfigureSIVC(newversion : SIVCNewVersionCallBack; getsocks:SIVCGetSOCKSServerCallBack);

    procedure ManualQuery(mcresult: SIVCManualQueryCallBack);
    function CanManualQuery:Boolean;

implementation

    uses
        Errors, Resources, MyNewPreferences, TCPOOConnections, DNR, MyMathUtils, TranslateISO,
        MyTypes, MyHandleFile, MySocks, MyStrings, MyVersionResource, MyUtils, MyStartup;

    const
        sivc_id = 932;
        sivc_default_port = 7124;
        idle_til_period = 10 * 60 *60; { only even consider checking every 10 minutes }
        timeout_period = 120 * 60;

    type
        SIVCStrings = (SS_None, SS_Server, SS_SOCKSServer);
        SIVCState = (ST_None, ST_SOCKS_DNR, ST_Connecting, ST_SendSOCKS, ST_SendQuery, ST_WaitClose, ST_Finished);
        SIVCMaunalState = (MS_None, MS_Want, MS_Doing);

    var
        newversion_callback : SIVCNewVersionCallBack;
        getsocks_callback : SIVCGetSOCKSServerCallBack;
        mcresult_callback : SIVCManualQueryCallBack;
        state : SIVCState;
        idle_til:longint;
        use_socks:boolean;
        sivc_dnr:Ptr;
        sivc_port:integer;
        sivc_addr: ipAddr;
        socks_port: integer;
        vers:versionRecord;
        app_creator: string[4];
        query_result:Handle;
        manual_state:SIVCMaunalState;
        timeout:longint;

    procedure ServerToHostPort(s:Str255; defport:integer; var host:Str255; var port:integer);
        var
            portstr:Str255;
            n:longint;
    begin
        if Split(':', s, host, portstr) | Split(' ', s, host, portstr) then begin
            StringToNum(portstr,n);
            port := n;
        end else begin
            host := s;
            port := defport;
        end;
    end;

    procedure GetSOCKSServer(var server:Str255);
    begin
        server := '';
        if getsocks_callback <> nil then begin
            getsocks_callback(server);
        end;
        if server = '' then begin
            GetIndString(server,sivc_id,ord(SS_SOCKSServer));
        end;
    end;

    procedure ReleaseConnection;
    begin
        TransportAbortDNR(sivc_dnr);
        TransportDestroy(tref);
    end;

    function SendQuery:OSErr;
        var
            query:Str255;
            count:integer;
            err: OSErr;
    begin
        if (manual_state = MS_Doing) then begin
            query := 'Query: ProductInfoManual';
        end else begin
            query := 'Query: ProductInfoAuto';
        end;
        query := concat(query, cr,
                                'Product: ', vers.name, cr,
                                'ProductID: macos:APPL/',app_creator,cr,
                                'Version: ',HexNN(longint(vers.numericVersion),8),cr,
                                cr);
        count := MacToNet(@query[1],length(query));

        err := TransportSend(tref, @query[1], count);
        SendQuery := err;
    end;

    function SendSocks:OSErr;
        var
            query:SocksRecordSmall;
    begin
        query.version := socks_version;
        query.cmd := socks_connect;
        query.port := sivc_port;
        query.ip := sivc_addr;
        SendSocks := TransportSend(tref, @query, SizeOf(query));
    end;

    function IsField(field:Str255; var line:Str255):Boolean;
        var
            s:Str255;
    begin
        IsField := false;
        if IsPrefix(line, field) then begin
            s := Trim(TPcopy(line, length(field)+1, 255));
            if (s<>'') & (s[1] = ':') then begin
                line := Trim(TPcopy(s, 2, 255));
                IsField := true;
            end;
        end;
    end;

    procedure ProcessResult;
        var
            hf:HandleFile;
            line:Str255;
            latest_version:longint;
            query_interval, users:longint;
            ver:NumVersion;
            new:boolean;
    begin
        hf.data := query_result;
        hf.pos := 0;
        hf.crlf := CL_CR;
        hf.error := noErr;
        latest_version := -1;
        while ReadFromHandleFile(hf, line) do begin
            if IsField('ReleaseVersion', line) then begin
                latest_version := HexToNum(line);
            end else if IsField('AutoQueryIntervalM', line) then begin
                StringToNum(line, query_interval);
                if (query_interval >= 1440) & (query_interval < 136800) then begin { 1 to 95 days }
                    prefs.SetTagLong(PC_CheckSIVCPeriod, query_interval);
                end;
            end else if IsField('UserCount',line) then begin
                StringToNum(line, users);
                prefs.SetTagLong(PC_SIVCUsers, users);
            end;
        end;
        new := (latest_version > longint(vers.numericVersion));
        line := '';
        if (latest_version <> -1) then begin
            ver := NumVersion(latest_version);
            line:=concat(NumToStr(ver.majorRev),'.',
                                NumToStr(BAND(ver.minorAndBugRev div 16,$0F)),'.',
                                NumToStr(BAND(ver.minorAndBugRev,$0F))
                                );
            if (ver.stage<>$80) or (ver.nonRelRev<>0) then begin
                case ver.stage of
                    $20:begin
                        line:=concat(line,'d');
                    end;
                    $40:begin
                        line:=concat(line,'a');
                    end;
                    $60:begin
                        line:=concat(line,'b');
                    end;
                    $80:begin
                        line:=concat(line,'f');
                    end;
                    otherwise begin
                        line:=concat(line,'<',NumToStr(ver.stage),'>');
                    end;
                end;
                if ver.nonRelRev <> 0 then begin
                    line:=concat(line,NumToStr(ver.nonRelRev));
                end;
            end;
        end;
        if (manual_state = MS_Doing) then begin
            if mcresult_callback <> nil then begin
                mcresult_callback(noErr, new, query_result, line);
                mcresult_callback := nil;
            end;
        end else begin
            if new & (newversion_callback <> nil) then begin
                newversion_callback(query_result, line);
            end;
        end;
    end;

    function GetThisQuantum:longint;
        var
            date,first_checked_date,check_period: longint;
    begin
        GetDateTime(date);
        prefs.GetTagLong(PC_FirstCheckSIVC,first_checked_date);
        prefs.GetTagLong(PC_CheckSIVCPeriod,check_period);
        GetThisQuantum := (date - first_checked_date) div 60 div check_period;
    end;

    procedure IdleSIVC;
        var
            last_quantum:longint;
            s:Str255;
            err:OSErr;
            socksresult:SocksRecordSmall;
            space: packed array[1..256] of Byte;
            count: integer;
            tstate :TCPStateType;
            date:longint;
            received:longint;
            result: OSStatus;
            junk: OSErr;
    begin
        if (state <> ST_Finished) & ((manual_state <> MS_None) | (TickCount > idle_til)) then begin
            err := noErr;
            if (manual_state = MS_Want) & (state = ST_None) then begin
                manual_state := MS_Doing;
            end;
            if (state <> ST_None) & (state <> ST_SOCKS_DNR) & (TickCount > timeout) then begin
                err := -8;
            end else if not prefs.GetTagBoolean(PC_UseSIVC) & (manual_state <> MS_Doing) then begin
                err := -4;
            end else begin
                case state of
                    ST_None: begin
                        prefs.GetTagLong(PC_LastCheckSIVCQuantum,last_quantum);
                        if (GetThisQuantum <> last_quantum) or (manual_state = MS_Doing) then begin
                            SetHandleSize(query_result,0);
                            GetSOCKSServer(s);
                            use_socks := s<>'';
                            GetIndString(s,sivc_id,ord(SS_Server));
                            ServerToHostPort(s,sivc_default_port,s,sivc_port);
                            if use_socks then begin
                                err := TransportNameToAddr(s, sivc_dnr);
                                state := ST_SOCKS_DNR;
                            end else begin
                                timeout := TickCount + timeout_period;
                                err := TransportOpenActiveConnection(tref, concat(s, ':', NumToStr(sivc_port)), 0, 0);
                                if err = noErr then begin
                                    err := TransportHandleTransfers(tref);
                                end;
                                state := ST_Connecting;
                            end;
                        end else begin
                            err := -1;
                        end;
                    end;
                    ST_SOCKS_DNR:begin
                        TransportGetNameToAddrResult(sivc_dnr, result, nil, @sivc_addr, 1);
                        case result of
                            inProgress: begin
                                err := noErr;
                            end;
                            noErr: begin
                                timeout := TickCount + timeout_period;
                                GetSOCKSServer(s);
                                ServerToHostPort(s, socks_default_port, s, socks_port);
                                err := TransportOpenActiveConnection(tref, concat(s, ':', NumToStr(socks_port)), 0, 0);
                                if err = noErr then begin
                                    err := TransportHandleTransfers(tref);
                                end;
                                state := ST_Connecting;
                            end;
                            otherwise begin
                                err := result;
                            end;
                        end;
                    end;
                    ST_Connecting:begin
                        if not (TransportGetConnectionState(tref) in [T_WaitingForOpen, T_Bored, T_Opening]) then begin
                            if TransportGetConnectionState(tref) = T_Established then begin
                                if use_socks then begin
                                    err := SendSOCKS;
                                    state := ST_SendSOCKS;
                                end else begin
                                    err := SendQuery;
                                    state := ST_SendQuery;
                                end;
                            end else begin
                                err := -6;
                            end;
                        end;
                    end;
                    ST_SendSOCKS:begin
                        if TransportGetConnectionState(tref) = T_Established then begin
                            if TransportCharsAvailable(tref) >= SizeOf(socksresult) then begin
                                err := TransportReceive(tref, @socksresult, SizeOf(socksresult), received);
                                if (err = noErr) & (received <> SizeOf(socksresult)) &  (socksresult.cmd <> socks_result) then begin
                                    err := -2;
                                end;
                                if err = noErr then begin
                                    err := SendQuery;
                                    state := ST_SendQuery;
                                end;
                            end;
                        end else begin
                            err := -72;
                        end;
                    end;
                    ST_SendQuery:begin
                        tstate := TransportGetConnectionState(tref);
                        count := Min(TransportCharsAvailable(tref),SizeOf(space));
                        if (tstate <> T_Dead) & (tstate <> T_Bored) & ((tstate <> T_PleaseClose) | (count > 0))then begin
                            if count>0 then begin
                                err := TransportReceive(tref, @space, count, received);
                                if err = noErr then begin
                                    count := NetToMac(@space,received);
                                    err:=PtrAndHand(@space,query_result,count);
                                end;
                            end;
                        end else begin
                            if tstate = T_PleaseClose then begin
                                TransportSendClose(tref);
                            end;
                            GetDateTime(date);
                            prefs.SetTagLong(PC_LastSIVC,date);
                            ProcessResult;
                            if (manual_state <> MS_Doing) then begin
                                prefs.SetTagLong(PC_LastCheckSIVCQuantum, GetThisQuantum);
                            end;
                            state := ST_WaitClose;
                            junk := WritePrefsData;
                        end;
                    end;
                    ST_WaitClose:begin
                        tstate := TransportGetConnectionState(tref);
                        if (tstate = T_Dead) or (tstate = T_Bored) then begin
                            err := -3;
                        end;
                    end;
                end;
            end;
            if err <> noErr then begin
                ReleaseConnection;
                idle_til := TickCount + idle_til_period;
                state := ST_None;
                if (manual_state = MS_Doing) then begin
                    manual_state := MS_None;
                    if mcresult_callback <> nil then begin
                        mcresult_callback(err, false, nil, '');
                        mcresult_callback := nil;
                    end;
                end;
            end;
        end;
    end;

    procedure DieBadly(err:OSErr);
    begin
        if manual_state = MS_Doing then begin
            manual_state := MS_None;
            if mcresult_callback <> nil then begin
                mcresult_callback(err, false, nil, '');
                mcresult_callback := nil;
            end;
        end;
        state := ST_None;
    end;

    type
        SIVCConnectionObject = object(ConnectionObject)
            procedure Destroy;
            override;
            procedure Established;
            override;
        end;

    procedure SIVCConnectionObject.Established;
        var
            err:OSErr;
    begin
        if use_socks then begin
            err := SendSOCKS;
        end else begin
            err := SendQuery;
        end;
        if err <> noErr then begin
            DieBadly( err );
            timetodie := true;
        end;
    end;

    procedure SIVCConnectionObject.Destroy;
    begin
        DieBadly(-3);
        inherited Destroy;
    end;

    type
        SIVCAddressSearchObject = object(AddressSearchObject)
            procedure FoundAddress (ip: longint);
            override;
            procedure Failed (oe: OSErr);
            override;
        end;

    procedure SIVCAddressSearchObject.FoundAddress (ip: longint);
        var
            s:Str255;
            conn_obj:SIVCConnectionObject;
    begin
        GetSOCKSServer(s);
        ServerToHostPort(s, socks_default_port, s, socks_port);
        new(conn_obj);
        conn_obj.NewActiveConnection( 0, s, socks_port );
    end;

    procedure SIVCAddressSearchObject.Failed (oe: OSErr);
    begin
        DieBadly(oe);
    end;

    procedure DoQuery( manual: Boolean );
        var
            s:Str255;
            addr_obj:SIVCAddressSearchObject;
            conn_obj:SIVCConnectionObject;
    begin
        if manual then begin
            manual_state := MS_Doing;
        end;
        SetHandleSize(query_result,0);
        GetSOCKSServer(s);
        use_socks := s<>'';
        GetIndString(s,sivc_id,ord(SS_Server));
        ServerToHostPort(s,sivc_default_port,s,sivc_port);
        if use_socks then begin
            new(addr_obj);
            addr_obj.FindAddress( s );
        end else begin
            new(conn_obj);
            conn_obj.NewActiveConnection( 0, s, sivc_port );
        end;
        state := ST_Doing;
    end;

    function CanManualQuery:Boolean;
    begin
        CanManualQuery := (manual_state = MS_None) & (state <> ST_Finished);
    end;

    procedure ManualQuery(mcresult: SIVCManualQueryCallBack);
    begin
        if CanManualQuery then begin
            mcresult_callback := mcresult;
            if (state = ST_None) then begin
                DoQuery(true);
            end else begin
                manual_state := MS_Want;
            end;
        end else begin
            if mcresult <> nil then begin
                mcresult(aspServerBusy,false,nil,'');
            end;
        end;
    end;

    procedure IdleSIVC;
    begin
        if (state = ST_None) then begin
            if (manual_state = MS_Want) then begin
                DoQuery(true);
            end else if prefs.GetTagBoolean( PC_UseSIVC ) then begin
                prefs.GetTagLong(PC_LastCheckSIVCQuantum,last_quantum);
                if (GetThisQuantum <> last_quantum) or (manual_state = MS_Doing) then begin
                    DoQuery(false);
                end;
            end;
        end;
    end;

    function InitSIVC(var msg: integer): OSStatus;
        var
            bndl:Handle;
            date:longint;
            junk: OSErr;
    begin
{$unused(msg)}
        sivc_dnr := nil;
        state := ST_None;
        tref := nil;
        idle_til := TickCount;
        GetVersion(vers);
        app_creator := '????';
        bndl := Get1Resource('BNDL', 128);
        if (bndl <> nil) & (bndl^ <> nil) & (GetHandleSize(bndl) >= 4) then begin
            BlockMove(bndl^, @app_creator[1], 4);
        end;
        query_result:= NewHandle(0);
        GetDateTime(date);
        SetDefaultLong(PC_FirstCheckSIVC,date);
        SetDefaultLong(PC_LastCheckSIVCQuantum,-1234);
        SetDefaultLong(PC_CheckSIVCPeriod,10080); { 1 week }
        SetDefaultLong(PC_LastSIVC,bad_date);
        SetDefaultLong(PC_SIVCUsers,-1);
        first_ever_sivc := not prefs.ExistsTag(PC_UseSIVC);
        junk := WritePrefsData;
        InitSIVC := noErr;
    end;

    procedure FinishSIVC;
    begin
        ReleaseConnection;
        state := ST_Finished;
        DisposeHandle(query_result);
    end;

    procedure ConfigureSIVC(newversion : SIVCNewVersionCallBack; getsocks:SIVCGetSOCKSServerCallBack);
    begin
        StartupSIVC;
        newversion_callback := newversion;
        getsocks_callback := getsocks;
    end;

    procedure StartupSIVC;
    begin
        StartupTransport;
        StartupTranslateISO;
        SetStartup(InitSIVC, IdleSIVC, 10, FinishSIVC);
    end;

end.