diff options
Diffstat (limited to 'main.f90')
| -rw-r--r-- | main.f90 | 551 |
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 |