Initial code commit, and it actually works

1 files changed, 358 insertions, 0 deletions

diff --git a/jessl.f90 b/jessl.f90
new file mode 100644
index 0000000..5c1a174
--- /dev/null
+++ b/jessl.f90
@@ -0,0 +1,358 @@
+! 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 
+    
+        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 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
+
+end module jessl