path: root/common/jessl.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.

! 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

    ! The timeout is specified in milliseconds, fyi
    function ssl_read(ssl, buf, timeout)
    use iso_c_binding
    use utilities, only: sleep_ms
    implicit none
    
        type(c_ptr)::ssl
        character(len=1), dimension(:), intent(out)::buf
        integer, intent(in), optional::timeout
        integer::ssl_read
        integer::bufsize
        
        integer(kind=8)::start_time, current_time, count_rate, dt
        
        character(kind=c_char), dimension(:), allocatable::cbuf
        bufsize = size(buf)
        allocate(cbuf(bufsize))
        
        if(present(timeout)) then
        
            call system_clock(start_time, count_rate=count_rate)
            current_time = start_time
            
            dt = 0
            
            do while(ssl_pending(ssl) <= 0 .and. dt < timeout .and. dt >= 0)
                call sleep_ms(timeout / 10)
                call system_clock(current_time)
                dt = ((current_time - start_time)*1000)/count_rate
            end do
        
        end if
        
        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