From fb11ffeb2d98f239b20e618c65b8534b677957e9 Mon Sep 17 00:00:00 2001 From: Jeffrey Armstrong Date: Wed, 24 Mar 2021 14:58:32 -0400 Subject: Initial import --- common/network.F90 | 326 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 326 insertions(+) create mode 100644 common/network.F90 (limited to 'common/network.F90') diff --git a/common/network.F90 b/common/network.F90 new file mode 100644 index 0000000..90bf2be --- /dev/null +++ b/common/network.F90 @@ -0,0 +1,326 @@ +! Copyright (c) 2020 Jeffrey Armstrong +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in +! all copies or substantial portions of the Software. +! +! The Software shall be used for Good, not Evil. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +! SOFTWARE. + +module network +use iso_c_binding +implicit none + + integer(kind=c_int), parameter::AF_INET = 2 + integer(kind=c_int), parameter::AF_INET6 = 10 + integer(kind=c_int), parameter::AF_UNIX = 1 + + integer(kind=c_int), parameter::SOCK_STREAM = 1 + + integer, parameter::socket_timeout_ms = 10000 + +#ifdef WINDOWS + integer, parameter::hostent_int_kind = c_short +#else + integer, parameter::hostent_int_kind = c_int +#endif + + type, bind(c) :: in_addr + integer(kind=c_int32_t)::s_addr + end type + + type, bind(c) :: sockaddr_in + integer(kind=c_short)::sin_family + integer(kind=c_int16_t)::sin_port + type(in_addr)::sin_addr + !integer(kind=c_int32_t)::s_addr + end type + + type, bind(c) :: hostent_c + type(c_ptr)::h_name !official name of host */ + type(c_ptr)::h_aliases !alias list */ + integer(kind=hostent_int_kind):: h_addrtype !host address type */ + integer(kind=hostent_int_kind):: h_length !length of address */ + type(c_ptr)::h_addr_list !list of addresses */ + end type + + ! Let's keep this simple... + type :: simple_hostent + character(len=:), allocatable::h_name + integer::h_addrtype + integer(kind=c_int32_t)::h_addr4 + integer(kind=c_int64_t)::h_addr6 + end type + +#ifndef WINDOWS + type, bind(c) :: timeval + integer(kind=c_long)::seconds + integer(kind=c_long)::useconds + end type +#endif + + integer(kind=c_size_t), parameter::sockaddr_size = 56 + + interface + function socket_c(i, j, k) bind(c, name="socket") + use iso_c_binding + integer(kind=c_int), value::i, j, k + integer(kind=c_int)::socket_c + end function socket_c + + function inet_addr_c(str) bind(c, name="inet_addr") + use iso_c_binding + type(c_ptr), value::str + integer(c_int32_t)::inet_addr_c + end function inet_addr_c + + function inet_ntoa_c(ip) bind(c, name="inet_ntoa") + use iso_c_binding + type(c_ptr)::inet_ntoa_c + integer(c_int32_t), value::ip + end function inet_ntoa_c + + function htons(i) bind(c) + use iso_c_binding + integer(kind=c_int32_t), value::i + integer(kind=c_int32_t)::htons + end function htons + + function connect_c(sockfd, sock_addr, socklen) bind(c, name="connect") + use iso_c_binding + import::sockaddr_in + integer(kind=c_int), value::sockfd + type(c_ptr), value::sock_addr + integer(kind=c_size_t), value::socklen + integer(kind=c_int)::connect_c + end function connect_c + + function gethostbyname_c(host) bind(c, name="gethostbyname") + use iso_c_binding + type(c_ptr), value::host + type(c_ptr)::gethostbyname_c + end function gethostbyname_c + + function close_c(s) bind(c, name="close") + use iso_c_binding + integer(kind=c_int), value::s + integer(kind=c_int)::close_c + end function close_c + + end interface + + contains + + function socket(domain, stype, protocol) + use iso_c_binding, only: c_int + implicit none + + integer::socket + integer, intent(in)::domain, stype, protocol + integer::ignored + +#ifdef WINDOWS + integer(kind=c_int32_t), target::timeout + integer(kind=c_int), parameter::timeout_size=c_int32_t +#else + type(timeval), target::timeout + integer(kind=c_int), parameter::timeout_size=2*c_long +#endif + + + ! Set up a timeout on the socket that's sensible + interface + function setsockopt(s, level, optname, optval, optlen) bind(c, name="setsockopt") + use iso_c_binding + integer(kind=c_int)::setsockopt + integer(kind=c_int), value::s + integer(kind=c_int), value::level, optname, optlen + type(c_ptr), value::optval + end function + end interface + +#ifdef WINDOWS + integer, parameter::SOL_SOCKET = 65535 + integer, parameter::SO_RCVTIMEO = 4102 + timeout = socket_timeout_ms +#else + integer, parameter::SOL_SOCKET = 1 + integer, parameter::SO_RCVTIMEO = 20 + timeout%useconds = 0 + timeout%seconds = socket_timeout_ms/1000 +#endif + + socket = socket_c(int(domain, c_int), int(stype, c_int), int(protocol, c_int)) + + ! Timeout call + ignored = setsockopt(socket, SOL_SOCKET, SO_RCVTIMEO, c_loc(timeout), timeout_size) + + + end function socket + + subroutine close_socket(s) + use iso_c_binding + implicit none + + integer::s + integer::ignored + + ignored = close_c(int(s, kind=c_int)) + + end subroutine close_socket + + function inet_addr(str) + use iso_c_binding + implicit none + + character(*), intent(in)::str + integer(c_int32_t)::inet_addr + + character(kind=c_char), dimension(:), allocatable, target::cstr + integer::i + + allocate(cstr(len_trim(str)+1)) + + do i=1, len_trim(str) + cstr(i) = str(i:i) + end do + cstr(len_trim(str)+1) = c_null_char + + inet_addr = inet_addr_c(c_loc(cstr)) + + deallocate(cstr) + + end function inet_addr + + function inet_ntoa(ip) result(res) + use iso_c_binding + implicit none + + integer(kind=c_int32_t), intent(in)::ip + character(15)::res + + type(c_ptr)::cptr + character(kind=c_char), dimension(:), pointer::cres + integer::i + + res = " " + cptr = inet_ntoa_c(ip) + if(c_associated(cptr)) then + call c_f_pointer(cptr, cres, [1]) + + i = 1 + do while(cres(i) /= c_null_char) + res(i:i) = cres(i) + i = i + 1 + end do + end if + + end function inet_ntoa + + function connect(sockfd, sock_addr) + use iso_c_binding + implicit none + + integer::sockfd + type(sockaddr_in), target::sock_addr + logical::connect + + !print *, c_sizeof(sock_addr) + + connect = (connect_c(int(sockfd, kind=c_int), & + c_loc(sock_addr), & + sockaddr_size) .eq. 0) + + end function connect + + function gethostbyname(host, success) result(res) + use iso_c_binding + implicit none + + character(*)::host + type(simple_hostent)::res + + type(hostent_c), pointer::cres + type(c_ptr)::callres + + logical, intent(out), optional::success + + ! To get the host to C + character(kind=c_char), dimension(:), allocatable, target::chost + integer::i + + ! To process h_name + character(kind=c_char), dimension(:), pointer::h_name + integer::hnamelen + interface + function strlen_c(cstr) bind(c, name="strlen") + use iso_c_binding + type(c_ptr), value::cstr + integer(kind=c_size_t)::strlen_c + end function strlen_c + end interface + + + ! To process h_addr + type(c_ptr), dimension(:), pointer::addrptr + integer(kind=c_int32_t), pointer::addr32 + integer(kind=c_int64_t), pointer::addr64 + + allocate(chost(len_trim(host)+1)) + + do i=1, len_trim(host) + chost(i) = host(i:i) + end do + chost(len_trim(host)+1) = c_null_char + + callres = gethostbyname_c(c_loc(chost)) + if(c_associated(callres)) then + call c_f_pointer(callres, cres) + + ! Extract the name + hnamelen = strlen_c(cres%h_name) + call c_f_pointer(cres%h_name, h_name, [hnamelen]) + allocate(character(len=i) :: res%h_name) + do i = 1, hnamelen + res%h_name(i:i) = h_name(i) + end do + + ! And address + res%h_addr4 = 0 + res%h_addr6 = 0 + + res%h_addrtype = cres%h_addrtype + call c_f_pointer(cres%h_addr_list, addrptr, [1]) + if(res%h_addrtype == AF_INET) then + call c_f_pointer(addrptr(1), addr32) + res%h_addr4 = addr32 + else if(res%h_addrtype == AF_INET6) then + call c_f_pointer(addrptr(1), addr64) + res%h_addr6 = addr64 + end if + + if(present(success)) then + success = .TRUE. + end if + else + if(present(success)) then + success = .FALSE. + end if + end if + + end function gethostbyname + +end module network \ No newline at end of file -- cgit v1.2.3