module web
implicit none
private
public :: handle_request
integer, parameter::REQUEST_UNKNOWN = 0
integer, parameter::REQUEST_GET = 1
integer, parameter::REQUEST_POST = 2
contains
function method()
use utilities, only: toupper
implicit none
integer::method
character(4)::method_text
call get_environment_variable("REQUEST_METHOD", method_text)
call toupper(method_text)
if(trim(method_text) == "GET") then
method = REQUEST_GET
else if(method_text == "POST") then
method = REQUEST_POST
else
method = REQUEST_UNKNOWN
end if
end function method
subroutine build_request_object(req)
use server_response, only:request
type(request), intent(out)::req
character(len=:), allocatable::url, script_name
character(len=4)::method
integer::url_size
call get_environment_variable("REQUEST_URI", length=url_size)
allocate(character(len=url_size)::url, script_name)
call get_environment_variable("REQUEST_URI", url)
call get_environment_variable("SCRIPT_NAME", script_name)
call get_environment_variable("REQUEST_METHOD", method)
! If we're in CGI mode, treat the "server" as the script name
call req%init(url, server_explicit=script_name, protocol_explicit="http", method=method)
deallocate(url)
deallocate(script_name)
end subroutine build_request_object
function html_link(link, label) result(res)
use request_utils, only: build_link
implicit none
character(*), intent(in)::link, label
character(len=:), pointer::res
res => build_link(link, label, .false.)
end function html_link
function generate_one_instuction_html(req) result(res)
use captain_db
use server_response
use request_utils, only: get_status_utf8, render_jobs_links, generate_simple_pager
implicit none
type(request)::req
character(len=:), pointer::res
integer::id_from_req
character(128)::instruction_name
type(job), dimension(:), pointer::jobs
integer, dimension(:), pointer::players
character(len=PLAYER_NAME_LENGTH), dimension(:), pointer::all_players
integer::i, j, n_jobs, n_players, nsize, job_start_index
character(len=:), pointer::job_link_text, one_link, pager
character(1)::nl = new_line(' ')
character(PLAYER_NAME_LENGTH)::player_name
character(4)::player_status
i = index(req%page, ".html")
instruction_name = req%page(1:i-1)
id_from_req = get_instruction_id(trim(instruction_name))
jobs => get_jobs_for_instruction(id_from_req)
if(associated(jobs)) then
if(associated(req%query_string)) then
read(req%query_string, *, iostat=j) job_start_index
if(j /= 0) then
job_start_index = 1
end if
else
job_start_index = 1
end if
n_jobs = size(jobs)
job_link_text => render_jobs_links(jobs, gemini_mode=.false., &
link_prefix="../", startindex=job_start_index, &
stopindex=min(job_start_index+4, n_jobs))
else
job_start_index = 0
n_jobs = 0
job_link_text => null()
end if
players => get_instruction_players(id_from_req)
if(associated(players)) then
n_players = size(players)
else
n_players = 0
end if
nsize = 1024
if(n_jobs > 0) then
nsize = nsize + len_trim(job_link_text)
end if
if(n_players > 0) then
nsize = nsize + n_players*(2*PLAYER_NAME_LENGTH+64)
end if
nsize = nsize + get_player_count()*(2*PLAYER_NAME_LENGTH+64)
allocate(character(len=nsize) :: res)
res = "
"//trim(instruction_name)//"
"
one_link => html_link(trim(instruction_name)//".json", &
"View Raw")
res = trim(res)//nl//""//one_link//"
"
deallocate(one_link)
if(n_players == 0) then
res = trim(res)//nl//"No players currently can run these instructions
"
else
res = trim(res)//nl//"Launch Now
"//nl//""
do i = 1, n_players
call get_player_name(players(i), player_name)
if(is_player_busy(players(i))) then
player_status = get_status_utf8(PLAYER_STATUS_BUSY)
else
player_status = get_status_utf8(PLAYER_STATUS_IDLE)
end if
one_link => html_link(req%page//"?launch="//trim(player_name), &
trim(player_status)//" "//trim(player_name))
res = trim(res)//nl//"- "//trim(one_link)//"
"
end do
res = trim(res)//nl//"
"
end if
res = trim(res)//nl//"Jobs
"
if(n_jobs == 0) then
res = trim(res)//nl//"None Yet"
else
pager => generate_simple_pager(job_start_index, job_start_index + 4, 5, n_jobs, req%page,.false.)
res = trim(res)//nl//job_link_text
if(associated(pager)) then
res = trim(res)//nl//pager
deallocate(pager)
end if
deallocate(job_link_text)
end if
all_players => get_player_names()
if(associated(all_players)) then
res = trim(res)//nl//"Assign
"//nl//"Assign a player to these instructions
"//nl//""
do i = 1, size(all_players)
if(n_players > 0) then
j = get_player_id(all_players(i))
if(any(j == players)) then
cycle
end if
end if
one_link => html_link(req%page//"?assign="//trim(all_players(i)), &
trim(all_players(i)))
res = trim(res)//nl//"- "//one_link//"
"
deallocate(one_link)
end do
res = trim(res)//nl//"
"
deallocate(all_players)
end if
if(n_players > 0) then
res = trim(res)//nl//"Remove
"//nl//"Remove a player from these instructions
"//nl//""
do i = 1, n_players
call get_player_name(players(i), player_name)
one_link => html_link(req%page//"?remove="//trim(player_name), &
trim(player_name))
res = trim(res)//nl//"- "//one_link//"
"
deallocate(one_link)
end do
res = trim(res)//nl//"
"
end if
end function generate_one_instuction_html
function generate_instructions_html(req) result(res)
use captain_db
use server_response, only:request
implicit none
type(request)::req
character(len=:), pointer::res
character(len=PLAYER_NAME_LENGTH), dimension(:), pointer::instruction_names
integer::n, i, nsize
character(len=:), pointer::one_player, scanlink
n = get_instuctions_count()
if(n == 0) then
allocate(character(len=1024) :: res)
res = "None Yet"
else
instruction_names => get_instruction_names()
nsize = 1024
do i = 1, size(instruction_names)
nsize = nsize + 16 + 2*len_trim(instruction_names(i))
end do
allocate(character(len=nsize) :: res)
res = "Instructions
"//new_line(' ')//""
do i = 1, n
one_player => html_link("instructions/"//trim(instruction_names(i))//".html", &
trim(instruction_names(i)))
res = trim(res)//new_line(' ')//"- "//trim(one_player)//"
"
deallocate(one_player)
end do
res = trim(res)//new_line(' ')//"
"
deallocate(instruction_names)
end if
res = trim(res)//new_line(' ')//"Management
"
scanlink => html_link(req%page//"?scan", "Scan for instructions now")
res = trim(res)//new_line(' ')//""//scanlink//"
"
deallocate(scanlink)
end function generate_instructions_html
function generate_players_html() result(res)
use captain_db
implicit none
character(len=:), pointer::res
character(len=PLAYER_NAME_LENGTH), dimension(:), pointer::players
integer::n, i, nsize
character(len=:), pointer::one_player
n = get_player_count()
if(n == 0) then
allocate(character(len=1024) :: res)
res = "None Yet"
else
players => get_player_names()
nsize = 1024
do i = 1, size(players)
nsize = nsize + 16 + 2*len_trim(players(i))
end do
allocate(character(len=nsize) :: res)
res = "Existing Players
"//new_line(' ')//""
do i = 1, n
one_player => html_link("players/"//trim(players(i))//".html", &
trim(players(i)))
res = trim(res)//new_line(' ')//"- "//trim(one_player)//"
"
deallocate(one_player)
end do
res = trim(res)//new_line(' ')//"
"
deallocate(players)
end if
res = trim(res)//new_line(' ')//"Management
"// &
new_line(' ')//''
end function generate_players_html
function generate_one_job_html(req) result(res)
use captain_db
use server_response
use special_filenames, only: get_task_result_static_filename
use request_utils, only: get_status_utf8
implicit none
type(request), intent(in)::req
character(len=:), pointer::res
character(4)::status
integer::i, j, job_id
type(job)::one_job
character(PLAYER_NAME_LENGTH)::player
character(1)::nl = new_line(' ')
type(task), dimension(:), pointer::tasks
character(32)::task_text, job_text
character(len=:), pointer::task_results_filename, one_link, local_task_results_filename
logical::file_exists
res => null()
! Ugh, all this nonsense
call req%last_component(job_text)
j = index(job_text, ".", back=.true.)
job_text(j:len(job_text)) = " "
read(job_text, '(I8)') job_id
one_job = get_job(job_id)
if(one_job%id >= 0) then
allocate(character(len=1024) :: res)
status = get_status_utf8(one_job%status)
res = "Status - "//status//"
"
call get_player_name(one_job%player, player)
res = trim(res)//nl//nl//"Running on "//trim(player)//nl// &
"Last update at: "//one_job%time//"
"
res = trim(res)//nl//nl//"Task Results
"
tasks => get_job_tasks(job_id)
if(associated(tasks)) then
res = trim(res)//nl//""
do i = 1, size(tasks)
status = get_status_utf8(tasks(i)%status)
task_results_filename => get_task_result_static_filename(one_job%id, i, no_path=.true.)
local_task_results_filename => get_task_result_static_filename(one_job%id, i, no_path=.false.)
inquire(file=local_task_results_filename, exist=file_exists)
write(task_text, '(I8)') i
if(file_exists) then
one_link => html_link("../results/"//task_results_filename, &
trim(status)//" - Task "//trim(adjustl(task_text)))
res = trim(res)//nl//" - "//trim(one_link)//"
"
deallocate(one_link)
else
res = trim(res)//nl//" - "// &
trim(status)//" - Task "//trim(adjustl(task_text))//"
"
end if
deallocate(local_task_results_filename)
deallocate(task_results_filename)
end do
res = trim(res)//nl//"
"
deallocate(tasks)
else
res = trim(res)//nl//nl//"None reported yet
"
end if
else
allocate(character(len=64) :: res)
write(res, '(A20, 1X, I5)') "No record of:", job_id
end if
end function generate_one_job_html
function generate_releases_html(req) result(res)
use utilities
use server_response
use config
implicit none
type(request), intent(in)::req
character(len=:), pointer::res
character(len=DIR_LIST_STRING_LENGTH), dimension(:), pointer::directories
character(len=DIR_LIST_STRING_LENGTH), dimension(:), pointer::files
character(1024)::public_path, local_path, subpath
integer::allocation_size, i
character(1)::nl = new_line(' ')
character(4)::folder_icon = char(240)//char(159)//char(147)//char(129)
character(len=:), pointer::one_link
if(.not. associated(req%query_string)) then
public_path = "/releases"
local_path = release_dir
else if(len_trim(req%query_string) == 0) then
public_path = "/releases"
local_path = release_dir
else
call combine_paths("/releases", req%query_string, public_path)
call combine_paths(release_dir, req%query_string, local_path)
end if
res => null()
! Easy safety check - no relative paths
if(index(local_path, '..') > 0) then
allocate(character(len=64)::res)
res = "None Found"
return
end if
directories => get_directories_in_directory(local_path)
files => get_files_in_directory(local_path)
allocation_size = 1024
if(associated(directories)) then
allocation_size = allocation_size + 2 * size(directories) * (DIR_LIST_STRING_LENGTH+32)
end if
if(associated(files)) then
allocation_size = allocation_size + 2 * size(files) * (DIR_LIST_STRING_LENGTH+32)
end if
allocate(character(len=allocation_size) :: res)
res = "Listing for "//trim(public_path)//"
"//nl//""
! Add an "Up" link
if(trim(public_path) /= "/releases") then
i = index(req%query_string, "/", back=.true.)
if(i > 0) then
one_link => html_link("releases.html?"//req%query_string(1:(i-1)), "Up a directory")
else
one_link => html_link("releases.html", "Up a directory")
end if
res = trim(res)//nl//"- "//one_link//"
"
deallocate(one_link)
end if
if(associated(directories)) then
do i = 1, size(directories)
if(associated(req%query_string)) then
call combine_paths(req%query_string, trim(directories(i)), subpath)
else
subpath = trim(directories(i))
end if
one_link => html_link("releases.html?"//trim(subpath), folder_icon//" "//trim(directories(i)))
res = trim(res)//nl//"- "//one_link//"
"
deallocate(one_link)
end do
deallocate(directories)
end if
if(associated(files)) then
do i = 1, size(files)
call combine_paths(public_path(2:len_trim(public_path)), trim(files(i)), subpath)
one_link => html_link(trim(subpath), trim(files(i)))
res = trim(res)//nl//"- "//one_link//"
"
deallocate(one_link)
end do
deallocate(files)
end if
res = trim(res)//nl//"
"
end function generate_releases_html
function generate_jobs_html(req) result(res)
use captain_db
use server_response
use request_utils, only: render_jobs_links, generate_simple_pager
use logging
implicit none
type(request)::req
character(len=:), pointer::res
type(job), dimension(:), pointer::jobs
integer::n, nsize
integer::i_start_jobs, ierr
character(len=:), pointer::linklist, pager
n = get_jobs_count()
if(n == 0) then
allocate(character(len=1024) :: res)
res = "None Yet"
else
if(associated(req%query_string)) then
read(req%query_string, *, iostat=ierr) i_start_jobs
else
ierr = -1
end if
if(ierr /= 0) then
i_start_jobs = 1
end if
jobs => get_jobs()
! 15 per page
nsize = 15*(2*PLAYER_NAME_LENGTH + 64) + 1024
allocate(character(len=nsize) :: res)
res = " "
linklist => render_jobs_links(jobs, i_start_jobs, min(i_start_jobs+14, n), .false.)
res = trim(res)//new_line(' ')//trim(linklist)
! Pagers
pager => generate_simple_pager(i_start_jobs, min(i_start_jobs+14, n), 15, n, req%page, .false.)
if(associated(pager)) then
res = trim(res)//new_line(' ')//pager
deallocate(pager)
end if
deallocate(linklist)
end if
end function generate_jobs_html
function request_templated(req) result(resp)
use page_template
use config, only: template_filepath, project
use logging
use server_response, only:request, response
use http, only: HTTP_CODE_SUCCESS, HTTP_CODE_NOTFOUND
use request_utils, only: get_job_page_title, handle_instruction_command
use captain_db, only: scan_instructions_for_db
implicit none
type(request), intent(in)::req
type(response)::resp
character(1024)::template_file
type(template)::page
character(64)::first
character(len=:), pointer::contents
character(128)::job_page_title
call template_filepath("index.html", template_file)
call write_log("Template base path is: "//trim(template_file), LOG_DEBUG)
call page%init(trim(template_file))
! Initialize with success
resp%code = HTTP_CODE_SUCCESS
call req%path_component(1, first)
if(trim(req%location) == "/" .or. trim(req%location) == "/index.html" .or. trim(req%location) == "/home.html") then
call page%assign('title', 'Home')
else if(trim(req%location) == "/releases.html") then
call page%assign('title', 'Releases')
contents => generate_releases_html(req)
call page%assign('contents', contents)
else if(trim(req%location) == "/jobs.html") then
call page%assign('title', 'Jobs')
contents => generate_jobs_html(req)
call page%assign('contents', contents)
else if(trim(req%location) == "/players.html") then
call page%assign('title', 'Players')
contents => generate_players_html()
call page%assign('contents', contents)
else if(req%location(1:9) == '/players/') then
else if(trim(req%location) == "/about.html") then
call page%assign('title', 'About')
else if(trim(req%location) == "/instructions.html") then
if(associated(req%query_string) ) then
if(trim(req%query_string) == "scan") then
call scan_instructions_for_db()
end if
end if
call page%assign('title', 'Build Instructions')
contents => generate_instructions_html(req)
call page%assign('contents', contents)
else if(trim(first) == "instructions") then
if(associated(req%query_string)) then
call handle_instruction_command(req)
end if
call page%assign('title', 'Build Instructions')
contents => generate_one_instuction_html(req)
call page%assign('contents', contents)
else if(trim(first) == "jobs") then
call get_job_page_title(req, job_page_title)
call page%assign('title', trim(job_page_title))
contents => generate_one_job_html(req)
call page%assign('contents', contents)
else
call page%assign('title', 'Not Found')
resp%code = HTTP_CODE_NOTFOUND
end if
call page%assign('project', project)
call page%assign('base_url', req%server)
call write_log("Rendering page for "//req%location)
call page%render()
call write_log("Finalizing response", LOG_INFO)
resp%temporary_file = .true.
resp%body_filename => page%output_filename
resp%body_mimetype = "text/html"
end function request_templated
function handle_post(req) result(resp)
use captain_db, only: add_player_db
use page_template
use config, only: template_filepath
use logging
use server_response, only:request, response
use http, only: HTTP_CODE_FAILURE, HTTP_CODE_SUCCESS
use http_post_utilities
use query_utilities, only: query
implicit none
type(request), intent(in)::req
type(response)::resp
type(query)::posted
character(1024)::template_file
type(template)::page
character(64)::category, second
posted = read_post_contents()
call write_log("Post Contents: "//posted%full, LOG_DEBUG)
if(posted%component_count() > 0) then
! We will immediately redirect after the command is handled
call template_filepath("redirect.html", template_file)
call page%init(trim(template_file))
! Handle based on category
call req%path_component(1, category)
if(trim(category) == "players") then
call req%path_component(2, second)
! Add a player
if(trim(second) == "add.html") then
call add_player_db(posted%get_value("name"))
call page%assign('destination', 'players.html')
end if
end if
! Handle the template
call page%assign('base_url', req%server)
call page%render()
call write_log("Finalizing response", LOG_INFO)
resp%temporary_file = .true.
resp%body_filename => page%output_filename
resp%body_mimetype = "text/html"
resp%code = HTTP_CODE_SUCCESS
call posted%destroy()
else
resp%code = HTTP_CODE_FAILURE
end if
end function handle_post
subroutine handle_request()
use server_response, only:request, response
use logging
use request_utils
use http
use iso_fortran_env, only: output_unit
use utilities, only: echo_file_stdout
implicit none
type(request)::req
type(response)::resp
integer::response_size
character(64)::logresponse
call build_request_object(req)
if(is_request_static(req)) then
call write_log("Req static", LOG_INFO)
resp = request_static(req)
else if(req%is_post()) then
call write_log("POST operation", LOG_INFO)
resp = handle_post(req)
else
call write_log("Req template", LOG_INFO)
resp = request_templated(req)
end if
! Perform the response
call write_log("Publishing response", LOG_INFO)
write(logresponse, *) "Response code is: ", resp%code
call write_log(trim(logresponse), LOG_INFO)
select case(resp%code)
case(HTTP_CODE_REDIRECT)
call write_redirect(output_unit, resp%code, trim(resp%url))
case(HTTP_CODE_SUCCESS)
inquire(file=resp%body_filename, size=response_size)
call write_response_headers(output_unit, resp%code, response_size, trim(resp%body_mimetype))
call echo_file_stdout(resp%body_filename)
case(HTTP_CODE_FAILURE)
call write_log("Failure reported for location: "//trim(req%location), LOG_NORMAL)
! Need some more...
end select
call write_log("Cleanup", LOG_INFO)
call resp%destroy()
call req%destroy()
call write_log("Exit handler", LOG_INFO)
end subroutine handle_request
end module web