! Copyright (c) 2021 Approximatrix, LLC ! ! 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 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//"" 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//"" deallocate(all_players) end if if(n_players > 0) then res = trim(res)//nl//"

Remove

"//nl//"

Remove a player from these instructions

"//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_instructions_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(' ')//"" 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_groups_html(req) result(res) use captain_db use server_response, only:request implicit none type(request)::req character(len=:), pointer::res integer, dimension(:), pointer::groups character(128)::one_group integer::n, i character(len=:), pointer::one_link n = get_group_count_db() if(n == 0) then allocate(character(len=1024) :: res) res = "None Yet" else allocate(character(len=(n*(256+64) + 384)) :: res) res = "

Groups

"//new_line(' ')//"" deallocate(groups) end if res = trim(res)//new_line(' ')//"

Management

" res = trim(res)//new_line(' ')// & '
'// & '
' end function generate_groups_html function generate_one_group_html(req) result(res) use captain_db use server_response, only:request use request_utils use query_utilities use logging use remote_launch, only: launch_group implicit none type(request)::req character(len=:), pointer::res type(query)::q character(128)::group_name, instruction_name, player_name integer::id type(group_entry), dimension(:), pointer::entries type(work_pair), dimension(:), pointer::all_entries character(len=:), pointer::one_link, delete_link, play_link, qreq character(128)::launch_msg integer::i, j, n_instructions_group, n_instructions_total call req%path_component(2, group_name) i = index(group_name, ".html") group_name(i:128) = ' ' id = get_group_id_db(trim(group_name)) entries => null() all_entries => null() launch_msg = " " if(associated(req%query_string)) then call q%init(req%query_string) qreq => q%get_value("add") if(associated(qreq)) then call write_log("ADD: "//trim(qreq)) i = index(qreq, ',') player_name = qreq(i+1:len_trim(qreq)) instruction_name = qreq(1:i-1) i = get_instruction_id(trim(instruction_name)) j = get_player_id(trim(player_name)) call add_entry_to_group_db(id, i, j) else qreq => q%get_value("delete") if(associated(qreq)) then i = index(qreq, ',') player_name = qreq(i+1:len(qreq)) instruction_name = qreq(1:i-1) i = get_instruction_id(trim(instruction_name)) j = get_player_id(trim(player_name)) call remove_entry_from_group_db(id, i, j) else if(trim(req%query_string) == "launch") then call launch_group(id) write(launch_msg, '(I4, 1X, A13)') get_group_entries_count_db(id), "jobs launched" else if(trim(req%query_string) == "destroy") then call delete_group_db(id) end if end if call q%destroy() end if n_instructions_group = get_group_entries_count_db(id) n_instructions_total = get_available_count_db() allocate(character( len=(n_instructions_total*384 + 512) ) :: res) res = "

"//trim(group_name)//"

" if(n_instructions_group == 0) then res = trim(res)//new_line(' ')//"

Contains no instructions.

" else if(len_trim(launch_msg) > 0) then res = trim(res)//new_line(' ')//'

'//trim(launch_msg)//'

' else res = trim(res)//new_line(' ')//'

🚀 Launch Now

' end if res = trim(res)//new_line(' ')//"

Work to Be Performed

"//new_line(' ')//"" end if if(n_instructions_total > 0) then res = trim(res)//new_line(' ')//"

Add Instructions

" all_entries => get_available_work_pairs_db() if(associated(all_entries)) then res = trim(res)//new_line(' ')//'
'// & ''//new_line(' ')// & ''//'
' end if end if res = trim(res)//new_line(' ')//'

Destroy This Group

'//new_line(' ')// & '

💣 Destroy

'//new_line(' ')// & '

This operation will not destroy any instructions

' end function generate_one_group_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(' ')//"" deallocate(players) end if res = trim(res)//new_line(' ')//"

Management

"// & new_line(' ')//'
'// & '
' end function generate_players_html function generate_one_player_html(req) result(res) use captain_db use server_response use request_utils implicit none type(request), intent(in)::req character(len=:), pointer::res character(len=PLAYER_NAME_LENGTH)::player_name, instruction_name character(len=:), pointer::one_link integer::i, n, pid integer, dimension(8)::values integer, dimension(:), pointer::instruction_ids character(len=64)::dateconvert call req%last_component(player_name) i = index(player_name, '.html') player_name = player_name(1:i-1) pid = get_player_id(trim(player_name)) n = get_instructions_count(player=pid) allocate(character(len=(2*n*PLAYER_NAME_LENGTH + 1024)) :: res) res = "

"//trim(player_name)//"

" ! Last checkin call get_last_checkin_time(pid, values) write(dateconvert, '(I4,A1,I0.2,A1,I0.2,3X,I2,A1,I0.2,A1,I0.2)') & values(1), '-', values(2), '-', values(3), & values(5), ':', values(6), ':', values(7) res = trim(res)//new_line(' ')//'

Last Checkin: '//trim(dateconvert)//& '

' ! List of instructions res = trim(res)//new_line(' ')//"

Instructions for "//trim(player_name)//"

" instruction_ids => get_instruction_ids(player=pid) if(associated(instruction_ids)) then res = trim(res)//new_line(' ')//"" deallocate(instruction_ids) else res = trim(res)//"

None Yet

" end if ! Token assignment res = trim(res)//new_line(' ')//"

Security

"//new_line(' ')//"

" if(player_has_token_db(trim(player_name))) then res = trim(res)//"Player currently has a token assigned." else res = trim(res)//"Player is insecure! Please assign a token!" end if res = trim(res)//"

" res = trim(res)//new_line(' ')// & '
'//new_line(' ')// & ''// & ''//new_line(' ')// & ''//new_line(' ')// & '
' end function generate_one_player_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, get_player_link => player_link, & get_instruction_link => instruction_link implicit none type(request), intent(in)::req character(len=:), pointer::res character(4)::status integer::i, j, job_id type(job)::one_job 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 character(len=:), pointer::player_link, instruction_link 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//"

" player_link => get_player_link(one_job%player, .FALSE., prefix="..") if(associated(player_link)) then res = trim(res)//nl//nl//"

Running on "//player_link//nl// & "Last update at: "//one_job%time//"

" deallocate(player_link) end if instruction_link => get_instruction_link(one_job%instruction, .FALSE., prefix="..") if(associated(instruction_link)) then res = trim(res)//nl//"

Executing: "//instruction_link//"

" deallocate(instruction_link) end if res = trim(res)//nl//nl//"

Task Results

" tasks => get_job_tasks(job_id) if(associated(tasks)) then 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//"" 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 use utilities, only: build_date implicit none type(request), intent(in)::req type(response)::resp character(64)::template_to_use character(1024)::template_file type(template)::page character(64)::first character(len=:), pointer::contents character(128)::job_page_title integer::i if(trim(req%location) == "/" .or. & trim(req%location) == "/index.html" .or. & trim(req%location) == "/home.html") & then template_to_use = "home.html" else if(trim(req%location) == "/about.html") then template_to_use = "about.html" else template_to_use = "index.html" end if call template_filepath(template_to_use, 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 call req%last_component(job_page_title) i = index(job_page_title, '.', back=.true.) call page%assign('title', job_page_title(1:i-1)) contents => generate_one_player_html(req) call page%assign('contents', contents) else if(trim(req%location) == "/about.html") then call page%assign('title', 'About') call page%assign('build_date', build_date()) 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 if(trim(req%location) == "/groups.html") then call page%assign('title', 'Instruction Groups') contents => generate_groups_html(req) call page%assign('contents', contents) else if(trim(first) == "groups") then call page%assign('title', 'Instruction Group') contents => generate_one_group_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, add_group_db, update_player_token_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') else if(trim(second) == "assign_token.html") then call update_player_token_db(posted%get_value("player"), posted%get_value("token")) call page%assign('destination', "players/"//posted%get_value("player")//".html") end if else if(trim(category) == "groups") then call req%path_component(2, second) ! Add a group if(trim(second) == "add.html") then call add_group_db(posted%get_value("name")) call page%assign('destination', 'groups.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