From 370a1dd973f10f47354cd17bdaa891bae5e87c12 Mon Sep 17 00:00:00 2001 From: interkosmos Date: Fri, 11 Oct 2024 18:50:33 +0200 Subject: [PATCH] Minor updates. --- app/dmbeat.f90 | 57 +++++++++++------------ app/dmbot.f90 | 113 ++++++++++++++++++++++++++++------------------ src/dm_jabber.f90 | 58 ++++++++++++++++-------- 3 files changed, 138 insertions(+), 90 deletions(-) diff --git a/app/dmbeat.f90 b/app/dmbeat.f90 index bb2dbf0..19efff4 100644 --- a/app/dmbeat.f90 +++ b/app/dmbeat.f90 @@ -12,28 +12,28 @@ program dmbeat integer, parameter :: APP_MINOR = 9 integer, parameter :: APP_PATCH = 6 - integer, parameter :: HOST_LEN = 256 !! Max. length of host name. - integer, parameter :: USERNAME_LEN = 256 !! Max. length of user name. - integer, parameter :: PASSWORD_LEN = 256 !! Max. length of password. + integer, parameter :: APP_HOST_LEN = 256 !! Max. length of host name. + integer, parameter :: APP_USERNAME_LEN = 256 !! Max. length of user name. + integer, parameter :: APP_PASSWORD_LEN = 256 !! Max. length of password. type :: app_type !! Application settings. - character(len=ID_LEN) :: name = APP_NAME !! Name of instance/configuration. - character(len=FILE_PATH_LEN) :: config = ' ' !! Path to configuration file. - character(len=LOGGER_NAME_LEN) :: logger = ' ' !! Name of logger (name implies IPC). - character(len=NODE_ID_LEN) :: node = ' ' !! Sensor node id (required). - character(len=HOST_LEN) :: host = ' ' !! IP or FQDN of API (`127.0.0.1`, `example.com`). - integer :: port = 0 !! API port (set to 0 for protocol default). - logical :: tls = .false. !! TLS encryption. - character(len=USERNAME_LEN) :: username = ' ' !! HTTP Basic Auth user name. - character(len=PASSWORD_LEN) :: password = ' ' !! HTTP Basic Auth password. - character(len=Z_TYPE_NAME_LEN) :: compression_name = 'zstd' !! Compression library (`none`, `zlib`, `zstd`). - integer :: compression = Z_TYPE_NONE !! Compression type (`Z_TYPE_*`). - integer :: count = 0 !! Maximum number of heartbeats to send (0 means unlimited). - integer :: interval = 60 !! Emit interval in seconds (>= 0). - logical :: debug = .false. !! Forward debug messages via IPC. - logical :: ipc = .false. !! Send logs via IPC (requires logger name to be set). - logical :: verbose = .false. !! Print debug messages to stderr. + character(len=ID_LEN) :: name = APP_NAME !! Name of instance/configuration. + character(len=FILE_PATH_LEN) :: config = ' ' !! Path to configuration file. + character(len=LOGGER_NAME_LEN) :: logger = ' ' !! Name of logger (name implies IPC). + character(len=NODE_ID_LEN) :: node = ' ' !! Sensor node id (required). + character(len=APP_HOST_LEN) :: host = ' ' !! IP or FQDN of API (`127.0.0.1`, `example.com`). + integer :: port = 0 !! API port (set to 0 for protocol default). + logical :: tls = .false. !! TLS encryption. + character(len=APP_USERNAME_LEN) :: username = ' ' !! HTTP Basic Auth user name. + character(len=APP_PASSWORD_LEN) :: password = ' ' !! HTTP Basic Auth password. + character(len=Z_TYPE_NAME_LEN) :: compression_name = 'zstd' !! Compression library (`none`, `zlib`, `zstd`). + integer :: compression = Z_TYPE_NONE !! Compression type (`Z_TYPE_*`). + integer :: count = 0 !! Maximum number of heartbeats to send (0 means unlimited). + integer :: interval = 60 !! Emit interval in seconds (>= 0). + logical :: debug = .false. !! Forward debug messages via IPC. + logical :: ipc = .false. !! Send logs via IPC (requires logger name to be set). + logical :: verbose = .false. !! Print debug messages to stderr. end type app_type class(logger_class), pointer :: logger ! Logger object. @@ -50,12 +50,12 @@ program dmbeat ! Initialise logger. logger => dm_logger_get_default() - call logger%configure(name = app%logger, & - node_id = app%node, & - source = app%name, & - debug = app%debug, & - ipc = app%ipc, & - verbose = app%verbose) + call logger%configure(name = app%logger, & ! Name of logger process. + node_id = app%node, & ! Node id. + source = app%name, & ! Log source. + debug = app%debug, & ! Forward DEBUG messages via IPC. + ipc = app%ipc, & ! Enable IPC. + verbose = app%verbose) ! Print logs to standard error. ! Initialise RPC backend. init_block: block @@ -68,7 +68,7 @@ program dmbeat ! Run main loop. call dm_signal_register(signal_callback) - call run(app, rc) + call run(app, error=rc) end block init_block ! Clean-up. @@ -171,9 +171,10 @@ integer function read_args(app) result(rc) end function read_args integer function read_config(app) result(rc) - !! Reads configuration from (Lua) file. + !! Reads configuration from file. type(app_type), intent(inout) :: app !! App type. - type(config_type) :: config + + type(config_type) :: config rc = E_NONE if (len_trim(app%config) == 0) return diff --git a/app/dmbot.f90 b/app/dmbot.f90 index d586dcc..9d177b2 100644 --- a/app/dmbot.f90 +++ b/app/dmbot.f90 @@ -14,41 +14,43 @@ program dmbot integer, parameter :: APP_MINOR = 9 integer, parameter :: APP_PATCH = 6 + ! Application parameters. integer, parameter :: APP_PING_INTERVAL = 60 !! XMPP ping interval in seconds. logical, parameter :: APP_TCP_KEEP_ALIVE = .true. !! Enable TCP Keep Alive. logical, parameter :: APP_TLS_TRUSTED = .false. !! Trust unknown TLS certificate. ! Bot commands. - integer, parameter :: BOT_COMMAND_PREFIX_LEN = 1 !! Command prefix length. - integer, parameter :: BOT_COMMAND_NAME_LEN = 6 !! Max. command name length. - integer, parameter :: BOT_COMMAND_LEN = BOT_COMMAND_PREFIX_LEN + BOT_COMMAND_NAME_LEN - - integer, parameter :: BOT_COMMAND_NONE = 0 !! No or invalid command. - integer, parameter :: BOT_COMMAND_BEATS = 1 !! Show time in Swatch Internet Time (.beats). - integer, parameter :: BOT_COMMAND_DATE = 2 !! Show date and time. - integer, parameter :: BOT_COMMAND_LOG = 3 !! Send log message to logger. - integer, parameter :: BOT_COMMAND_POKE = 4 !! Wake up bot. - integer, parameter :: BOT_COMMAND_UPTIME = 5 !! Show system uptime. - integer, parameter :: BOT_NCOMMANDS = 5 !! Number of commands. + integer, parameter :: BOT_COMMAND_NONE = 0 !! No or invalid command. + integer, parameter :: BOT_COMMAND_BEATS = 1 !! Show time in Swatch Internet Time (.beats). + integer, parameter :: BOT_COMMAND_DATE = 2 !! Show date and time. + integer, parameter :: BOT_COMMAND_LOG = 3 !! Send log message to logger. + integer, parameter :: BOT_COMMAND_POKE = 4 !! Wake up bot. + integer, parameter :: BOT_COMMAND_UNAME = 5 !! Show Unix name. + integer, parameter :: BOT_COMMAND_UPTIME = 6 !! Show system uptime. + integer, parameter :: BOT_NCOMMANDS = 6 !! Number of commands. + + integer, parameter :: BOT_COMMAND_PREFIX_LEN = 1 !! Command prefix length. + integer, parameter :: BOT_COMMAND_NAME_LEN = 6 !! Max. command name length. + integer, parameter :: BOT_COMMAND_LEN = BOT_COMMAND_PREFIX_LEN + BOT_COMMAND_NAME_LEN character(len=BOT_COMMAND_PREFIX_LEN), parameter :: BOT_COMMAND_PREFIX = '!' !! Command prefix. character(len=BOT_COMMAND_NAME_LEN), parameter :: BOT_COMMAND_NAMES(BOT_NCOMMANDS) = [ & - character(len=BOT_COMMAND_NAME_LEN) :: 'beats', 'date', 'log', 'poke', 'uptime' & + character(len=BOT_COMMAND_NAME_LEN) :: 'beats', 'date', 'log', 'poke', 'uname', 'uptime' & ] !! Command names. type :: app_type !! Application settings. - character(len=ID_LEN) :: name = APP_NAME !! Name of instance/configuration. - character(len=FILE_PATH_LEN) :: config = ' ' !! Path to config file. - character(len=LOGGER_NAME_LEN) :: logger = ' ' !! Name of logger. - character(len=NODE_ID_LEN) :: node = ' ' !! Node id. - character(len=JABBER_HOST_LEN) :: host = ' ' !! IP or FQDN of XMPP server. - integer :: port = JABBER_PORT !! Port of XMPP server. - logical :: tls = .true. !! TLS is mandatory. - character(len=JABBER_JID_LEN) :: jid = ' ' !! HTTP Basic Auth user name. - character(len=JABBER_PASSWORD_LEN) :: password = ' ' !! HTTP Basic Auth password. - logical :: debug = .false. !! Force writing of output file. - logical :: verbose = .false. !! Force writing of output file. + character(len=ID_LEN) :: name = APP_NAME !! Name of instance/configuration. + character(len=FILE_PATH_LEN) :: config = ' ' !! Path to config file. + character(len=LOGGER_NAME_LEN) :: logger = ' ' !! Name of logger. + character(len=NODE_ID_LEN) :: node = ' ' !! Node id. + character(len=JABBER_HOST_LEN) :: host = ' ' !! IP or FQDN of XMPP server. + integer :: port = JABBER_PORT !! Port of XMPP server. + logical :: tls = .true. !! TLS is mandatory. + character(len=JABBER_JID_LEN) :: jid = ' ' !! HTTP Basic Auth user name. + character(len=JABBER_PASSWORD_LEN) :: password = ' ' !! HTTP Basic Auth password. + logical :: debug = .false. !! Force writing of output file. + logical :: verbose = .false. !! Force writing of output file. end type app_type class(logger_class), pointer :: logger ! Logger object. @@ -66,10 +68,10 @@ program dmbot ! Initialise logger. logger => dm_logger_get_default() - call logger%configure(name = app%logger, & ! Name of logger process. - node_id = app%node, & ! Node id. - source = app%name, & ! Log source. - debug = app%debug, & ! Forward DEBUG messages via IPC. + call logger%configure(name = app%logger, & ! Name of logger process. + node_id = app%node, & ! Node id. + source = app%name, & ! Log source. + debug = app%debug, & ! Forward DEBUG messages via IPC. ipc = (len_trim(app%logger) > 0), & ! Enable IPC. verbose = app%verbose) ! Print logs to standard error. @@ -215,9 +217,10 @@ integer function read_args(app) result(rc) end function read_args integer function read_config(app) result(rc) - !! Reads configuration from (Lua) file. + !! Reads configuration from file. type(app_type), intent(inout) :: app !! App type. - type(config_type) :: config + + type(config_type) :: config rc = E_NONE if (len_trim(app%config) == 0) return @@ -252,8 +255,8 @@ subroutine halt(error) if (dm_is_error(error)) stat = STOP_FAILURE if (dm_jabber_is_connected(jabber)) then - call dm_jabber_send_presence(jabber, JABBER_STANZA_TEXT_OFFLINE) - call logger%debug('set presence to offline') + call dm_jabber_send_presence(jabber, JABBER_STANZA_TEXT_AWAY) + call logger%debug('set presence to ' // JABBER_STANZA_TEXT_AWAY) call dm_jabber_disconnect(jabber) end if @@ -264,7 +267,7 @@ subroutine halt(error) end subroutine halt ! ****************************************************************** - ! COMMANDS. + ! BOT COMMANDS. ! ****************************************************************** function bot_reply_beats() result(reply) !! Returns current time in Swatch Internet Time (.beats). @@ -298,6 +301,21 @@ function bot_reply_poke(bot_name) result(reply) reply = reply // ' is online' end function bot_reply_poke + function bot_reply_uname() result(reply) + !! Returns Unix name. + character(len=:), allocatable :: reply + + type(uname_type) :: uname + + call dm_system_uname(uname) + + reply = trim(uname%system_name) // ' ' // & + trim(uname%node_name) // ' ' // & + trim(uname%release) // ' ' // & + trim(uname%version) // ' ' // & + trim(uname%machine) + end function bot_reply_uname + function bot_reply_uptime() result(reply) !! Returns system uptime. character(len=:), allocatable :: reply @@ -315,6 +333,8 @@ end function bot_reply_uptime ! CALLBACK PROCEDURES. ! ****************************************************************** subroutine connection_callback(connection, event, error, stream_error, user_data) bind(c) + !! C-interoperable connection handler called on connect and disconnect + !! events. Must be passed to `dm_jabber_connect()`. type(c_ptr), intent(in), value :: connection !! xmpp_conn_t * integer(kind=c_int), intent(in), value :: event !! xmpp_conn_event_t integer(kind=c_int), intent(in), value :: error !! int @@ -331,13 +351,13 @@ subroutine connection_callback(connection, event, error, stream_error, user_data trim(jabber%host) // ':' // dm_itoa(jabber%port)) ! Add handlers. - call xmpp_handler_add(connection, iq_callback, '', 'iq', '', user_data) + call xmpp_handler_add(connection, iq_callback, '', 'iq', '', user_data) call xmpp_handler_add(connection, message_callback, '', 'message', '', user_data) call xmpp_timed_handler_add(connection, ping_callback, int(APP_PING_INTERVAL * 1000, kind=c_long), user_data) ! Set presence to online. call dm_jabber_send_presence(jabber, JABBER_STANZA_TEXT_ONLINE) - call logger%debug('set presence to online') + call logger%debug('set presence to ' // JABBER_STANZA_TEXT_ONLINE) else call logger%debug('disconnected from ' // trim(jabber%host) // ':' // dm_itoa(jabber%port)) @@ -351,6 +371,7 @@ subroutine connection_callback(connection, event, error, stream_error, user_data end subroutine connection_callback function disconnect_callback(connection, user_data) bind(c) + !! C-interoperable disconnect event handler. type(c_ptr), intent(in), value :: connection !! xmpp_conn_t * type(c_ptr), intent(in), value :: user_data !! void * integer(kind=c_int) :: disconnect_callback !! int @@ -362,14 +383,15 @@ function disconnect_callback(connection, user_data) bind(c) if (.not. c_associated(user_data)) return call c_f_pointer(user_data, jabber) - ! Set presence to offline. - call dm_jabber_send_presence(jabber, JABBER_STANZA_TEXT_OFFLINE) - call logger%debug('set presence to offline') + ! Set presence to away. + call dm_jabber_send_presence(jabber, JABBER_STANZA_TEXT_AWAY) + call logger%debug('set presence to ' // JABBER_STANZA_TEXT_AWAY) call dm_jabber_disconnect(jabber) end function disconnect_callback function iq_callback(connection, iq_stanza, user_data) bind(c) + !! C-interoperable iq stanza handler for ping processing. type(c_ptr), intent(in), value :: connection !! xmpp_conn_t * type(c_ptr), intent(in), value :: iq_stanza !! xmpp_stanza_t * type(c_ptr), intent(in), value :: user_data !! void * @@ -377,8 +399,8 @@ function iq_callback(connection, iq_stanza, user_data) bind(c) character(len=:), allocatable :: from, id, type integer :: stat - type(jabber_type), pointer :: jabber type(c_ptr) :: ping_stanza, result_stanza + type(jabber_type), pointer :: jabber iq_callback = 1 @@ -425,6 +447,8 @@ function iq_callback(connection, iq_stanza, user_data) bind(c) end function iq_callback function message_callback(connection, stanza, user_data) bind(c) + !! C-interoperable message handler. Must be registered in + !! `connection_callback()`. type(c_ptr), intent(in), value :: connection !! xmpp_conn_t * type(c_ptr), intent(in), value :: stanza !! xmpp_stanza_t * type(c_ptr), intent(in), value :: user_data !! void * @@ -448,6 +472,7 @@ function message_callback(connection, stanza, user_data) bind(c) call logger%debug('received message from ' // from) + ! Parse message text and call command handler function. select case (parse_message(text)) case (BOT_COMMAND_BEATS) reply_text = bot_reply_beats() @@ -458,20 +483,20 @@ function message_callback(connection, stanza, user_data) bind(c) case (BOT_COMMAND_POKE) reply_text = bot_reply_poke(app%name) + case (BOT_COMMAND_UNAME) + reply_text = bot_reply_uname() + case (BOT_COMMAND_UPTIME) reply_text = bot_reply_uptime() - ! case (BOT_COMMAND_QUIT) - ! call xmpp_timed_handler_add(connection, disconnect_callback, int(500, kind=c_long), user_data) - case default - ! No reply. + ! No reply if command is not supported. return end select + ! Create and send reply. reply = xmpp_stanza_reply(stanza) - if (.not. c_associated(reply)) stat = xmpp_stanza_set_type(reply, 'chat') - + if (.not. c_associated(reply)) stat = xmpp_stanza_set_type(reply, JABBER_STANZA_TYPE_CHAT) stat = xmpp_message_set_body(reply, reply_text) call xmpp_send(jabber%connection, reply) call logger%debug('sent message to ' // from) diff --git a/src/dm_jabber.f90 b/src/dm_jabber.f90 index 59ceccd..7733efb 100644 --- a/src/dm_jabber.f90 +++ b/src/dm_jabber.f90 @@ -173,33 +173,55 @@ module dm_jabber character(len=*), parameter, public :: JABBER_STANZA_NAME_X = 'x' ! Stanze default name spaces. - character(len=*), parameter, public :: JABBER_STANZA_NS_PING = 'urn:xmpp:ping' + character(len=*), parameter, public :: JABBER_STANZA_NS_AUTH = XMPP_NS_AUTH + character(len=*), parameter, public :: JABBER_STANZA_NS_BIND = XMPP_NS_BIND + character(len=*), parameter, public :: JABBER_STANZA_NS_CLIENT = XMPP_NS_CLIENT + character(len=*), parameter, public :: JABBER_STANZA_NS_COMPONENT = XMPP_NS_COMPONENT + character(len=*), parameter, public :: JABBER_STANZA_NS_COMPRESSION = XMPP_NS_COMPRESSION + character(len=*), parameter, public :: JABBER_STANZA_NS_DISCO_INFO = XMPP_NS_DISCO_INFO + character(len=*), parameter, public :: JABBER_STANZA_NS_DISCO_ITEMS = XMPP_NS_DISCO_ITEMS + character(len=*), parameter, public :: JABBER_STANZA_NS_FEATURE_COMPRESSION = XMPP_NS_FEATURE_COMPRESSION + character(len=*), parameter, public :: JABBER_STANZA_NS_PING = 'urn:xmpp:ping' + character(len=*), parameter, public :: JABBER_STANZA_NS_REGISTER = XMPP_NS_REGISTER + character(len=*), parameter, public :: JABBER_STANZA_NS_ROSTER = XMPP_NS_ROSTER + character(len=*), parameter, public :: JABBER_STANZA_NS_SASL = XMPP_NS_SASL + character(len=*), parameter, public :: JABBER_STANZA_NS_SESSION = XMPP_NS_SESSION + character(len=*), parameter, public :: JABBER_STANZA_NS_SM = XMPP_NS_SM + character(len=*), parameter, public :: JABBER_STANZA_NS_STANZAS_IETF = XMPP_NS_STANZAS_IETF + character(len=*), parameter, public :: JABBER_STANZA_NS_STREAMS = XMPP_NS_STREAMS + character(len=*), parameter, public :: JABBER_STANZA_NS_STREAMS_IETF = XMPP_NS_STREAMS_IETF + character(len=*), parameter, public :: JABBER_STANZA_NS_TLS = XMPP_NS_TLS ! Stanza default texts. - character(len=*), parameter, public :: JABBER_STANZA_TEXT_AWAY = 'away' - character(len=*), parameter, public :: JABBER_STANZA_TEXT_CHAT = 'chat' - character(len=*), parameter, public :: JABBER_STANZA_TEXT_DND = 'dnd' - character(len=*), parameter, public :: JABBER_STANZA_TEXT_OFFLINE = 'unavailable' - character(len=*), parameter, public :: JABBER_STANZA_TEXT_ONLINE = 'online' - character(len=*), parameter, public :: JABBER_STANZA_TEXT_XA = 'xa' + character(len=*), parameter, public :: JABBER_STANZA_TEXT_AWAY = 'away' + character(len=*), parameter, public :: JABBER_STANZA_TEXT_CHAT = 'chat' + character(len=*), parameter, public :: JABBER_STANZA_TEXT_DND = 'dnd' + character(len=*), parameter, public :: JABBER_STANZA_TEXT_ONLINE = 'online' + character(len=*), parameter, public :: JABBER_STANZA_TEXT_XA = 'xa' ! Stanza default types. - character(len=*), parameter, public :: JABBER_STANZA_TYPE_CANCEL = 'cancel' - character(len=*), parameter, public :: JABBER_STANZA_TYPE_ERROR = 'error' - character(len=*), parameter, public :: JABBER_STANZA_TYPE_GET = 'get' - character(len=*), parameter, public :: JABBER_STANZA_TYPE_RESULT = 'result' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_CANCEL = 'cancel' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_CHAT = 'chat' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_ERROR = 'error' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_GET = 'get' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_MODIFY = 'modify' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_NORMAL = 'normal' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_RESULT = 'result' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_SET = 'set' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_SUBMIT = 'submit' + character(len=*), parameter, public :: JABBER_STANZA_TYPE_UNAVAILABLE = 'unavailable' type, public :: jabber_type !! Jabber/XMPP context type. type(c_ptr) :: ctx = c_null_ptr !! libstrophe context. type(c_ptr) :: connection = c_null_ptr !! libstrophe connection. type(c_ptr) :: sm_state = c_null_ptr !! libstrophe stream management state. - character(len=JABBER_HOST_LEN) :: host = ' ' !! Jabber server host. - integer :: port = JABBER_PORT !! Jabber server port. - character(len=JABBER_JID_LEN) :: jid = ' ' !! Jabber id of account. - character(len=JABBER_JID_FULL_LEN) :: jid_full = ' ' !! Jabber id with resource. - character(len=JABBER_PASSWORD_LEN) :: password = ' ' !! Jabber password of account. - character(len=JABBER_PING_ID_LEN) :: ping_id = ' ' + character(len=JABBER_HOST_LEN) :: host = ' ' !! XMPP server host. + integer :: port = JABBER_PORT !! XMPP server port. + character(len=JABBER_JID_LEN) :: jid = ' ' !! XMPP id of account. + character(len=JABBER_JID_FULL_LEN) :: jid_full = ' ' !! XMPP id with resource. + character(len=JABBER_PASSWORD_LEN) :: password = ' ' !! XMPP password of account. + character(len=JABBER_PING_ID_LEN) :: ping_id = ' ' !! XMPP ping id (XEP-0199). end type jabber_type ! Imported abstract interfaces. @@ -374,7 +396,7 @@ type(c_ptr) function dm_jabber_create_iq_error(jabber, id, type, condition) resu if (present(condition)) then condition_stanza = xmpp_stanza_new(jabber%ctx) stat = xmpp_stanza_set_name(condition_stanza, condition) - stat = xmpp_stanza_set_ns(condition_stanza, XMPP_NS_STANZAS_IETF) + stat = xmpp_stanza_set_ns(condition_stanza, JABBER_STANZA_NS_STANZAS_IETF) stat = xmpp_stanza_add_child(error_stanza, condition_stanza) end if