Ada bind libcurl. Simple Ada parser

Задача №1

Нужно непрерывно выкачивать сотни миллионов файлов (тайлов) через прокси.

Раньше мы использовали небольшой пайтоновский скрипт который в один поток с помощью urllib скачивал файл за файлом, но когда дело приняло серьезные обороты и стала потребность выкачать миллиарды файлов, я решил - "Ада, я вызываю тебя :)".

Ну задача банальная: в несколько потоков через прокси скачивать файлы.

В несколько потоков - проще всего! Создали task type, создали массив с задачами длиною в количество потоков.

Через прокси - долго выбирал у кого же купить, остановился на каком-то малоизвестном сервисе где за 9$ дают 1к прокси в месяц. Написал диспетчер который выдавал задачам прокси и в случае надобности запрашивал у сервиса пачку новых прокси.

Скачивать файлы - а вот здесь уже проблемы. На данный момент почти единственный путь это с помощью AWS (Ada web server) - это огромная  библиотека которая имеет клиентскую часть с помощью которой можно открыть урл, НО: она большая, зависимость gnat 5+, а по умолчанию в минте 17.3 версия 4.8. Хотелось простое и универсальное решение.

libcurl

libcurl - наверно самая известная кроссплатформенная библиотека для веба, написана на С и как пишет Вики есть привязки более чем для 30 ЯП (но не для Ады), а это значит что если Вы знаете libcurl то Вы сможете почти на любом языке работать с FTP, FTPS, HTTP, HTTPS, TFTP, SCP, SFTP, Telnet, DICT, LDAP, POP3, IMAP, SMTP, HTTPS.

На запрос "ada libcurl" гугл выдал лишь гитхабовскую страничку ada-util. Ada-util это такой швейцарский нож, который ,скорее всего, писался для личных целей французским программистом по имени Stephane Carrez, так как функционала полно но он настолько урезан что полноценно использовать не дописывая невозможно, ну и документация есть но нету.
В ada-util для процедуры get может использоватся как libcurl так и aws, поэтому подсмотрев как Стефан забиндил libcurl я написал свой.

Преимущества:

- работает как на более старых версиях gnat, проверял на 4.6 и 4.8, так и 5;
- Вы без проблем зная libcurl сможете добавить функционал который нужно, так как я для своих целей описал лишь 5% setoptов и getoptов;
- вместо генерации файла с константами используется "адский" способ бинда констант (libcurlconstnts.c), давайте с него и начнем

libcurlconstants.c

Этот файл нужен чтобы импортнуть константы (определены через define) с libcurl для setopt и getinfo

#include <curl/curl.h>

const int _curle_ok = CURLE_OK;

const int _curlopt_url = CURLOPT_URL;
const int _curlopt_verbose = CURLOPT_VERBOSE;
const int _curlopt_writefunction = CURLOPT_WRITEFUNCTION;
const int _curlopt_writedata = CURLOPT_WRITEDATA;
const int _curlopt_proxy = CURLOPT_PROXY;
const int _curlopt_ssl_verifypeer = CURLOPT_SSL_VERIFYPEER;
const int _curlopt_ssl_verifyhost = CURLOPT_SSL_VERIFYHOST;
const int _curlopt_useragent = CURLOPT_USERAGENT;
const int _curlopt_timeout = CURLOPT_TIMEOUT;

const int _curlinfo_response_code = CURLINFO_RESPONSE_CODE;
// const int _curlinfo_size_download = CURLINFO_SIZE_DOWNLOAD;

И непосредственно заголовок и тело пакета

libcurl.ads

-- импортируем нужные нам модули
with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Interfaces.C.Pointers;
with Ada.Sequential_IO;

package libcurl is -- заголовок пакета
  -- переименовываем для удобства использования
  package C renames Interfaces.C;
  package Strings renames Interfaces.C.Strings;

  -- чтобы можно было использовать операции описаны в модулях описывающие эти типы
  use type interfaces.c.size_t;
  use type interfaces.c.int;

  -- объявляем новые подтипы
  subtype int is interfaces.c.int;
  subtype chars_ptr is interfaces.c.strings.chars_ptr;
  subtype size_t is interfaces.c.size_t;

  subtype curl is system.address;
  -- и типы
  type curl_option is new int;
  type curl_info is new int;
  type curl_code is new interfaces.c.int;

  -- описываем основные функции инициализации
  function curl_easy_init return curl;
  pragma import (c, curl_easy_init, "curl_easy_init");
  -- и выполнения
  function curl_easy_perform (handle : in curl) return curl_code;
  pragma import (c, curl_easy_perform, "curl_easy_perform");

  -- описываем наши функции которые будут конвертировать в адовские типы
  function curl_easy_setopt_string (handle : in curl; opt : in curl_option; val : in string) return curl_code;
  function curl_easy_getinfo_natural (handle : in curl; inf : in curl_info) return natural;
  -- function curl_easy_getinfo_float (handle : in curl; inf : in curl_info) return float; -- хотел использовать для времени загрузки

  -- импортируем константы с libcurlconstants.c которые в свою очередь подтянулись с libcurl
  curlopt_url : curl_option;
  pragma import (C, curlopt_url, "_curlopt_url");

  curle_ok : Integer;
  pragma import (c, curle_ok, "_curle_ok");

  curlopt_verbose : curl_option;
  pragma import (c, curlopt_verbose, "_curlopt_verbose");

  curlopt_writefunction : curl_option;
  pragma import (c, curlopt_writefunction, "_curlopt_writefunction");

  curlopt_writedata : curl_option;
  pragma import (c, curlopt_writedata, "_curlopt_writedata");

  curlopt_proxy : curl_option;
  pragma import (c, curlopt_proxy, "_curlopt_proxy");

  curlopt_ssl_verifypeer : curl_option;
  pragma import (c, curlopt_ssl_verifypeer, "_curlopt_ssl_verifypeer");

  curlopt_ssl_verifyhost : curl_option;
  pragma import (c, curlopt_ssl_verifyhost, "_curlopt_ssl_verifyhost");

  curlopt_useragent : curl_option;
  pragma import (c, curlopt_useragent, "_curlopt_useragent");

  curlopt_timeout : curl_option;
  pragma import (c, curlopt_timeout, "_curlopt_timeout");

  curlinfo_response_code : curl_info;
  pragma import (c, curlinfo_response_code, "_curlinfo_response_code");

  curlinfo_size_download : curl_info;
  pragma import (c, curlinfo_size_download, "_curlinfo_size_download");

  function curl_easy_setopt_long (
    handle : in curl; option : in curl_option; value : in interfaces.c.long) return curl_code;
  pragma import (c, curl_easy_setopt_long, "curl_easy_setopt");

  function curl_easy_getinfo_long (
    handle : in curl; option : in curl_info; value : access c.long) return curl_code;
  pragma import (c, curl_easy_getinfo_long, "curl_easy_getinfo");

  -- function curl_easy_getinfo_double (
  --   handle : in curl; option : in curl_info; value : access c.double) return curl_code;
  -- pragma import (c, curl_easy_getinfo_double, "curl_easy_getinfo");

  procedure curl_easy_cleanup (handle : in curl);
  pragma import (c, curl_easy_cleanup, "curl_easy_cleanup");

  -- создаем пакеты на основе generic поинтеров
  package char_ptrs is new interfaces.c.pointers (
    index => interfaces.c.size_t,
    element => interfaces.c.char,
    element_array => interfaces.c.char_array,
    default_terminator => c.nul);
  use type char_ptrs.pointer;
  subtype char_star is char_ptrs.pointer;

  -- создаем пакеты для файлов
  package file_io is new ada.sequential_io(interfaces.c.char);

  -- описываем функции для write_callback (спасибо Stephane Carrez) и write_data
  function writer (
    ptr : in char_star; size : in size_t;
    nmemb : in size_t; userdata : in file_io.file_type) return size_t;
  pragma convention (c, writer);

  type write_callback_access is access function (
    ptr  : in char_star; size : in size_t;
    nmemb : in size_t; userdata : in file_io.file_type) return size_t;
  pragma convention (c, write_callback_access);

  function curl_easy_setopt_write_callback (
    handle : in curl; option : in curl_option;
    func : in write_callback_access) return curl_code;
  pragma import (c, curl_easy_setopt_write_callback, "curl_easy_setopt");

  function curl_easy_setopt_write_data (
    handle : in curl; option : in curl_option;
    pointer : in file_io.file_type) return curl_code;
  pragma import (c, curl_easy_setopt_write_data, "curl_easy_setopt");

private

  function curl_easy_setopt (
    handle : in curl; option : in curl_option; value : in chars_ptr) return curl_code;
  pragma import (c, curl_easy_setopt, "curl_easy_setopt");

end libcurl;

libcurl.adb

package body libcurl is

  function curl_easy_setopt_string (handle : in curl; opt : in curl_option; val : in string) return curl_code is
  begin
    return curl_easy_setopt (handle, opt, interfaces.c.strings.new_string(val));
  end curl_easy_setopt_string;

  function curl_easy_getinfo_natural (handle : in curl; inf : in curl_info) return natural is
    val : aliased interfaces.c.long;
    res : curl_code;
  begin
    res := curl_easy_getinfo_long(handle, inf, val'access);
    return natural(val);
  end curl_easy_getinfo_natural;

  -- function curl_easy_getinfo_float (handle : in curl; inf : in curl_info) return float is
  --   val : aliased interfaces.c.double;
  --   res : curl_code;
  -- begin
  --   res := curl_easy_getinfo_double(handle, inf, val'access);
  --   return float(val);
  -- end curl_easy_getinfo_float;

  function writer (
      ptr : in char_star; size : in size_t;
      nmemb : in size_t; userdata : in file_io.file_type) return libcurl.size_t is

    total : constant libcurl.size_t := size * nmemb;
    c_char : c.char;
    pointer : char_star;
   begin
      pointer := ptr;
      for i in 1..integer(total) loop
        c_char := pointer.all;
        file_io.write(userdata, c_char);
        char_ptrs.increment(pointer);
      end loop;
      return total;
   end writer;

end libcurl;

В теле ничего интересного и все понятно.
А теперь давайте напишем простую программу которая будет скачивать изображение и возвращать код ответа.

test.adb

with ada.text_io;
with libcurl;

procedure test is
  use type libcurl.curl_code;

  c : libcurl.curl;
  r : libcurl.curl_code;

  f : libcurl.file_io.file_type;
begin
  c := libcurl.curl_easy_init; -- инициализируем
  r := libcurl.curl_easy_setopt_long(c, libcurl.curlopt_verbose, 0); -- без отладочной инфы
  r := libcurl.curl_easy_setopt_long(c, libcurl.curlopt_timeout, 5); -- таймаут
  r := libcurl.curl_easy_setopt_string(c, libcurl.curlopt_useragent, "ada_libcurl"); -- useragent
  r := libcurl.curl_easy_setopt_write_callback(
    c, libcurl.curlopt_writefunction, libcurl.writer'Access); -- ссылка на функцию которая записывает, другой пример этой функции см. дальше
  r := libcurl.curl_easy_setopt_string(c, libcurl.curlopt_url,
    "https://upload.wikimedia.org/wikipedia/commons/a/a4/Ada_Lovelace_portrait.jpg"); -- url
  libcurl.file_io.create(file => f, mode => libcurl.file_io.out_file,
    name => "ada.jpg"); -- создаем файл на запись. нужно обрабатывать на ошибки
  r := libcurl.curl_easy_setopt_write_data(c, libcurl.curlopt_writedata, f); -- userdata - это то что будет передано в функцию writefunction, в этом случае это файл
  if libcurl.curl_easy_perform(c) /= 0 then -- если не 0 смотреть в документации
    ada.text_io.put_line("error perform:" & r'img);
    libcurl.file_io.close(f);
    return;
  end if;
  libcurl.file_io.close(f); -- закрываем файл
  ada.text_io.put_line("return code:" & natural'image(
    libcurl.curl_easy_getinfo_natural(c, libcurl.curlinfo_response_code))); -- получаем код ответа и выводим его
  libcurl.curl_easy_cleanup(c); -- закрываем и очищаем
end test;

Обработку ошибок я возлагаю на заинтересованного в этом программиста.
Скорость такая же как и при пайтновском методе urllib.urlretrieve.
Возможные ошибки (r /= 0) libcurl-errors.

Задача №2

Друг попросил. Получить страницу, распарсить и вытянуть информацию с сайта (olx).

Получить. Мы умеем сохранять сразу же в файл, но для того чтобы вытянуть инфу нужно страницу записывать не в файл, а в переменную. Для этого нужно добавить функцию reader.

Распарсить. В пайтоне я использовал lxml.html, здесь я решил написать свою функцию.

Вытянуть инфу после правильного парсинга страницы несложно.

libcurl.ads

Хранить страницу будем в unbounded_string, это адовский тип для хранения строк динамической длины (вектор символов).

Все по аналогии с функцией writer, но в userdata будет ссылка на unbounded_string

with ada.strings.unbounded;

package libcurl is
  package unb renames ada.strings.unbounded;
  use type unb.unbounded_string;

...
  function reader (
    ptr : in char_star; size : in size_t;
    nmemb : in size_t; userdata : access unb.unbounded_string) return size_t;
  pragma convention (c, reader);

  type read_callback_access is access function (
    ptr  : in char_star; size : in size_t;
    nmemb : in size_t; userdata : access unb.unbounded_string) return size_t;
  pragma convention (c, read_callback_access);

  function curl_easy_setopt_read_callback (
    handle : in curl; option : in curl_option;
    func : in read_callback_access) return curl_code;
  pragma import (c, curl_easy_setopt_read_callback, "curl_easy_setopt");

  function curl_easy_setopt_read_data (
    handle : in curl; option : in curl_option;
    pointer : access unb.unbounded_string) return curl_code;
  pragma import (c, curl_easy_setopt_read_data, "curl_easy_setopt");

libcurl.adb

  function reader (
      ptr : in char_star; size : in size_t;
      nmemb : in size_t; userdata : access unb.unbounded_string) return libcurl.size_t is
    total : constant libcurl.size_t := size * nmemb;
  begin
    unb.append(userdata.all, unb.to_unbounded_string(
      interfaces.c.strings.value(interfaces.c.strings.new_char_array(
        char_ptrs.value(ptr)))));
    return total;
  end reader;

test.adb

  s : aliased unb.unbounded_string;
...
  r := libcurl.curl_easy_setopt_read_callback(c, libcurl.curlopt_writefunction, libcurl.reader'Access);
  r := libcurl.curl_easy_setopt_read_data(c, libcurl.curlopt_writedata, s'access);

Ок, теперь в s у нас записана страница и нужно ее распарсить.
Парсить дом не сложно, главное правильно определить родителя.
Для начала нужно создать правильную структуру в которую мы сможем записать все объекты дома, потом функцию для парсинга и пару функций для поиска по дому.

parser.ads

with ada.text_io; -- для отладки
with ada.strings.unbounded;

package parser is
  package unb renames ada.strings.unbounded; -- для удобства
  use type unb.unbounded_string;

  type cont; -- неполное описание типа (смотреть примечание)
  type cont_ptr is access all cont; -- ссылочный тип на тип cont
  type cont is tagged record -- описание типа
    tag : unb.unbounded_string; -- тег блока
    tag_all : unb.unbounded_string; -- вся строчка от "<" до ">"
    class : unb.unbounded_string; -- класс блока
    text : unb.unbounded_string; -- все что не входит в блоки
    parent : cont_ptr := null; -- родитель
    next : cont_ptr := null; -- следующий блок
    prev : cont_ptr := null; -- предыдущий блок
    closed : boolean := false; -- был ли закрыт тег (например img будет false)
  end record;

  root : cont_ptr := new cont; -- создаем родительский объект
  last : cont_ptr; -- tmp

  -- следующие функции будут прокомментированы в теле пакета

  function get_attr (t : cont_ptr; attr : string) return string;
procedure init (s : string);
  function get_by_class (s : string; start : cont_ptr) return cont_ptr;
  function parents (ptr : cont_ptr; s : string; offset : positive := 1) return cont_ptr;
end parser;

Примечание: статья в adacode.ru о ссылочных типах.
Изначально моя запись не содержала класса и текста, но для удобства вытягивания информации я добавил эти поля и переделал соответствующую функцию, возможно Вам понадобиться что-то еще, например id.

parser.adb

package body parser is
  -- процедура для создания нового блока в дереве
  -- все как у всех векторов
  procedure append is
    t_cont : cont_ptr;
  begin
    t_cont := new cont;
    last.next := t_cont;
    t_cont.prev := last;
    last := t_cont;
  end append;

  -- функция которая возвращает значения атрибута
  function get_attr (t : cont_ptr; attr : string) return string is
    m, n : natural;
    j : natural := 0;
  begin
    m := unb.index(t.tag_all, attr & "=");
    if m > 0 then
      n := m + attr'length + 2;
      for i in n..unb.length(t.tag_all) loop
        if unb.element(t.tag_all, i) = '"' then
          j := i - 1;
          exit;
        end if;
      end loop;
      if n <= j then
        return unb.slice(t.tag_all, n, j);
      end if;
    end if;
    return "";
  end get_attr;

  -- процедура парсинга, которая принимает обычную строку
  procedure init (s : string) is
    cur, parent : cont_ptr;
    base : cont;

    m : natural;
    tb : boolean := false;
    close : boolean := false;
    is_tag : boolean := false;
  begin
    last := root;
    parent := root;

    if s'length < 2 or else s(s'last) = '<' then

      ada.text_io.put_line("error <");
    end if;

    for i in s'range loop
      if s(i) = '<' then
        is_tag := true;
        if s(i + 1) = '/' then
          m := i + 2;
          close := true;
        else
          m := i + 1;
          append;
        end if;
        tb := true;
      elsif tb and then (s(i) = ' ' or s(i) = '>') then
        if close then
          close := false;
          cur := last;
          loop
            exit when cur = null;
            if not cur.closed and cur.tag = unb.to_unbounded_string(s(m..(i - 1))) then
              cur.closed := true;
              exit;
            end if;
            cur := cur.prev;
          end loop;
          loop
            exit when parent = null or else
              parent.tag = unb.to_unbounded_string(s(m..(i - 1)));
            parent := parent.parent;
          end loop;
          parent := parent.parent;
        else
          last.tag := unb.to_unbounded_string(s(m..(i - 1)));
          last.parent := parent;
          parent := last;
        end if;
        tb := false;
        if s(i) = '>' then
          is_tag := false;
        end if;
      elsif s(i) = '>' then
        if close then
          close := false;
        else
          last.tag_all := unb.to_unbounded_string(s(m..(i - 1)));
        end if;
        is_tag := false;
      elsif not is_tag then
        unb.append(last.text, s(i));
      end if;
    end loop;

    cur := last;
    loop
      exit when cur = null or else cur.parent = null;
      cur.class := unb.to_unbounded_string(get_attr(cur, "class"));
      if not cur.parent.closed then
        loop
          exit when cur.parent = null or else cur.parent.closed;
          cur.parent := cur.parent.parent;
        end loop;
      end if;
      cur := cur.prev;
    end loop;
  end init;

  -- функция возвращающая первый элемент с искомым классом начиная поиск с start
  -- если таких нету возвращает null
  function get_by_class (s : string; start : cont_ptr) return cont_ptr is
    cur : cont_ptr := start.next; -- следующий элемент после исходного
  begin
    loop -- бесконечный цикл
      -- выходим с цикла дошли к концу дерева или нашли с нужным классом
      exit when cur = null or else cur.class = s;
      cur := cur.next; -- следующий элемент
    end loop;
    return cur; -- возвращаем удовлетворяющий запросу или null
  end get_by_class;

  -- возвращает i-го (offset) родителя (папу, дедушку, прадедушку и т.д.) с искомым тегом
  function parents (ptr : cont_ptr; s : string; offset : positive := 1) return cont_ptr is
    cur : cont_ptr := ptr;
    i : natural := 0;
  begin
    loop
      exit when cur = null or i = offset;
      cur := cur.parent;
      if cur.tag = s then
        i := i + 1;
      end if;
    end loop;
    return cur;
  end parents;
end parser;

И вот сотня строчек дает возможность распарсить да еще и вспомогательные функции.
Все что осталось это используя написанное получить информацию.
Для теста вытянем с сайта adacode.ru заголовки, даты и ссылки на статьи с главной страницы.

test.adb

with ada.text_io;
with parser;
with ada.strings.unbounded;
with libcurl;

procedure test is
  package unb renames ada.strings.unbounded;
  use type libcurl.curl_code;
  use type parser.cont_ptr;

  url : constant string := "http://adacode.ru/";

  conn : libcurl.curl;
  res : libcurl.curl_code;

  tsa : aliased unb.unbounded_string;
  h : parser.cont_ptr := parser.root;
begin
  conn := libcurl.curl_easy_init;
  res := libcurl.curl_easy_setopt_long(conn, libcurl.curlopt_verbose, 0);
  res := libcurl.curl_easy_setopt_long(conn, libcurl.curlopt_timeout, 5);
  res := libcurl.curl_easy_setopt_string(conn, libcurl.curlopt_useragent, "libcurl");
  res := libcurl.curl_easy_setopt_read_callback(conn, libcurl.curlopt_writefunction, libcurl.reader'Access);
  res := libcurl.curl_easy_setopt_read_data(conn, libcurl.curlopt_writedata, tsa'access);

  res := libcurl.curl_easy_setopt_string(conn, libcurl.curlopt_url, url);

  res := libcurl.curl_easy_perform(conn);
  if res = 0 and libcurl.curl_easy_getinfo_natural(
      conn, libcurl.curlinfo_response_code) = 200 then
    parser.init(unb.to_string(tsa));

    ada.text_io.put_line("adacode.ru");
    loop
      h := parser.get_by_class("entry-title", h);
      exit when h = null;
      ada.text_io.put_line("---");
      ada.text_io.put_line(unb.to_string(h.next.text));
      ada.text_io.put_line(parser.get_attr(h.next, "href"));
    end loop;
  else
    ada.text_io.put_line("error");
  end if;

  libcurl.curl_easy_cleanup(conn);
end test;

на выходе мы получим

adacode.ru
---
Контролируемые типы и объектно-ориентированное программирование        
        
http://adacode.ru/ada-materialy-i-zadachi/kontroliruemye-tipy/
---
Теговые типы. Объектно-ориентированное программирование        
        
http://adacode.ru/ada-materialy-i-zadachi/tegovye-tipy-obektno-orientirovannoe-programmirovanie/
---
Задачи (параллельное программирование). Часть 2        
        
http://adacode.ru/ada-materialy-i-zadachi/zadachi-parallelnoe-programmirovanie-chast-2/
---
Задачи (параллельное программирование). Часть 1        
        
http://adacode.ru/ada-materialy-i-zadachi/zadachi-parallelnoe-programmirovanie-chast-1/
---
Обработка исключений в языке Ада        
        
http://adacode.ru/ada-materialy-i-zadachi/obrabotka-isklyuchenij-v-yazyke-ada/

Замечание. Для работы с https мне понадобилось установить с помощью apt libcurl4-openssl-dev.

Чтобы скомпилировать примеры нужно выполнить

gcc -c libcurlconstants.c -lcurl
gnatmake test.adb -largs -lcurl -largs libcurlconstants.o

P.S.

Все что связано с задачей 2 не должно рассматриваться как готовый модули или правильный код. Это обычный пример что с помощью Ады можно делать и что на Аде можно говнокодить (за пару часов написать парсер).

Я добавил это в статью чтобы ответить на вопрос "И что можно делать на Аде? Где практическое применение?" (об этом мы еще поговорим в отдельной статье ...)

Страничка на github

P.P.S. после написания статьи нашел https://directory.fsf.org/wiki/AdacURL