Initial code commit, and it actually works

1 files changed, 551 insertions, 0 deletions

diff --git a/main.f90 b/main.f90
new file mode 100644
index 0000000..0a21e5a
--- /dev/null
+++ b/main.f90
@@ -0,0 +1,551 @@
+! 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.
+
+program gnc
+use jessl
+use iso_c_binding
+use iso_fortran_env
+implicit none
+
+    ! For our TLS connection
+    type(c_ptr)::ctx
+    type(c_ptr)::method
+    type(c_ptr)::ssl
+    integer(kind=c_long)::res
+    
+    ! Cert stuff
+    character(512)::cert_public, cert_private
+    
+    ! Requested file
+    character(1024)::request
+    character(512)::mimetype
+    integer::request_unit
+    
+    ! Argument handling
+    integer::i
+    character(512)::arg
+    
+    ! Logfile
+    integer, parameter::logunit = 1097
+    character(512)::logfile
+    
+    ! root serving dir
+    character(512), target::rootdir
+
+    logfile = "/tmp/gnc.log"
+    rootdir = " "
+    
+    if(command_argument_count() < 4) then
+        call usage()
+        close(logunit)
+        stop
+    end if
+    
+    i = 1
+    do while(i < command_argument_count())
+        call get_command_argument(i, arg)
+        if(trim(arg) == "-pub") then
+            i = i + 1
+            call get_command_argument(i, cert_public)
+        else if(trim(arg) == "-priv") then
+            i = i + 1
+            call get_command_argument(i, cert_private)
+        else if(trim(arg) == "-l") then
+            i = i + 1
+            call get_command_argument(i, logfile)
+        else if(trim(arg) == "-root") then
+            i = i + 1
+            call get_command_argument(i, rootdir)
+        end if
+        i = i + 1
+    end do
+   
+    open(unit=logunit, file=trim(logfile), action="write", status="unknown", position="append")
+   
+    call write_log("Initiating program")
+   
+    call random_seed()
+    
+    call library_init()
+    method = tls_server_method()
+    ctx = ctx_new(method)
+    
+    if(.not. C_ASSOCIATED(ctx)) then
+        call write_log("Context failed")
+        close(logunit)
+        stop
+    end if
+    
+    ! Seems to be a dummy now...
+    !res = ctx_set_ecdh_auto(ctx, 1)
+    
+    if(.not. ctx_use_certificate_file(ctx, trim(cert_public), SSL_FILETYPE_PEM)) then
+        call write_log("Cert file failed")
+        call write_log("Public: "//trim(cert_public))
+        !call print_error()
+        close(logunit)
+        stop
+    end if
+    
+    if(.not. ctx_use_private_key_file(ctx, trim(cert_private), SSL_FILETYPE_PEM)) then
+        call write_log("Cert file failed")
+        call write_log("Private: "//trim(cert_private))
+        !call print_error()
+        close(logunit)
+        stop
+    end if
+    
+    ssl = ssl_new(ctx)
+
+    call write_log("Initiating connection")
+
+    ! So this is a GNU Extension...
+    res = set_read_fd(ssl, fnum(input_unit))
+    if(res /= 1) then
+        call write_log("set rfd failed")
+        !call print_error()
+        close(logunit)
+        stop
+    end if
+    
+    res = set_write_fd(ssl, fnum(output_unit))
+    if(res /= 1) then
+        call write_log("set wfd failed")
+        !call print_error()
+        close(logunit)
+        stop
+    end if
+    
+    res = ssl_accept(ssl)
+    if(res <= 0) then
+        call write_log("ssl_accept failed")
+        !call print_error()
+        close(logunit)
+        stop
+    end if
+
+    call write_log("Handling read_request")
+
+    ! Do the actual protocol nonsense
+    call read_request(ssl, request)
+    
+    call write_log("Request is "//trim(request))
+    
+    ! If it ends in a slash, let's manually and silently add "index.gmi"
+    if(request(len_trim(request):len_trim(request)) == "/") then
+        request = trim(request)//"index.gmi"
+    end if
+    
+    res = process_request(trim(request), trim(rootdir), request_unit, mimetype)
+    
+    call write_log("Request processed")
+    
+    select case(res)
+    
+        case(2) ! Success
+            call write_log("Delivering")
+            call write_file(ssl, request_unit, mimetype)
+            close(request_unit)
+            
+        case(3) ! Redirect
+            call write_log("Redirecting")
+            call write_redirect(ssl, request)
+            
+        case(5) ! Not Found
+            call write_log("Notfound")
+            call write_notfound(ssl)
+            
+    end select
+    
+    call write_log("Shutdown")
+    
+    res = ssl_shutdown(ssl)
+    res = ssl_free(ssl)
+    res = ctx_free(ctx)
+    
+    close(logunit)
+    
+contains
+
+    subroutine write_string(ssl, string)
+    use jessl, only: ssl_write
+    use iso_c_binding, only: c_ptr
+    implicit none
+    
+        type(c_ptr)::ssl
+        character(*)::string
+        character, dimension(:), allocatable::buf
+        integer::i
+        
+        allocate(buf(len(string)))
+        
+        do i = 1, len(string)
+            buf(i) = string(i:i)
+        end do
+        
+        i = ssl_write(ssl, buf)
+        
+        deallocate(buf)
+    
+    end subroutine write_string
+
+    subroutine write_notfound(ssl)
+    use iso_c_binding, only: c_ptr, c_carriage_return, c_new_line
+    implicit none
+
+        type(c_ptr)::ssl
+        character(*), parameter::notfound_response = "50 Not Found"
+
+        call write_string(ssl, notfound_response//c_carriage_return//c_new_line)
+
+    end subroutine write_notfound
+
+    function read_into_buffer(unit_number, buffer)
+    implicit none
+    
+        integer, intent(in)::unit_number
+        character, dimension(*), intent(out)::buffer
+        integer::read_into_buffer
+        
+        integer::i, ierr
+        
+        ierr = 0
+        i = 0
+        do while(ierr == 0 .and. i < len(buffer))
+            i = i + 1
+            read(unit_number, iostat=ierr) buffer(i)
+        end do
+            
+        if(ierr /= 0) then
+            i = i - 1
+        end if
+        
+        read_into_buffer = i
+    
+    end function read_into_buffer
+
+    subroutine write_file(ssl, unit_number, mimetype)
+    use iso_c_binding, only: c_ptr, c_carriage_return, c_new_line
+    use jessl, only: ssl_write
+    implicit none
+    
+        type(c_ptr)::ssl
+        integer, intent(in)::unit_number
+        character(*), intent(in)::mimetype
+        character, dimension(64)::buf
+        integer::buflen, written
+        
+        call write_string(ssl, "20 "//trim(mimetype)//c_carriage_return//c_new_line)
+        
+        buflen = read_into_buffer(unit_number, buf)
+        do while(buflen > 0)
+            written = ssl_write(ssl, buf(1:buflen))
+            buflen = read_into_buffer(unit_number, buf)
+        end do
+            
+    end subroutine write_file
+
+    subroutine write_redirect(ssl, req)
+    use iso_c_binding, only: c_ptr, c_carriage_return, c_new_line
+    implicit none
+    
+        type(c_ptr)::ssl
+        character(*), intent(in)::req
+        integer::i
+        
+        character(*), parameter::index_file = "index.gmi"
+        
+        i = len_trim(req)
+        if(req(i:i) == '/') then
+            call write_string(ssl, "30 "//trim(req)//index_file//c_carriage_return//c_new_line)
+        else
+            call write_string(ssl, "30 "//trim(req)//"/"//index_file//c_carriage_return//c_new_line)
+        end if
+    
+    end subroutine write_redirect
+
+    function requires_redirect(req)
+    implicit none
+    
+        character(*), intent(in)::req
+        logical::requires_redirect
+    
+        integer::i
+        
+        requires_redirect = .false.
+        
+        i = len_trim(req)
+        if(req(i:i) == '/') then
+            requires_redirect = .true.
+        else
+            ! The root url without any further slashes also requires redirect
+            i = index(req, "://")
+            if(i > 0) then
+                requires_redirect = (index(req(i+3:len_trim(req)), "/") <= 0)
+            end if
+        end if
+    
+    end function requires_redirect
+
+    subroutine determine_mimetype(filename, mimetype)
+    implicit none
+    
+        character(*), intent(in)::filename
+        character(*), intent(out)::mimetype
+    
+    
+        character(256)::tmpfile
+        character(1024)::cmdline
+        character, dimension(5)::rand_string
+        real, dimension(5)::rand_values
+    
+        integer::i, readback_unit
+        
+        i = index(filename, ".gmi")
+        if(i == (len_trim(filename)-3)) then
+        
+            mimetype = "text/gemini"
+            
+        else
+        
+            call random_number(rand_values)
+            rand_string = char(ichar('A') + int(25*rand_values))
+            tmpfile = "/tmp/gemini_"
+            do i = 1, 5
+                tmpfile = trim(tmpfile)//rand_string(i)
+            end do
+            
+            cmdline = "file -b --mime-type "//trim(filename)//" > "//trim(tmpfile)
+            call write_log("Executing: "//trim(cmdline))
+            call execute_command_line(cmdline, wait=.true.)
+            
+            open(newunit=readback_unit, file=tmpfile, action="read", status="old")
+            read(readback_unit, *) mimetype
+            close(readback_unit)
+            
+            ! I saw this happen once...
+            if(trim(mimetype) == "text") then
+                mimetype = "text/plain"
+            end if
+            
+            ! GNU Extenstion... :(
+            call unlink(tmpfile)
+            
+        end if
+    
+    end subroutine determine_mimetype
+
+    function process_request(request, rootdir, request_unit, mimetype) result(status_code)
+    implicit none
+    
+        character(*), intent(in)::request
+        character(*), intent(in)::rootdir
+        integer, intent(out)::request_unit
+        character(*), intent(out)::mimetype
+        integer::status_code
+    
+        character(1024)::filename
+        integer::i, j, ioerror
+    
+        if(requires_redirect(request)) then
+        
+            status_code = 3
+        
+        else
+        
+            ! Get the file of interest
+            i = index(request, "://")
+            if(i <= 0) then
+                filename = request
+            else
+                j = index(request(i+3:len_trim(request)), "/")
+                filename = request((i+j+2):len_trim(request))
+            end if
+            
+            if(len_trim(rootdir) > 0) then
+            
+                filename = rootdir//"/"//trim(filename)
+                call write_log("Canonicalize: "//trim(filename))
+                
+                ! Here we'll get rid of any dots or whatever and 
+                if(.not. canonicalize_path(filename) .or. index(filename, rootdir) /= 1) then
+                    call write_log("File outside root requested: "//trim(filename))
+                    status_code = 5
+                    return
+                end if
+                
+            end if
+    
+            call write_log("Opening: "//trim(filename))
+            
+            ! First, check if exists by opening
+            open(newunit=request_unit, file=trim(filename), status="old", &
+                form="unformatted", iostat=ioerror, access="stream")
+            
+            if(ioerror /= 0) then
+                
+                status_code = 5
+                
+            else
+            
+                call determine_mimetype(filename, mimetype)
+                status_code = 2
+            
+            end if
+        
+        end if
+    
+    end function process_request
+
+    subroutine read_request(ssl, req)
+    use jessl, only: ssl_read
+    use iso_c_binding, only: c_ptr
+    implicit none
+    
+        type(c_ptr)::ssl
+        character(*), intent(out)::req
+        
+        character, dimension(64)::buf
+        integer::bufread
+        
+        integer::i, j
+        
+        req = " "
+        i = 1
+        
+        bufread = ssl_read(ssl, buf)
+        do while(bufread > 0)
+            
+            do j = 1, bufread
+                if(buf(j) == c_new_line) then
+                    exit
+                end if
+                
+                if(buf(j) /= c_carriage_return) then
+                    req(i:i) = buf(j)
+                    i = i + 1
+                end if
+                
+            end do
+            
+            if(buf(j) == c_new_line) then
+                exit
+            end if
+            
+            bufread = ssl_read(ssl, buf)
+        end do
+    
+    end subroutine read_request
+    
+    function canonicalize_path(path)
+    use iso_c_binding, only: c_char, c_null_char
+    implicit none
+    
+        character(*), intent(inout)::path
+        character(kind=c_char), allocatable, dimension(:), target::srcpath
+        logical::canonicalize_path
+        
+        type(c_ptr)::cdst
+        character(kind=c_char), dimension(:), pointer::dstpath
+        
+        character(256)::errr
+        integer::pathlen, i
+        
+        interface
+            function realpath(src, dst) bind(c)
+            use iso_c_binding
+            type(c_ptr)::realpath
+            type(c_ptr), value::src, dst
+            end function realpath
+        end interface
+        
+        interface
+            subroutine c_free(p) bind(c, name="free")
+            use iso_c_binding
+            type(c_ptr), value::p
+            end subroutine c_free
+        end interface
+            
+        pathlen = (len_trim(path)+1)
+        
+        allocate(srcpath(len(path)))
+        
+        srcpath = c_null_char
+        
+        do i = 1, pathlen-1
+            srcpath(i) = path(i:i)
+        end do
+        srcpath(pathlen) = c_null_char
+
+        cdst = realpath(c_loc(srcpath), c_null_ptr)
+        if(c_associated(cdst)) then
+        
+            path = " "
+            call c_f_pointer(cdst, dstpath, [1])
+            
+            i = 1
+            do while(dstpath(i) /= c_null_char)
+                path(i:i) = dstpath(i)
+                i = i + 1
+            end do
+            
+            dstpath => null()
+            call c_free(cdst)
+            
+            canonicalize_path = .true.
+            
+        else
+        
+            write(errr, *) "realpath error: ", ierrno()
+            call write_log(trim(errr))
+        
+            canonicalize_path = .false.
+        
+        end if
+        
+        deallocate(srcpath)
+        
+    end function canonicalize_path
+
+    subroutine usage()
+    implicit none
+    
+        character(256)::exe
+        
+        call get_command_argument(0, exe)
+        
+        Print *, "Usage: "//trim(exe)//" -pub <public cert> -priv <private cert> [-l <logfile>] [-root <rootdir>]"
+        
+    end subroutine usage
+    
+    subroutine write_log(string)
+    implicit none
+    
+        character(*), intent(in)::string
+        
+        ! GNU Extension... :(
+        write(logunit, *) fdate()//" :: "//string
+        call flush(logunit)
+        
+    end subroutine write_log
+    
+end program gnc
\ No newline at end of file