! 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 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_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) implicit none character(*), intent(in)::url character(:), allocatable, intent(out)::server integer::start_server, end_server, length 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 allocate(character(len=length) :: server) server = url(start_server:end_server) 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