diff options
| -rw-r--r-- | common/jessl.f90 | 374 | ||||
| -rw-r--r-- | common/network.F90 | 326 | ||||
| -rw-r--r-- | common/protocol.f90 | 474 | ||||
| -rw-r--r-- | common/request.f90 | 294 | ||||
| -rw-r--r-- | common/wsa.f90 | 68 | ||||
| -rw-r--r-- | player/config.f90 | 8 | ||||
| -rw-r--r-- | player/instructions.f90 | 198 | ||||
| -rw-r--r-- | player/levitating-player.prj | 96 | ||||
| -rw-r--r-- | player/main.f90 | 87 | ||||
| -rw-r--r-- | player/tasks.f90 | 216 | ||||
| -rw-r--r-- | player/utilities.F90 | 208 |
11 files changed, 2349 insertions, 0 deletions
diff --git a/common/jessl.f90 b/common/jessl.f90 new file mode 100644 index 0000000..223fd14 --- /dev/null +++ b/common/jessl.f90 @@ -0,0 +1,374 @@ +! 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. + +! Just Enough SSL... + +module jessl +use iso_c_binding +implicit none + + ! Constants needed for SNI + integer(kind=c_long), parameter::TLSEXT_NAMETYPE_host_name = 0 + + integer(kind=c_int), parameter::SSL_CTRL_SET_TLSEXT_HOSTNAME = 55 + + integer(kind=c_int), parameter::SSL_FILETYPE_PEM = 1 + + interface + + function init_ssl_c(flags, settings) bind(c, name="OPENSSL_init_ssl") + use iso_c_binding + integer(kind=c_int64_t), value::flags + type(c_ptr), value::settings + integer(kind=c_int)::init_ssl_c + end function init_ssl_c + + subroutine add_ssl_algorithms() bind(c, name="SSLeay_add_ssl_algorithms") + end subroutine add_ssl_algorithms + + subroutine load_error_strings() bind(c, name="SSL_load_error_strings") + end subroutine load_error_strings + + function tls_client_method() bind(c, name="TLS_client_method") + use iso_c_binding + type(c_ptr)::tls_client_method + end function tls_client_method + + function tls_server_method() bind(c, name="TLS_server_method") + use iso_c_binding + type(c_ptr)::tls_server_method + end function tls_server_method + + !subroutine print_error() bind(c, name="print_error") + !use iso_c_binding + !end subroutine print_error + + function ctx_new(meth) bind(c, name="SSL_CTX_new") + use iso_c_binding + type(c_ptr)::ctx_new + type(c_ptr), value::meth + end function ctx_new + + function ctx_set_ecdh_auto(ctx, state) bind(c, name="SSL_CTX_set_ecdh_auto") + use iso_c_binding + type(c_ptr), value::ctx + integer(kind=c_int), value::state + integer(kind=c_long)::ctx_set_ecdh_auto + end function ctx_set_ecdh_auto + + function ctx_use_certificate_file_c(ctx, filename, certtype) bind(c, name="SSL_CTX_use_certificate_file") + use iso_c_binding + type(c_ptr), value::ctx + character(kind=c_char), dimension(*), intent(inout)::filename + integer(kind=c_int), value::certtype + integer(kind=c_int)::ctx_use_certificate_file_c + end function ctx_use_certificate_file_c + + function ctx_use_private_key_file_c(ctx, filename, certtype) bind(c, name="SSL_CTX_use_PrivateKey_file") + use iso_c_binding + type(c_ptr), value::ctx + character(kind=c_char), dimension(*), intent(inout)::filename + integer(kind=c_int), value::certtype + integer(kind=c_int)::ctx_use_private_key_file_c + end function ctx_use_private_key_file_c + + function ssl_new(ctx) bind(c, name="SSL_new") + use iso_c_binding + type(c_ptr)::ssl_new + type(c_ptr), value::ctx + end function ssl_new + + function get_fd(ssl) bind(c, name="SSL_get_fd") + use iso_c_binding + integer(kind=c_int)::get_fd + type(c_ptr), value::ssl + end function get_fd + + function set_fd(ssl, fd) bind(c, name="SSL_set_fd") + use iso_c_binding + integer(kind=c_int)::set_fd + integer(kind=c_int), value::fd + type(c_ptr), value::ssl + end function set_fd + + function set_read_fd(ssl, fd) bind(c, name="SSL_set_rfd") + use iso_c_binding + integer(kind=c_int)::set_read_fd + integer(kind=c_int), value::fd + type(c_ptr), value::ssl + end function set_read_fd + + function set_write_fd(ssl, fd) bind(c, name="SSL_set_wfd") + use iso_c_binding + integer(kind=c_int)::set_write_fd + integer(kind=c_int), value::fd + type(c_ptr), value::ssl + end function set_write_fd + + function ssl_connect(ssl) bind(c, name="SSL_connect") + use iso_c_binding + integer(kind=c_int)::ssl_connect + type(c_ptr), value::ssl + end function ssl_connect + + function ssl_accept(ssl) bind(c, name="SSL_accept") + use iso_c_binding + integer(kind=c_int)::ssl_accept + type(c_ptr), value::ssl + end function ssl_accept + + function ssl_shutdown(ssl) bind(c, name="SSL_shutdown") + use iso_c_binding + integer(kind=c_int)::ssl_shutdown + type(c_ptr), value::ssl + end function ssl_shutdown + + function ssl_free(ssl) bind(c, name="SSL_free") + use iso_c_binding + integer(kind=c_int)::ssl_free + type(c_ptr), value::ssl + end function ssl_free + + function ctx_free(ctx) bind(c, name="SSL_CTX_free") + use iso_c_binding + integer(kind=c_int)::ctx_free + type(c_ptr), value::ctx + end function ctx_free + + function ssl_ctrl_c(ctx, cmd, arg, vp) bind(c, name="SSL_ctrl") + use iso_c_binding + type(c_ptr), value::ctx + integer(kind=c_int), value::cmd + integer(kind=c_long), value::arg + type(c_ptr), value::vp + integer(kind=c_long)::ssl_ctrl_c + end function ssl_ctrl_c + + ! Actually a macro... + !function get_cipher_c(ssl) bind(c, name="SSL_get_cipher_name") + !use iso_c_binding + !type(c_ptr)::get_cipher_c + !type(c_ptr), value::ssl + !end function get_cipher_c + + function read_c(ssl, buf, length) bind(c, name="SSL_read") + use iso_c_binding + type(c_ptr), value::ssl + character(kind=c_char), dimension(*), intent(inout)::buf + integer(kind=c_int), value::length + integer(kind=c_int)::read_c + end function read_c + + function write_c(ssl, buf, length) bind(c, name="SSL_write") + use iso_c_binding + type(c_ptr), value::ssl + character(kind=c_char), dimension(*), intent(inout)::buf + integer(kind=c_int), value::length + integer(kind=c_int)::write_c + end function write_c + + function get_error(ssl, retcode) bind(c, name="SSL_get_error") + use iso_c_binding + type(c_ptr), value::ssl + integer(kind=c_int), value::retcode + integer(kind=c_int)::get_error + end function get_error + + function ssl_pending(ssl) bind(c, name="SSL_pending") + use iso_c_binding + type(c_ptr), value::ssl + integer(kind=c_int)::ssl_pending + end function ssl_pending + + end interface + +contains + + function ssl_read(ssl, buf) + use iso_c_binding + implicit none + + type(c_ptr)::ssl + character, dimension(:), intent(inout)::buf + integer::ssl_read + integer::bufsize + + character(kind=c_char), dimension(:), allocatable::cbuf + bufsize = size(buf) + allocate(cbuf(bufsize)) + + ssl_read = read_c(ssl, cbuf, bufsize) + buf = cbuf + + deallocate(cbuf) + + end function ssl_read + + function ssl_write(ssl, buf) + use iso_c_binding + implicit none + + type(c_ptr)::ssl + character, dimension(:), intent(in)::buf + integer::ssl_write + + character(kind=c_char), dimension(:), allocatable::cbuf + + allocate(cbuf(size(buf))) + + cbuf = buf + ssl_write = write_c(ssl, cbuf, size(buf)) + + deallocate(cbuf) + + end function ssl_write + + subroutine get_cipher(ssl, res) + use iso_c_binding + implicit none + + character(:), allocatable, intent(out)::res + type(c_ptr)::ssl + + type(c_ptr)::cptr + + character(kind=c_char), dimension(:), pointer::cstring + + integer::i + + cptr = c_null_ptr + if(.not. c_associated(cptr)) then + + allocate(character(len=1)::res) + res = " " + + else + + call c_f_pointer(cptr, cstring, [1]) + + i = 1 + do while(cstring(i) /= c_null_char) + i = i + 1 + end do + allocate(character(len=(i-1))::res) + + i = 1 + do while(cstring(i) /= c_null_char) + res(i:i) = cstring(i) + end do + + end if + + end subroutine get_cipher + + function set_tlsext_host_name(ctx, hostname) + use iso_c_binding + implicit none + + type(c_ptr)::ctx + character(*), intent(in)::hostname + integer::set_tlsext_host_name + + character(kind=c_char), dimension(:), allocatable, target::chostname + + integer::i + + allocate(chostname(len_trim(hostname)+1)) + + do i = 1, len_trim(hostname) + chostname(i) = hostname(i:i) + end do + chostname(len_trim(hostname)+1) = c_null_char + + set_tlsext_host_name = ssl_ctrl_c(ctx, & + SSL_CTRL_SET_TLSEXT_HOSTNAME, & + TLSEXT_NAMETYPE_host_name, & + c_loc(chostname)) + + deallocate(chostname) + + end function set_tlsext_host_name + + function ctx_use_certificate_file(ctx, filename, certtype) + use iso_c_binding + implicit none + + type(c_ptr)::ctx + character(*), intent(in)::filename + integer::certtype + logical::ctx_use_certificate_file + + character(kind=c_char), dimension(:), allocatable, target::cfilename + + integer::i + + allocate(cfilename(len_trim(filename)+1)) + do i = 1, len_trim(filename) + cfilename(i) = filename(i:i) + end do + cfilename(len_trim(filename)+1) = c_null_char + i = ctx_use_certificate_file_c(ctx, cfilename, int(certtype, kind=c_int)) + ctx_use_certificate_file = (i == 1) + + deallocate(cfilename) + + end function ctx_use_certificate_file + + function ctx_use_private_key_file(ctx, filename, certtype) + use iso_c_binding + implicit none + + type(c_ptr)::ctx + character(*), intent(in)::filename + integer::certtype + logical::ctx_use_private_key_file + + character(kind=c_char), dimension(:), allocatable, target::cfilename + + integer::i + + allocate(cfilename(len_trim(filename)+1)) + do i = 1, len_trim(filename) + cfilename(i) = filename(i:i) + end do + cfilename(len_trim(filename)+1) = c_null_char + + i = ctx_use_private_key_file_c(ctx, cfilename, int(certtype, kind=c_int)) + ctx_use_private_key_file = (i == 1) + + deallocate(cfilename) + + end function ctx_use_private_key_file + + subroutine library_init() + use iso_c_binding + implicit none + + integer(kind=c_int64_t)::flags + integer::res + + flags = 0 + res = init_ssl_c(flags, c_null_ptr) + + end subroutine library_init + +end module jessl diff --git a/common/network.F90 b/common/network.F90 new file mode 100644 index 0000000..90bf2be --- /dev/null +++ b/common/network.F90 @@ -0,0 +1,326 @@ +! 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. + +module network +use iso_c_binding +implicit none + + integer(kind=c_int), parameter::AF_INET = 2 + integer(kind=c_int), parameter::AF_INET6 = 10 + integer(kind=c_int), parameter::AF_UNIX = 1 + + integer(kind=c_int), parameter::SOCK_STREAM = 1 + + integer, parameter::socket_timeout_ms = 10000 + +#ifdef WINDOWS + integer, parameter::hostent_int_kind = c_short +#else + integer, parameter::hostent_int_kind = c_int +#endif + + type, bind(c) :: in_addr + integer(kind=c_int32_t)::s_addr + end type + + type, bind(c) :: sockaddr_in + integer(kind=c_short)::sin_family + integer(kind=c_int16_t)::sin_port + type(in_addr)::sin_addr + !integer(kind=c_int32_t)::s_addr + end type + + type, bind(c) :: hostent_c + type(c_ptr)::h_name !official name of host */ + type(c_ptr)::h_aliases !alias list */ + integer(kind=hostent_int_kind):: h_addrtype !host address type */ + integer(kind=hostent_int_kind):: h_length !length of address */ + type(c_ptr)::h_addr_list !list of addresses */ + end type + + ! Let's keep this simple... + type :: simple_hostent + character(len=:), allocatable::h_name + integer::h_addrtype + integer(kind=c_int32_t)::h_addr4 + integer(kind=c_int64_t)::h_addr6 + end type + +#ifndef WINDOWS + type, bind(c) :: timeval + integer(kind=c_long)::seconds + integer(kind=c_long)::useconds + end type +#endif + + integer(kind=c_size_t), parameter::sockaddr_size = 56 + + interface + function socket_c(i, j, k) bind(c, name="socket") + use iso_c_binding + integer(kind=c_int), value::i, j, k + integer(kind=c_int)::socket_c + end function socket_c + + function inet_addr_c(str) bind(c, name="inet_addr") + use iso_c_binding + type(c_ptr), value::str + integer(c_int32_t)::inet_addr_c + end function inet_addr_c + + function inet_ntoa_c(ip) bind(c, name="inet_ntoa") + use iso_c_binding + type(c_ptr)::inet_ntoa_c + integer(c_int32_t), value::ip + end function inet_ntoa_c + + function htons(i) bind(c) + use iso_c_binding + integer(kind=c_int32_t), value::i + integer(kind=c_int32_t)::htons + end function htons + + function connect_c(sockfd, sock_addr, socklen) bind(c, name="connect") + use iso_c_binding + import::sockaddr_in + integer(kind=c_int), value::sockfd + type(c_ptr), value::sock_addr + integer(kind=c_size_t), value::socklen + integer(kind=c_int)::connect_c + end function connect_c + + function gethostbyname_c(host) bind(c, name="gethostbyname") + use iso_c_binding + type(c_ptr), value::host + type(c_ptr)::gethostbyname_c + end function gethostbyname_c + + function close_c(s) bind(c, name="close") + use iso_c_binding + integer(kind=c_int), value::s + integer(kind=c_int)::close_c + end function close_c + + end interface + + contains + + function socket(domain, stype, protocol) + use iso_c_binding, only: c_int + implicit none + + integer::socket + integer, intent(in)::domain, stype, protocol + integer::ignored + +#ifdef WINDOWS + integer(kind=c_int32_t), target::timeout + integer(kind=c_int), parameter::timeout_size=c_int32_t +#else + type(timeval), target::timeout + integer(kind=c_int), parameter::timeout_size=2*c_long +#endif + + + ! Set up a timeout on the socket that's sensible + interface + function setsockopt(s, level, optname, optval, optlen) bind(c, name="setsockopt") + use iso_c_binding + integer(kind=c_int)::setsockopt + integer(kind=c_int), value::s + integer(kind=c_int), value::level, optname, optlen + type(c_ptr), value::optval + end function + end interface + +#ifdef WINDOWS + integer, parameter::SOL_SOCKET = 65535 + integer, parameter::SO_RCVTIMEO = 4102 + timeout = socket_timeout_ms +#else + integer, parameter::SOL_SOCKET = 1 + integer, parameter::SO_RCVTIMEO = 20 + timeout%useconds = 0 + timeout%seconds = socket_timeout_ms/1000 +#endif + + socket = socket_c(int(domain, c_int), int(stype, c_int), int(protocol, c_int)) + + ! Timeout call + ignored = setsockopt(socket, SOL_SOCKET, SO_RCVTIMEO, c_loc(timeout), timeout_size) + + + end function socket + + subroutine close_socket(s) + use iso_c_binding + implicit none + + integer::s + integer::ignored + + ignored = close_c(int(s, kind=c_int)) + + end subroutine close_socket + + function inet_addr(str) + use iso_c_binding + implicit none + + character(*), intent(in)::str + integer(c_int32_t)::inet_addr + + character(kind=c_char), dimension(:), allocatable, target::cstr + integer::i + + allocate(cstr(len_trim(str)+1)) + + do i=1, len_trim(str) + cstr(i) = str(i:i) + end do + cstr(len_trim(str)+1) = c_null_char + + inet_addr = inet_addr_c(c_loc(cstr)) + + deallocate(cstr) + + end function inet_addr + + function inet_ntoa(ip) result(res) + use iso_c_binding + implicit none + + integer(kind=c_int32_t), intent(in)::ip + character(15)::res + + type(c_ptr)::cptr + character(kind=c_char), dimension(:), pointer::cres + integer::i + + res = " " + cptr = inet_ntoa_c(ip) + if(c_associated(cptr)) then + call c_f_pointer(cptr, cres, [1]) + + i = 1 + do while(cres(i) /= c_null_char) + res(i:i) = cres(i) + i = i + 1 + end do + end if + + end function inet_ntoa + + function connect(sockfd, sock_addr) + use iso_c_binding + implicit none + + integer::sockfd + type(sockaddr_in), target::sock_addr + logical::connect + + !print *, c_sizeof(sock_addr) + + connect = (connect_c(int(sockfd, kind=c_int), & + c_loc(sock_addr), & + sockaddr_size) .eq. 0) + + end function connect + + function gethostbyname(host, success) result(res) + use iso_c_binding + implicit none + + character(*)::host + type(simple_hostent)::res + + type(hostent_c), pointer::cres + type(c_ptr)::callres + + logical, intent(out), optional::success + + ! To get the host to C + character(kind=c_char), dimension(:), allocatable, target::chost + integer::i + + ! To process h_name + character(kind=c_char), dimension(:), pointer::h_name + integer::hnamelen + interface + function strlen_c(cstr) bind(c, name="strlen") + use iso_c_binding + type(c_ptr), value::cstr + integer(kind=c_size_t)::strlen_c + end function strlen_c + end interface + + + ! To process h_addr + type(c_ptr), dimension(:), pointer::addrptr + integer(kind=c_int32_t), pointer::addr32 + integer(kind=c_int64_t), pointer::addr64 + + allocate(chost(len_trim(host)+1)) + + do i=1, len_trim(host) + chost(i) = host(i:i) + end do + chost(len_trim(host)+1) = c_null_char + + callres = gethostbyname_c(c_loc(chost)) + if(c_associated(callres)) then + call c_f_pointer(callres, cres) + + ! Extract the name + hnamelen = strlen_c(cres%h_name) + call c_f_pointer(cres%h_name, h_name, [hnamelen]) + allocate(character(len=i) :: res%h_name) + do i = 1, hnamelen + res%h_name(i:i) = h_name(i) + end do + + ! And address + res%h_addr4 = 0 + res%h_addr6 = 0 + + res%h_addrtype = cres%h_addrtype + call c_f_pointer(cres%h_addr_list, addrptr, [1]) + if(res%h_addrtype == AF_INET) then + call c_f_pointer(addrptr(1), addr32) + res%h_addr4 = addr32 + else if(res%h_addrtype == AF_INET6) then + call c_f_pointer(addrptr(1), addr64) + res%h_addr6 = addr64 + end if + + if(present(success)) then + success = .TRUE. + end if + else + if(present(success)) then + success = .FALSE. + end if + end if + + end function gethostbyname + +end module network
\ No newline at end of file diff --git a/common/protocol.f90 b/common/protocol.f90 new file mode 100644 index 0000000..be6f280 --- /dev/null +++ b/common/protocol.f90 @@ -0,0 +1,474 @@ +! 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. + +module gemini_protocol +implicit none + + integer, parameter::STATUS_INPUT = 1 + integer, parameter::STATUS_SUCCESS = 2 + integer, parameter::STATUS_REDIRECT = 3 + integer, parameter::STATUS_TEMPFAIL = 4 + integer, parameter::STATUS_PERMFAIL = 5 + integer, parameter::STATUS_CERTREQ = 6 + integer, parameter::STATUS_BADRESPONSE = 7 + integer, parameter::STATUS_LOCALFAIL = -1 + integer, parameter::STATUS_CONNECTFAIL = -2 + integer, parameter::STATUS_PROTOCOLFAIL = -3 + + integer, parameter::BUFFER_SIZE = 256 + + integer, parameter::gemini_default_port = 1965 + +contains + + function is_failure_code(return_code) + implicit none + + integer, intent(in)::return_code + logical::is_failure_code + + is_failure_code = any(return_code == & + [STATUS_CONNECTFAIL, & + STATUS_LOCALFAIL, & + STATUS_BADRESPONSE, & + STATUS_PERMFAIL, & + STATUS_TEMPFAIL, & + STATUS_PROTOCOLFAIL]) + + end function is_failure_code + + subroutine get_mimetype(status_line, return_type) + implicit none + + character(*), intent(in)::status_line + character(*), intent(out)::return_type + + integer::i, j + + return_type = " " + + ! Advance past status and space + i = 1 + do while(status_line(i:i) /= " " .and. status_line(i:i) /= char(9) .and. i < len_trim(status_line)) + i = i + 1 + end do + do while((status_line(i:i) == " " .or. status_line(i:i) == char(9)) .and. i < len_trim(status_line)) + i = i + 1 + end do + + j = 0 + do while(.not. any([char(13), char(10)] == status_line(i:i))) + j = j + 1 + return_type(j:j) = status_line(i:i) + i = i + 1 + end do + + ! Default + if(len_trim(return_type) == 0) then + return_type = "text/gemini" + end if + + end subroutine get_mimetype + + function get_return_code(status_line) result(ret) + implicit none + + integer::ret + character(*), intent(in)::status_line + integer::istatus + + read(status_line, '(i1)', iostat=istatus) ret + + if(istatus /= 0) then + ret = STATUS_BADRESPONSE + end if + + end function get_return_code + + function request_url(url, unit_number, return_type) result(returncode) + use request + use iso_c_binding + implicit none + + character(*), intent(inout)::url + integer, intent(in)::unit_number + character(*), intent(out)::return_type + integer::port + + integer::returncode + + character(:), allocatable::server + + type(connection)::conn + + integer::bytes_received, i + character, dimension(BUFFER_SIZE)::buffer + + ! For direct processing of the reponse line + integer::response_line_index + character(1024)::response_line + logical::response_line_completed + + returncode = -1 + rewind(unit_number) + + + allocate(character(len=len_trim(url)) :: server) + call get_server_from_url(url, server, port) + if(port < 0) then + port = gemini_default_port + end if + + ! Correct URL relative paths + call fix_url_relative_paths(url) + + conn = open_connection(server) + + if(conn%code == CONNECTION_OPEN) then + if(send_string(conn%ssl, trim(url)//c_carriage_return//c_new_line, trimming=.false.)) then + + response_line_completed = .false. + response_line = " " + response_line_index = 0 + + bytes_received = retrieve_characters(conn%ssl, buffer) + do while(bytes_received > 0) + + do i=1, bytes_received + + if(.not. response_line_completed) then + response_line_index = response_line_index + 1 + response_line(response_line_index:response_line_index) = buffer(i) + + ! If we encountered our first newline, we have a complete status + ! line - handle it here + if(buffer(i) == char(10) .or. response_line_index == 1024) then + response_line_completed = .true. + + returncode = get_return_code(response_line) + + if(returncode == STATUS_SUCCESS) then + + call get_mimetype(response_line, return_type) + + else + + exit + + end if + + end if + + else + + write(unit_number) buffer(i) + + end if + + end do + + bytes_received = retrieve_characters(conn%ssl, buffer) + end do + + else + + returncode = STATUS_CONNECTFAIL + + end if + + else + + returncode = STATUS_CONNECTFAIL + + end if + + call close_connection(conn) + + end function request_url + + function titan_post_url(url, unit_number, file_length, token, is_plain_text) result(returncode) + use request + use iso_c_binding + use utilities, only: read_into_buffer + use jessl, only: ssl_write + implicit none + + character(*), intent(inout)::url + character(*), intent(in)::token + integer, intent(in)::unit_number + logical, intent(in), optional::is_plain_text + integer::port + + integer::returncode + + integer(kind=8), intent(in)::file_length + + character(:), allocatable::server + character(len=16)::file_length_text + + type(connection)::conn + + character, dimension(BUFFER_SIZE)::buffer + logical, dimension(4)::successes + integer::i, ierr, bytes_read, bytes_written, total_written + + returncode = -1 + rewind(unit_number) + + allocate(character(len=len_trim(url)) :: server) + call get_server_from_url(url, server, port) + if(port < 0) then + port = gemini_default_port + end if + + ! Correct URL relative paths + call fix_url_relative_paths(url) + + conn = open_connection(server) + + if(conn%code == CONNECTION_OPEN) then + + successes(1) = send_string(conn%ssl, trim(url), trimming=.false.) + successes(2) = send_string(conn%ssl, ";token="//trim(token), trimming=.false.) + + if(present(is_plain_text)) then + if(is_plain_text) then + successes(3) = send_string(conn%ssl, ";mime=text/plain", trimming=.false.) + else + successes(3) = send_string(conn%ssl, ";mime=application/octet-stream", trimming=.false.) + end if + else + successes(3) = send_string(conn%ssl, ";mime=application/octet-stream", trimming=.false.) + end if + + write(file_length_text, *) file_length + file_length_text = adjustl(file_length_text) + successes(4) = send_string(conn%ssl, ";size="//trim(file_length_text)//c_carriage_return//c_new_line, trimming=.false.) + + if(all(successes, 1)) then + + total_written = 0 + bytes_read = read_into_buffer(unit_number, buffer) + do while(bytes_read > 0) + bytes_written = ssl_write(conn%ssl, buffer) + total_written = total_written + bytes_written + bytes_read = read_into_buffer(unit_number, buffer) + end do + + if(total_written >= file_length) then + returncode = STATUS_SUCCESS + else + returncode = STATUS_LOCALFAIL + end if + + else + + returncode = STATUS_CONNECTFAIL + + end if + + else + + returncode = STATUS_CONNECTFAIL + + end if + + call close_connection(conn) + + end function titan_post_url + + subroutine get_redirect_url(unit_number, url) + implicit none + + integer, intent(in)::unit_number + character(*), intent(inout)::url + + character(1024)::new_url + character::search + integer::i, istat + + rewind(unit_number) + + ! Status code + read(unit_number, '(A1)', advance='no') search + read(unit_number, '(A1)', advance='no') search + + new_url = " " + + ! At least one whitespace, but whatever... + read(unit_number, '(A1)', advance='no') search + do while(search == " " .or. search == CHAR(9)) + read(unit_number, '(A1)', advance='no', iostat=istat) search + end do + + ! Now search contains our first url component + i = 0 + do while(search /= CHAR(13) .and. i < len(url) .and. istat == 0) + i = i + 1 + new_url(i:i) = search + read(unit_number, '(A1)', advance='no', iostat=istat) search + end do + + ! Process this url properly + if(index(new_url, "://") > 0) then + url = new_url + else + call handle_relative_url(url, new_url) + end if + + end subroutine get_redirect_url + + subroutine handle_relative_url(current_url, path) + implicit none + + character(*), intent(inout)::current_url + character(*), intent(in)::path + + integer::past_protocol, first_slash, last_slash + + ! For debugging + ! Print *, "*** Requested path is '"//trim(path)//"'" + + past_protocol = index(current_url, "://") + + if(path(1:2) == "//") then + current_url = "gemini:"//path + + else if(past_protocol > 0) then + + past_protocol = past_protocol + 3 + + if(path(1:1) == "/") then + + first_slash = index(current_url(past_protocol:len_trim(current_url)), "/") + if(first_slash < 1) then + current_url = trim(current_url)//trim(path) + else + current_url = current_url(1:(past_protocol + first_slash - 1))//path(2:len_trim(path)) + end if + + else + + last_slash = index(current_url, "/", back=.true.) + if(last_slash > 0) then + current_url = current_url(1:last_slash)//path + end if + + end if + + end if + + end subroutine handle_relative_url + + subroutine replace_text(string, pattern, replacement, once) + implicit none + + character(*), intent(inout)::string + character(*), intent(in)::pattern + character(*), intent(in), optional::replacement + logical, intent(in), optional::once + + integer::i,j + + ! Print *, "*** Replacement: string='"//trim(string)//"' Pattern='"//pattern//"'" + + i = index(string, pattern) + do while(i > 0) + j = i + len(pattern) ! First character after match + + ! First + if(i == 1) then + if(present(replacement)) then + string = replacement//string(j:len_trim(string)) + else + string = string(j:len_trim(string)) + end if + + ! Last + elseif(j > len_trim(string)) then + if(present(replacement)) then + string = string(1:i-1)//replacement + else + string = string(1:i-1) + end if + + ! Middle + else + if(present(replacement)) then + string = string(1:i-1)//replacement//string(j:len_trim(string)) + else + string = string(1:i-1)//string(j:len_trim(string)) + end if + end if + + ! All on the same line crashes GNU Fortran... + if(present(once)) then + if(once) then + exit + end if + end if + + i = index(string, pattern) + end do + + end subroutine replace_text + + subroutine fix_url_relative_paths(url) + implicit none + + character(*), intent(inout)::url + integer::i, pattern_start + + ! These shouldn't be there + i = index(url, '/./') + if(i > 0) then + call replace_text(url, '/./', replacement="/") + end if + + ! Remove .. + i = index(url, '/../') + do while(i > 0) + + ! Need to build the pattern + pattern_start = i - 1 + do while(url(pattern_start:pattern_start) /= "/" .and. pattern_start > 1) + pattern_start = pattern_start - 1 + end do + + if(pattern_start == 1) then + ! Error state - just exit + exit + end if + + ! Check for root... + if(url(pattern_start-1:pattern_start) == "//") then + call replace_text(url, "/../", replacement="/", once=.true.) + else + call replace_text(url, url(pattern_start:i+2), once=.true.) + end if + + i = index(url, '/../') + end do + + end subroutine fix_url_relative_paths + +end module gemini_protocol
\ No newline at end of file diff --git a/common/request.f90 b/common/request.f90 new file mode 100644 index 0000000..e9043c0 --- /dev/null +++ b/common/request.f90 @@ -0,0 +1,294 @@ +! 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. + +module request +use network +use iso_c_binding +implicit none + + integer, parameter::bufsize = 65536 + + integer, parameter::CONNECTION_NONE = 0 + integer, parameter::CONNECTION_CLOSED = 1 + integer, parameter::CONNECTION_SERVER_NOT_FOUND = 2 + integer, parameter::CONNECTION_SOCKET_FAILURE = 3 + integer, parameter::CONNECTION_SSL_SETUP_FAILURE = 4 + integer, parameter::CONNECTION_SSL_CONN_FAILURE = 5 + integer, parameter::CONNECTION_OPEN = 6 + + character(23), dimension(0:6), parameter:: connection_code_str = & + ["No Connection ", & + "Connection Closed ", & + "Server Not Found ", & + "Local Socket Failure ", & + "SSL Configuration Error", & + "SSL Connection Failure ", & + "SSL Connection Open " ] + + + type :: connection + + integer::code + + type(simple_hostent)::host + integer::socket + type(c_ptr)::ssl_ctx + type(c_ptr)::ssl + + end type connection + +contains + + function translate_connection_code(code) + implicit none + + integer, intent(in)::code + character(23)::translate_connection_code + + if(code >= lbound(connection_code_str, 1) .and. & + code <= ubound(connection_code_str, 1)) then + + translate_connection_code = connection_code_str(code) + + else + + translate_connection_code = "Unknown Error" + + end if + + end function translate_connection_code + + function open_connection(server, port) result(conn) + use jessl + use network + implicit none + + character(*), intent(in)::server + integer, intent(in), optional::port + type(connection)::conn + + type(sockaddr_in), target::sa + type(c_ptr)::ssl_method + + conn%code = CONNECTION_NONE + + ! Lookup host + conn%host = gethostbyname(server) + if((.not. allocated(conn%host%h_name)) .or. (conn%host%h_addr4 == 0)) then + conn%code = CONNECTION_SERVER_NOT_FOUND + return + end if + + ! Build the socket + sa%sin_family = AF_INET + sa%sin_addr%s_addr = conn%host%h_addr4 + if(present(port)) then + sa%sin_port = htons(port) + else + sa%sin_port = htons(1965) + end if + conn%socket = socket(AF_INET, SOCK_STREAM, 0) + if(.not. connect(conn%socket, sa)) then + conn%code = CONNECTION_SOCKET_FAILURE + return + end if + + ! Set up ssl now + ssl_method = tls_client_method() + conn%ssl_ctx = ctx_new(ssl_method) + + conn%ssl = ssl_new(conn%ssl_ctx) + if((.not. c_associated(conn%ssl)) .or. & + (set_tlsext_host_name(conn%ssl, server) == 0) .OR. & + (set_fd(conn%ssl, conn%socket) /= 1)) then + + conn%code = CONNECTION_SSL_SETUP_FAILURE + return + + end if + + ! Connect via ssl + if(ssl_connect(conn%ssl) /= 1) then + conn%code = CONNECTION_SSL_CONN_FAILURE + return + end if + + ! Here, the connection is live + conn%code = CONNECTION_OPEN + + end function open_connection + + subroutine close_connection(conn) + use jessl + use network + implicit none + + type(connection), intent(inout)::conn + integer::res + + if(conn%code >= CONNECTION_OPEN) then + res = ssl_shutdown(conn%ssl) + end if + + if(conn%code >= CONNECTION_SSL_CONN_FAILURE) then + res = ssl_free(conn%ssl) + end if + + if(conn%code >= CONNECTION_SSL_SETUP_FAILURE) then + res = ctx_free(conn%ssl_ctx) + end if + + if(conn%code > CONNECTION_SOCKET_FAILURE) then + call close_socket(conn%socket) + end if + + if(conn%code > CONNECTION_SERVER_NOT_FOUND) then + deallocate(conn%host%h_name) + end if + + conn%code = CONNECTION_CLOSED + + end subroutine close_connection + + subroutine get_server_from_url(url, server, port) + implicit none + + character(*), intent(in)::url + character(*), intent(out)::server + integer, intent(out), optional::port + + integer::start_server, end_server, length + integer::start_port, iostatus + integer::myport + + myport = -1 + + start_server = index(url, "://") + if(start_server > 0) then + + start_server = start_server + 3 + end_server = index(url(start_server:len_trim(url)), "/") + if(end_server <= 0) then + end_server = len_trim(url) + else + ! Get rid of trailing slash + end_server = end_server + start_server - 2 + end if + length = end_server - start_server + 1 + + server = url(start_server:end_server) + + end if + + ! Need to check if a port was specified too + start_port = index(server, ":") + if(start_port > 0) then + + read(server(start_port+1:len_trim(server)), *, iostat=iostatus) myport + if(iostatus /= 0) then + myport = -1 + end if + + server = server(1:start_port-1) + + end if + + if(present(port)) then + port = myport + end if + + end subroutine get_server_from_url + + function send_string(ssl, str, trimming) result(success) + use iso_c_binding + use jessl + implicit none + + logical::success + type(c_ptr)::ssl + character(*), intent(in)::str + logical, intent(in), optional::trimming + + integer::start_send + integer::chars_sent_this_time, chars_sending + integer::i, bytes + integer::string_length + + character, dimension(bufsize)::buffer + + if(present(trimming)) then + if(trimming) then + string_length = len_trim(str) + else + string_length = len(str) + end if + else + string_length = len_trim(str) + end if + + success = .true. + start_send = 1 + do while(start_send <= string_length) + + chars_sending = 0 + do i = start_send, string_length + buffer(i-start_send+1) = str(i:i) + chars_sending = chars_sending + 1 + if(chars_sending == bufsize) then + exit + end if + end do + + ! A null character seems necessary at the end of the request + if(i >= string_length) then + chars_sending = chars_sending + 1 + buffer(chars_sending) = c_null_char + end if + + ! Minus 1 because we're sending start_send as well + chars_sent_this_time = ssl_write(ssl, buffer(start_send:(start_send+chars_sending-1))) + + if(chars_sent_this_time < 0) then + success = .false. + exit + end if + + start_send = start_send + chars_sent_this_time + + end do + + end function send_string + + function retrieve_characters(ssl, arr) result(chars_read) + use iso_c_binding + use jessl + implicit none + + integer::chars_read + type(c_ptr)::ssl + character(len=1), dimension(:), intent(inout)::arr + + chars_read = ssl_read(ssl, arr) + + end function retrieve_characters + +end module request diff --git a/common/wsa.f90 b/common/wsa.f90 new file mode 100644 index 0000000..080da11 --- /dev/null +++ b/common/wsa.f90 @@ -0,0 +1,68 @@ +! 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. + +module wsa_network +use iso_c_binding +implicit none + + integer, parameter::wsa_description_length_plus_1 = 256 + + type, bind(c) :: wsadata + integer(kind=c_int16_t)::wVersion + integer(kind=c_int16_t)::wHighVersion + integer(kind=c_short)::iMaxSockets + integer(kind=c_short)::iMaxUdpDg + + type(c_ptr)::lpVendorInfo + character(len=1, kind=c_char), dimension(wsa_description_length_plus_1)::szDescription + character(len=1, kind=c_char), dimension(wsa_description_length_plus_1)::szSystemStatus + end type + +contains + + subroutine startup() + use iso_c_binding + implicit none + + interface + function wsa_startup(v, p) bind(c, name="WSAStartup") + use iso_c_binding + integer(kind=c_int16_t), value::v + type(c_ptr), value::p + integer(kind=c_int)::wsa_startup + end function wsa_startup + end interface + + type(wsadata), target::startup_data + integer::res + + ! need to use wVersionRequested = MAKEWORD(2, 2); + + + res = wsa_startup(int(z'0202', kind=c_int16_t), c_loc(startup_data)) + if(res /= 0) then + Print *, "Windows Networking failed to start" + Print *, "Error=", res + stop + end if + end subroutine startup +end module wsa_network diff --git a/player/config.f90 b/player/config.f90 new file mode 100644 index 0000000..96c775c --- /dev/null +++ b/player/config.f90 @@ -0,0 +1,8 @@ +module config +implicit none + + character(len=:), pointer::working_directory + character(len=:), pointer::logfile + character(len=1024)::captain + character(len=36)::token +end module config diff --git a/player/instructions.f90 b/player/instructions.f90 new file mode 100644 index 0000000..8c671c4 --- /dev/null +++ b/player/instructions.f90 @@ -0,0 +1,198 @@ +module instructions +implicit none + +contains + + function parse_instructions(filename) result(j) + use json_module + implicit none + + type(json_file)::j + character(*), intent(in)::filename + + call j%initialize() + call j%load_file(filename=filename) + + end function parse_instructions + + subroutine destroy_instructions(j) + use json_module + implicit none + + type(json_file)::j + call j%destroy() + + end subroutine destroy_instructions + + subroutine get_description(j, description) + use json_module + implicit none + + class(json_file)::j + character(*), intent(out)::description + character(len=:), allocatable::json_string_value + logical::found + + call j%get("description", json_string_value, found) + if(.not. found .or. .not. allocated(json_string_value)) then + description = "(instructions)" + else + description = json_string_value + end if + + end subroutine get_description + + function get_task_count(j) result(n) + use json_module + implicit none + + class(json_file)::j + integer::n + + type(json_value), pointer ::server + logical::found + character(3)::index_string + n = 0 + + found = .true. + do while(found) + n = n + 1 + write(index_string, '(I3)') n + call j%get("tasks("//trim(index_string)//")", server, found) + end do + n = n - 1 + + end function get_task_count + + pure subroutine task_component(i, component, label) + implicit none + + integer, intent(in)::i + character(*), intent(in)::component + character(*), intent(out)::label + + write(label, '(A6,I3,A2)') "tasks(", i, ")." + label = label//trim(component) + + end subroutine task_component + + function get_task_string(j, i, component, res) result(found) + use json_module + implicit none + + class(json_file)::j + integer, intent(in)::i + character(*), intent(in)::component + character(*), intent(out)::res + logical::found + + character(len=64)::label + character(len=:), allocatable::json_string_value + + call task_component(i, component, label) + + call j%get(trim(label), json_string_value, found) + + if(allocated(json_string_value)) then + res = json_string_value + end if + + end function get_task_string + + subroutine get_task_name(j, i, description) + use json_module + implicit none + + class(json_file)::j + character(*), intent(out)::description + integer, intent(in)::i + logical::found + + found = get_task_string(j, i, "name", description) + + if(.not. found) then + write(description, '(A4, 1X, I3)') "Task", i + end if + + end subroutine get_task_name + + subroutine get_task_operation(j, i, op) + use json_module + implicit none + + class(json_file)::j + character(*), intent(out)::op + integer, intent(in)::i + logical::found + + found = get_task_string(j, i, "operation", op) + + if(.not. found) then + op = " " + end if + + end subroutine get_task_operation + + function perform_task(j, i, capture_filename) result(success) + use json_module + use tasks + use utilities + implicit none + + class(json_file)::j + integer, intent(in)::i + character(len=:), pointer, intent(out)::capture_filename + logical::success + + character(32)::operation + character(256)::url + character(256)::filename + + logical, dimension(4)::found + + call get_task_operation(j, i, operation) + + found = .true. + capture_filename => null() + + if(trim(operation) == "upload") then + found(1) = get_task_string(j, i, "url", url) + found(2) = get_task_string(j, i, "filename", filename) + if(.not. all(found,1)) then + success = .false. + else + success = upload(url, filename) + end if + + else if(trim(operation) == "download") then + found(1) = get_task_string(j, i, "url", url) + found(2) = get_task_string(j, i, "filename", filename) + if(.not. all(found,1)) then + success = .false. + else + success = download(url, filename) + end if + + else if(trim(operation) == "git_update") then + capture_filename => generate_temporary_filename() + + found(1) = get_task_string(j, i, "url", url) + found(2) = get_task_string(j, i, "filename", filename) + if(.not. all(found,1)) then + success = .false. + else + success = download(url, filename) + end if + + + else if(trim(operation) == "shell") then + + + else if(trim(operation) == "delete_tree") then + + + end if + + end function perform_task + +end module instructions
\ No newline at end of file diff --git a/player/levitating-player.prj b/player/levitating-player.prj new file mode 100644 index 0000000..b6a36a4 --- /dev/null +++ b/player/levitating-player.prj @@ -0,0 +1,96 @@ +{ + "Root":{ + "Folders":[{ + "Folders":[], + "Name":"+common", + "Files":[{ + "filename":"..\\common\\jessl.f90", + "enabled":"1" + },{ + "filename":"..\\common\\network.F90", + "enabled":"1" + },{ + "filename":"..\\common\\protocol.f90", + "enabled":"1" + },{ + "filename":"..\\common\\request.f90", + "enabled":"1" + },{ + "filename":"..\\common\\wsa.f90", + "enabled":"1" + }] + }], + "Name":"+levitating-player (target.exe)", + "Files":[{ + "filename":".\\config.f90", + "enabled":"1" + },{ + "filename":".\\instructions.f90", + "enabled":"1" + },{ + "filename":".\\main.f90", + "enabled":"1" + },{ + "filename":".\\tasks.f90", + "enabled":"1" + },{ + "filename":".\\utilities.F90", + "enabled":"1" + }] + }, + "Name":"levitating-player (target.exe)", + "Options":{ + "Compiler Options":{ + "Fortran Flags":"", + "Link Flags":"", + "C Flags":"" + }, + "Architecture":1, + "Type":0, + "Revision":2, + "Windows GUI":0, + "File Options":{ + "Library Directories":["Default Add-On Directory"], + "Build Directory":"build", + "Module Directory":"modules", + "Include Directories":["Default Add-On Include Directory"] + }, + "Target":"target.exe", + "Fortran Options":{ + "Use C Preprocessor":"false", + "Runtime Diagnostics":"false", + "Floating Point Exception Trap":0, + "Cray Pointers":"false", + "Enable Coarrays":"false", + "Enable OpenMP":"false", + "Initialize Variables to Zero":"false", + "Default Double for Real":"false" + }, + "Code Generation Options":{ + "CPU Specific":"false", + "Processor":"generic", + "Aggressive Loops":"false", + "Debugging":"true", + "Optimization Mode":0, + "Profiling":"false" + }, + "Build Dependencies":1, + "Launch Options":{ + "Working Directory":"", + "Launch Using MPI":"false", + "Keep Console":"true", + "External Console":"false", + "Command Line Arguments":"", + "Build Before Launch":"true" + }, + "Build Options":{ + "Makefile":"Makefile", + "Auto Makefile":"true" + }, + "Linker Options":{ + "Static Linking Mode":7, + "Link MPI Library":"false", + "Link LAPACK":0 + } + } +}
\ No newline at end of file diff --git a/player/main.f90 b/player/main.f90 new file mode 100644 index 0000000..cdf646e --- /dev/null +++ b/player/main.f90 @@ -0,0 +1,87 @@ +program player +use config +implicit none + + character(len=1024)::option + + integer::slen + integer::i + + i = 1 + do while(i <= command_argument_count()) + call get_command_argument(i, option) + + if(option(1:1) /= "-") then + captain = option + + else if(trim(option) == "-h") then + call usage() + stop + + else if(trim(option) == "-w") then + i = i + 1 + call get_command_argument(i, length=slen) + allocate(character(len=slen) :: working_directory) + call get_command_argument(i, working_directory) + + else if(trim(option) == "-l") then + i = i + 1 + call get_command_argument(i, length=slen) + allocate(character(len=slen) :: logfile) + call get_command_argument(i, logfile) + + end if + + i = i + 1 + end do + + ! Assign working directory from command if not specified + if(.not. associated(working_directory)) then + call get_command_argument(0, length=slen) + allocate(character(len=slen) :: working_directory) + call get_command_argument(i, working_directory) + i = index(working_directory, "/", back=.true.) + if(i == 0) then + i = index(working_directory, "/", back=.true.) + endif + if(i == 0) then + Print *, "Could not determine working_directory" + stop + else + working_directory(i:slen) = ' ' + end if + end if + + ! Assign a temporary directory and file for a log file + ! NOTE: will fail on Windows + if(.not. associated(logfile)) then + allocate(character(len=256) :: logfile) + logfile = "/tmp/levitating.log" + end if + + ! Change directory to the working directory now + call chdir(working_directory) + + +contains + + subroutine usage() + implicit none + + character(len=256)::pname + + call get_command_argument(0, pname) + + Print *, "Usage: "//trim(pname)//" <options> <captain>" + Print *, " " + Print *, "captain is the build control server" + Print *, " " + + Print *, "Options:" + Print *, " -h Display this help" + Print *, " -w <dir> Use dir as the working directory" + Print *, " -l <log> Use log as the logfile" + + end subroutine usage + +end program player
\ No newline at end of file diff --git a/player/tasks.f90 b/player/tasks.f90 new file mode 100644 index 0000000..c64cb40 --- /dev/null +++ b/player/tasks.f90 @@ -0,0 +1,216 @@ +module tasks +implicit none + +contains + + function shell(command, directory, capture_filename) + use config + use utilities + implicit none + + logical::shell + character(*), intent(in)::command + character(*), intent(in)::directory + character(*), intent(in)::capture_filename + + character(len=:), allocatable::task_directory + + integer::return_value, details_unit + integer, dimension(8)::timedate_start, timedate_end + + shell = .false. + + if(is_absolute_path(directory)) then + call chdir(directory) + else + allocate(character(len=(len_trim(directory) + len_trim(working_directory) + 1)) :: task_directory) + call combine_paths(working_directory, directory, task_directory) + call chdir(task_directory) + end if + + call date_and_time(values=timedate_start) + + call execute_command_line(trim(command)//" 1>> "//trim(capture_filename)//" 2>&1", & + wait=.true., exitstat=return_value) + + shell = (return_value == 0) + + ! Write out some final info + open(newunit=details_unit, file=capture_filename, status="old", access="append") + write(details_unit, *) repeat("=", 80) + write(details_unit, '(1X, A25, I3)') "Task Completed with Code ", return_value + + call date_and_time(values=timedate_end) + + write(details_unit, '(1X, A8, 1X)', advance='no') "Started:" + call write_date_and_time(details_unit, timedate_start) + + write(details_unit, '(1X, A8, 1X)', advance='no') " Ended:" + call write_date_and_time(details_unit, timedate_end) + + write(details_unit, *) "Command:" + write(details_unit, *) " "//trim(command) + + write(details_unit, *) "Working Directory:" + if(allocated(task_directory)) then + write(details_unit, *) " "//trim(task_directory) + else + write(details_unit, *) " "//trim(directory) + end if + + write(details_unit, *) repeat("=", 80) + close(details_unit) + + call chdir(working_directory) + + if(allocated(task_directory)) then + deallocate(task_directory) + end if + + end function shell + + function upload(url, source_filename) + use config, only: token + use gemini_protocol, only: titan_post_url, STATUS_SUCCESS + implicit none + + logical::upload + character(*), intent(in)::url + character(*), intent(in)::source_filename + + character(len=:), allocatable::mod_url + + integer(kind=8)::file_size + integer::unit_number, istatus + + inquire(file=source_filename, size=file_size) + + open(newunit=unit_number, file=trim(source_filename), status='UNKNOWN', & + access='STREAM', form='UNFORMATTED', iostat=istatus) + + allocate(character(len=len_trim(url)) :: mod_url) + mod_url = url + + if(istatus == 0) then + istatus = titan_post_url(mod_url, unit_number, file_size, token) + upload = (istatus == STATUS_SUCCESS) + close(unit_number) + else + upload = .false. + end if + + deallocate(mod_url) + + end function upload + + function download(url, destination_filename) + use gemini_protocol, only: request_url, STATUS_SUCCESS + implicit none + + logical::download + character(*), intent(in)::url + character(*), intent(in)::destination_filename + + character(len=256)::mimetype + + character(len=:), allocatable::mod_url + + integer::unit_number, istatus + + allocate(character(len=len_trim(url)) :: mod_url) + mod_url = url + + open(newunit=unit_number, file=trim(destination_filename), status='UNKNOWN', & + access='STREAM', form='UNFORMATTED', iostat=istatus) + + if(istatus == 0) then + istatus = request_url(mod_url, unit_number, mimetype) + download = (istatus == STATUS_SUCCESS) + close(unit_number) + else + download = .false. + end if + + deallocate(mod_url) + + end function download + + function git_update(origin, branch, directory, destructive, capture_filename) + use config + implicit none + + logical::git_update + character(*), intent(in)::origin + character(*), intent(in)::directory + character(*), intent(in)::branch + logical, intent(in)::destructive + character(*), intent(in)::capture_filename + + logical::res + integer::retval + character(len=32)::options + + ! If we're working in destructive mode, just checkout the current head + if(destructive) then + res = delete_tree(directory) + options = " --depth 1" + else + options = " " + end if + + call execute_command_line("mkdir "//trim(directory), wait=.true., exitstat=retval) + + ! If Zero, there is no existing directory... + if(retval == 0) then + res = shell("git clone"//trim(options)//" "//trim(origin)//" "//trim(directory), working_directory, capture_filename) + if(res) then + res = shell("git submodule init", directory, capture_filename) + end if + else + res = .true. + end if + + ! Check that nothing went wrong so far... + if(res) then + res = shell("git checkout "//trim(branch), directory, capture_filename) + if(res) then + res = shell("git submodule update", directory, capture_filename) + end if + end if + + git_update = res + + end function git_update + + function delete_tree(directory) + use config, only: working_directory + use utilities + implicit none + + logical::delete_tree + character(*), intent(in)::directory + character(len=:), allocatable::fulldir + + ! Only proceed in the working directory... + ! Relative paths could still break this, but what can you do... + if(is_absolute_path(directory)) then + delete_tree = .false. + else + + allocate(character(len=( len_trim(working_directory)+len_trim(directory)+1 )) :: fulldir) + call combine_paths(working_directory, directory, fulldir) + + ! No spaces allowed. Tough... + if(index(fulldir, " ") /= 0) then + delete_tree = .false. + else + delete_tree = remove_directory(fulldir) + end if + + deallocate(fulldir) + + end if + + end function delete_tree + +end module tasks diff --git a/player/utilities.F90 b/player/utilities.F90 new file mode 100644 index 0000000..c7fd523 --- /dev/null +++ b/player/utilities.F90 @@ -0,0 +1,208 @@ +module utilities + +#ifdef WINDOWS + character, parameter::dir_sep = '\' +#else + character, parameter::dir_sep = '/' +#endif + +contains + + function is_absolute_path(path) + implicit none + + logical::is_absolute_path + character(len=*), intent(in)::path + + is_absolute_path = .false. + if(path(1:1) == dir_sep) then + is_absolute_path = .true. + else +#ifdef WINDOWS + if(path(2:2) == ":") then + is_absolute_path = .true. + end if +#endif + end if + + end function is_absolute_path + + subroutine combine_paths(first, second, res) + implicit none + + character(len=*), intent(in)::first, second + character(len=*), intent(out)::res + + integer::i + + i = len_trim(first) + + if(first(i:i) == dir_sep) then + res = trim(first)//trim(second) + else + res = trim(first)//dir_sep//trim(second) + end if + + end subroutine combine_paths + + subroutine write_date_and_time(unit_number, values) + implicit none + + integer, intent(in)::unit_number + integer, intent(in), dimension(8)::values + + write(unit_number, '(I4, A1, I2, A1, I2, 1X, I2, A1, I2, A1, I2)') & + values(1), "-", & + values(2), "-", & + values(3), & + values(5), ":", & + values(6), ":", & + values(7) + + end subroutine write_date_and_time + + function remove_directory(absolute_dir, and_files) + implicit none + + character(*), intent(in)::absolute_dir + logical, intent(in), optional::and_files + logical::remove_directory + + character(len=8)::cmd, flags + integer::retval + +#ifdef WINDOWS + flags = " " + cmd = "rmdir" +#else + flags = "-r" + cmd = "rm" +#endif + + if(present(and_files)) then + if(and_files) then +#ifdef WINDOWS + flags = "/S /Q" +#else + flags = "-rf" +#endif + end if + end if + + call execute_command_line(trim(cmd)//" "//trim(flags)//" "//trim(absolute_dir), & + wait=.true., exitstat=retval) + + remove_directory = (retval == 0) + + end function remove_directory + + 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 + + function generate_temporary_filename() result(fullpath) + use iso_c_binding + implicit none + + character(len=:), pointer::fullpath + type(c_ptr)::tmp_name + character(kind=c_char), dimension(:), pointer::cfullpath + integer(kind=c_size_t)::clength + integer::i + + interface + function c_strlen(p) bind(c, name='strlen') + use iso_c_binding + type(c_ptr), value::p + integer(kind=c_size_t)::strlen + end function c_strlen + + function c_malloc(x) bind(c, name='malloc') + use iso_c_binding + type(c_ptr)::c_malloc + integer(kind=c_size_t), value::x + end function c_malloc + + subroutine c_free(p) bind(c, name='free') + use iso_c_binding + type(c_ptr), value::p + end subroutine c_free + + end interface + +#ifdef WINDOWS + interface + function GetTempPath(n, b) bind(c, name='GetTempPathA') + use iso_c_binding + integer(kind=c_int32_t)::GetTempPath + integer(kind=c_int32_t), value::n + type(c_ptr), value::b + + function GetTempFileName(pn, prefix, unique, b) bind(c, name='GetTempFileNameA') + use iso_c_binding + integer(kind=c_int)::GetTempFileName + integer(kind=c_int), value::unique + type(c_ptr), value::pn, prefix, b + end function GetTempFileName + end interface + + type(c_ptr)::tmp_path + integer::res + + tmp_path = c_malloc(1024) + res = GetTempPath(1023, tmp_path) + + tmp_name = c_malloc(1024) + res = GetTempFileName(tmp_path, c_null_ptr(), 0, tmp_name) + + c_free(tmp_path) +#else + interface + function tmpnam(p) bind(c, name='tmpnam') + use iso_c_binding + type(c_ptr), value::p + type(c_ptr)::tmpnam + end function tmpnam + end interface + + type(c_ptr)::ignored + + tmp_name = c_malloc(int(1024, kind=c_size_t)) + + ignored = tmpnam(tmp_name) +#endif + + ! Convert the C Ptr to a Fortran object + clength = c_strlen(tmp_name) + call c_f_pointer(tmp_name, cfullpath, (/ clength /)) + allocate(character(len=clength)::fullpath) + do i = 1, clength + fullpath(i:i) = cfullpath(i) + end do + + cfullpath => null() + call c_free(tmp_name) + + end function generate_temporary_filename + +end module utilities
\ No newline at end of file |