320 lines
11 KiB
Fortran
320 lines
11 KiB
Fortran
! db.f90
|
|
module db
|
|
use iso_fortran_env
|
|
use iso_c_binding
|
|
use json_module
|
|
use mod_dill, only: msend, suffix_attach, suffix_detach
|
|
use :: sqlite3
|
|
implicit none
|
|
private
|
|
|
|
integer, parameter, public :: DB_OK = SQLITE_OK
|
|
|
|
type, public :: db_type
|
|
type(c_ptr) :: ptr = c_null_ptr
|
|
end type db_type
|
|
|
|
public :: db_close
|
|
public :: db_open
|
|
public :: db_create_users
|
|
public :: db_get_logged_in_users
|
|
public :: db_add_user
|
|
public :: db_login_user
|
|
public :: db_logout_user
|
|
public :: db_move_user
|
|
public :: db_delete_user
|
|
|
|
private :: db_error
|
|
private :: db_exec
|
|
contains
|
|
|
|
integer function db_open(db, path) result(rc)
|
|
!! Opens database.
|
|
type(db_type), intent(inout) :: db
|
|
character(len=*), intent(in) :: path
|
|
|
|
rc = sqlite3_open(path, db%ptr)
|
|
call db_error(rc, 'sqlite3_open()')
|
|
end function db_open
|
|
|
|
integer function db_exec(db, query) result(rc)
|
|
!! Executes SQLite query.
|
|
type(db_type), intent(inout) :: db
|
|
character(len=*), intent(in) :: query
|
|
character(len=:), allocatable :: err_msg
|
|
|
|
rc = sqlite3_exec(db%ptr, query, c_null_ptr, c_null_ptr, err_msg)
|
|
call db_error(rc, 'sqlite3_exec()', err_msg)
|
|
end function db_exec
|
|
|
|
integer function db_close(db) result(rc)
|
|
!! Closes database.
|
|
type(db_type), intent(inout) :: db
|
|
|
|
rc = sqlite3_close(db%ptr)
|
|
call db_error(rc, 'sqlite3_close()')
|
|
end function db_close
|
|
|
|
integer function db_create_users(db) result(rc)
|
|
!! Creates database tables.
|
|
type(db_type), intent(inout) :: db
|
|
|
|
! Create table "users".
|
|
rc = db_exec(db, "CREATE TABLE users " &
|
|
//"(id INTEGER PRIMARY KEY ASC, " &
|
|
//"username TEXT, password TEXT, " &
|
|
//"apperance_r INTEGER, apperance_g INTEGER, apperance_b INTEGER, " &
|
|
//"x_pos REAL, y_pos REAL, logged_in INTEGER, " &
|
|
//"created INTEGER);")
|
|
if (rc /= SQLITE_OK) return
|
|
end function db_create_users
|
|
|
|
integer function db_add_user(db, username, password, apperance_r, apperance_g, apperance_b, &
|
|
x_pos, y_pos, logged_in, created) result(rc)
|
|
|
|
!! Adds student to database.
|
|
type(db_type), intent(inout) :: db
|
|
character(len=*), intent(in) :: username
|
|
character(len=*), intent(in) :: password
|
|
integer(kind=c_int), intent(in) :: apperance_r
|
|
integer(kind=c_int), intent(in) :: apperance_g
|
|
integer(kind=c_int), intent(in) :: apperance_b
|
|
real(kind=c_double), intent(in) :: x_pos
|
|
real(kind=c_double), intent(in) :: y_pos
|
|
integer(kind=c_int), intent(in) :: logged_in
|
|
integer(kind=c_int), intent(in) :: created
|
|
type(c_ptr) :: stmt
|
|
|
|
! Insert values through prepared statement.
|
|
rc = sqlite3_prepare_v2(db%ptr, "INSERT INTO users(username, password, " &
|
|
//"apperance_r, apperance_g, apperance_b, x_pos, y_pos, logged_in, created) VALUES (?,?,?,?,?,?,?,?,?)", stmt)
|
|
call db_error(rc, 'sqlite3_prepare_v2()')
|
|
|
|
rc = sqlite3_bind_text(stmt, 1, username)
|
|
call db_error(rc, 'sqlite3_bind_text()')
|
|
rc = sqlite3_bind_text(stmt, 2, password)
|
|
call db_error(rc, 'sqlite3_bind_text()')
|
|
rc = sqlite3_bind_int(stmt, 3, apperance_r)
|
|
call db_error(rc, 'sqlite3_bind_int()')
|
|
rc = sqlite3_bind_int(stmt, 4, apperance_g)
|
|
call db_error(rc, 'sqlite3_bind_int()')
|
|
rc = sqlite3_bind_int(stmt, 5, apperance_b)
|
|
call db_error(rc, 'sqlite3_bind_int()')
|
|
rc = sqlite3_bind_double(stmt, 6, x_pos)
|
|
call db_error(rc, 'sqlite3_bind_double()')
|
|
rc = sqlite3_bind_double(stmt, 7, y_pos)
|
|
call db_error(rc, 'sqlite3_bind_double()')
|
|
rc = sqlite3_bind_int(stmt, 8, logged_in)
|
|
call db_error(rc, 'sqlite3_bind_int()')
|
|
rc = sqlite3_bind_int(stmt, 9, created)
|
|
call db_error(rc, 'sqlite3_bind_int()')
|
|
|
|
! Insert bound value into database.
|
|
rc = sqlite3_step(stmt)
|
|
call db_error(rc, 'sqlite3_step()')
|
|
|
|
! Clean-up prepared statement.
|
|
rc = sqlite3_finalize(stmt)
|
|
call db_error(rc, 'sqlite3_finalize()')
|
|
end function db_add_user
|
|
|
|
integer function db_delete_user(db, username) result(rc)
|
|
!! Adds student to database.
|
|
type(db_type), intent(inout) :: db
|
|
character(len=*), intent(in) :: username
|
|
type(c_ptr) :: stmt
|
|
|
|
! Insert values through prepared statement.
|
|
rc = sqlite3_prepare_v2(db%ptr, "DELETE FROM users WHERE users.username = ?;", stmt)
|
|
call db_error(rc, 'sqlite3_prepare_v2()')
|
|
|
|
rc = sqlite3_bind_text(stmt, 1, username)
|
|
call db_error(rc, 'sqlite3_bind_text()')
|
|
|
|
! Insert bound value into database.
|
|
rc = sqlite3_step(stmt)
|
|
call db_error(rc, 'sqlite3_step()')
|
|
|
|
! Clean-up prepared statement.
|
|
rc = sqlite3_finalize(stmt)
|
|
call db_error(rc, 'sqlite3_finalize()')
|
|
end function db_delete_user
|
|
|
|
integer function db_get_logged_in_users(db, connection) result(rc)
|
|
!! Prints number of courses per student to standard output.
|
|
type(db_type), intent(inout) :: db
|
|
integer(c_int), intent(inout) :: connection
|
|
character(len=*), parameter :: TCP_SUFFIX = c_carriage_return // c_new_line // c_null_char
|
|
|
|
character(len=:), allocatable :: str
|
|
type(json_value), pointer :: root, users, user
|
|
type(json_core) :: json
|
|
|
|
type(c_ptr) :: stmt
|
|
character(len=:), allocatable :: username
|
|
integer :: apperance_r, apperance_g, apperance_b
|
|
real(real64) :: x_pos, y_pos
|
|
|
|
rc = sqlite3_prepare_v2(db%ptr, &
|
|
"SELECT username, apperance_r, apperance_g, apperance_b, x_pos, y_pos "// &
|
|
"FROM users u WHERE u.logged_in = 1;", stmt)
|
|
call db_error(rc, 'sqlite3_prepare_v2()')
|
|
|
|
call json%initialize()
|
|
call json%create_object(root, '')
|
|
call json%create_array(users, 'users')
|
|
|
|
step_loop: do
|
|
rc = sqlite3_step(stmt)
|
|
|
|
select case (rc)
|
|
case (SQLITE_ROW)
|
|
username = sqlite3_column_text(stmt, 0)
|
|
apperance_r = sqlite3_column_int(stmt, 1)
|
|
apperance_g = sqlite3_column_int(stmt, 2)
|
|
apperance_b = sqlite3_column_int(stmt, 3)
|
|
x_pos = sqlite3_column_double(stmt, 4)
|
|
y_pos = sqlite3_column_double(stmt, 5)
|
|
|
|
call json%create_object(user, username)
|
|
call json%add(user, 'apperance_r', apperance_r)
|
|
call json%add(user, 'apperance_g', apperance_g)
|
|
call json%add(user, 'apperance_b', apperance_b)
|
|
call json%add(user, 'x_pos', x_pos)
|
|
call json%add(user, 'y_pos', y_pos)
|
|
call json%add(user, 'username', username)
|
|
call json%add(users, user)
|
|
nullify(user) !cleanup
|
|
|
|
case (SQLITE_DONE)
|
|
exit step_loop
|
|
|
|
case default
|
|
call db_error(rc, 'sqlite3_step()')
|
|
exit step_loop
|
|
end select
|
|
end do step_loop
|
|
|
|
call json%add(root, users)
|
|
call json%serialize(root, str)
|
|
|
|
print *, 'sending users'
|
|
call json%print(root)
|
|
|
|
rc = msend(connection, f_c_string(str, .true.), &
|
|
transfer(Len_Trim(f_c_string(str, .true.)), 0_c_size_t), -1_c_int64_t)
|
|
|
|
call json%destroy()
|
|
|
|
rc = sqlite3_finalize(stmt)
|
|
call db_error(rc, 'sqlite3_finalize()')
|
|
end function db_get_logged_in_users
|
|
|
|
integer function db_login_user(db, username) result(rc)
|
|
type(db_type), intent(inout) :: db
|
|
character(len=:), allocatable, intent(in) :: username
|
|
type(c_ptr) :: stmt
|
|
|
|
rc = sqlite3_prepare_v2(db%ptr, &
|
|
"UPDATE users SET logged_in = 1 WHERE users.username = ?;", stmt)
|
|
call db_error(rc, 'sqlite3_prepare_v2()')
|
|
|
|
rc = sqlite3_bind_text(stmt, 1, username(:Len_Trim(username)))
|
|
call db_error(rc, 'sqlite3_bind_text()')
|
|
|
|
rc = sqlite3_step(stmt)
|
|
call db_error(rc, 'sqlite3_step()')
|
|
|
|
rc = sqlite3_finalize(stmt)
|
|
call db_error(rc, 'sqlite3_finalize()')
|
|
end function db_login_user
|
|
|
|
integer function db_logout_user(db, username) result(rc)
|
|
type(db_type), intent(inout) :: db
|
|
character(len=:), allocatable, intent(in) :: username
|
|
type(c_ptr) :: stmt
|
|
|
|
rc = sqlite3_prepare_v2(db%ptr, &
|
|
"UPDATE users SET logged_in = 0 WHERE users.username = ?;", stmt)
|
|
call db_error(rc, 'sqlite3_prepare_v2()')
|
|
|
|
rc = sqlite3_bind_text(stmt, 1, username)
|
|
call db_error(rc, 'sqlite3_bind_text()')
|
|
|
|
rc = sqlite3_step(stmt)
|
|
call db_error(rc, 'sqlite3_step()')
|
|
|
|
rc = sqlite3_finalize(stmt)
|
|
call db_error(rc, 'sqlite3_finalize()')
|
|
end function db_logout_user
|
|
|
|
integer function db_move_user(db, username, x_pos, y_pos) result(rc)
|
|
type(db_type), intent(inout) :: db
|
|
character(len=:), allocatable, intent(in) :: username
|
|
real(c_double), intent(in) :: x_pos
|
|
real(c_double), intent(in) :: y_pos
|
|
type(c_ptr) :: stmt
|
|
|
|
rc = sqlite3_prepare_v2(db%ptr, &
|
|
"UPDATE users SET x_pos = ?, y_pos = ? WHERE users.username = ?;", stmt)
|
|
call db_error(rc, 'sqlite3_prepare_v2()')
|
|
|
|
rc = sqlite3_bind_double(stmt, 1, x_pos)
|
|
call db_error(rc, 'sqlite3_bind_double()')
|
|
rc = sqlite3_bind_double(stmt, 2, y_pos)
|
|
call db_error(rc, 'sqlite3_bind_double()')
|
|
rc = sqlite3_bind_text(stmt, 3, username)
|
|
call db_error(rc, 'sqlite3_bind_text()')
|
|
|
|
rc = sqlite3_step(stmt)
|
|
call db_error(rc, 'sqlite3_step()')
|
|
|
|
rc = sqlite3_finalize(stmt)
|
|
call db_error(rc, 'sqlite3_finalize()')
|
|
end function db_move_user
|
|
|
|
subroutine db_error(code, proc, err_msg)
|
|
!! Prints error message.
|
|
integer, intent(in) :: code
|
|
character(len=*), intent(in), optional :: proc
|
|
character(len=*), intent(in), optional :: err_msg
|
|
|
|
if (code == SQLITE_OK .or. code == SQLITE_DONE) return
|
|
|
|
if (present(proc) .and. present(err_msg)) then
|
|
print *, proc, err_msg, code
|
|
return
|
|
end if
|
|
|
|
if (present(proc)) then
|
|
print *, proc, code
|
|
return
|
|
end if
|
|
|
|
print *, 'unknown error: ', code
|
|
end subroutine db_error
|
|
|
|
! from ivanpribec `https://fortran-lang.discourse.group/t/best-practices-for-passing-c-strings/104/12`
|
|
function f_c_string(string, trim)
|
|
use, intrinsic :: iso_c_binding, only: c_char, c_null_char
|
|
implicit none
|
|
character(len=*), intent(in) :: string
|
|
logical, intent(in), optional :: trim
|
|
|
|
character(kind=c_char, len=:), allocatable :: f_c_string
|
|
logical :: trim_
|
|
|
|
trim_ = .true.
|
|
if (present(trim)) trim_ = trim
|
|
|
|
block
|
|
intrinsic trim
|
|
if (trim_) then
|
|
f_c_string = trim(string)//c_null_char
|
|
else
|
|
f_c_string = string//c_null_char
|
|
end if
|
|
end block
|
|
end function
|
|
end module db
|