diff options
| -rw-r--r-- | LICENSE.txt | 9 | ||||
| -rw-r--r-- | README.md | 57 | ||||
| -rw-r--r-- | errors.c | 16 | ||||
| -rw-r--r-- | gnc.prj | 75 | ||||
| -rw-r--r-- | jessl.f90 | 358 | ||||
| -rw-r--r-- | main.f90 | 551 | ||||
| -rw-r--r-- | makefile.gnu | 68 |
7 files changed, 1134 insertions, 0 deletions
diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 index 0000000..c46078c --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,9 @@ +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.
\ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..409a40a --- /dev/null +++ b/README.md @@ -0,0 +1,57 @@ +# GNC: A Gemini Server for inetd + +GNC is a pure-Fortran implementation of a simple Gemini server for UNIX-like +systems. The server requires the inetd super-server (or compatible system +like xinetd) to work. GNC will handle all the TLS nonsense, and, if given a +root directory to work with, should provide some mild security that only +files in that directory will be served (no promises, though!). + +## Requirements + +GNC requires almost nothing: + + * A modern Fortran compiler (GNU Fortran > 7) + * OpenSSL + * The *file* command (for computing MIME types) + * inetd or equivalent (Debian calls it inetutils-inetd) + +There is a makefile provided to compile it (makefile.gnu) and a Simply +Fortran project if you're rad. + +## Usage + +These directions will focus on just getting everything running on plain, old +BSD-esque inetd. Users can probably extrapolate for other systems. + +You'll first need to set up the Gemini protocol in the file /etc/services: + +``` +gemini 1965/tcp # Gemini... +``` + +Next, you can add a nice line to inetd.conf: + +``` +gemini stream tcp nowait root /path/to/gnc gnc -pub /path/to/certs/cer +t.pem -priv /path/to/certs/key.pem -root /path/to/files/to/serve -l /path/to/logfile +``` + +Note that if you don't provide a logfile (the "-l" option), GNC will write to +/tmp/gnc.log all the time. + +The inetd.conf line above implies using *root* as the user for GNC which is super- +unecessary. Users should probably set up a sensible user instead. + +The "-root" option isn't mandatory. If you don't provide it, though, GNC will just +serve your **entire filesystem**, so maybe you should provide it... + +After that, it should just work. + +Paths ending in a slash will actually attempt to open a file "index.gmi" without +letting the end user know. You might want one of those in your root directory +from which you're serving. + +## License + +GNC is Copyright (c) 2020 Jeffrey Armstrong <jeff@rainbow-100.com>, and the software +is licensed under the JSON license. See LICENSE.txt for more details. diff --git a/errors.c b/errors.c new file mode 100644 index 0000000..0ab0c77 --- /dev/null +++ b/errors.c @@ -0,0 +1,16 @@ + +#include <openssl/err.h> + +#include <stdio.h> + +void print_error() +{ +FILE *fp; + + //ERR_print_errors_fp(stderr); + + fp = fopen("/tmp/gnc.log", "a"); + fprintf(fp, "ssl was %d ::\n",SSL_get_error()); + ERR_print_errors_fp(fp); + fclose(fp); +} @@ -0,0 +1,75 @@ +{ + "Root":{ + "Folders":[], + "Name":"+gnc (gnc)", + "Files":[{ + "filename":"errors.c", + "enabled":"0" + },{ + "filename":"jessl.f90", + "enabled":"1" + },{ + "filename":"LICENSE.txt", + "enabled":"1" + },{ + "filename":"main.f90", + "enabled":"1" + },{ + "filename":"README.md", + "enabled":"1" + }] + }, + "Name":"gnc (gnc)", + "Options":{ + "Compiler Options":{ + "Fortran Flags":"", + "Link Flags":"-lssl -lcrypto", + "C Flags":"" + }, + "Architecture":0, + "Type":0, + "Revision":2, + "Windows GUI":0, + "File Options":{ + "Library Directories":["Default Library Directory"], + "Build Directory":"build", + "Module Directory":"modules", + "Include Directories":["Default Include Directory"] + }, + "Target":"gnc", + "Fortran Options":{ + "Use C Preprocessor":"false", + "Runtime Diagnostics":"false", + "Cray Pointers":"false", + "Enable OpenMP":"false", + "Enable Coarrays":"false", + "Default Double for Real":"false" + }, + "Code Generation Options":{ + "CPU Specific":"false", + "Processor":"generic", + "Aggressive Loops":"false", + "Debugging":"true", + "Optimization Mode":0, + "Profiling":"false" + }, + "Build Dependencies":1, + "Launch Options":{ + "Working Directory":"", + "Launch Using MPI":"false", + "Keep Console":"true", + "External Console":"false", + "Command Line Arguments":"", + "Build Before Launch":"true" + }, + "Build Options":{ + "Makefile":"Makefile", + "Auto Makefile":"true" + }, + "Linker Options":{ + "Static Linking Mode":0, + "Link MPI Library":"false", + "Link LAPACK":0 + } + } +}
\ No newline at end of file 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 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 diff --git a/makefile.gnu b/makefile.gnu new file mode 100644 index 0000000..d3f0960 --- /dev/null +++ b/makefile.gnu @@ -0,0 +1,68 @@ +# +# Automagically generated by Approximatrix Simply Fortran 3.12 +# +FC?="gfortran" +CC?="gcc" +AR?="ar" +WRC?="windres" +RM=rm -f + + +OPTFLAGS= -g + +SPECIALFLAGS= + +RCFLAGS=-O coff + +PRJ_FFLAGS= + +PRJ_CFLAGS= + +PRJ_LFLAGS=-lssl -lcrypto + +FFLAGS=$(SPECIALFLAGS) $(OPTFLAGS) $(PRJ_FFLAGS) -Jmodules + +CFLAGS=$(SPECIALFLAGS) $(OPTFLAGS) $(PRJ_CFLAGS) + +build: + mkdir -p $@ + +modules: + mkdir -p $@ + +.PHONY: all clean + + +build/errors.o: errors.c | build + @echo Compiling errors.c + @$(CC) -c -o "build/errors.o" $(CFLAGS) "errors.c" + +build/jessl.o: jessl.f90 | modules build + @echo Compiling jessl.f90 + @$(FC) -c -o "build/jessl.o" $(FFLAGS) "jessl.f90" +modules/jessl.mod : | modules build/jessl.o + +build/main.o: main.f90 modules/jessl.mod | modules build + @echo Compiling main.f90 + @$(FC) -c -o "build/main.o" $(FFLAGS) "main.f90" + +clean: + @echo Deleting build/errors.o and related files + @$(RM) "build/errors.o" + @echo Deleting build/jessl.o and related files + @$(RM) "build/jessl.o" "modules/jessl.mod" "modules/jessl.smod" + @echo Deleting build/main.o and related files + @$(RM) "build/main.o" + @echo Deleting directory modules + @rmdir modules + @echo Deleting directory build + @rmdir build + @echo Deleting gnc + @$(RM) "gnc" + +gnc: build/jessl.o build/main.o + @echo Generating gnc + @$(FC) -o "gnc" build/jessl.o build/main.o $(LDIR) $(PRJ_LFLAGS) + +all: gnc + |