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

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 = " "
    cert_public = " "
    cert_private = " "
    
    if(command_argument_count() < 4) then
        call usage()
        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")
   
    ! Diagnostics
    do i = 1,command_argument_count()
        call get_command_argument(i, arg)
        call write_log("Argument: "//trim(arg))
    end do
   
    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