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

Text File | 1997-01-30 | 12.0 KB | 442 lines | [TEXT/CWIE]

unit MySIVC;

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, MyTransport, DNR, MyMathUtils, MyTranslateISO,
        MyTypes, MyHandleFile, MySocks, MyStrings, MyVersionResource, MyUtils, MyStartup, MySystemGlobals;

    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;
        tref: TransportRef;
        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;
        last_char_was_cr: boolean;

    procedure ServerToHostPort(s:Str255; defport:integer; var host:Str255; var port:integer);
        var
            portstr:Str255;
            n:longint;
    begin
        if SplitAt(s, ':', host, portstr) | SplitAt(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: UInt32;
            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:UInt32;
            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
                        last_char_was_cr := false;
                        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, last_char_was_cr );
                                    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;

    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;
            manual_state := MS_Want;
        end else begin
            if mcresult <> nil then begin
                mcresult(aspServerBusy,false,nil,'');
            end;
        end;
    end;

    function InitSIVC(var msg: integer): OSStatus;
        var
            bndl:Handle;
            date:UInt32;
            junk: OSErr;
    begin
{$unused(msg)}
        sivc_dnr := nil;
        state := ST_None;
        tref := nil;
        idle_til := TickCount;
        GetVersion(app_resfile, vers);
        app_creator := '????';
        bndl := Get1Resource('BNDL', 128);
        if (bndl <> nil) & (bndl^ <> nil) & (GetHandleSize(bndl) >= 4) then begin
            BlockMoveData(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.