newlib/socket.ajla

   1 {*
   2  * Copyright (C) 2024 Mikulas Patocka
   3  *
   4  * This file is part of Ajla.
   5  *
   6  * Ajla is free software: you can redistribute it and/or modify it under the
   7  * terms of the GNU General Public License as published by the Free Software
   8  * Foundation, either version 3 of the License, or (at your option) any later
   9  * version.
  10  *
  11  * Ajla is distributed in the hope that it will be useful, but WITHOUT ANY
  12  * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  13  * A PARTICULAR PURPOSE. See the GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License along with
  16  * Ajla. If not, see <https://www.gnu.org/licenses/>.
  17  *}
  18
  19 unit socket;
  20
  21 uses io;
  22 uses socket_consts;
  23
  24 type address := bytes;
  25
  26 fn address_family(a : address) : int;
  27
  28 fn socket(w : world, p s pr : int) : (world, handle);
  29 fn connect(w : world, s : handle, addr : address) : world;
  30 fn bind(w : world, s : handle, addr : address) : world;
  31 fn listen(w : world, s : handle) : world;
  32 fn accept(w : world, s : handle) : (world, handle);
  33 fn getsockname(w : world, s : handle) : (world, address);
  34 fn getpeername(w : world, s : handle) : (world, address);
  35 fn recvfrom(w : world, s : handle, length : int, flags : int) : (world, bytes, address);
  36 fn sendto(w : world, s : handle, data : bytes, flags : int, addr : address) : (world, int);
  37
  38 type sockopt;
  39 conversion fn sockopt_int(s : sockopt) : int;
  40 conversion fn int_sockopt(i : int) : sockopt;
  41 conversion fn sockopt_byte(s : sockopt) : byte;
  42 conversion fn byte_sockopt(i : byte) : sockopt;
  43 conversion fn sockopt_cstring(s : sockopt) : bytes;
  44 conversion fn cstring_sockopt(b : bytes) : sockopt;
  45 fn getsockopt(w : world, s : handle, l opt : int) : (world, sockopt);
  46 fn setsockopt(w : world, s : handle, l opt : int, data : sockopt) : world;
  47
  48 fn getaddrinfo(w : world, name : bytes, port : int) : (world, list(address));
  49 fn getnameinfo(w : world, addr : address) : (world, bytes);
  50
  51 fn connect_tcp(implicit w : world, host : bytes, port : int) : (world, handle);
  52
  53 implementation
  54
  55 uses exception;
  56
  57 fn address_family(a : address) : int
  58 [
  59         return a[0] + (a[1] shl 8);
  60 ]
  61
  62 fn socket(w : world, p s pr : int) : (world, handle)
  63 [
  64         var w2 : world;
  65         var h : handle;
  66         pcode IO IO_Socket 2 4 0 =w2 =h w p s pr;
  67         return w2, h;
  68 ]
  69
  70 fn connect(w : world, s : handle, addr : address) : world
  71 [
  72         var w2 w3 : world;
  73         pcode IO IO_Connect 1 3 0 =w2 w s addr;
  74         pcode IO IO_Connect_Wait 1 2 0 =w3 w2 s;
  75         return w3;
  76 ]
  77
  78 fn bind(w : world, s : handle, addr : address) : world
  79 [
  80         var w2 : world;
  81         pcode IO IO_Bind 1 3 0 =w2 w s addr;
  82         return w2;
  83 ]
  84
  85 fn listen(w : world, s : handle) : world
  86 [
  87         var w2 : world;
  88         pcode IO IO_Listen 1 2 0 =w2 w s;
  89         return w2;
  90 ]
  91
  92 fn accept(w : world, s : handle) : (world, handle)
  93 [
  94         var h : handle;
  95         var w2 : world;
  96         pcode IO IO_Accept 2 2 0 =w2 =h w s;
  97         return w2, h;
  98 ]
  99
 100 fn getsockname(w : world, s : handle) : (world, address)
 101 [
 102         var w2 : world;
 103         var addr : address;
 104         pcode IO IO_Get_Sock_Name 2 2 0 =w2 =addr w s;
 105         return w2, addr;
 106 ]
 107
 108 fn getpeername(w : world, s : handle) : (world, address)
 109 [
 110         var w2 : world;
 111         var addr : address;
 112         pcode IO IO_Get_Peer_Name 2 2 0 =w2 =addr w s;
 113         return w2, addr;
 114 ]
 115
 116 fn recvfrom(w : world, s : handle, length : int, flags : int) : (world, bytes, address)
 117 [
 118         var w2 : world;
 119         var data : bytes;
 120         var addr : address;
 121         pcode IO IO_Recv_From 3 4 0 =w2 =data =addr w s length flags;
 122         return w2, data, addr;
 123 ]
 124
 125 fn sendto(w : world, s : handle, data : bytes, flags : int, addr : address) : (world, int)
 126 [
 127         var w2 : world;
 128         var length : int;
 129         pcode IO IO_Send_To 2 5 0 =w2 =length w s data flags addr;
 130         return w2, length;
 131 ]
 132
 133 type sockopt := bytes;
 134
 135 conversion fn sockopt_int(s : sockopt) : int
 136 [
 137         return native_to_int(native.integer, s);
 138 ]
 139
 140 conversion fn int_sockopt(i : int) : sockopt
 141 [
 142         return int_to_native(native.integer, i);
 143 ]
 144
 145 conversion fn sockopt_byte(s : sockopt) : byte
 146 [
 147         return s[0];
 148 ]
 149
 150 conversion fn byte_sockopt(i : byte) : sockopt
 151 [
 152         return bytes.[ i ];
 153 ]
 154
 155 conversion fn sockopt_cstring(s : sockopt) : bytes
 156 [
 157         if not list_ends_with(s, bytes.[ 0 ]) then
 158                 return exception_make_str(bytes, ec_sync, error_system_returned_invalid_data, 0, true, "the string returned by getsockopt is not 0-terminated");
 159         return s[ .. len(s) - 1];
 160 ]
 161
 162 conversion fn cstring_sockopt(b : bytes) : sockopt
 163 [
 164         return b + bytes.[ 0 ];
 165 ]
 166
 167 fn getsockopt(w : world, s : handle, l opt : int) : (world, sockopt)
 168 [
 169         var w2 : world;
 170         var data : sockopt;
 171         pcode IO IO_Get_Sock_Opt 2 4 0 =w2 =data w s l opt;
 172         return w2, data;
 173 ]
 174
 175 fn setsockopt(w : world, s : handle, l opt : int, data : sockopt) : world
 176 [
 177         var w2 : world;
 178         pcode IO IO_Set_Sock_Opt 1 5 0 =w2 w s l opt data;
 179         return w2;
 180 ]
 181
 182 fn getaddrinfo(w : world, name : bytes, port : int) : (world, list(address))
 183 [
 184         var h : handle;
 185         var w2 : world;
 186         pcode IO IO_Get_Addr_Info 2 3 0 =w2 =h w name port;
 187         var w3 := w2;
 188
 189         var s := empty(byte);
 190         while true do [
 191                 var b : bytes;
 192                 w3, b := read_partial~strict(w3, h, 1024);
 193                 if not len_greater_than(b, 0) then
 194                         break;
 195                 s += b;
 196         ]
 197
 198         if s[1] <> 0 then [
 199                 var error_class := #100 * s[3] + s[2];
 200                 var error_type := #100 * s[5] + s[4];
 201                 var error_aux := #1000000 * s[9] + #10000 * s[8] + #100 * s[7] + s[6];
 202                 abort exception_make_str(int, error_class, error_type, error_aux, false, "failed to lookup " + name + ", " + ntos(port));
 203         ]
 204
 205         s := s[2 .. ];
 206         var a := empty(address);
 207         while len_greater_than(s, 0) do [
 208                 var found_addrlen := #100 * s[1] + s[0];
 209                 var found_addr := s[2 .. 2 + found_addrlen];
 210                 s := s[2 + found_addrlen .. ];
 211
 212                 a +<= found_addr;
 213         ]
 214         return w3, a;
 215 ]
 216
 217 fn getnameinfo(w : world, addr : address) : (world, bytes)
 218 [
 219         var h : handle;
 220         var w2 : world;
 221         pcode IO IO_Get_Name_Info 2 2 0 =w2 =h w addr;
 222         var w3 := w2;
 223
 224         var s := empty(byte);
 225         while true do [
 226                 var b : bytes;
 227                 w3, b := read_partial~strict(w3, h, 1024);
 228                 if not len_greater_than(b, 0) then
 229                         break;
 230                 s += b;
 231         ]
 232
 233         if s[1] <> 0 then [
 234                 var error_class := #100 * s[3] + s[2];
 235                 var error_type := #100 * s[5] + s[4];
 236                 var error_aux := #1000000 * s[9] + #10000 * s[8] + #100 * s[7] + s[6];
 237                 abort exception_make_str(int, error_class, error_type, error_aux, false, "failed to lookup address");
 238         ]
 239
 240         return w3, s[2 .. ];
 241 ]
 242
 243 fn connect_recursive(w : world, a : list(address)) : (world, handle)
 244 [
 245         var w1 : world;
 246         w, w1 := fork(w);
 247         var s1 : handle;
 248         w1, s1 := socket(w1, address_family(a[0]), sock_stream, 0);
 249         w1 := connect(w1, s1, a[0]);
 250
 251         if not len_greater_than(a, 1) then
 252                 return w1, s1;
 253
 254         w := sleep(w, 1000000);
 255
 256         var b : bool;
 257         b := any(w1, w);
 258         w := select(b, w1, w);
 259         if not b then [
 260                 if not is_exception w1 then
 261                         return w1, s1;
 262         ]
 263
 264         var w2 : world;
 265         w, w2 := fork(w);
 266         var s2 : handle;
 267         w2, s2 := connect_recursive(w2, a[1 .. ]);
 268
 269         b := any(w1, w2);
 270         w := select(b, w1, w2);
 271         if not b then [
 272                 if not is_exception w1 then
 273                         return w1, s1;
 274                 return w2, s2;
 275         ] else [
 276                 if not is_exception w2 then
 277                         return w2, s2;
 278                 return w1, s1;
 279         ]
 280 ]
 281
 282 fn connect_tcp(implicit w : world, host : bytes, port : int) : (world, handle)
 283 [
 284         var a := getaddrinfo(host, port);
 285         if not len_greater_than(a, 0) then
 286                 abort exception_make(int, ec_syscall, error_system, system_error_enetunreach, false);
 287         return connect_recursive(a);
 288 ]