[Back to NETWORK SWAG index] [Back to Main SWAG index] [Original]

    {$R+,V-}

    { This program will prompt for a server, login id and password.  All }
    { input will be echoed to the screen!                                }

    PROGRAM LOGON;

    USES
      Dos,
      Crt;

    CONST
      NET_USER         = 1;
      USER_GROUP       = 2;
      FILE_SERVER      = 4;

      MaxServers       = 8;
      DriveHandleTable = 0;
      DriveFlagTable   = 1;
      DriveServerTable = 2;
      ServerMapTable   = 3;
      ServerNameTable  = 4;

    TYPE
      Buf32 = ARRAY [0..31] OF BYTE;
      Buf16 = ARRAY [0..15] OF BYTE;
      Buf8  = ARRAY [0..7]  OF BYTE;
      Buf4  = ARRAY [0..3]  OF BYTE;

    CONST
      EncryptTable : ARRAY [BYTE] OF BYTE =
    ($7,$8,$0,$8,$6,$4,$E,$4,$5,$C,$1,$7,$B,$F,$A,$8,
     $F,$8,$C,$C,$9,$4,$1,$E,$4,$6,$2,$4,$0,$A,$B,$9,
     $2,$F,$B,$1,$D,$2,$1,$9,$5,$E,$7,$0,$0,$2,$6,$6,
     $0,$7,$3,$8,$2,$9,$3,$F,$7,$F,$C,$F,$6,$4,$A,$0,
     $2,$3,$A,$B,$D,$8,$3,$A,$1,$7,$C,$F,$1,$8,$9,$D,
     $9,$1,$9,$4,$E,$4,$C,$5,$5,$C,$8,$B,$2,$3,$9,$E,
     $7,$7,$6,$9,$E,$F,$C,$8,$D,$1,$A,$6,$E,$D,$0,$7,
     $7,$A,$0,$1,$F,$5,$4,$B,$7,$B,$E,$C,$9,$5,$D,$1,
     $B,$D,$1,$3,$5,$D,$E,$6,$3,$0,$B,$B,$F,$3,$6,$4,
     $9,$D,$A,$3,$1,$4,$9,$4,$8,$3,$B,$E,$5,$0,$5,$2,
     $C,$B,$D,$5,$D,$5,$D,$2,$D,$9,$A,$C,$A,$0,$B,$3,
     $5,$3,$6,$9,$5,$1,$E,$E,$0,$E,$8,$2,$D,$2,$2,$0,
     $4,$F,$8,$5,$9,$6,$8,$6,$B,$A,$B,$F,$0,$7,$2,$8,
     $C,$7,$3,$A,$1,$4,$2,$5,$F,$7,$A,$C,$E,$5,$9,$3,
     $E,$7,$1,$2,$E,$1,$F,$4,$A,$6,$C,$6,$F,$4,$3,$0,
     $C,$0,$3,$6,$F,$8,$7,$B,$2,$D,$C,$6,$A,$A,$8,$D);

      EncryptKeys : Buf32 =
    ($48,$93,$46,$67,$98,$3D,$E6,$8D,$B7,$10,$7A,$26,$5A,$B9,$B1,$35,
     $6B,$0F,$D5,$70,$AE,$FB,$AD,$11,$F4,$47,$DC,$A7,$EC,$CF,$50,$C0);

    TYPE
      WORD   = INTEGER;

      NetStr = STRING[47];
      GenStr = STRING[128];
      FourBytes = ARRAY [1..4] of BYTE;
      MemBlock = ARRAY [1..128] OF CHAR;

    {  RegsType = RECORD case integer of
        1: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : INTEGER);
        2: (AL, AH, BL, BH, CL, CH, DL, DH            : BYTE);
        END; }

      ServerItem = ARRAY [1..48] OF CHAR;
      ServerName = ARRAY[1..MaxServers] OF ServerItem;
      ServerNamePtr = ^ServerName;

      ServerMappingEntry = RECORD
        SlotInUse      : BYTE;
        OrderNumber    : BYTE;
        ServerNet      : ARRAY [1..10] OF CHAR;
        ServerSocket   : WORD;
        RouterNet      : ARRAY [1..10] OF CHAR;
        RouterSocket   : WORD;
        ShellInternal  : ARRAY [1..6] OF CHAR;
      END;

      ServerMappingTable = ARRAY [1..MaxServers] OF ServerMappingEntry;
      ServerMappingPtr   = ^ServerMappingTable;

    VAR
      rc   : BYTE;
      Regs : Registers;
      { Regs : RegsType; }

    { -------------------------------------------------------------- }

    FUNCTION GetString(VAR NameEntry: ServerItem): GenStr;
    VAR   tmp: GenStr;
          i:   INTEGER;
          ct:  BYTE;
    BEGIN
      i  := 1;
      ct := 0;

      WHILE NameEntry[i] <> CHR(0) DO
         BEGIN
           tmp[i] := NameEntry[i];
           i  := i  + 1;
           ct := ct + 1;
           END;

      tmp[0] := CHAR(ct);
      GetString := tmp;
      END;

    PROCEDURE Str2Az(st: GenStr; VAR az; size: INTEGER);
    VAR  p: ^BYTE;
    BEGIN
      Fillchar(az, size+1, 0);
      p := ADDR(st[1]);
      Move(p^, az, size);
      END;

    PROCEDURE DefaultRegs(VAR r: Registers);
    BEGIN
      r.DS := DSeg;
      r.ES := DSeg;
    { r.AX := 0;
      r.BX := 0;
      r.CX := 0;
      r.DX := 0;
      r.BP := 0;
      r.SI := 0;
      r.DI := 0; }
      END;

    FUNCTION FileServiceRequest( func:            BYTE;
                                 VAR q; qlen:     WORD;
                                 VAR reply; rlen: WORD): BYTE;
    BEGIN
      DefaultRegs(Regs);
      Regs.DS := Seg(q);
      Regs.SI := Ofs(q);
      Regs.CX := qlen;
      Regs.ES := Seg(reply);
      Regs.DI := Ofs(reply);
      Regs.DX := rlen;
      Regs.AH := $F2;
      Regs.AL := func;
      MSDOS(Regs);
      FileServiceRequest := Regs.AL;
    END;

    FUNCTION CallNetware(RegAH : BYTE; VAR request, reply): BYTE;
    BEGIN
      DefaultRegs(Regs);
      Regs.AH := RegAH;
      Regs.DS := Seg(request);
      Regs.SI := Ofs(request);
      Regs.ES := Seg(reply);
      Regs.DI := Ofs(reply);
      MSDOS(Regs);
      CallNetware := Regs.AL;
      END;

    PROCEDURE UpcaseStr(VAR s: GenStr);
    VAR  i : INTEGER;
    BEGIN
      for i := 1 to Length(s) do
        Begin
        s[i] := UpCase(s[i]);
        End;
      END;

    FUNCTION GetServerMappingPtr : ServerMappingPtr;
    VAR TmpPtr: ServerMappingPtr;
    BEGIN
      DefaultRegs(Regs);
      Regs.AX := $EF03;
      MSDOS(Regs);
      TmpPtr  := Ptr(Regs.ES, Regs.SI);
      GetServerMappingPtr := TmpPtr;
      END;

    FUNCTION GetServerNamePtr : ServerNamePtr;
    VAR TmpPtr: ServerNamePtr;
    BEGIN
      DefaultRegs(Regs);
      Regs.AX := $EF04;
      MSDOS(Regs);
      TmpPtr  := Ptr(Regs.ES, Regs.SI);
      GetServerNamePtr := TmpPtr;
      END;

    FUNCTION GetServerNumber(s: NetStr): BYTE;
    VAR
      t : ServerNamePtr;
      m : ServerMappingPtr;
      i : INTEGER;
    BEGIN
      m := GetServerMappingPtr;
      t := GetServerNamePtr;
      UpCaseStr(s);

      FOR i:=1 TO MaxServers DO BEGIN
        IF (m^[i].SlotInUse = $FF) AND (GetString(t^[i]) = s) THEN BEGIN
          GetServerNumber := i;
          Exit;
        END;
      END;
      GetServerNumber := 0;
    END;

    FUNCTION ReadPropertyValue(ObjectType : WORD; ObjectName : NetStr;
                            Segnr : BYTE; Property : NetStr;
                            VAR item): BYTE;
    VAR
      req : RECORD
        plen : WORD;
        func : BYTE;
        otype : WORD;
        Filler : GenStr;
      END;
      rep : RECORD
        plen : WORD;
        Data : ARRAY [1..128] OF BYTE;
        More : BYTE;
        PropFlags : BYTE;
      END;

    BEGIN
      req.func := 61;
      req.otype := Swap(ObjectType);
      req.plen := Length(ObjectName) +
                  Length(Property) + 6;
      req.filler := ObjectName + Char(Segnr) +
                    Char(Length(Property)) +
                    Property;
      req.filler[0] := Char(Length(ObjectName));
      rep.plen := SizeOf(rep) - 2;
      ReadPropertyValue := CallNetware($E3,req,rep);
      Move(rep.data, item, SizeOf(rep.data) + 2);
    END;

    FUNCTION InsertServer(Name : NetStr):BYTE;
    VAR
      MapPtr  : ServerMappingPtr;
      NamePtr : ServerNamePtr;
      res     : BYTE;
      free,i  : INTEGER;
      data    : ARRAY [1..130] OF BYTE;

      FUNCTION LowerAddr(VAR a, b): BOOLEAN;
      TYPE
        Net_Address = ARRAY [1..10] OF CHAR;
      VAR
        a_addr : Net_Address ABSOLUTE a;
        b_addr : Net_Address ABSOLUTE b;
      BEGIN
        LowerAddr := a_addr < b_addr;
      END;

    BEGIN
      UpCaseStr(Name);
      IF GetServerNumber(Name) <> 0 THEN BEGIN
        InsertServer := 0;
        Exit;
      END;

      res := ReadPropertyValue(FILE_SERVER, name, 1, 'NET_ADDRESS', data);
      IF res <> 0 THEN BEGIN
        InsertServer := $7D;
        Exit;
      END;

      MapPtr := GetServerMappingPtr;
      free := 1;
      WHILE (MapPtr^[free].SlotInUse = $FF) DO BEGIN
        free := free + 1;
        IF free > MaxServers THEN BEGIN
          InsertServer := $7C;
          Exit;
        END;
      END;

      NamePtr := GetServerNamePtr;
      WITH MapPtr^[free] DO BEGIN
        Move(data, ServerNet, 12);
        Str2Az(name, NamePtr^[free], SizeOf(NamePtr^[free]));
        OrderNumber := 1;
        FOR i := 1 TO MaxServers DO BEGIN
          IF MapPtr^[i].SlotInUse = $FF THEN BEGIN
            IF LowerAddr(MapPtr^[i].ServerNet, ServerNet) THEN
              OrderNumber := OrderNumber + 1
            ELSE
              MapPtr^[i].OrderNumber := MapPtr^[i].OrderNumber + 1;
          END;
        END;
        SlotInUse := $FF;
      END;
      InsertServer := 0;
    END;

    FUNCTION AttachServerNumber(func : BYTE; sn : BYTE) : BYTE;
    BEGIN
      DefaultRegs(Regs);
      Regs.ah := $F1;
      Regs.al := func;
      Regs.dl := sn;
      MSDOS(Regs);
      AttachServerNumber := Regs.al;
    END;

    FUNCTION AttachServer(func : BYTE; name : NetStr) : BYTE;
    VAR
      sn : BYTE;
    BEGIN
      sn := GetServerNumber(name);
      IF sn = 0 THEN BEGIN
        AttachServer := $7B;
        Exit;
      END;
      AttachServer := AttachServerNumber(func,sn);
    END;

    FUNCTION GetEffectiveServer:BYTE;
    BEGIN
      DefaultRegs(Regs);
      Regs.ax := $F002;
      MSDOS(Regs);
      GetEffectiveServer := Regs.al;
    END;

    PROCEDURE SetPrimaryServer(sno:BYTE);
    BEGIN
      DefaultRegs(Regs);
      Regs.ax := $F004;
      Regs.dl := sno;
      MSDOS(Regs);
    END;

    FUNCTION GetPrimaryServer:BYTE;
    BEGIN
      DefaultRegs(Regs);
      Regs.ax := $F005;
      MSDOS(Regs);
      GetPrimaryServer := Regs.al;
    END;

    FUNCTION SetPreferredServer(sno: BYTE): BYTE;
    BEGIN
      DefaultRegs(Regs);
      Regs.ax := $F000;
      Regs.dl := sno;
      MSDOS(Regs);
      Regs.ax := $F001;
      MSDOS(Regs);
      SetPreferredServer := Regs.AL;
    END;

    FUNCTION MapNameToNumber(ObjectType : WORD;ObjectName : NetStr;
                             VAR ObjectID : FourBytes): BYTE;
    VAR
      req : RECORD
        plen : WORD;
        func : BYTE;
        otype : WORD;
        name : NetStr;
      END;
      rep : RECORD
        plen : WORD;
        objID : FourBytes;
        otype : WORD;
        name : ARRAY [1..48] OF CHAR;
      END;
    BEGIN
      req.func := 53;      {Get an object's number}
      req.otype := Swap(ObjectType);
      req.name := ObjectName;
      req.plen := Length(ObjectName) + 4;
      rep.plen := SizeOf(rep) - 2;
      MapNameToNumber := CallNetware($E3, req, rep);
      ObjectID := rep.objID;
    END;

    FUNCTION MapNumberToName(ID : FourBytes; VAR Name; VAR Otype : WORD):BYTE;
    VAR
      req : RECORD
        plen : WORD;
        func : BYTE;
        OID  : FourBytes;
      END;
      rep : RECORD
        plen  : WORD;
        OID   : FourBytes;
        otyp  : WORD;
        Oname : ServerItem;
      END;
      nam : NetStr ABSOLUTE Name;
    BEGIN
      req.func := 54;      {Get an object's name}
      req.OID := ID;
      req.plen := SizeOf(req) - 2;
      rep.plen := SizeOf(rep) - 2;
      MapNumberToName := CallNetware($E3,req,rep);
      Nam := GetString(rep.OName);
      Otype:= Swap(rep.Otyp);
    END;

    FUNCTION LoginAnObject( Name:NetStr; Otype:WORD; Passw: NetStr):BYTE;
    VAR
      req : RECORD
        plen : WORD;
        func : BYTE;
        otype : WORD;
        NamePass : STRING[96];
      END;
      rep : RECORD
        plen : WORD;
      END;
    BEGIN
      req.plen := 5 + Length(Name) + Length(Passw);
      req.func := 20;
      UpCaseStr(Passw);
      UpCaseStr(Name);
      req.otype := Swap(otype);
      req.NamePass:=Name;
      Move(Passw, req.NamePass[Length(Name)+1], Length(Passw) + 1);
      rep.plen := 0;
      LoginAnObject := CallNetware($E3, req, rep);
    END;

    FUNCTION LoginUser(Name, Password: NetStr): BYTE;
    VAR
      req : RECORD
        plen : INTEGER;
        func : BYTE;
        NamePass : STRING[96];
      END;
      rep : RECORD
        plen : INTEGER;
      END;

    BEGIN
      req.plen := 3 + Length(Name) + Length(Password);
      req.func := 0;
      UpcaseStr(Password);
      UpcaseStr(Name);
      req.NamePass := Name;
      Move(Password, req.NamePass[Length(Name)+1], Length(Password)+1);
      rep.plen := 0;
      LoginUser := CallNetware($E3, req, rep);
    END;

    FUNCTION GetEncryptionKey(VAR key : Buf8): BYTE;
    VAR
      q : RECORD
        plen : WORD;
        func : BYTE;
      END;
    BEGIN
      q.plen := 1;
      q.func := $17;
      GetEncryptionKey := FileServiceRequest($17, q, SizeOf(q), key, SizeOf(key));
    END;

    FUNCTION LoginEncrypted(name : NetStr; otype : WORD; VAR key : Buf8): BYTE;
    VAR
      a : RECORD
        plen : WORD;
        func : BYTE;
        key  : Buf8;
        otyp : WORD;
        name : NetStr;
      END;
    BEGIN
      a.plen := Length(name) + 12;
      a.func := $18;
      a.key  := key;
      a.otyp := Swap(otype);
      a.name := name;
      LoginEncrypted := FileServiceRequest($17, a, Length(name)+14, Mem[0:0], 0);
    END;

    PROCEDURE Shuffle1(VAR temp : Buf32; VAR target);
    VAR
      t  :  Buf16 ABSOLUTE target;
      b4 :  WORD;
      b3 :  BYTE;
      s, d, b2, i : WORD;
    BEGIN
      b4 := 0;
      FOR b2 := 0 TO 1 DO BEGIN
        FOR s := 0 TO 31 DO BEGIN
          b3 := Lo(Lo(temp[s] + b4)
                XOR Lo(temp[(s + b4) AND 31]
              - EncryptKeys[s]));
          b4 := b4 + b3;
          temp[s] := b3;
        END;
      END;

      FOR i := 0 TO 15 DO
        t[i] := EncryptTable[temp[i Shl 1]]
            OR (EncryptTable[temp[i Shl 1 +1]] Shl 4);
    END;

    PROCEDURE Shuffle(VAR lon, buf; buflen : WORD; VAR target);
    VAR
      l : Buf4 ABSOLUTE lon;
      b : ARRAY [0..127] OF BYTE ABSOLUTE buf;
      b2 : WORD;
      temp : Buf32;
      s, d : WORD;
    BEGIN
      IF buflen > 0 THEN
         WHILE (buflen > 0) AND (b[buflen-1] = 0) DO
           buflen := buflen - 1;

      FillChar(temp, SizeOf(temp), #0);

      d := 0;
      WHILE buflen >= 32 DO BEGIN
        FOR s := 0 TO 31 DO BEGIN
          temp[s] := temp[s] XOR b[d];
          d := d + 1;
        END;
        buflen := buflen - 32;
      END;
      b2 := d;

      IF buflen > 0 THEN BEGIN
        FOR s := 0 TO 31 DO BEGIN
          IF d + buflen = b2 THEN BEGIN
            b2 := d;
            temp[s] := temp[s] XOR EncryptKeys[s];
          END
          ELSE BEGIN
            temp[s] := temp[s] XOR b[b2];
            b2 := b2 + 1;
          END;
        END;
      END;
      FOR s := 0 TO 31 DO
        temp[s] := temp[s] XOR l[s AND 3];

      Shuffle1(temp, target);
    END;

    PROCEDURE Encrypt(VAR fra, buf, til);
    VAR
      f : Buf8  ABSOLUTE fra;
      t : Buf8  ABSOLUTE til;
      k : Buf32;
      s : WORD;
    BEGIN
      Shuffle(f[0], buf, 16, k[0]);
      Shuffle(f[4], buf, 16, k[16]);
      FOR s := 0 TO 15 DO
        k[s] := k[s] XOR k[31-s];
      FOR s := 0 TO 7 DO
        t[s] := k[s] XOR k[15-s];
    END;

    FUNCTION LoginToFileServer(name: NetStr; otype: WORD; passw: GenStr): BYTE;
    VAR
      key : Buf8;
      id  : FourBytes;
      buf : Buf32;
      res : BYTE;

    BEGIN
      UpCaseStr(passw);
      res := GetEncryptionKey(key);
      IF res = 0 THEN BEGIN
        res := MapNameToNumber(otype, name, id);
        IF res = 0 THEN BEGIN
          Shuffle(id, passw[1], Length(passw), buf);
          Encrypt(key, buf, key);
          res := LoginEncrypted(name, otype, key);
        END;
      END
      ELSE BEGIN
        res := LoginAnObject(name, otype, passw);
        END;

      LoginToFileServer := res;
    END;

    FUNCTION Login(Sname, OName : NetStr; OType : WORD; Passw : NetStr) : BYTE;
    VAR
      sn, res, rc : BYTE;
      Curr_Server : BYTE;
    BEGIN
      UpCaseStr(SName);
      sn := GetServerNumber(Sname);

      IF sn = 0 THEN BEGIN
        res := InsertServer(SName);
        IF res <> 0 THEN BEGIN
          Login := res;
          Exit;
        END;
        sn := GetServerNumber(SName);
      END;

      res := AttachServerNumber(0, sn);
      IF res <> 0 THEN BEGIN
        Login := res;
        Exit;
      END;

      Curr_Server := GetEffectiveServer;
      IF SetPreferredServer(sn) = sn THEN
        rc := LoginToFileServer(OName, Otype, Passw)
      ELSE
        rc := $7A;

      res := SetPreferredServer(Curr_Server);
      Login := rc;
    END;

    BEGIN
      IF ParamCount <> 3 THEN BEGIN
         Writeln('Please supply server name, your user id, and a password.');
         Exit;
         END;

      rc := Login(ParamStr(1), ParamStr(2), NET_USER, ParamStr(3));

      IF rc <> 0 THEN BEGIN
         Writeln('Login failed.');
         Exit;
         END;

      END.

[Back to NETWORK SWAG index] [Back to Main SWAG index] [Original]