aboutsummaryrefslogtreecommitdiff
path: root/common
diff options
context:
space:
mode:
authorJeffrey Armstrong <jeff@approximatrix.com>2021-03-24 14:58:32 -0400
committerJeffrey Armstrong <jeff@approximatrix.com>2021-03-24 14:58:32 -0400
commitfb11ffeb2d98f239b20e618c65b8534b677957e9 (patch)
treeccb017781f08d10b8d5f5cd6569122b84af997a5 /common
downloadlevitating-fb11ffeb2d98f239b20e618c65b8534b677957e9.tar.gz
levitating-fb11ffeb2d98f239b20e618c65b8534b677957e9.zip
Initial import
Diffstat (limited to 'common')
-rw-r--r--common/jessl.f90374
-rw-r--r--common/network.F90326
-rw-r--r--common/protocol.f90474
-rw-r--r--common/request.f90294
-rw-r--r--common/wsa.f9068
5 files changed, 1536 insertions, 0 deletions
diff --git a/common/jessl.f90 b/common/jessl.f90
new file mode 100644
index 0000000..223fd14
--- /dev/null
+++ b/common/jessl.f90
@@ -0,0 +1,374 @@
+! 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.
+
+! Just Enough SSL...
+
+module jessl
+use iso_c_binding
+implicit none
+
+ ! Constants needed for SNI
+ integer(kind=c_long), parameter::TLSEXT_NAMETYPE_host_name = 0
+
+ integer(kind=c_int), parameter::SSL_CTRL_SET_TLSEXT_HOSTNAME = 55
+
+ integer(kind=c_int), parameter::SSL_FILETYPE_PEM = 1
+
+ interface
+
+ function init_ssl_c(flags, settings) bind(c, name="OPENSSL_init_ssl")
+ use iso_c_binding
+ integer(kind=c_int64_t), value::flags
+ type(c_ptr), value::settings
+ integer(kind=c_int)::init_ssl_c
+ end function init_ssl_c
+
+ subroutine add_ssl_algorithms() bind(c, name="SSLeay_add_ssl_algorithms")
+ end subroutine add_ssl_algorithms
+
+ subroutine load_error_strings() bind(c, name="SSL_load_error_strings")
+ end subroutine load_error_strings
+
+ function tls_client_method() bind(c, name="TLS_client_method")
+ use iso_c_binding
+ type(c_ptr)::tls_client_method
+ end function tls_client_method
+
+ function tls_server_method() bind(c, name="TLS_server_method")
+ use iso_c_binding
+ type(c_ptr)::tls_server_method
+ end function tls_server_method
+
+ !subroutine print_error() bind(c, name="print_error")
+ !use iso_c_binding
+ !end subroutine print_error
+
+ function ctx_new(meth) bind(c, name="SSL_CTX_new")
+ use iso_c_binding
+ type(c_ptr)::ctx_new
+ type(c_ptr), value::meth
+ end function ctx_new
+
+ function ctx_set_ecdh_auto(ctx, state) bind(c, name="SSL_CTX_set_ecdh_auto")
+ use iso_c_binding
+ type(c_ptr), value::ctx
+ integer(kind=c_int), value::state
+ integer(kind=c_long)::ctx_set_ecdh_auto
+ end function ctx_set_ecdh_auto
+
+ function ctx_use_certificate_file_c(ctx, filename, certtype) bind(c, name="SSL_CTX_use_certificate_file")
+ use iso_c_binding
+ type(c_ptr), value::ctx
+ character(kind=c_char), dimension(*), intent(inout)::filename
+ integer(kind=c_int), value::certtype
+ integer(kind=c_int)::ctx_use_certificate_file_c
+ end function ctx_use_certificate_file_c
+
+ function ctx_use_private_key_file_c(ctx, filename, certtype) bind(c, name="SSL_CTX_use_PrivateKey_file")
+ use iso_c_binding
+ type(c_ptr), value::ctx
+ character(kind=c_char), dimension(*), intent(inout)::filename
+ integer(kind=c_int), value::certtype
+ integer(kind=c_int)::ctx_use_private_key_file_c
+ end function ctx_use_private_key_file_c
+
+ function ssl_new(ctx) bind(c, name="SSL_new")
+ use iso_c_binding
+ type(c_ptr)::ssl_new
+ type(c_ptr), value::ctx
+ end function ssl_new
+
+ function get_fd(ssl) bind(c, name="SSL_get_fd")
+ use iso_c_binding
+ integer(kind=c_int)::get_fd
+ type(c_ptr), value::ssl
+ end function get_fd
+
+ function set_fd(ssl, fd) bind(c, name="SSL_set_fd")
+ use iso_c_binding
+ integer(kind=c_int)::set_fd
+ integer(kind=c_int), value::fd
+ type(c_ptr), value::ssl
+ end function set_fd
+
+ function set_read_fd(ssl, fd) bind(c, name="SSL_set_rfd")
+ use iso_c_binding
+ integer(kind=c_int)::set_read_fd
+ integer(kind=c_int), value::fd
+ type(c_ptr), value::ssl
+ end function set_read_fd
+
+ function set_write_fd(ssl, fd) bind(c, name="SSL_set_wfd")
+ use iso_c_binding
+ integer(kind=c_int)::set_write_fd
+ integer(kind=c_int), value::fd
+ type(c_ptr), value::ssl
+ end function set_write_fd
+
+ function ssl_connect(ssl) bind(c, name="SSL_connect")
+ use iso_c_binding
+ integer(kind=c_int)::ssl_connect
+ type(c_ptr), value::ssl
+ end function ssl_connect
+
+ function ssl_accept(ssl) bind(c, name="SSL_accept")
+ use iso_c_binding
+ integer(kind=c_int)::ssl_accept
+ type(c_ptr), value::ssl
+ end function ssl_accept
+
+ function ssl_shutdown(ssl) bind(c, name="SSL_shutdown")
+ use iso_c_binding
+ integer(kind=c_int)::ssl_shutdown
+ type(c_ptr), value::ssl
+ end function ssl_shutdown
+
+ function ssl_free(ssl) bind(c, name="SSL_free")
+ use iso_c_binding
+ integer(kind=c_int)::ssl_free
+ type(c_ptr), value::ssl
+ end function ssl_free
+
+ function ctx_free(ctx) bind(c, name="SSL_CTX_free")
+ use iso_c_binding
+ integer(kind=c_int)::ctx_free
+ type(c_ptr), value::ctx
+ end function ctx_free
+
+ function ssl_ctrl_c(ctx, cmd, arg, vp) bind(c, name="SSL_ctrl")
+ use iso_c_binding
+ type(c_ptr), value::ctx
+ integer(kind=c_int), value::cmd
+ integer(kind=c_long), value::arg
+ type(c_ptr), value::vp
+ integer(kind=c_long)::ssl_ctrl_c
+ end function ssl_ctrl_c
+
+ ! Actually a macro...
+ !function get_cipher_c(ssl) bind(c, name="SSL_get_cipher_name")
+ !use iso_c_binding
+ !type(c_ptr)::get_cipher_c
+ !type(c_ptr), value::ssl
+ !end function get_cipher_c
+
+ function read_c(ssl, buf, length) bind(c, name="SSL_read")
+ use iso_c_binding
+ type(c_ptr), value::ssl
+ character(kind=c_char), dimension(*), intent(inout)::buf
+ integer(kind=c_int), value::length
+ integer(kind=c_int)::read_c
+ end function read_c
+
+ function write_c(ssl, buf, length) bind(c, name="SSL_write")
+ use iso_c_binding
+ type(c_ptr), value::ssl
+ character(kind=c_char), dimension(*), intent(inout)::buf
+ integer(kind=c_int), value::length
+ integer(kind=c_int)::write_c
+ end function write_c
+
+ function get_error(ssl, retcode) bind(c, name="SSL_get_error")
+ use iso_c_binding
+ type(c_ptr), value::ssl
+ integer(kind=c_int), value::retcode
+ integer(kind=c_int)::get_error
+ end function get_error
+
+ function ssl_pending(ssl) bind(c, name="SSL_pending")
+ use iso_c_binding
+ type(c_ptr), value::ssl
+ integer(kind=c_int)::ssl_pending
+ end function ssl_pending
+
+ end interface
+
+contains
+
+ function ssl_read(ssl, buf)
+ use iso_c_binding
+ implicit none
+
+ type(c_ptr)::ssl
+ character, dimension(:), intent(inout)::buf
+ integer::ssl_read
+ integer::bufsize
+
+ character(kind=c_char), dimension(:), allocatable::cbuf
+ bufsize = size(buf)
+ allocate(cbuf(bufsize))
+
+ ssl_read = read_c(ssl, cbuf, bufsize)
+ buf = cbuf
+
+ deallocate(cbuf)
+
+ end function ssl_read
+
+ function ssl_write(ssl, buf)
+ use iso_c_binding
+ implicit none
+
+ type(c_ptr)::ssl
+ character, dimension(:), intent(in)::buf
+ integer::ssl_write
+
+ character(kind=c_char), dimension(:), allocatable::cbuf
+
+ allocate(cbuf(size(buf)))
+
+ cbuf = buf
+ ssl_write = write_c(ssl, cbuf, size(buf))
+
+ deallocate(cbuf)
+
+ end function ssl_write
+
+ subroutine get_cipher(ssl, res)
+ use iso_c_binding
+ implicit none
+
+ character(:), allocatable, intent(out)::res
+ type(c_ptr)::ssl
+
+ type(c_ptr)::cptr
+
+ character(kind=c_char), dimension(:), pointer::cstring
+
+ integer::i
+
+ cptr = c_null_ptr
+ if(.not. c_associated(cptr)) then
+
+ allocate(character(len=1)::res)
+ res = " "
+
+ else
+
+ call c_f_pointer(cptr, cstring, [1])
+
+ i = 1
+ do while(cstring(i) /= c_null_char)
+ i = i + 1
+ end do
+ allocate(character(len=(i-1))::res)
+
+ i = 1
+ do while(cstring(i) /= c_null_char)
+ res(i:i) = cstring(i)
+ end do
+
+ end if
+
+ end subroutine get_cipher
+
+ function set_tlsext_host_name(ctx, hostname)
+ use iso_c_binding
+ implicit none
+
+ type(c_ptr)::ctx
+ character(*), intent(in)::hostname
+ integer::set_tlsext_host_name
+
+ character(kind=c_char), dimension(:), allocatable, target::chostname
+
+ integer::i
+
+ allocate(chostname(len_trim(hostname)+1))
+
+ do i = 1, len_trim(hostname)
+ chostname(i) = hostname(i:i)
+ end do
+ chostname(len_trim(hostname)+1) = c_null_char
+
+ set_tlsext_host_name = ssl_ctrl_c(ctx, &
+ SSL_CTRL_SET_TLSEXT_HOSTNAME, &
+ TLSEXT_NAMETYPE_host_name, &
+ c_loc(chostname))
+
+ deallocate(chostname)
+
+ end function set_tlsext_host_name
+
+ function ctx_use_certificate_file(ctx, filename, certtype)
+ use iso_c_binding
+ implicit none
+
+ type(c_ptr)::ctx
+ character(*), intent(in)::filename
+ integer::certtype
+ logical::ctx_use_certificate_file
+
+ character(kind=c_char), dimension(:), allocatable, target::cfilename
+
+ integer::i
+
+ allocate(cfilename(len_trim(filename)+1))
+ do i = 1, len_trim(filename)
+ cfilename(i) = filename(i:i)
+ end do
+ cfilename(len_trim(filename)+1) = c_null_char
+ i = ctx_use_certificate_file_c(ctx, cfilename, int(certtype, kind=c_int))
+ ctx_use_certificate_file = (i == 1)
+
+ deallocate(cfilename)
+
+ end function ctx_use_certificate_file
+
+ function ctx_use_private_key_file(ctx, filename, certtype)
+ use iso_c_binding
+ implicit none
+
+ type(c_ptr)::ctx
+ character(*), intent(in)::filename
+ integer::certtype
+ logical::ctx_use_private_key_file
+
+ character(kind=c_char), dimension(:), allocatable, target::cfilename
+
+ integer::i
+
+ allocate(cfilename(len_trim(filename)+1))
+ do i = 1, len_trim(filename)
+ cfilename(i) = filename(i:i)
+ end do
+ cfilename(len_trim(filename)+1) = c_null_char
+
+ i = ctx_use_private_key_file_c(ctx, cfilename, int(certtype, kind=c_int))
+ ctx_use_private_key_file = (i == 1)
+
+ deallocate(cfilename)
+
+ end function ctx_use_private_key_file
+
+ subroutine library_init()
+ use iso_c_binding
+ implicit none
+
+ integer(kind=c_int64_t)::flags
+ integer::res
+
+ flags = 0
+ res = init_ssl_c(flags, c_null_ptr)
+
+ end subroutine library_init
+
+end module jessl
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
diff --git a/common/protocol.f90 b/common/protocol.f90
new file mode 100644
index 0000000..be6f280
--- /dev/null
+++ b/common/protocol.f90
@@ -0,0 +1,474 @@
+! 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 gemini_protocol
+implicit none
+
+ integer, parameter::STATUS_INPUT = 1
+ integer, parameter::STATUS_SUCCESS = 2
+ integer, parameter::STATUS_REDIRECT = 3
+ integer, parameter::STATUS_TEMPFAIL = 4
+ integer, parameter::STATUS_PERMFAIL = 5
+ integer, parameter::STATUS_CERTREQ = 6
+ integer, parameter::STATUS_BADRESPONSE = 7
+ integer, parameter::STATUS_LOCALFAIL = -1
+ integer, parameter::STATUS_CONNECTFAIL = -2
+ integer, parameter::STATUS_PROTOCOLFAIL = -3
+
+ integer, parameter::BUFFER_SIZE = 256
+
+ integer, parameter::gemini_default_port = 1965
+
+contains
+
+ function is_failure_code(return_code)
+ implicit none
+
+ integer, intent(in)::return_code
+ logical::is_failure_code
+
+ is_failure_code = any(return_code == &
+ [STATUS_CONNECTFAIL, &
+ STATUS_LOCALFAIL, &
+ STATUS_BADRESPONSE, &
+ STATUS_PERMFAIL, &
+ STATUS_TEMPFAIL, &
+ STATUS_PROTOCOLFAIL])
+
+ end function is_failure_code
+
+ subroutine get_mimetype(status_line, return_type)
+ implicit none
+
+ character(*), intent(in)::status_line
+ character(*), intent(out)::return_type
+
+ integer::i, j
+
+ return_type = " "
+
+ ! Advance past status and space
+ i = 1
+ do while(status_line(i:i) /= " " .and. status_line(i:i) /= char(9) .and. i < len_trim(status_line))
+ i = i + 1
+ end do
+ do while((status_line(i:i) == " " .or. status_line(i:i) == char(9)) .and. i < len_trim(status_line))
+ i = i + 1
+ end do
+
+ j = 0
+ do while(.not. any([char(13), char(10)] == status_line(i:i)))
+ j = j + 1
+ return_type(j:j) = status_line(i:i)
+ i = i + 1
+ end do
+
+ ! Default
+ if(len_trim(return_type) == 0) then
+ return_type = "text/gemini"
+ end if
+
+ end subroutine get_mimetype
+
+ function get_return_code(status_line) result(ret)
+ implicit none
+
+ integer::ret
+ character(*), intent(in)::status_line
+ integer::istatus
+
+ read(status_line, '(i1)', iostat=istatus) ret
+
+ if(istatus /= 0) then
+ ret = STATUS_BADRESPONSE
+ end if
+
+ end function get_return_code
+
+ function request_url(url, unit_number, return_type) result(returncode)
+ use request
+ use iso_c_binding
+ implicit none
+
+ character(*), intent(inout)::url
+ integer, intent(in)::unit_number
+ character(*), intent(out)::return_type
+ integer::port
+
+ integer::returncode
+
+ character(:), allocatable::server
+
+ type(connection)::conn
+
+ integer::bytes_received, i
+ character, dimension(BUFFER_SIZE)::buffer
+
+ ! For direct processing of the reponse line
+ integer::response_line_index
+ character(1024)::response_line
+ logical::response_line_completed
+
+ returncode = -1
+ rewind(unit_number)
+
+
+ allocate(character(len=len_trim(url)) :: server)
+ call get_server_from_url(url, server, port)
+ if(port < 0) then
+ port = gemini_default_port
+ end if
+
+ ! Correct URL relative paths
+ call fix_url_relative_paths(url)
+
+ conn = open_connection(server)
+
+ if(conn%code == CONNECTION_OPEN) then
+ if(send_string(conn%ssl, trim(url)//c_carriage_return//c_new_line, trimming=.false.)) then
+
+ response_line_completed = .false.
+ response_line = " "
+ response_line_index = 0
+
+ bytes_received = retrieve_characters(conn%ssl, buffer)
+ do while(bytes_received > 0)
+
+ do i=1, bytes_received
+
+ if(.not. response_line_completed) then
+ response_line_index = response_line_index + 1
+ response_line(response_line_index:response_line_index) = buffer(i)
+
+ ! If we encountered our first newline, we have a complete status
+ ! line - handle it here
+ if(buffer(i) == char(10) .or. response_line_index == 1024) then
+ response_line_completed = .true.
+
+ returncode = get_return_code(response_line)
+
+ if(returncode == STATUS_SUCCESS) then
+
+ call get_mimetype(response_line, return_type)
+
+ else
+
+ exit
+
+ end if
+
+ end if
+
+ else
+
+ write(unit_number) buffer(i)
+
+ end if
+
+ end do
+
+ bytes_received = retrieve_characters(conn%ssl, buffer)
+ end do
+
+ else
+
+ returncode = STATUS_CONNECTFAIL
+
+ end if
+
+ else
+
+ returncode = STATUS_CONNECTFAIL
+
+ end if
+
+ call close_connection(conn)
+
+ end function request_url
+
+ function titan_post_url(url, unit_number, file_length, token, is_plain_text) result(returncode)
+ use request
+ use iso_c_binding
+ use utilities, only: read_into_buffer
+ use jessl, only: ssl_write
+ implicit none
+
+ character(*), intent(inout)::url
+ character(*), intent(in)::token
+ integer, intent(in)::unit_number
+ logical, intent(in), optional::is_plain_text
+ integer::port
+
+ integer::returncode
+
+ integer(kind=8), intent(in)::file_length
+
+ character(:), allocatable::server
+ character(len=16)::file_length_text
+
+ type(connection)::conn
+
+ character, dimension(BUFFER_SIZE)::buffer
+ logical, dimension(4)::successes
+ integer::i, ierr, bytes_read, bytes_written, total_written
+
+ returncode = -1
+ rewind(unit_number)
+
+ allocate(character(len=len_trim(url)) :: server)
+ call get_server_from_url(url, server, port)
+ if(port < 0) then
+ port = gemini_default_port
+ end if
+
+ ! Correct URL relative paths
+ call fix_url_relative_paths(url)
+
+ conn = open_connection(server)
+
+ if(conn%code == CONNECTION_OPEN) then
+
+ successes(1) = send_string(conn%ssl, trim(url), trimming=.false.)
+ successes(2) = send_string(conn%ssl, ";token="//trim(token), trimming=.false.)
+
+ if(present(is_plain_text)) then
+ if(is_plain_text) then
+ successes(3) = send_string(conn%ssl, ";mime=text/plain", trimming=.false.)
+ else
+ successes(3) = send_string(conn%ssl, ";mime=application/octet-stream", trimming=.false.)
+ end if
+ else
+ successes(3) = send_string(conn%ssl, ";mime=application/octet-stream", trimming=.false.)
+ end if
+
+ write(file_length_text, *) file_length
+ file_length_text = adjustl(file_length_text)
+ successes(4) = send_string(conn%ssl, ";size="//trim(file_length_text)//c_carriage_return//c_new_line, trimming=.false.)
+
+ if(all(successes, 1)) then
+
+ total_written = 0
+ bytes_read = read_into_buffer(unit_number, buffer)
+ do while(bytes_read > 0)
+ bytes_written = ssl_write(conn%ssl, buffer)
+ total_written = total_written + bytes_written
+ bytes_read = read_into_buffer(unit_number, buffer)
+ end do
+
+ if(total_written >= file_length) then
+ returncode = STATUS_SUCCESS
+ else
+ returncode = STATUS_LOCALFAIL
+ end if
+
+ else
+
+ returncode = STATUS_CONNECTFAIL
+
+ end if
+
+ else
+
+ returncode = STATUS_CONNECTFAIL
+
+ end if
+
+ call close_connection(conn)
+
+ end function titan_post_url
+
+ subroutine get_redirect_url(unit_number, url)
+ implicit none
+
+ integer, intent(in)::unit_number
+ character(*), intent(inout)::url
+
+ character(1024)::new_url
+ character::search
+ integer::i, istat
+
+ rewind(unit_number)
+
+ ! Status code
+ read(unit_number, '(A1)', advance='no') search
+ read(unit_number, '(A1)', advance='no') search
+
+ new_url = " "
+
+ ! At least one whitespace, but whatever...
+ read(unit_number, '(A1)', advance='no') search
+ do while(search == " " .or. search == CHAR(9))
+ read(unit_number, '(A1)', advance='no', iostat=istat) search
+ end do
+
+ ! Now search contains our first url component
+ i = 0
+ do while(search /= CHAR(13) .and. i < len(url) .and. istat == 0)
+ i = i + 1
+ new_url(i:i) = search
+ read(unit_number, '(A1)', advance='no', iostat=istat) search
+ end do
+
+ ! Process this url properly
+ if(index(new_url, "://") > 0) then
+ url = new_url
+ else
+ call handle_relative_url(url, new_url)
+ end if
+
+ end subroutine get_redirect_url
+
+ subroutine handle_relative_url(current_url, path)
+ implicit none
+
+ character(*), intent(inout)::current_url
+ character(*), intent(in)::path
+
+ integer::past_protocol, first_slash, last_slash
+
+ ! For debugging
+ ! Print *, "*** Requested path is '"//trim(path)//"'"
+
+ past_protocol = index(current_url, "://")
+
+ if(path(1:2) == "//") then
+ current_url = "gemini:"//path
+
+ else if(past_protocol > 0) then
+
+ past_protocol = past_protocol + 3
+
+ if(path(1:1) == "/") then
+
+ first_slash = index(current_url(past_protocol:len_trim(current_url)), "/")
+ if(first_slash < 1) then
+ current_url = trim(current_url)//trim(path)
+ else
+ current_url = current_url(1:(past_protocol + first_slash - 1))//path(2:len_trim(path))
+ end if
+
+ else
+
+ last_slash = index(current_url, "/", back=.true.)
+ if(last_slash > 0) then
+ current_url = current_url(1:last_slash)//path
+ end if
+
+ end if
+
+ end if
+
+ end subroutine handle_relative_url
+
+ subroutine replace_text(string, pattern, replacement, once)
+ implicit none
+
+ character(*), intent(inout)::string
+ character(*), intent(in)::pattern
+ character(*), intent(in), optional::replacement
+ logical, intent(in), optional::once
+
+ integer::i,j
+
+ ! Print *, "*** Replacement: string='"//trim(string)//"' Pattern='"//pattern//"'"
+
+ i = index(string, pattern)
+ do while(i > 0)
+ j = i + len(pattern) ! First character after match
+
+ ! First
+ if(i == 1) then
+ if(present(replacement)) then
+ string = replacement//string(j:len_trim(string))
+ else
+ string = string(j:len_trim(string))
+ end if
+
+ ! Last
+ elseif(j > len_trim(string)) then
+ if(present(replacement)) then
+ string = string(1:i-1)//replacement
+ else
+ string = string(1:i-1)
+ end if
+
+ ! Middle
+ else
+ if(present(replacement)) then
+ string = string(1:i-1)//replacement//string(j:len_trim(string))
+ else
+ string = string(1:i-1)//string(j:len_trim(string))
+ end if
+ end if
+
+ ! All on the same line crashes GNU Fortran...
+ if(present(once)) then
+ if(once) then
+ exit
+ end if
+ end if
+
+ i = index(string, pattern)
+ end do
+
+ end subroutine replace_text
+
+ subroutine fix_url_relative_paths(url)
+ implicit none
+
+ character(*), intent(inout)::url
+ integer::i, pattern_start
+
+ ! These shouldn't be there
+ i = index(url, '/./')
+ if(i > 0) then
+ call replace_text(url, '/./', replacement="/")
+ end if
+
+ ! Remove ..
+ i = index(url, '/../')
+ do while(i > 0)
+
+ ! Need to build the pattern
+ pattern_start = i - 1
+ do while(url(pattern_start:pattern_start) /= "/" .and. pattern_start > 1)
+ pattern_start = pattern_start - 1
+ end do
+
+ if(pattern_start == 1) then
+ ! Error state - just exit
+ exit
+ end if
+
+ ! Check for root...
+ if(url(pattern_start-1:pattern_start) == "//") then
+ call replace_text(url, "/../", replacement="/", once=.true.)
+ else
+ call replace_text(url, url(pattern_start:i+2), once=.true.)
+ end if
+
+ i = index(url, '/../')
+ end do
+
+ end subroutine fix_url_relative_paths
+
+end module gemini_protocol \ No newline at end of file
diff --git a/common/request.f90 b/common/request.f90
new file mode 100644
index 0000000..e9043c0
--- /dev/null
+++ b/common/request.f90
@@ -0,0 +1,294 @@
+! 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 request
+use network
+use iso_c_binding
+implicit none
+
+ integer, parameter::bufsize = 65536
+
+ integer, parameter::CONNECTION_NONE = 0
+ integer, parameter::CONNECTION_CLOSED = 1
+ integer, parameter::CONNECTION_SERVER_NOT_FOUND = 2
+ integer, parameter::CONNECTION_SOCKET_FAILURE = 3
+ integer, parameter::CONNECTION_SSL_SETUP_FAILURE = 4
+ integer, parameter::CONNECTION_SSL_CONN_FAILURE = 5
+ integer, parameter::CONNECTION_OPEN = 6
+
+ character(23), dimension(0:6), parameter:: connection_code_str = &
+ ["No Connection ", &
+ "Connection Closed ", &
+ "Server Not Found ", &
+ "Local Socket Failure ", &
+ "SSL Configuration Error", &
+ "SSL Connection Failure ", &
+ "SSL Connection Open " ]
+
+
+ type :: connection
+
+ integer::code
+
+ type(simple_hostent)::host
+ integer::socket
+ type(c_ptr)::ssl_ctx
+ type(c_ptr)::ssl
+
+ end type connection
+
+contains
+
+ function translate_connection_code(code)
+ implicit none
+
+ integer, intent(in)::code
+ character(23)::translate_connection_code
+
+ if(code >= lbound(connection_code_str, 1) .and. &
+ code <= ubound(connection_code_str, 1)) then
+
+ translate_connection_code = connection_code_str(code)
+
+ else
+
+ translate_connection_code = "Unknown Error"
+
+ end if
+
+ end function translate_connection_code
+
+ function open_connection(server, port) result(conn)
+ use jessl
+ use network
+ implicit none
+
+ character(*), intent(in)::server
+ integer, intent(in), optional::port
+ type(connection)::conn
+
+ type(sockaddr_in), target::sa
+ type(c_ptr)::ssl_method
+
+ conn%code = CONNECTION_NONE
+
+ ! Lookup host
+ conn%host = gethostbyname(server)
+ if((.not. allocated(conn%host%h_name)) .or. (conn%host%h_addr4 == 0)) then
+ conn%code = CONNECTION_SERVER_NOT_FOUND
+ return
+ end if
+
+ ! Build the socket
+ sa%sin_family = AF_INET
+ sa%sin_addr%s_addr = conn%host%h_addr4
+ if(present(port)) then
+ sa%sin_port = htons(port)
+ else
+ sa%sin_port = htons(1965)
+ end if
+ conn%socket = socket(AF_INET, SOCK_STREAM, 0)
+ if(.not. connect(conn%socket, sa)) then
+ conn%code = CONNECTION_SOCKET_FAILURE
+ return
+ end if
+
+ ! Set up ssl now
+ ssl_method = tls_client_method()
+ conn%ssl_ctx = ctx_new(ssl_method)
+
+ conn%ssl = ssl_new(conn%ssl_ctx)
+ if((.not. c_associated(conn%ssl)) .or. &
+ (set_tlsext_host_name(conn%ssl, server) == 0) .OR. &
+ (set_fd(conn%ssl, conn%socket) /= 1)) then
+
+ conn%code = CONNECTION_SSL_SETUP_FAILURE
+ return
+
+ end if
+
+ ! Connect via ssl
+ if(ssl_connect(conn%ssl) /= 1) then
+ conn%code = CONNECTION_SSL_CONN_FAILURE
+ return
+ end if
+
+ ! Here, the connection is live
+ conn%code = CONNECTION_OPEN
+
+ end function open_connection
+
+ subroutine close_connection(conn)
+ use jessl
+ use network
+ implicit none
+
+ type(connection), intent(inout)::conn
+ integer::res
+
+ if(conn%code >= CONNECTION_OPEN) then
+ res = ssl_shutdown(conn%ssl)
+ end if
+
+ if(conn%code >= CONNECTION_SSL_CONN_FAILURE) then
+ res = ssl_free(conn%ssl)
+ end if
+
+ if(conn%code >= CONNECTION_SSL_SETUP_FAILURE) then
+ res = ctx_free(conn%ssl_ctx)
+ end if
+
+ if(conn%code > CONNECTION_SOCKET_FAILURE) then
+ call close_socket(conn%socket)
+ end if
+
+ if(conn%code > CONNECTION_SERVER_NOT_FOUND) then
+ deallocate(conn%host%h_name)
+ end if
+
+ conn%code = CONNECTION_CLOSED
+
+ end subroutine close_connection
+
+ subroutine get_server_from_url(url, server, port)
+ implicit none
+
+ character(*), intent(in)::url
+ character(*), intent(out)::server
+ integer, intent(out), optional::port
+
+ integer::start_server, end_server, length
+ integer::start_port, iostatus
+ integer::myport
+
+ myport = -1
+
+ start_server = index(url, "://")
+ if(start_server > 0) then
+
+ start_server = start_server + 3
+ end_server = index(url(start_server:len_trim(url)), "/")
+ if(end_server <= 0) then
+ end_server = len_trim(url)
+ else
+ ! Get rid of trailing slash
+ end_server = end_server + start_server - 2
+ end if
+ length = end_server - start_server + 1
+
+ server = url(start_server:end_server)
+
+ end if
+
+ ! Need to check if a port was specified too
+ start_port = index(server, ":")
+ if(start_port > 0) then
+
+ read(server(start_port+1:len_trim(server)), *, iostat=iostatus) myport
+ if(iostatus /= 0) then
+ myport = -1
+ end if
+
+ server = server(1:start_port-1)
+
+ end if
+
+ if(present(port)) then
+ port = myport
+ end if
+
+ end subroutine get_server_from_url
+
+ function send_string(ssl, str, trimming) result(success)
+ use iso_c_binding
+ use jessl
+ implicit none
+
+ logical::success
+ type(c_ptr)::ssl
+ character(*), intent(in)::str
+ logical, intent(in), optional::trimming
+
+ integer::start_send
+ integer::chars_sent_this_time, chars_sending
+ integer::i, bytes
+ integer::string_length
+
+ character, dimension(bufsize)::buffer
+
+ if(present(trimming)) then
+ if(trimming) then
+ string_length = len_trim(str)
+ else
+ string_length = len(str)
+ end if
+ else
+ string_length = len_trim(str)
+ end if
+
+ success = .true.
+ start_send = 1
+ do while(start_send <= string_length)
+
+ chars_sending = 0
+ do i = start_send, string_length
+ buffer(i-start_send+1) = str(i:i)
+ chars_sending = chars_sending + 1
+ if(chars_sending == bufsize) then
+ exit
+ end if
+ end do
+
+ ! A null character seems necessary at the end of the request
+ if(i >= string_length) then
+ chars_sending = chars_sending + 1
+ buffer(chars_sending) = c_null_char
+ end if
+
+ ! Minus 1 because we're sending start_send as well
+ chars_sent_this_time = ssl_write(ssl, buffer(start_send:(start_send+chars_sending-1)))
+
+ if(chars_sent_this_time < 0) then
+ success = .false.
+ exit
+ end if
+
+ start_send = start_send + chars_sent_this_time
+
+ end do
+
+ end function send_string
+
+ function retrieve_characters(ssl, arr) result(chars_read)
+ use iso_c_binding
+ use jessl
+ implicit none
+
+ integer::chars_read
+ type(c_ptr)::ssl
+ character(len=1), dimension(:), intent(inout)::arr
+
+ chars_read = ssl_read(ssl, arr)
+
+ end function retrieve_characters
+
+end module request
diff --git a/common/wsa.f90 b/common/wsa.f90
new file mode 100644
index 0000000..080da11
--- /dev/null
+++ b/common/wsa.f90
@@ -0,0 +1,68 @@
+! 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 wsa_network
+use iso_c_binding
+implicit none
+
+ integer, parameter::wsa_description_length_plus_1 = 256
+
+ type, bind(c) :: wsadata
+ integer(kind=c_int16_t)::wVersion
+ integer(kind=c_int16_t)::wHighVersion
+ integer(kind=c_short)::iMaxSockets
+ integer(kind=c_short)::iMaxUdpDg
+
+ type(c_ptr)::lpVendorInfo
+ character(len=1, kind=c_char), dimension(wsa_description_length_plus_1)::szDescription
+ character(len=1, kind=c_char), dimension(wsa_description_length_plus_1)::szSystemStatus
+ end type
+
+contains
+
+ subroutine startup()
+ use iso_c_binding
+ implicit none
+
+ interface
+ function wsa_startup(v, p) bind(c, name="WSAStartup")
+ use iso_c_binding
+ integer(kind=c_int16_t), value::v
+ type(c_ptr), value::p
+ integer(kind=c_int)::wsa_startup
+ end function wsa_startup
+ end interface
+
+ type(wsadata), target::startup_data
+ integer::res
+
+ ! need to use wVersionRequested = MAKEWORD(2, 2);
+
+
+ res = wsa_startup(int(z'0202', kind=c_int16_t), c_loc(startup_data))
+ if(res /= 0) then
+ Print *, "Windows Networking failed to start"
+ Print *, "Error=", res
+ stop
+ end if
+ end subroutine startup
+end module wsa_network