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
use query_utilities
implicit none

    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

        character(len=:), pointer::cookiecmd => null()
        
        contains
        
        procedure :: destroy => response_destroy
        procedure :: set_message => response_set_message
        procedure :: set_url => response_set_url
        procedure :: set_gemini_session_url => reponse_set_gemini_session_url
        procedure :: set_body_contents => response_temp_file_contents
        procedure :: set_filename => response_set_filename_using_allocation
        procedure :: set_cookie_cmd => response_set_cookie_cmd
        procedure :: set_cookie => response_set_cookie
        
    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=:), pointer::token => null()
        character(len=4)::method = "GET"
        
        integer::auth_level
        
        type(query)::q
        type(cookies)::c
    
        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
        procedure :: has_query => request_has_query
        procedure :: is_authenticated_user => request_is_authenticated_user
        procedure :: set_token => request_set_token
        procedure :: remove_first_path_component => request_remove_first_path_component
        procedure :: clear_token => request_clear_token
        
    end type request
    
    type, extends(request) :: titan_request

        integer(kind=8)::size
        character(len=:), pointer::mimetype
        
        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

    function gemini_session_link_url(link, session_token) result(res)
    implicit none
    
        character(*), intent(in)::link
        character(len=:), pointer, intent(in), optional::session_token
        character(len=:), pointer::res
        logical::prepend_session
        integer::nl
    
        nl = len_trim(link)
    
        prepend_session = .false.
        if(link(1:1) == "/") then
            if(present(session_token)) then
                if(associated(session_token)) then
                    nl = nl + 9 + len_trim(session_token)
                    prepend_session = .true.
                end if
            end if
        end if
        
        allocate(character(len=nl)::res)
        
        if(prepend_session) then
            res = "/session-"//trim(session_token)//trim(link)
        else
            res = link
        end if
    
    end function gemini_session_link_url

    subroutine request_init(self, str, server_explicit, protocol_explicit, method, cookiestring)
    use logging
    use utilities, only: toupper
    use captain_db, only: get_session_auth_db
    use auth_levels, only: AUTH_NONE
    implicit none
    
        class(request) :: self
        character(*), intent(in)::str
        character(*), intent(in), optional::server_explicit, protocol_explicit, method, cookiestring
        
        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
    
        if(associated(self%query_string)) then
            call self%q%init(self%query_string)
            
            if(associated(self%q%get_value("token"))) then
                self%token => self%q%get_value("token")
            end if
        else
            call self%q%init()
        end if
    
        if(present(cookiestring)) then
            call self%c%init(cookiestring)
            if(.not.associated(self%token) .and. associated(self%c%get_value("token"))) then
                self%token => self%c%get_value("token")
            end if
        else
            call self%c%init()
        end if
        
        if(associated(self%token)) then
            self%auth_level = get_session_auth_db(self%token)
        else
            self%auth_level = AUTH_NONE
        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
    
    function request_is_authenticated_user(self)
    use captain_db
    implicit none
    
        class(request), intent(in)::self
        logical::request_is_authenticated_user
        
        request_is_authenticated_user = .false.
        if(associated(self%token)) then
            request_is_authenticated_user = is_valid_session_db(self%token)
            if(request_is_authenticated_user) then
                call update_session_db(self%token)
            end if
        end if
    
    end function request_is_authenticated_user
    
    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
    
    function request_has_query(self)
    implicit none
    
        class(request)::self
        logical::request_has_query
        
        request_has_query = associated(self%query_string) .and. self%q%component_count() > 0
        
    end function request_has_query
    
    subroutine request_set_token(self, token)
    use captain_db
    implicit none
    
        class(request), intent(inout)::self
        character(len=*), intent(in)::token
        
        allocate(character(len=len_trim(token)) :: self%token)
        self%token = token
        self%auth_level = get_session_auth_db(self%token)
        
    end subroutine request_set_token
    
    subroutine request_clear_token(self)
    implicit none
    
        class(request), intent(inout)::self
        logical::safe_to_deallocate
        
        if(associated(self%token)) then
            safe_to_deallocate = .not. (associated(self%c%get_value("token"), self%token) .or. &
                                        associated(self%q%get_value("token"), self%token))
            
            if(safe_to_deallocate) then
                deallocate(self%token)
            end if
           
        end if
        
        self%token => null()
        self%auth_level = 0
        
    end subroutine request_clear_token
    
    ! This routine is needed if we're stripping session identifiers
    ! in Gemini URLs
    subroutine request_remove_first_path_component(self)
    implicit none
    
        class(request), intent(inout)::self
        character(len=:), pointer::first, newloc
        
        integer::i, j, n
        
        i = 1
        if(self%location(1:1) == "/") then
            i = i + 1
        end if
        
        n = len_trim(self%location)
        j = index(self%location(i:n), "/") + (i-1)
        if(j == 0) then
            j = n
        end if
        
        ! First component should be self%location(i:j)
        n = n - (j-i+1)
        
        allocate(character(len=n)::newloc)
        if(i > 1) then
            newloc(1:1) = self%location(1:1)
        end if
        
        newloc(2:n) = self%location(j+1:len_trim(self%location))
        deallocate(self%location)
        self%location => newloc
        newloc => null()
    
    end subroutine request_remove_first_path_component
    
    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
        
        ! Needs to happen before we destroy the cookies and query string
        call self%clear_token()
        
        call self%q%destroy()
        call self%c%destroy()
        
    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
        
        if(associated(resp%cookiecmd)) then
            deallocate(resp%cookiecmd)
        end if
    
    end subroutine response_destroy
    
    subroutine response_set_cookie_cmd(resp, str)
    implicit none
    
        class(response)::resp
        character(*), intent(in)::str
        
        integer::newlength
        character(len=:), pointer::tmp
        
        if(len_trim(str) > 0) then
            if(associated(resp%cookiecmd)) then
                newlength = len(resp%cookiecmd)+len_trim(str)+1
                allocate(character(len=newlength)::tmp)
                tmp = resp%cookiecmd//new_line(' ')//trim(str)
                deallocate(resp%cookiecmd)
                resp%cookiecmd => tmp
                tmp => null()
            else
                allocate(character(len=len_trim(str)) :: resp%cookiecmd)
                resp%cookiecmd = trim(str)
            end if
        end if
    
    end subroutine response_set_cookie_cmd
    
    subroutine response_set_cookie(resp, k, v, httponly)
    implicit none
    
        class(response)::resp
        character(len=*), intent(in)::k, v
        logical, optional::httponly
        
        character(len=10)::httponly_trailing
        
        httponly_trailing = "; HttpOnly"
        if(present(httponly)) then
            if(.not. httponly) then
                httponly_trailing = " "
            end if
        end if
        
        call resp%set_cookie_cmd("Set-Cookie: "//trim(k)//"="//trim(v)//"; SameSite=Strict"//trim(httponly_trailing))
        
    end subroutine response_set_cookie
    
    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 reponse_set_gemini_session_url(resp, str, session_token)
    !use request_utils, only: gemini_session_link_url
    implicit none
    
        class(response), intent(inout)::resp
        character(*), intent(in)::str
        character(len=:), pointer, intent(in)::session_token
        character(len=:), pointer::session_url
        
        if(associated(session_token)) then
            session_url => gemini_session_link_url(str, session_token)
            call resp%set_url(session_url)
            deallocate(session_url)
        else
            call resp%set_url(str)
        end if
    
    end subroutine reponse_set_gemini_session_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
            if(.not. associated(self%q%get_value("token"), self%token)) then
                deallocate(self%token)
            end if
        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, file_exists
        
        !character(128)::msg
        
        success = .false.
        
        ! Writing to an existing file has been broken for some reason...
        inquire(file=filename, exist=file_exists)
        if(file_exists) then
            ! GNU Extension, boo...
            call unlink(filename)
        end if
        
        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