path: root/common/network.F90

! Copyright (c) 2020 Jeffrey Armstrong <jeff@rainbow-100.com>
!
! 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 = 16
    
    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
        
        !subroutine memset_c(p, v, n) bind(c, name="memset")
        !use iso_c_binding
        !type(c_ptr), value::p
        !integer(kind=c_int), value::v, n
        !end subroutine memset_c
        
        ! Debugging routine
        !subroutine output_sa(p) bind(c, name="output_sa")
        !use iso_c_binding
        !type(c_ptr), value::p
        !end subroutine output_sa
        
    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
        
        ! Just for debugging
        !call output_sa(c_loc(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=hnamelen) :: 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