path: root/captain/response.f90

! Copyright (c) 2021 Approximatrix, LLC <support@approximatrix.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.

module server_response
use iso_c_binding
implicit none

    integer, parameter::GEMINI_CODE_INPUT    = 10
    integer, parameter::GEMINI_CODE_SUCCESS  = 20
    integer, parameter::GEMINI_CODE_REDIRECT = 30
    integer, parameter::GEMINI_CODE_TEMPFAIL = 40
    integer, parameter::GEMINI_CODE_PERMFAIL = 50

    character(*), parameter::RESPONSE_JSON_OKAY = '{"status": "okay"}'

    type :: response
    
        integer::code
        
        ! Used for redirects
        character(len=:), pointer::url => null()
        
        ! Used for inputs in gemini
        character(len=:), pointer::message => null()
        
        logical::temporary_file = .false.
        character(len=:), pointer::body_filename => null()
        character(len=64)::body_mimetype
        
        contains
        
        procedure :: destroy => response_destroy
        procedure :: set_message => response_set_message
        procedure :: set_url => response_set_url
        procedure :: set_body_contents => response_temp_file_contents
        procedure :: set_filename => response_set_filename_using_allocation
        
    end type
    
    type :: request
    
        character(len=:), pointer::url => null()
        character(len=:), pointer::server => null()
        character(len=:), pointer::protocol => null()
        character(len=:), pointer::location => null()
        character(len=:), pointer::page => null()
        character(len=:), pointer::query_string => null()
        character(len=4)::method = "GET"
    
        contains
        
        procedure :: init => request_init
        procedure :: destroy => request_destroy
        procedure :: last_component => request_last_component
        procedure :: path_component => request_component
        procedure :: path_component_int => request_component_int
        procedure :: path_starting_with_component => request_component_starting_with
        procedure :: component => request_component_func
        procedure :: is_get => request_is_get
        procedure :: is_post => request_is_post

    end type request
    
    type, extends(request) :: titan_request

        integer(kind=8)::size
        character(len=:), pointer::mimetype
        character(len=:), pointer::token
        
        type(c_ptr)::ssl_connection
        
        contains
        
        procedure :: init_from_request => titan_request_init
        procedure :: destroy => titan_request_destroy
        procedure :: write_to => titan_write_to_filename
    
    end type titan_request
    
contains

    subroutine request_init(self, str, server_explicit, protocol_explicit, method)
    use logging
    use utilities, only: toupper
    implicit none
    
        class(request) :: self
        character(*), intent(in)::str
        character(*), intent(in), optional::server_explicit, protocol_explicit, method
        
        character(len=:), allocatable::temppage
        integer::i, j, n
        
        character(64)::msg
        
        n = len_trim(str)
        allocate(character(len=n) :: self%url)
        self%url = trim(str)
        call write_log("URL: "//self%url, LOG_NORMAL)
        
        i = index(str, "://")
        if(i <= 0 .and. present(protocol_explicit)) then
            allocate(character(len=len_trim(protocol_explicit)) :: self%protocol)
            self%protocol = protocol_explicit
            i = 1
        else
            allocate(character(len=(i-1)) :: self%protocol)
            self%protocol = str(1:i-1)
            i = i + 3
        end if
        call write_log("Protocol: "//self%protocol, LOG_DEBUG)
        
        ! We only want to "assume" the server if a :// was never found
        if(i == 1 .and. present(server_explicit)) then
            allocate(character(len=len_trim(server_explicit)) :: self%server)
            self%server = server_explicit
            
            ! This string, in CGI cases, actually represents the SCRIPT root,
            ! so we need to skip ahead of it in the URL if it is there...
            i = index(str, self%server)
            if(i > 0) then
                i = i + len(self%server)
            else
                i = 1
            end if
            
        else
        
            j = index(str(i:n), "/")
            if(j <= 0) then
                j = len_trim(str) + 1 - i
            end if
            allocate(character(len=(j-1)) :: self%server)
            self%server = str(i:(i+j-1))
            
            i = j+i-1
             
        end if
        call write_log("Server: "//self%server//"|", LOG_DEBUG)
        
        j = index(str, "?")
        if(j == 0) then
            if(n-i+1 == 0) then
                allocate(character(len=1) :: self%location)
                self%location = "/"
            else
                write(msg, '(I12,1X,I12)') i, n
                call write_log("i n: "//trim(msg), LOG_DEBUG)
                
                allocate(character(len=(n - i + 1)) :: self%location)
                call write_log("str(i:n): "//str(i:n), LOG_DEBUG)
                self%location = str(i:n)
            end if
            call write_log("Location: "//self%location, LOG_DEBUG)
            
        else
            allocate(character(len=(n-j)) :: self%query_string)
            self%query_string = str(j+1:n)
            call write_log("Query: "//self%query_string, LOG_DEBUG)
            
            allocate(character(len=(j-i)) :: self%location)
            self%location = str(i:j-1)
            call write_log("Location: "//self%location, LOG_DEBUG)
        end if
    
        ! and page, which is really just a last location if there is an extension...
        ! I realize this is not so great, but whatever.
        allocate(character(len=len(self%location)) :: temppage)
        call self%last_component(temppage)
        if(index(temppage, ".") > 0) then
            allocate(character(len=len_trim(temppage)) :: self%page)
            self%page = temppage
        end if
        deallocate(temppage)
        
        if(present(method)) then
            self%method = method
            call toupper(self%method)
        end if
    
    end subroutine request_init
    
    function request_component_start_location(self, i_component) result(res)
    implicit none
    
        class(request) :: self
        integer, intent(in)::i_component
        integer::res
        
        integer::i, j, i_last, n
        
        res = -1
    
        n = len_trim(self%location)

        i_last = 0
        j = 0
        i = index(self%location, "/")
        do while(i /= i_last .and. j < i_component)
            j = j + 1
            
            i_last = i
            i = index(self%location(i_last+1:n), "/")
            i = i_last + i
        end do
        
        ! Found
        if(j == i_component) then
            res = i_last + 1
        end if
    
    end function request_component_start_location
    
    subroutine request_component(self, i_component, res)
    use logging
    implicit none
    
        class(request) :: self
        integer, intent(in)::i_component
        character(*), intent(out)::res
        
        integer::i, j, i_last, n
        
        res = " "
        
        n = len_trim(self%location)

        i_last = 0
        j = 0
        i = index(self%location, "/")
        do while(i /= i_last .and. j < i_component)
            j = j + 1
            
            i_last = i
            i = index(self%location(i_last+1:n), "/")
            i = i_last + i
        end do
        
        ! Found
        if(j == i_component) then
            if(i == i_last) then
                res = self%location(i_last+1:n)
            else
                res = self%location(i_last+1:i-1)
            end if
        end if
        
    end subroutine request_component
    
    subroutine request_component_starting_with(self, i_component, res)
    implicit none
    
        class(request) :: self
        integer, intent(in)::i_component
        character(*), intent(out)::res
        
        integer::string_index_component
        
        string_index_component = request_component_start_location(self, i_component)
        
        if(string_index_component > 0) then
            res = self%location(string_index_component:len_trim(self%location))
        else
            res = " "
        end if
        
    end subroutine request_component_starting_with
    
    function request_component_int(self, i) result(res)
    implicit none
    
        class(request) :: self
        integer, intent(in)::i
        integer :: res
        
        character(24)::restext
        
        restext = " "
        
        call self%path_component(i, restext)
        
        read(restext, '(I16)') res
    
    end function request_component_int
    
    
    function request_component_func(self, i) result(res)
    implicit none
    
        class(request) :: self
        integer, intent(in)::i
        character(128) :: res
        
        res = " "
        
        call self%path_component(i, res)
    
    end function request_component_func

    subroutine request_last_component(self, res)
    implicit none
    
        class(request) :: self
        character(*), intent(out)::res
        
        integer::i, n
        
        n = len_trim(self%location) 
        if(n == 1) then
            res = "/"
        else
        
            i = index(self%location, "/", back=.true.)
        
            if(i == n) then
                i = index(self%location(1:n-1), "/", back=.true.)
                if(i > 0) then
                    res = self%location(i+1:n-1)
                else
                    res = "/"
                end if
            else
                res = self%location((i+1):n)
            end if
        end if
        
    end subroutine request_last_component
    
    function request_is_get(self) result(res)
    implicit none
    
        class(request)::self
        logical::res
        
        res = (self%method == "GET")
    
    end function request_is_get
    
    function request_is_post(self) result(res)
    implicit none
    
        class(request)::self
        logical::res
        
        res = (self%method == "POST")
    
    end function request_is_post
    
    subroutine request_destroy(self)
    implicit none
    
        class(request) :: self
        
        if(associated(self%url)) then
            deallocate(self%url)
        end if
        
        if(associated(self%server)) then
            deallocate(self%server)
        end if
        
        if(associated(self%location)) then
            deallocate(self%location)
        end if
        
        if(associated(self%query_string)) then
            deallocate(self%query_string)
        end if
        
        if(associated(self%protocol)) then
            deallocate(self%protocol)
        end if
        
        if(associated(self%page)) then
            deallocate(self%page)
        end if
        
    end subroutine request_destroy

    subroutine response_destroy(resp)
    use utilities, only: delete_file
    implicit none
    
        class(response)::resp
    
        if(associated(resp%url)) then
            deallocate(resp%url)
        end if
        
        if(associated(resp%message)) then
            deallocate(resp%message)
        end if
        
        if(associated(resp%body_filename)) then
            if(resp%temporary_file) then
                call delete_file(resp%body_filename)
            end if
            deallocate(resp%body_filename)
        end if
    
    end subroutine response_destroy
    
    subroutine response_set_message(resp, str)
    implicit none
    
        class(response)::resp
        character(*), intent(in)::str
        
        if(len_trim(str) > 0) then
            allocate(character(len=len_trim(str)) :: resp%message)
            resp%message = trim(str)
        end if
    
    end subroutine response_set_message
    
    subroutine response_set_url(resp, str)
    implicit none
    
        class(response)::resp
        character(*), intent(in)::str
        
        if(len_trim(str) > 0) then
            allocate(character(len=len_trim(str)) :: resp%url)
            resp%url = trim(str)
        end if
    
    end subroutine response_set_url
    
    subroutine response_temp_file_contents(resp, str, mimetype)
    use utilities, only: generate_temporary_filename
    implicit none
    
        class(response)::resp
        character(*), intent(in)::str
        character(*), intent(in), optional::mimetype
        
        integer::unum
        
        resp%body_filename => generate_temporary_filename()
        open(newunit=unum, file=resp%body_filename, action="write", status="new")
        write(unum, *) str
        close(unum)
        
        resp%temporary_file = .true.
        
        if(present(mimetype)) then
            resp%body_mimetype = mimetype
        else
            resp%body_mimetype = "text/plain"
        end if
    
    end subroutine response_temp_file_contents
    
    subroutine response_set_filename_using_allocation(resp, fname, mimetype)
    implicit none
    
        class(response)::resp
        character(*), intent(in)::fname
        character(*), intent(in), optional::mimetype
            
        allocate(character(len=len_trim(fname)) :: resp%body_filename)
        resp%body_filename = trim(fname)
        
        if(present(mimetype)) then
            resp%body_mimetype = mimetype
        else
            resp%body_mimetype = "text/plain"
        end if
        
    end subroutine response_set_filename_using_allocation
    
    function titan_get_request_value( full_location, label) result(p)
    implicit none
    
        character(*), intent(in)::full_location, label
        character(len=:), pointer::p
        
        integer::i, j, n, label_width
        
        label_width = len_trim(label)
        
        n = len_trim(full_location)
        i = index(full_location, ";"//trim(label)//"=")
        j = index(full_location(i+1:n), ";")
        if(j<=0) then 
            j = n
        else
            j = j+i-1
        end if
        i = i + label_width + 2
        
        allocate(character(len=(j-i+1))::p)
        p = full_location(i:j)
        
    end function titan_get_request_value
    
    subroutine titan_request_init(self, regular_request, ssl_connection)
    implicit none
    
        class(titan_request)::self
        class(request), intent(inout)::regular_request
        type(c_ptr)::ssl_connection
        
        character(len=:), pointer::size_text
        integer::i, ierr
        
        self%url => regular_request%url
        regular_request%url => null()
        
        self%protocol => regular_request%protocol
        regular_request%protocol => null()
        
        self%server => regular_request%server
        regular_request%server => null()
        
        self%query_string => regular_request%query_string
        
        i = index(regular_request%location, ";")
        allocate(character(len=(i-1)) :: self%location)
        self%location = regular_request%location(1:i-1)
        
        size_text => titan_get_request_value(regular_request%location, "size")
        read(size_text, '(I16)', iostat=ierr) self%size
        if(ierr /= 0) then
            self%size = 0
        end if
        deallocate(size_text)
        
        self%mimetype => titan_get_request_value(regular_request%location, "mime")
        self%token => titan_get_request_value(regular_request%location, "token")
        
        self%ssl_connection = ssl_connection
        
    end subroutine titan_request_init
    
    subroutine titan_request_destroy(self)
    implicit none
    
        class(titan_request)::self
        
        if(associated(self%mimetype)) then
            deallocate(self%mimetype)
        end if
        if(associated(self%token)) then
            deallocate(self%token)
        end if
        
        call request_destroy(self)
        
    end subroutine titan_request_destroy
    
    function titan_write_to_filename(self, filename) result(success)
    use jessl, only: ssl_read
    use logging
    implicit none
    
        class(titan_request)::self
        character(*), intent(in)::filename
        integer::unum
        
        character(len=1), dimension(1024)::buf
        integer::bufread
        
        integer(kind=8)::bytes_to_go
        integer::istat
        
        logical::success
        
        !character(128)::msg
        
        success = .false.
        
        open(newunit=unum, file=filename, status="unknown", &
             action="write", access='stream', iostat=istat) 

        bytes_to_go = self%size
        
        do while(bytes_to_go > 0 .and. istat == 0)
            bufread = ssl_read(self%ssl_connection, buf)
            bytes_to_go = bytes_to_go - bufread

            write(unum, iostat=istat) buf(1:bufread)

        end do
        
        close(unum)
        
        success = (istat == 0)
        
    end function titan_write_to_filename
    
end module server_response