From fc140dd0cdbc03c8ed706f24bfa0364b76602b33 Mon Sep 17 00:00:00 2001 From: Manoel Vilela Date: Thu, 15 Feb 2018 02:49:58 -0300 Subject: [PATCH] General refactor of server.lisp and add docstrings --- src/server.lisp | 119 ++++++++++++++++++++++++++++++++++-------------- 1 file changed, 84 insertions(+), 35 deletions(-) diff --git a/src/server.lisp b/src/server.lisp index 2644bf3..69397ad 100644 --- a/src/server.lisp +++ b/src/server.lisp @@ -2,112 +2,136 @@ ;; Manoel Vilela (defpackage :lisp-chat-server - (:use :usocket :cl :lisp-chat-config) + (:use :usocket :cl :lisp-chat-config :sb-thread) (:export :main)) (in-package :lisp-chat-server) -;; constants -;; (don't use defconstant because create a bug as ASDF system compile time) -(defparameter +commands-names+ '("/users" "/help" "/log" "/quit" "/uptime")) -(defparameter +day-names+ '("Monday" "Tuesday" "Wednesday" - "Thursday" "Friday" "Saturday" "Sunday")) -(defparameter +uptime+ (multiple-value-list (get-decoded-time))) ;; global vars +(defvar *day-names* '("Monday" "Tuesday" "Wednesday" + "Thursday" "Friday" "Saturday" "Sunday")) +(defvar *uptime* (multiple-value-list (get-decoded-time))) +(defparameter *commands-names* '("/users" "/help" "/log" "/quit" "/uptime")) (defparameter *clients* nil) (defparameter *messages-stack* nil) (defparameter *messages-log* nil) - +(defparameter *server-nickname* "@server") ;; thread control -(defvar *message-semaphore* (sb-thread:make-semaphore :name "message semaphore" +(defvar *message-semaphore* (make-semaphore :name "message semaphore" :count 0)) -(defvar *client-mutex* (sb-thread:make-mutex :name "client list mutex")) +(defvar *client-mutex* (make-mutex :name "client list mutex")) + (defstruct message - from content time) + "This structure abstract the type message with is saved + into *messages-log* and until consumed, temporally pushed + to *messages-stack*. FROM, CONTENT and TIME has type string" + from + content + time ) (defstruct client - name socket address) + "This structure handle the creation/control of the clients of the server. + NAME is a string. Socket is a USOCKET:SOCKET and address is a ipv4 encoded + string. " + name + socket + address) (defun socket-peer-address (socket) + "Given a USOCKET:SOCKET instance return a ipv4 encoded IP string" (format nil "~{~a~^.~}\:~a" (map 'list #'identity (get-peer-address socket)) (get-peer-port socket))) (defun client-stream (c) + "Select the stream IO from the client" (socket-stream (client-socket c))) (defun debug-format (&rest args) + "If *debug* from lisp-chat-config is true, print debug info on + running based on ARGS" (if *debug* (apply #'format args))) (defun get-time () + "Return a encoded string as HH:MM:SS based on the current timestamp." (multiple-value-bind (second minute hour) (get-decoded-time) (format nil "~2,'0d:~2,'0d:~2,'0d" hour minute second))) (defun formated-message (message) + "The default message format of this server. MESSAGE is a string + Changing this reflects all the layout from client/server. + Probably this would be the MFRP: Manoel Fucking Raw Protocol. + Because this we can still use netcat as client for lisp-chat." (format nil "|~a| [~a]: ~a" (message-time message) (message-from message) (message-content message))) (defun command-message (content) - (let* ((from "@server") + "This function prepare the CONTENT as a message by the @server" + (let* ((from *server-nickname*) (time (get-time)) (message (make-message :from from :content content :time time))) (formated-message message))) (defun call-command-by-name (string) + "Wow, this is a horrible hack to get a string as symbol for functions/command + like /help /users /log and so on." (funcall (find-symbol (string-upcase string) :lisp-chat-server))) ;; user commands prefixed with / (defun /users () + "Return a list separated by commas of the currently logged users" (command-message (format nil "~{~a~^, ~}" (mapcar #'client-name *clients*)))) (defun /help () - (command-message (format nil "~{~a~^, ~}" +commands-names+))) + "Show a list of the available commands of lisp-chat" + (command-message (format nil "~{~a~^, ~}" *commands-names*))) (defun /log (&optional (depth 20)) + "Show the last messages typed on the server. + DEPTH is optional number of messages frames from log" (format nil "~{~a~^~%~}" (reverse (subseq *messages-log* 0 (min depth (length *messages-log*)))))) (defun /uptime () + "Return a string nice encoded to preset the uptime since the server started." (multiple-value-bind (second minute hour date month year day-of-week dst-p tz) - (values-list +uptime+) + (values-list *uptime*) (declare (ignore dst-p)) (command-message (format nil "Server online since ~2,'0d:~2,'0d:~2,'0d of ~a, ~2,'0d/~2,'0d/~d (GMT~@d)" - hour - minute - second - (nth day-of-week +day-names+) - month - date - year + hour minute second + (nth day-of-week *day-names*) + month date year (- tz))))) (defun push-message (from content) + "Push a messaged FROM as CONTENT into the *messages-stack*" (push (make-message :from from :content content :time (get-time)) *messages-stack*) - (sb-thread:signal-semaphore *message-semaphore*)) + (signal-semaphore *message-semaphore*)) (defun client-delete (client) - (sb-thread:with-mutex (*client-mutex*) + "Delete a CLIENT from the list *clients*" + (with-mutex (*client-mutex*) (setf *clients* (remove-if (lambda (c) (equal (client-address c) (client-address client))) @@ -120,14 +144,18 @@ (socket-close (client-socket client))) (defun send-message (client message) + "Send to CLIENT a MESSAGE :type string" (let ((stream (client-stream client))) (write-line message stream) (finish-output stream))) (defun client-reader-routine (client) + "This function create a IO-bound procedure to act + by reading the events of a specific CLIENT. + On this software each client talks on your own thread." (loop for message = (read-line (client-stream client)) while (not (equal message "/quit")) - if (member message +commands-names+ :test #'equal) + if (member message *commands-names* :test #'equal) do (send-message client (call-command-by-name message)) else when (> (length message) 0) @@ -136,6 +164,8 @@ finally (client-delete client))) (defun client-reader (client) + "This procedure is a wrapper for CLIENT-READER-ROUTINE + treating all the possible errors based on HANDLER-CASE macro." (handler-case (client-reader-routine client) (end-of-file () (client-delete client)) (sb-int:simple-stream-error () @@ -150,6 +180,9 @@ (client-delete client))))) (defun create-client (connection) + "This procedure create a new client based on CONNECTION made by + USOCKET:SOCKET-ACCEPT. This shit create a lot of side effects as messages + if the debug is on because this makes all the log stuff to make analysis" (debug-format t "Incoming connection from ~a ~%" (socket-peer-address connection)) (let ((client-stream (socket-stream connection))) (write-line "> Type your username: " client-stream) @@ -157,24 +190,28 @@ (let ((client (make-client :name (read-line client-stream) :socket connection :address (socket-peer-address connection)))) - (sb-thread:with-mutex (*client-mutex*) + (with-mutex (*client-mutex*) (debug-format t "Added new user ~a@~a ~%" (client-name client) (client-address client)) (push client *clients*)) (push-message "@server" (format nil "The user ~s joined to the party!" (client-name client))) - (sb-thread:make-thread #'client-reader + (make-thread #'client-reader :name (format nil "~a reader thread" (client-name client)) :arguments (list client))))) ;; a function defined to handle the errors of client thread (defun safe-client-thread (connection) + "This function is a wrapper for CREATE-CLIENT treating the +exceptions." (handler-case (create-client connection) (end-of-file () nil) (usocket:address-in-use-error () nil))) (defun message-broadcast () - (loop when (sb-thread:wait-on-semaphore *message-semaphore*) + "This procedure is a general independent thread to run brodcasting + all the clients when a message is ping on this server" + (loop when (wait-on-semaphore *message-semaphore*) do (let ((message (formated-message (pop *messages-stack*)))) (push message *messages-log*) (loop for client in *clients* @@ -183,22 +220,34 @@ (sb-bsd-sockets:not-connected-error () (client-delete client))))))) (defun connection-handler (socket-server) + "This is a special thread just for accepting connections from SOCKET-SERVER + and creating new clients from it." (loop for connection = (socket-accept socket-server) - do (sb-thread:make-thread #'safe-client-thread - :arguments (list connection) - :name "create client"))) + do (make-thread #'safe-client-thread + :arguments (list connection) + :name "create client"))) (defun server-loop (socket-server) + "This is the general server-loop procedure. Create the threads + necessary for the basic working state of this chat. The main idea + is creating a MESSAGE-BROADCAST procedure and CONNECTION-HANDLER + procedure running as separated threads. + + The first procedure send always a new message too all clients + defined on *clients* when *messages-semaphore* is signalized. + The second procedure is a general connection-handler for new + clients trying connecting to the server." (format t "Running server... ~%") - (let* ((connection-thread (sb-thread:make-thread #'connection-handler + (let* ((connection-thread (make-thread #'connection-handler :arguments (list socket-server) :name "Connection handler")) - (broadcast-thread (sb-thread:make-thread #'message-broadcast + (broadcast-thread (make-thread #'message-broadcast :name "Message broadcast"))) - (sb-thread:join-thread connection-thread) - (sb-thread:join-thread broadcast-thread))) + (join-thread connection-thread) + (join-thread broadcast-thread))) (defun main () + "Well, this function run all the necessary shits." (let ((socket-server (socket-listen *host* *port*))) (unwind-protect (handler-case (server-loop socket-server) (usocket:address-in-use-error ()