! 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. ! Just Enough SSL... module jessl implicit none interface subroutine library_init() bind(c, name="OPENSSL_init_ssl") end subroutine library_init 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 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 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 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_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 ! 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, 1) 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 cbuf(size(buf)) = c_null_char 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 end module jessl