{-------------------------------------------------------------}
{
{    Webvox - Módulo de acesso a rede e arquivos
{
{    Autor: Jose' Antonio Borges
{
{    Em 14/05/98
{
{-------------------------------------------------------------}

unit webTraz;

interface
uses winProcs, winDos, winTypes, shellApi,
     dvcrt, strings, dvWin, dvInet, winsock,
     webVars, webMsg, webUrl, webCabec, webCook, webMail, webFtp;

function trazerPagina (nomePag: string; metodo: char): boolean;
procedure voltarPagina;
function carregarArquivo (nomePag: string): boolean;
procedure recarregaPagina;

implementation

var quantosTrazidos: longint;

{-------------------------------------------------------------}
{                      escreve texto de debug
{-------------------------------------------------------------}

procedure netDebug (s: pchar; tam: integer);
begin
    if not debug then exit;
    textBackGround (BROWN);
    write ('>>>');
    writebuf (s, tam);
    textBackGround (BLACK);
end;

{-------------------------------------------------------------}
{                 recebe cabecalho e pagina
{-------------------------------------------------------------}

function recebeTextoHTTP (nomeArq: string): boolean;
var
   arq: file;
   s: string;
   i, lidos: integer;
   trazendo, comClek: boolean;
   c: char;
label fim, erroDisco;

begin
    recebeTextoHTTP := true;
    quantosTrazidos := 0;
    comClek := true;

    if debug then
        writeln ('Arquivo de trabalho: ', nomearq);

    assign (arq, nomeArq);
    {$I-}  rewrite (arq, 1);  {$I+}
    if ioresult <> 0 then
        begin
erroDisco:
            mensagem ('WBERRDSK', 1);  {'Problemas para gravar texto no disco'}
            recebeTextoHTTP := false;
            {$I-}  close (arq);  {$I+}
            if ioresult <> 0 then;
            fechaConexao (sockHTTP);
            exit;
        end;

    if posBufRecebe < lidosBufRecebe then
        begin
            {$I-}  blockWrite (arq, bufRecebe [posBufRecebe], lidosBufRecebe-posBufRecebe);  {$I+}
            if ioresult <> 0 then goto erroDisco;
            lidosBufRecebe := 0;   {programação preventiva}
        end;

    trazendo := true;
    while trazendo do
        begin
            repeat
                if keypressed then
                    begin
                        c := readkey;
                        if c = ' ' then
                            begin
                                comClek := not comClek;
                                sintBip;
                            end
                        else
                        if c = #$1b then
                            begin
                                mensagem ('WBRECINT', 1);
                                exit;
                            end
                        else
                            begin
                                write (#$0d);  clreol;
                                sintWriteInt (quantosTrazidos);
                                s := buscaInfoCabec ('Content-length:');
                                if s <> '' then sintWrite (' de ' + s);
                                write ('  ');
                            end;
                    end;

            until chegouRede (sockHTTP);

            lidos := recv (sockHTTP, bufRecebe, BUFSIZE, 0);
            if (lidos <= 0) then
                goto fim;

            if comClek then sintClek;

            quantosTrazidos := quantosTrazidos + lidos;

            {$I-}  blockWrite (arq, bufRecebe, lidos);  {$I+}
            if ioresult <> 0 then goto erroDisco;
        end;
fim:
    fechaConexao (sockHTTP);

    {$I-}  close (arq);  {$I+}
    if ioresult <> 0 then goto erroDisco;
    exit;
end;

{-------------------------------------------------------------}
{                  transforma cadeia em base 64
{-------------------------------------------------------------}

function base64 (bloco: string): string;
const
    MIME64: array [0..63] of char =
       'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
var
   lidos, guarda, aux: integer;
   byteEnt: byte;
   s: string [80];
   indBloco: integer;

label erro;

begin
   lidos := 0;
   s := '';

   for indBloco := 1 to length (bloco) do
       begin
           byteEnt := ord(bloco [indBloco]);
           case lidos of
               0: begin
                      s := s + MIME64[byteEnt shr 2];
                      guarda := (byteEnt and 3) shl 4;
                  end;
               1: begin
                      s := s + MIME64[((byteEnt shr 4) and $f) or guarda];
                      guarda := (byteEnt and $f) shl 2;
                  end;
               2: begin
                      s := s + MIME64[((byteEnt shr 6) and $3) or guarda];
                      guarda := byteEnt and $3f;
                      s := s + MIME64[guarda];
                  end;
           end;

           lidos := (lidos + 1) mod 3;
       end;

   if lidos <> 0 then
       s := s + MIME64[guarda];

    while (length (s) mod 4) <> 0 do
        s := s + '=';

    base64 := s;
end;

{-------------------------------------------------------------}
{                envia pedido de home page
{-------------------------------------------------------------}

function trazTextoHTTP (metodo, net_loc, nome: string; autent: string): integer;
var
    i, lidos: integer;
    tempFileName: array [0..144] of char;
    codigo: integer;
    sn, ext: string[10];
    tipo: string;
    penv, faltaEnviar, enviados: integer;
begin
    StrPCopy (bufEnvia, metodo + ' ' + nome + ' HTTP/1.0' + CRLF);
    send (sockHTTP, bufEnvia, strlen (bufEnvia), 0);
    netDebug (bufEnvia, strlen (bufEnvia));

    StrPCopy (bufEnvia, 'Host: ' + net_loc + CRLF);
    send (sockHTTP, bufEnvia, strlen (bufEnvia), 0);
    netDebug (bufEnvia, strlen (bufEnvia));

    StrPCopy (bufEnvia, 'User-Agent: Webvox ' + versao + CRLF);
    send (sockHTTP, bufEnvia, strlen (bufEnvia), 0);
    netDebug (bufEnvia, strlen (bufEnvia));

    if autent <> '' then
        begin
            StrPCopy (bufEnvia, 'Authorization: Basic ' + base64 (autent) + CRLF);
            send (sockHTTP, bufEnvia, strlen (bufEnvia), 0);
            netDebug (bufEnvia, strlen (bufEnvia));
        end;

    enviaCookies;

    if metodo = 'POST' then
        begin
            str (strLen (dadosPost), sn);
            StrPCopy (bufEnvia,
                 'Content-Type: application/x-www-form-urlencoded' + CRLF +
                 'Content-Length: ' + sn + CRLF);
            send (sockHTTP, bufEnvia, strlen (bufEnvia), 0);
            netDebug (bufEnvia, strlen (bufEnvia));
        end;

    StrPCopy (bufEnvia, CRLF);
    send (sockHTTP, bufEnvia, strlen (bufEnvia), 0);
    netDebug (bufEnvia, strlen (bufEnvia));

    if metodo = 'POST' then
        begin
            faltaEnviar := strlen (dadosPost);
            penv := 0;
            repeat
                enviados := send (sockHTTP, @dadosPost[penv], faltaEnviar, 0);
                faltaEnviar := faltaEnviar - enviados;
                penv := penv + enviados;
            until (faltaEnviar = 0) or (enviados = 0);
            netDebug (dadosPost, strlen (dadosPost));
        end;

    codigo := trazCabecHttp;
    { debugCabec; }

    if codigo <> 504 then
        begin
            getTempFileName(getTempDrive ('C'), 'web', 0, tempFileName);
            nomeTemp := strPas (tempFileName);

            tipo := buscaInfoCabec ('Content-type:');
            if tipo = '' then
                tipo := 'text/html';

            ext := '';
            if tipo = 'text/plain' then  ext := 'TXT'
            else
            if (tipo = 'audio/midi') or (tipo = 'audio/mid') then  ext := 'MID'
            else
            if tipo = 'audio/mpeg' then  ext := 'MP3'
            else
            if tipo = 'audio/x-pn-realaudio' then ext := 'RAM'
            else
            if tipo = 'text/html' then   ext := 'HTM';

            if ext <> '' then
                begin
                    delete (nomeTemp, length (nomeTemp)-2, 3);
                    nomeTemp := nomeTemp + ext;
                end
            else
                begin
                    for i := length (nome) downto length (nome)-4 do
                        if (i > 0) and (nome[i] = '.') then
                              begin
                                  delete (nomeTemp, length (nomeTemp)-2, 3);
                                  nomeTemp := nomeTemp + copy (nome, i+1, 5);
                              end;
                end;

            if not recebeTextoHTTP (nomeTemp) then
                begin
                    mensagem ('WBRECINT', 1);  {'Recepção interrompida'}
                    codigo := 500;
                    cabecHttp[1]^ := 'HTTP/1.0 500 Recepção interrompida';
                end;
        end;

    trazTextoHTTP := codigo;
end;

{-------------------------------------------------------------}
{                        ajuda
{-------------------------------------------------------------}

procedure ajudaTrazPag;
begin
    mensagem ('WBAJU101', 1);  {'Tecle um nome tradicional da web, por exemplo:'}
    mensagem ('WBAJU102', 1);  {'http://www.companhia.com.br'}
    mensagem ('WBAJU103', 1);  {'Para acessar a página do DOSVOX tecle'}
    mensagem ('WBAJU104', 1);  {'http://caec.nce.ufrj.br'}
    writeln;
end;

{-------------------------------------------------------------}
{                registra página trazida na pilha
{-------------------------------------------------------------}

procedure registraPilha (nomePag, nomeTemp: string; linhaAtual: integer; tempApagavel: boolean);
var i: integer;
begin
    if topoPilhaPag < MAXPILHA then
        topoPilhaPag := topoPilhaPag + 1
    else
        begin
            dispose (pilhaPag[1]);
            for i := 1 to MAXPILHA-1 do
                pilhaPag [i] := pilhaPag [i+1];
        end;
    new (pilhaPag [topoPilhaPag]);

    with pilhaPag [topoPilhaPag]^ do
        begin
            nomePagina := nomePag;
            nomePagAtual := nomePag;      { variáveis globais }
            posicao := linhaAtual;
            posFormPreenc := ntagsForms;
            nomeArqTemp := nomeTemp;
            podeApagarTemp := tempApagavel;
            jaCompilado := false;
        end;
end;

{-------------------------------------------------------------}
{           traz uma pagina HTTP de um arquivo local
{-------------------------------------------------------------}

function carregarArquivo (nomePag: string): boolean;
var arq, arqTemp: text;
    tipo, s, rotulo: string;
    tempFileName: array [0..144] of char;
    i: integer;
    dir: string;

label erroDisco;
begin
    carregarArquivo := false;
    if nomePag = '' then
        begin
            mensagem ('WBINFARQ', 1);  {'Informe o nome o arquivo a carregar'}
            sintReadln (nomePag);
        end;

    while (nomePag <> '') and (nomePag[1] = ' ') do delete (nomePag, 1, 1);
    if nomePag = '' then exit;

    getDir (0, dir);
    if nomePag [2] <> ':' then
        nomePag := dir[1] + ':' + nomePag;

    completaEsquema (nomePag);
    if (copy (maiusc(nomePag), 1, 7) <> 'FILE://') then
        begin
            carregarArquivo := trazerPagina (nomePag, 'G');
            exit;
        end;

    delete (nomePag, 1, 7);

    if nomePag [2] = '|' then nomePag [2] := ':';
    for i := 1 to length (nomePag) do
        if nomePag[i] = '/' then nomePag[i] := '\';

    getDir (0, dir);
    if nomePag[1] = '\' then
         nomePag := dir[0] + ':' + nomePag
    else
    if nomePag [2] <> ':' then
        begin
            if dir [length(dir)] = '\' then delete (dir, length(dir), 1);
            nomePag := dir + '\'  + nomePag;
        end;

    { abre arquivo }

    assign (arq, nomePag);
    {$I-}  reset (arq);  {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('WBARQNAO', 1);  {'Este arquivo não existe'}
            exit;
        end;
    close (arq);

    nlinCabecHTTP := 1;

    i := length (nomepag);
    while (i > 1) and (nomePag[i] <> '.') do
        i := i - 1;
    tipo := maiusc (copy (nomePag, i, 255));
    if (tipo = '.TXT') then
        cabecHTTP [1]^ := 'Content-type:text/plain'
    else
    if (tipo = '.MID') or (tipo = '.MIDI') then
        cabecHTTP [1]^ := 'Content-type:audio/midi'
    else
    if (tipo = '.RAM') or (tipo = '.RM') then
        cabecHTTP [1]^ := 'Content-type:audio/x-pn-realaudio'
    else
        cabecHTTP [1]^ := 'Content-type:text/html';

    { guarda em formato padrao HTTP }

    nomeTemp := nomePag;
    rotulo := '';    {provisório}

    nomePag [2] := '|';
    for i := 1 to length (nomePag) do
        if nomePag[i] = '\' then nomePag[i] := '/';
    nomePagAtual := 'file://'+ nomePag;

    linhaAtual := 1;
    nomeBase := nomePagAtual;
    registraPilha (nomePagAtual, nomeTemp, linhaAtual, false);

    mensagem ('WBOK', 1);  {'OK'}
    carregarArquivo := true;
end;

{-------------------------------------------------------------}
{            se com proxy, checa se tem barra final
{-------------------------------------------------------------}

function checaBarraFinal (uriPag: string): string;
var i: integer;
label fim;
begin
    checaBarraFinal := uriPag;
    if maiusc (copy (uriPag, 1, 7)) <> 'HTTP://' then exit;

    delete (uriPag, 1, 7);
    if pos ('/', uripag) <> 0 then exit;

    i := pos (';', uriPag);
    if i <> 0 then goto fim;

    i := pos ('?', uriPag);
    if i <> 0 then goto fim;

    i := length (uriPag) + 1;

fim:
    insert ('/', uriPag, i);
    checaBarraFinal := 'HTTP://' + uriPag;
end;

{-------------------------------------------------------------}
{                    traz uma pagina
{-------------------------------------------------------------}

function trazerPagina (nomePag: string; metodo: char): boolean;
var
    scheme, net_loc, path, params, query: string;
    fragment: string;
    hostPag, uriPag: string;
    codigo, portaPag: word;
    nomeAbsoluto: string;
    msgAutent, autent: string;
    rebuscando: boolean;
    p: integer;
    conta, senha: string;
    primeiraTent: boolean;

label
    registra, rebusca, deNovo, trazDeNovo;

begin
    trazerPagina := false;
    rebuscando := false;
    autent := '';
    primeiraTent := true;

    if nomePag = '' then
        begin
deNovo:
            mensagem ('WBPAGTRA', 1);  {'Informe o nome da página a trazer (? ajuda)'}
            nomePag := '';
            sintEdita (nomePag, wherex, wherey, 250, true);
            writeln;
            if nomePag = '' then exit;
            metodo := 'G';
            completaEsquema (nomePag);
            linhaAtual := 1;
        end;

    if nomePag = '?' then
        begin
            ajudaTrazPag;
            goto deNovo;
        end;

rebusca:
    compilaURL (nomePag, scheme, net_loc, path, params, query, fragment);
    if scheme = 'MAILTO' then
         begin
             if net_loc = '' then net_loc := path;
             miniCorreio (net_loc);
             exit;
         end;

    if (scheme = 'FTP') and (not comProxy) then
         begin
             miniFtp (net_loc, path);
             exit;
         end;

    if scheme = 'FILE' then
        begin
            cookie := '';
            delete (nomepag, 1, 7);
            trazerPagina := carregarArquivo (nomePag);
            exit;
        end;

    if scheme = 'HTTPS' then
        begin
            scheme := 'HTTP';
            mensagem ('WBPGSEGU', 1);    {'Página segura, vou tentar processar sem segurança'}
        end;

    if (scheme = 'HTTP') and (net_loc = '') then
        begin
            montaURLrelativa (nomePag, nomeBase, nomeAbsoluto);
            nomePag := nomeAbsoluto;
            compilaURL (nomePag, scheme, net_loc, path, params, query, fragment);
        end;

    rotuloInicial := fragment;

    if (scheme <> 'HTTP') and (scheme <> 'FILE') and (scheme <> 'FTP') then
        begin
            mensagem ('WBSOHTTP', 1);  {'Este programa só aceita páginas HTTP ou FTP'}
            exit;
        end;

    montaCookies (nomePag);

    {... completar - verificar se página anteriormente carregada e assim não trazer ...}

    if not rebuscando then
        begin
            mensagem ('WBCONTAC', 1);  {'Contactando...  '}
            while sintFalando do;
        end;

trazDeNovo:
    if comProxy then
         sockHTTP := abreConexao (hostProxy, portaProxy)
    else
         begin
             extraiNomePorta (net_loc, hostPag, portaPag);
          {  if debug then
                 writeln ('NET_LOC ', net_loc, '->', hostPag, '->', portaPag);   }
             sockHTTP := abreConexao (hostPag, portaPag);
         end;

    if sockHTTP <= 0 then
        begin
            mensagem ('WBNAOCON', 1);     {'Não consegui realizar a conexão'}
            exit;
        end;

    if comProxy then
        uriPag := checaBarraFinal (nomePag)
    else
        begin
            uriPag := path;
            if params <> '' then uriPag := uriPag + ';' + params;
            if query  <> '' then uriPag := uriPag + '?' + query;
        end;

    if metodo = 'G' then
        codigo := trazTextoHTTP ('GET', net_loc, uriPag, autent)
    else
        codigo := trazTextoHTTP ('POST', net_loc, uriPag, autent);

    writeln;
    if (codigo = 301) or (codigo = 302) then
        begin
            nomeBase := nomePag;
            nomePag := buscaInfoCabec ('Location:');
            montaURLrelativa (nomePag, nomeBase, nomeAbsoluto);
            nomePag := nomeAbsoluto;
            mensagem ('WBPAGALT', 1);
            writeln (nomePag);
            rebuscando := true;
            goto rebusca;
        end;

    if (codigo = 401) then
        begin
            msgAutent := buscaInfoCabec ('WWW-Authenticate:');
            p := pos ('realm', msgAutent);
            while (p <= length (msgAutent)) and (msgAutent[p] <> '=') do p := p + 1;
            msgAutent := copy (msgAutent, p+2, 999);

            if primeiraTent and (msgAutent = ultMsgAutent) then
                begin
                    autent := ultAutent;
                    primeiraTent := false;
                    goto trazDeNovo;
                end;

            if autent = '' then
                mensagem ('WBAUTENT', 1)    {'Servidor solicitou autenticação'}
            else
                mensagem ('WBERRAUT', 1);    {'Autenticação não foi aceita'}
            sintWriteln (msgAutent);

            mensagem ('WBCONTA', 0);   {'Informe sua conta  '}
            sintReadln (conta);
            if conta = '' then
                begin
                    linhaAtual := 1;
                    registraPilha (nomePag, '$#$', linhaAtual, true);
                    mensagem ('WBDESIST', 1);  {'Desistiu...'}
                    exit;
                end;

            mensagem ('WBSENHA', 0);   {'Informe sua senha  '}
            p := textAttr;
            textColor (black);
            readln (senha);
            textAttr := p;

            autent := conta + ':' + senha;
            ultMsgAutent := msgAutent;
            ultAutent := autent;

            rebuscando := true;
            goto trazDeNovo;
        end;

    primeiraTent := true;
    if codigo = 200 then
        begin
            cookie := obtemCookie;
            mensagem ('WBOK', 1);  {'OK'}
            linhaAtual := 1;      { *** verificar se fragmento *** }
            registraPilha (nomePag, nomeTemp, linhaAtual, true);
            nomeBase := nomePag;
            trazerPagina := true;
        end
    else
        begin
            linhaAtual := 1;
            registraPilha (nomePag, '$#$', linhaAtual, true);
            mensagem ('WBNAOPAG', 1);   {'Página não foi trazida'}
            mensagem ('WBMSGSRV', 1);   {'Mensagem do servidor'}
            sintWriteln (cabecHTTP [1]^);
        end;
end;

{-------------------------------------------------------------}
{                 voltar à penultima página lida
{-------------------------------------------------------------}

procedure voltarPagina;
var arq: file;
    i: integer;
begin
    { provisorio }
    nlinCabecHTTP := 1;
    cabecHTTP [1]^ := 'Content-type:text/html';

    if topoPilhaPag <= 1 then
         begin
             mensagem ('WBNAOVOL', 1);    {'Não posso, estou primeira página lida'}
             exit;
         end;

    if pilhaPag [topoPilhaPag]^.podeApagarTemp then
        begin
            assign (arq, pilhaPag [topoPilhaPag]^.nomeArqTemp);
            {$I-}  erase (arq);  {$I+}
            if ioresult <> 0 then;
        end;

    with pilhaPag [topoPilhaPag]^ do
        begin
            for i := posFormPreenc+1 to ntagsForms do
                freeMem (tagsForms^[i], length (tagsForms^[i]^)+1);
            ntagsForms := posFormPreenc;
        end;

    topoPilhaPag := topoPilhaPag - 1;
    with pilhaPag [topoPilhaPag]^ do
        begin
            nomePagAtual := nomePagina;
            linhaAtual := posicao;
            nomeTemp := nomeArqTemp;
         end;

    nomeBase := nomePagAtual;

    mensagem ('WBVOLPAG', 1);    {'Voltando à pagina anterior'}
    writeln (nomePagAtual);
end;

{-------------------------------------------------------------}
{                 voltar à penultima página lida
{-------------------------------------------------------------}

procedure recarregaPagina;
var arq: file;
    aTrazer: string;
    i: integer;
begin
    { provisorio }
    nlinCabecHTTP := 1;
    cabecHTTP [1]^ := 'Content-type: text/html';

    if topoPilhaPag < 1 then
         begin
             mensagem ('WBSEMPAG', 1);    {'Não tenho página na memória'}
             exit;
         end;

    if pilhaPag [topoPilhaPag]^.podeApagarTemp then
        begin
            assign (arq, pilhaPag [topoPilhaPag]^.nomeArqTemp);
            {$I-}  erase (arq);  {$I+}
            if ioresult <> 0 then;
        end;

    for i := pilhaPag [topoPilhaPag]^.posFormPreenc+1 to ntagsForms do
        freeMem (tagsForms^[i], length (tagsForms^[i]^)+1);
    ntagsForms := pilhaPag [topoPilhaPag]^.posFormPreenc;

    aTrazer := pilhaPag [topoPilhaPag]^.nomePagina;

    topoPilhaPag := topoPilhaPag - 1;
    nomeBase := '';
    nomePagAtual := '';

    trazerPagina (aTrazer, 'G');
end;

end.
