Initial import

1 files changed, 326 insertions, 0 deletions

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 <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 = 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