mmo-project/fortran/www/app/main.f90

147 lines
3.8 KiB
Fortran

program main
use, intrinsic :: iso_c_binding
use www
use db
implicit none
character, dimension(:), allocatable :: form_data
character(len=32) :: index_path
character(len=128):: db_path
integer :: err, i, length
logical :: exist
inquire (file="debug.log", exist=exist)
if (exist) then
open (12, file="debug.log", status="old", position="append", action="write")
else
open (12, file="debug.log", status="new", action="write")
end if
call getarg(1, index_path)
call getarg(2, db_path)
call request(form_data, length)
if (length .gt. 0) then
inquire (file=db_path(:Len_Trim(db_path)), exist=exist)
if (.not. exist) then
call create_db(db_path)
end if
call add_user(db_path, form_data, length)
end if
call write_index(index_path)
if (allocated(form_data)) deallocate (form_data, stat=err)
if (err /= 0) print *, "index_html: Deallocation request denied"
close (unit=12)
contains
subroutine create_db(db_path)
character(len=128), intent(in) :: db_path
type(db_type) :: db
integer :: rc
rc = db_open(db, db_path(:Len_Trim(db_path)))
rc = db_create_users(db)
rc = db_close(db)
end subroutine create_db
subroutine add_user(db_path, request, length)
character(len=128), intent(in) :: db_path
character, dimension(:), allocatable, intent(in) :: request
integer, intent(in) :: length
integer :: i, j, s_idx, e_idx, username_len, password_len
character(len=24) :: username
character(len=24) :: password
integer :: appearance_r, appearance_g, appearance_b
real(kind=c_double) :: x_pos = 0.0_c_double
real(kind=c_double) :: y_pos = 0.0_c_double
logical :: start = .false.
type(db_type) :: db
integer :: rc
j = 1
get_username: do i = 1, length
if (request(i) .eq. '=') then
s_idx = i + 1
start = .true.
end if
if (request(i) .eq. '&') then
e_idx = i - 1
start = .false.
exit get_username
end if
if (start) then
username(j:j) = request(i + 1)
j = j + 1
end if
end do get_username
username_len = j - 2
j = 1
get_password: do i = e_idx + 2, length
if (request(i) .eq. '=') then
s_idx = i + 1
start = .true.
end if
if (request(i) .eq. '&') then
e_idx = i - 1
start = .false.
exit get_password
end if
if (start) then
password(j:j) = request(i + 1)
j = j + 1
end if
end do get_password
password_len = j - 2
get_appearance: do i = e_idx + 2, length
if (request(i) .eq. '=') then
s_idx = i + 4
end if
end do get_appearance
appearance_r = hex2int(request(s_idx), request(s_idx+1))
appearance_g = hex2int(request(s_idx+2), request(s_idx+3))
appearance_b = hex2int(request(s_idx+4), request(s_idx+5))
rc = db_open(db, db_path(:Len_Trim(db_path)))
rc = db_add_user(db, username(:username_len), password(:password_len), &
appearance_r, appearance_g, appearance_b, x_pos, y_pos, 0, time())
rc = db_close(db)
end subroutine add_user
integer function hex2int(h1, h2) result(val)
character, intent(in) :: h1
character, intent(in) :: h2
integer :: a, b
if (ichar(h1) .le. ichar('9')) then
a = ichar(h1) - ichar('0')
else
a = iand(ichar(h1), 7) + 9
end if
if (ichar(h2) .le. ichar('9')) then
b = ichar(h2) - ichar('0')
else
b = iand(ichar(h2), 7) + 9
end if
val = shiftl(a, 4) + b
end function hex2int
end program main